Tie-Hash-Indexed-0.05/0000755000175000001440000000000010663555313013140 5ustar mhxusersTie-Hash-Indexed-0.05/t/0000755000175000001440000000000010663555312013402 5ustar mhxusersTie-Hash-Indexed-0.05/t/103_bugs.t0000644000175000001440000000221510663555276015123 0ustar mhxusers################################################################################ # # $Project: /Tie-Hash-Indexed $ # $Author: mhx $ # $Date: 2006/01/21 12:07:00 +0100 $ # $Revision: 2 $ # $Source: /t/103_bugs.t $ # ################################################################################ # # Copyright (c) 2002-2003 Marcus Holland-Moritz. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # ################################################################################ use Test; BEGIN { plan tests => 12 }; use Tie::Hash::Indexed; ok(1); tie %h, 'Tie::Hash::Indexed'; ok(1); ###---------------------------------------------------------------------------- ### BUG: Deleting hash values while iterating caused segfaults or panics ### ### Bug spotted by Cristian Cocheci ###---------------------------------------------------------------------------- %h = ( mhx => 1, abc => 2, foo => 3, bar => 4, ); ok(scalar keys %h, 4); $i = 1; while (my($key, $val) = each %h) { my $v = delete $h{$key}; ok($v, $val); ok($v, $i++); } ok(scalar keys %h, 0); Tie-Hash-Indexed-0.05/t/102_storable.t0000644000175000001440000000431710663555276016002 0ustar mhxusers################################################################################ # # $Project: /Tie-Hash-Indexed $ # $Author: mhx $ # $Date: 2006/01/21 12:07:00 +0100 $ # $Revision: 3 $ # $Source: /t/102_storable.t $ # ################################################################################ # # Copyright (c) 2002-2003 Marcus Holland-Moritz. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # ################################################################################ use Test; BEGIN { $tests = 25; plan tests => $tests }; use Tie::Hash::Indexed; ok(1); eval { require Storable; import Storable qw( dclone freeze thaw ) }; if ($@) { for (2..$tests) { skip("skip: Storable not installed", 0, 1) } exit; } if (eval $Storable::VERSION < 1.011) { for (2..$tests) { skip("skip: Storable $Storable::VERSION is buggy", 0, 1) } exit; } @keys = reverse 'a' .. 'z'; $r = do { my %h; tie %h, 'Tie::Hash::Indexed'; my $i = 1; %h = map { $_ => $i++ } @keys; dclone(\%h); }; { my $k = join(',', @keys); my $v = join(',', 1..@keys); ok(join(',', keys %$r), $k); ok(join(',', values %$r), $v); my $frozen = freeze($r); my $thawed = thaw($frozen); ok(join(',', keys %$thawed), $k); ok(join(',', values %$thawed), $v); } $r = do { my(%h1, %h2, %h3); tie %h1, 'Tie::Hash::Indexed'; tie %h2, 'Tie::Hash::Indexed'; tie %h3, 'Tie::Hash::Indexed'; %h1 = ( foo => 1, bar => 'indexed', mhx => undef ); %h2 = ( h1 => \%h1, zzz => undef, aaa => [1 .. 3] ); %h3 = ( this => 42, hash => { h1 => \%h1, h2 => \%h2 }, is => undef, indexed => [\%h2] ); dclone(\%h3); }; { my $frozen = freeze($r); my $thawed = thaw($frozen); for my $x ( $r, $thawed ) { ok(join(',', keys %$x), 'this,hash,is,indexed'); ok(join(',', keys %{$x->{indexed}[0]}), 'h1,zzz,aaa'); ok(join(',', keys %{$x->{indexed}[0]{h1}}), 'foo,bar,mhx'); ok(not defined $x->{is}); ok(not defined $x->{hash}{h1}{mhx}); ok(not defined $x->{hash}{h2}{zzz}); ok($x->{this}, 42); ok($x->{hash}{h1}, $x->{hash}{h2}{h1}); ok($x->{hash}{h2}, $x->{indexed}[0]); ok(join(',', @{$x->{hash}{h2}{aaa}}), '1,2,3'); } } Tie-Hash-Indexed-0.05/t/101_basic.t0000644000175000001440000000456510663555276015254 0ustar mhxusers################################################################################ # # $Project: /Tie-Hash-Indexed $ # $Author: mhx $ # $Date: 2007/08/24 15:12:22 +0200 $ # $Revision: 7 $ # $Source: /t/101_basic.t $ # ################################################################################ # # Copyright (c) 2002-2003 Marcus Holland-Moritz. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # ################################################################################ use Test; BEGIN { plan tests => 32 }; use Tie::Hash::Indexed; ok(1); $scalar = $] < 5.008003 || $] == 5.009 ? 'skip: no scalar context for tied hashes' : ''; $broken_untie = $] == 5.009003 ? 'skip: broken untie' : ''; tie %h, 'Tie::Hash::Indexed'; ok(1); sub scalar_h { $scalar ? 0 : scalar %h } $s = &scalar_h; skip($scalar, $s, 0); %h = (foo => 1, bar => 2, zoo => 3, baz => 4); ok(join(',', keys %h), 'foo,bar,zoo,baz'); ok(exists $h{foo}); ok(exists $h{bar}); ok(!exists $h{xxx}); $s = &scalar_h; skip($scalar, $s =~ /^(\d+)\/\d+$/ && $1 == scalar keys %h); $h{xxx} = 5; ok(join(',', keys %h), 'foo,bar,zoo,baz,xxx'); ok(exists $h{xxx}); $s = &scalar_h; skip($scalar, $s =~ /^(\d+)\/\d+$/ && $1 == scalar keys %h); $h{foo} = 6; ok(join(',', keys %h), 'foo,bar,zoo,baz,xxx'); ok(exists $h{foo}); $s = &scalar_h; skip($scalar, $s =~ /^(\d+)\/\d+$/ && $1 == scalar keys %h); while (my($k,$v) = each %h) { $key .= $k; push @val, $v; } ok($key, 'foobarzoobazxxx'); ok(join('|', @val), '6|2|3|4|5'); $val = delete $h{bar}; ok($val, 2); ok(join(',', keys %h), 'foo,zoo,baz,xxx'); ok(join(',', values %h), '6,3,4,5'); ok(scalar keys %h, 4); ok(!exists $h{bar}); $val = delete $h{bar}; ok(not defined $val); $val = delete $h{nokey}; ok(not defined $val); %h = (); ok(scalar keys %h, 0); ok(!exists $h{zoo}); $s = &scalar_h; skip($scalar, $s, 0); %h = (foo => 1, bar => 2, zoo => 3, baz => 4); ok(join(',', %h), "foo,1,bar,2,zoo,3,baz,4"); ok(scalar keys %h, 4); for ($h{foo}) { $_ = 42 } ok($h{foo}, 42); untie %h; # TODO: these tests fail with recent versions of blead skip($broken_untie, scalar keys %h, 0); skip($broken_untie, join(',', %h), ''); # test Tie::InsertOrderHash-like initializer tie my %hash => 'Tie::Hash::Indexed', foo => 1, bar => 2, zoo => 3, baz => 4; ok(join(',', keys %hash), 'foo,bar,zoo,baz'); Tie-Hash-Indexed-0.05/lib/0000755000175000001440000000000010663555312013705 5ustar mhxusersTie-Hash-Indexed-0.05/lib/Tie/0000755000175000001440000000000010663555312014426 5ustar mhxusersTie-Hash-Indexed-0.05/lib/Tie/Hash/0000755000175000001440000000000010663555312015311 5ustar mhxusersTie-Hash-Indexed-0.05/lib/Tie/Hash/Indexed.pm0000644000175000001440000000542010663555276017241 0ustar mhxusers################################################################################ # # $Project: /Tie-Hash-Indexed $ # $Author: mhx $ # $Date: 2007/08/24 15:10:13 +0200 $ # $Revision: 6 $ # $Source: /lib/Tie/Hash/Indexed.pm $ # ################################################################################ # # Copyright (c) 2002-2003 Marcus Holland-Moritz. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # ################################################################################ package Tie::Hash::Indexed; use 5.004; use strict; use DynaLoader; use Tie::Hash; use vars qw($VERSION @ISA); @ISA = qw(DynaLoader Tie::Hash); $VERSION = do { my @r = '$Snapshot: /Tie-Hash-Indexed/0.05 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; bootstrap Tie::Hash::Indexed $VERSION; 1; __END__ =head1 NAME Tie::Hash::Indexed - Ordered hashes for Perl =head1 SYNOPSIS use Tie::Hash::Indexed; tie my %hash, 'Tie::Hash::Indexed'; %hash = ( I => 1, n => 2, d => 3, e => 4 ); $hash{x} = 5; print keys %hash, "\n"; # prints 'Index' print values %hash, "\n"; # prints '12345' =head1 DESCRIPTION Tie::Hash::Indexed is very similar to Tie::IxHash. However, it is written completely in XS and usually about twice as fast as Tie::IxHash. It's quite a lot faster when it comes to clearing or deleting entries from large hashes. Currently, only the plain tying mechanism is supported. =head1 ENVIRONMENT =head2 C If Tie::Hash::Indexed is built with debugging support, you can use this environment variable to specify debugging options. Currently, the only useful values you can pass in are C or C, which both enable debug output for the module. =head1 PROBLEMS As the data of Tie::Hash::Indexed objects is hidden inside the XS implementation, cloning/serialization is problematic. Tie::Hash::Indexed implements hooks for Storable, so cloning or serializing objects using Storable is safe. Tie::Hash::Indexed tries very hard to detect any corruption in its data at runtime. So if something goes wrong, you'll most probably receive an appropriate error message. =head1 BUGS If you find any bugs, Tie::Hash::Indexed doesn't seem to build on your system or any of its tests fail, please use the CPAN Request Tracker at L to create a ticket for the module. Alternatively, just send a mail to Emhx@cpan.orgE. =head1 TODO If you're interested in what I currently plan to improve (or fix), have a look at the F file. =head1 COPYRIGHT Copyright (c) 2003 Marcus Holland-Moritz. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L and L. =cut Tie-Hash-Indexed-0.05/TODO0000644000175000001440000000075510663555276013647 0ustar mhxusers * make the doubly linked list more efficient (both memory and speed when accessing individual elements) * add configuration options, e.g.: - Reverse => new elements are inserted in front - AppendExisting => storing values to existing keys will append (or prepend in case of Reverse) this key * add more compatibility with Tie::IxHash (i.e. push, pop, shift, unshift, splice, ...) * add more tests * add more documentation Tie-Hash-Indexed-0.05/README0000644000175000001440000000335310663555276014034 0ustar mhxusersCONTENTS 1. DESCRIPTION 2. INSTALLATION 3. FEATURES 4. COPYRIGHT -------------- 1. DESCRIPTION -------------- Tie::Hash::Indexed is very similar to Tie::IxHash. However, it is written completely in XS and usually about twice as fast as Tie::IxHash. It's quite a lot faster when it comes to clearing or deleting entries from large hashes. Currently, only the plain tying mechanism is supported. --------------- 2. INSTALLATION --------------- Installation of the Tie::Hash::Indexed module follows the standard Perl Way and should not be harder than: perl Makefile.PL make make test make install Note that you may need to become superuser to 'make install'. If you're building the module under Windows, you may need to use a different make program, such as 'nmake', instead of 'make'. ----------- 3. FEATURES ----------- You can enable or disable certain features at compile time by adding options to the Makefile.PL call. However, you can safely leave them at their default. Currently, the only available feature is 'debug' to build the module with debugging support. If your perl binary was already built with debugging support, the 'debug' feature is enabled by default. You can enable or disable features explicitly by adding the arguments enable-feature disable-feature to the Makefile.PL call. To explicitly build the module with debugging enabled, you would say: perl Makefile.PL enable-debug This will still allow you to pass other 'standard' arguments to Makefile.PL, like perl Makefile.PL enable-debug OPTIMIZE=-O3 ------------ 4. COPYRIGHT ------------ Copyright (c) 2003 Marcus Holland-Moritz. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Tie-Hash-Indexed-0.05/Changes0000644000175000001440000000170110663555276014442 0ustar mhxusers------------------------- Version 0.05 (2007-08-24) ------------------------- * fixed: added missing interpreter context to store() * add support of initialization in tie statement * skip untie tests for perl-5.9.3 ------------------------- Version 0.04 (2006-01-21) ------------------------- * fixed: deleting the current item from the hash while iterating with "each" caused segfaults or panics; thanks to Cristian Cocheci for spotting this bug * added SCALAR method * minor improvements ------------------------- Version 0.03 (2003-11-11) ------------------------- * added Storable hooks to allow for serializing and cloning objects using Storable * added runtime object corruption detection * added debugging support ------------------------- Version 0.02 (2003-11-03) ------------------------- * extended compatibility back to perl 5.4.0 ------------------------- Version 0.01 (2003-11-02) ------------------------- * initial release Tie-Hash-Indexed-0.05/Indexed.xs0000644000175000001440000004267410663555276015121 0ustar mhxusers/******************************************************************************* * * MODULE: Indexed.xs * ******************************************************************************** * * DESCRIPTION: XS Interface for Tie::Hash::Indexed Perl extension module * ******************************************************************************** * * $Project: /Tie-Hash-Indexed $ * $Author: mhx $ * $Date: 2007/08/24 15:09:14 +0200 $ * $Revision: 14 $ * $Snapshot: /Tie-Hash-Indexed/0.05 $ * $Source: /Indexed.xs $ * ******************************************************************************** * * Copyright (c) 2002-2003 Marcus Holland-Moritz. All rights reserved. * This program is free software; you can redistribute it and/or modify * it under the same terms as Perl itself. * *******************************************************************************/ /*===== GLOBAL INCLUDES ======================================================*/ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef THI_DEBUGGING #define NEED_sv_2pv_nolen #endif #include "ppport.h" /*===== DEFINES ==============================================================*/ #define XSCLASS "Tie::Hash::Indexed" /*-----------------*/ /* debugging stuff */ /*-----------------*/ #define DB_THI_MAIN 0x00000001 #ifdef THI_DEBUGGING # define DEBUG_FLAG(flag) \ (DB_THI_ ## flag & gs_dbflags) # define THI_DEBUG(flag, x) \ do { if (DEBUG_FLAG(flag)) debug_printf x; } while (0) # define DBG_CTXT_FMT "%s" # define DBG_CTXT_ARG (GIMME_V == G_VOID ? "0=" : \ (GIMME_V == G_SCALAR ? "$=" : \ (GIMME_V == G_ARRAY ? "@=" : \ "?=" \ ))) #else # define THI_DEBUG(flag, x) (void) 0 #endif #define THI_DEBUG_METHOD \ THI_DEBUG(MAIN, (DBG_CTXT_FMT XSCLASS "::%s\n", DBG_CTXT_ARG, method)) #define THI_DEBUG_METHOD1(fmt, arg1) \ THI_DEBUG(MAIN, (DBG_CTXT_FMT XSCLASS "::%s(" fmt ")\n", \ DBG_CTXT_ARG, method, arg1)) #define THI_DEBUG_METHOD2(fmt, arg1, arg2) \ THI_DEBUG(MAIN, (DBG_CTXT_FMT XSCLASS "::%s(" fmt ")\n", \ DBG_CTXT_ARG, method, arg1, arg2)) #define THI_METHOD( name ) const char * const method = #name #define THI_METHOD_VAR const char * method = "" #define THI_METHOD_SET( string ) method = string /*---------------------------------*/ /* check object against corruption */ /*---------------------------------*/ #define THI_CHECK_OBJECT \ do { \ if (THIS == NULL ) \ Perl_croak(aTHX_ "NULL OBJECT IN " XSCLASS "::%s", method); \ if (THIS->signature != THI_SIGNATURE) \ { \ if (THIS->signature == 0xDEADC0DE) \ Perl_croak(aTHX_ "DEAD OBJECT IN " XSCLASS "::%s", method); \ Perl_croak(aTHX_ "INVALID OBJECT IN " XSCLASS "::%s", method); \ } \ if (THIS->hv == NULL || THIS->root == NULL) \ Perl_croak(aTHX_ "OBJECT INCONSITENCY IN " XSCLASS "::%s", method);\ } while (0) /*--------------------------------*/ /* very simple doubly linked list */ /*--------------------------------*/ #define IxLink_new(link) \ do { \ Newz(0, link, 1, IxLink); \ (link)->key = NULL; \ (link)->val = NULL; \ (link)->prev = (link)->next = link; \ } while (0) #define IxLink_delete(link) \ do { \ Safefree(link); \ link = NULL; \ } while (0) #define IxLink_push(root, link) \ do { \ (link)->prev = (root)->prev; \ (link)->next = (root); \ (root)->prev->next = (link); \ (root)->prev = (link); \ } while (0) #define IxLink_extract(link) \ do { \ (link)->prev->next = (link)->next; \ (link)->next->prev = (link)->prev; \ (link)->next = (link); \ (link)->prev = (link); \ } while (0) /*===== TYPEDEFS =============================================================*/ typedef struct sIxLink IxLink; struct sIxLink { SV *key; SV *val; IxLink *prev; IxLink *next; }; typedef struct { HV *hv; IxLink *root; IxLink *iter; U32 signature; #define THI_SIGNATURE 0x54484924 } IXHV; /*---------------*/ /* serialization */ /*---------------*/ typedef struct { char id[4]; #define THI_SERIAL_ID "THI!" /* this must _never_ be changed */ unsigned char major; #define THI_SERIAL_REV_MAJOR 0 /* incompatible changes */ unsigned char minor; #define THI_SERIAL_REV_MINOR 0 /* compatible changes */ } SerialRev; typedef struct { SerialRev rev; /* add configuration items here, don't change order, only use bytes */ } Serialized; /*===== STATIC VARIABLES =====================================================*/ #ifdef THI_DEBUGGING static U32 gs_dbflags; #endif /*===== STATIC FUNCTIONS =====================================================*/ #ifdef THI_DEBUGGING static void debug_printf(char *f, ...) { va_list l; va_start(l, f); vfprintf(stderr, f, l); va_end(l); } static void set_debug_opt(pTHX_ const char *dbopts) { if (strEQ(dbopts, "all")) gs_dbflags = 0xFFFFFFFF; else { gs_dbflags = 0; while (*dbopts) { switch (*dbopts) { case 'd': gs_dbflags |= DB_THI_MAIN; break; default: Perl_croak(aTHX_ "Unknown debug option '%c'", *dbopts); break; } dbopts++; } } } #endif static void store(pTHX_ IXHV *THIS, SV *key, SV *value) { HE *he; if ((he = hv_fetch_ent(THIS->hv, key, 1, 0)) == NULL) Perl_croak(aTHX_ "couldn't store value"); if (SvTYPE(HeVAL(he)) == SVt_NULL) { IxLink *cur; IxLink_new(cur); IxLink_push(THIS->root, cur); sv_setiv(HeVAL(he), PTR2IV(cur)); cur->key = newSVsv(key); cur->val = newSVsv(value); } else sv_setsv((INT2PTR(IxLink *, SvIV(HeVAL(he))))->val, value); } /*===== XS FUNCTIONS =========================================================*/ MODULE = Tie::Hash::Indexed PACKAGE = Tie::Hash::Indexed PROTOTYPES: ENABLE ################################################################################ # # METHOD: TIEHASH # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ IXHV * TIEHASH(CLASS, ...) char *CLASS PREINIT: THI_METHOD(TIEHASH); int i; CODE: THI_DEBUG_METHOD; Newz(0, RETVAL, 1, IXHV); IxLink_new(RETVAL->root); RETVAL->iter = NULL; RETVAL->hv = newHV(); RETVAL->signature = THI_SIGNATURE; for (i = 1; i < items; i += 2) { store(aTHX_ RETVAL, ST(i), ST(i + 1)); } OUTPUT: RETVAL ################################################################################ # # METHOD: DESTROY # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ void IXHV::DESTROY() PREINIT: THI_METHOD(DESTROY); IxLink *cur; CODE: THI_DEBUG_METHOD; THI_CHECK_OBJECT; for (cur = THIS->root->next; cur != THIS->root;) { IxLink *del = cur; cur = cur->next; SvREFCNT_dec(del->key); if (del->val) SvREFCNT_dec(del->val); IxLink_delete(del); } IxLink_delete(THIS->root); SvREFCNT_dec(THIS->hv); THIS->root = NULL; THIS->iter = NULL; THIS->hv = NULL; THIS->signature = 0xDEADC0DE; Safefree(THIS); ################################################################################ # # METHOD: FETCH # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ void IXHV::FETCH(key) SV *key PREINIT: THI_METHOD(FETCH); HE *he; PPCODE: THI_DEBUG_METHOD1("'%s'", SvPV_nolen(key)); THI_CHECK_OBJECT; if ((he = hv_fetch_ent(THIS->hv, key, 0, 0)) == NULL) XSRETURN_UNDEF; ST(0) = sv_mortalcopy((INT2PTR(IxLink *, SvIV(HeVAL(he))))->val); XSRETURN(1); ################################################################################ # # METHOD: STORE # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ void IXHV::STORE(key, value) SV *key SV *value PREINIT: THI_METHOD(STORE); CODE: THI_DEBUG_METHOD2("'%s', '%s'", SvPV_nolen(key), SvPV_nolen(value)); THI_CHECK_OBJECT; store(aTHX_ THIS, key, value); ################################################################################ # # METHOD: FIRSTKEY # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ void IXHV::FIRSTKEY() PREINIT: THI_METHOD(FIRSTKEY); PPCODE: THI_DEBUG_METHOD; THI_CHECK_OBJECT; THIS->iter = THIS->root->next; if (THIS->iter->key == NULL) XSRETURN_UNDEF; ST(0) = sv_mortalcopy(THIS->iter->key); XSRETURN(1); ################################################################################ # # METHOD: NEXTKEY # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ void IXHV::NEXTKEY(last) SV *last PREINIT: THI_METHOD(NEXTKEY); PPCODE: THI_DEBUG_METHOD1("'%s'", SvPV_nolen(last)); THI_CHECK_OBJECT; THIS->iter = THIS->iter->next; if (THIS->iter->key == NULL) XSRETURN_UNDEF; ST(0) = sv_mortalcopy(THIS->iter->key); XSRETURN(1); ################################################################################ # # METHOD: EXISTS # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ void IXHV::EXISTS(key) SV *key PREINIT: THI_METHOD(EXISTS); PPCODE: THI_DEBUG_METHOD1("'%s'", SvPV_nolen(key)); THI_CHECK_OBJECT; if (hv_exists_ent(THIS->hv, key, 0)) XSRETURN_YES; else XSRETURN_NO; ################################################################################ # # METHOD: DELETE # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ void IXHV::DELETE(key) SV *key PREINIT: THI_METHOD(DELETE); IxLink *cur; SV *sv; PPCODE: THI_DEBUG_METHOD1("'%s'", SvPV_nolen(key)); THI_CHECK_OBJECT; if ((sv = hv_delete_ent(THIS->hv, key, 0, 0)) == NULL) { THI_DEBUG(MAIN, ("key '%s' not found\n", SvPV_nolen(key))); XSRETURN_UNDEF; } cur = INT2PTR(IxLink *, SvIV(sv)); SvREFCNT_dec(cur->key); sv = cur->val; if (THIS->iter == cur) { THI_DEBUG(MAIN, ("need to move current iterator %p -> %p\n", THIS->iter, cur->prev)); THIS->iter = cur->prev; } IxLink_extract(cur); IxLink_delete(cur); THI_DEBUG(MAIN, ("key '%s' deleted\n", SvPV_nolen(key))); ST(0) = sv_2mortal(sv); XSRETURN(1); ################################################################################ # # METHOD: CLEAR # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ void IXHV::CLEAR() PREINIT: THI_METHOD(CLEAR); IxLink *cur; PPCODE: THI_DEBUG_METHOD; THI_CHECK_OBJECT; for (cur = THIS->root->next; cur != THIS->root;) { IxLink *del = cur; cur = cur->next; SvREFCNT_dec(del->key); if (del->val) SvREFCNT_dec(del->val); IxLink_delete(del); } THIS->root->next = THIS->root->prev = THIS->root; hv_clear(THIS->hv); ################################################################################ # # METHOD: SCALAR # # WRITTEN BY: Marcus Holland-Moritz ON: Jan 2004 # CHANGED BY: ON: # ################################################################################ void IXHV::SCALAR() PREINIT: THI_METHOD(SCALAR); PPCODE: THI_DEBUG_METHOD; THI_CHECK_OBJECT; #ifdef hv_scalar ST(0) = hv_scalar(THIS->hv); #else ST(0) = sv_newmortal(); if (HvFILL(THIS->hv)) Perl_sv_setpvf(aTHX_ ST(0), "%ld/%ld", (long)HvFILL(THIS->hv), (long)HvMAX(THIS->hv)+1); else sv_setiv(ST(0), 0); #endif XSRETURN(1); ################################################################################ # # METHOD: STORABLE_freeze # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ void IXHV::STORABLE_freeze(cloning) int cloning; PREINIT: THI_METHOD(STORABLE_freeze); Serialized s; IxLink *cur; int n; PPCODE: THI_DEBUG_METHOD1("%d", cloning); THI_CHECK_OBJECT; Copy(THI_SERIAL_ID, &s.rev.id[0], 4, char); s.rev.major = THI_SERIAL_REV_MAJOR; s.rev.minor = THI_SERIAL_REV_MINOR; XPUSHs(sv_2mortal(newSVpvn((char *)&s, sizeof(Serialized)))); n = 1; for (cur = THIS->root->next; cur != THIS->root; cur = cur->next) { XPUSHs(sv_2mortal(newRV_inc(cur->key))); XPUSHs(sv_2mortal(newRV_inc(cur->val))); n += 2; } XSRETURN(n); ################################################################################ # # METHOD: STORABLE_thaw # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ void STORABLE_thaw(object, cloning, serialized, ...) SV *object; int cloning; SV *serialized; PREINIT: THI_METHOD(STORABLE_thaw); IXHV *THIS; Serialized *ps; STRLEN len; int i; PPCODE: THI_DEBUG_METHOD1("%d", cloning); if (!sv_isobject(object) || SvTYPE(SvRV(object)) != SVt_PVMG) Perl_croak(aTHX_ XSCLASS "::%s: THIS is not " "a blessed SV reference", method); ps = (Serialized *) SvPV(serialized, len); if (len < sizeof(SerialRev) || strnNE(THI_SERIAL_ID, &ps->rev.id[0], 4)) Perl_croak(aTHX_ "invalid frozen " XSCLASS " object (len=%d)", len); if (ps->rev.major != THI_SERIAL_REV_MAJOR) Perl_croak(aTHX_ "cannot thaw incompatible " XSCLASS " object"); /* TODO: implement minor revision handling */ Newz(0, THIS, 1, IXHV); sv_setiv((SV*)SvRV(object), PTR2IV(THIS)); THIS->signature = THI_SIGNATURE; THIS->hv = newHV(); THIS->iter = NULL; IxLink_new(THIS->root); if ((items-3) % 2) Perl_croak(aTHX_ "odd number of items in STORABLE_thaw"); for (i = 3; i < items; i+=2) { IxLink *cur; SV *key, *val; key = SvRV(ST(i)); val = SvRV(ST(i+1)); IxLink_new(cur); IxLink_push(THIS->root, cur); cur->key = newSVsv(key); cur->val = newSVsv(val); val = newSViv(PTR2IV(cur)); if (hv_store_ent(THIS->hv, key, val, 0) == NULL) { SvREFCNT_dec(val); Perl_croak(aTHX_ "couldn't store value"); } } XSRETURN_EMPTY; ################################################################################ # # BOOTCODE # # WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003 # CHANGED BY: ON: # ################################################################################ BOOT: #ifdef THI_DEBUGGING { const char *str; if ((str = getenv("THI_DEBUG_OPT")) != NULL) set_debug_opt(aTHX_ str); } #endif Tie-Hash-Indexed-0.05/Makefile.PL0000644000175000001440000000410410663555276015121 0ustar mhxusers################################################################################ # # $Project: /Tie-Hash-Indexed $ # $Author: mhx $ # $Date: 2006/01/21 12:06:59 +0100 $ # $Revision: 6 $ # $Source: /Makefile.PL $ # ################################################################################ # # Copyright (c) 2002-2003 Marcus Holland-Moritz. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # ################################################################################ use ExtUtils::MakeMaker; use Config; $MODULE = 'Tie::Hash::Indexed'; %FEATURES = ( debug => { enabled => $Config{ccflags} =~ /-DDEBUGGING\b/ ? 1 : 0, e_flags => [qw( THI_DEBUGGING )], d_flags => [qw( NDEBUG )], }, ); @ARGV = map { my $myopt = 0; if( my($what, $feat) = /^(en|dis)able-(\S+)$/ ) { exists $FEATURES{$feat} or $feat = '$'.$feat; exists $FEATURES{$feat} or die "Invalid feature '$2'. Use one of [ @{[keys %FEATURES]} ].\n"; $FEATURES{$feat}{enabled} = $what eq 'en'; $myopt = 1; } elsif( /^help$/ ) { die <= 6) { push @moreopts, AUTHOR => 'Marcus Holland-Moritz ', ABSTRACT_FROM => 'lib/Tie/Hash/Indexed.pm'; } if (eval $ExtUtils::MakeMaker::VERSION >= 6.30_01) { print "Setting license tag...\n"; push @moreopts, LICENSE => 'perl'; } WriteMakefile( NAME => $MODULE, VERSION_FROM => 'lib/Tie/Hash/Indexed.pm', PREREQ_PM => { 'Test' => 0 }, INC => '-I.', CONFIGURE => \&configure, @moreopts, ); sub configure { for( keys %FEATURES ) { my $f = $FEATURES{$_}; $f->{enabled} and print "Building with feature '$_'\n"; push @DEFINE, @{$f->{enabled} ? $f->{e_flags} : $f->{d_flags} }; } { 'DEFINE' => join(' ', map("-D$_", @DEFINE)) }; } Tie-Hash-Indexed-0.05/META.yml0000644000175000001440000000065710663555313014421 0ustar mhxusers--- #YAML:1.0 name: Tie-Hash-Indexed version: 0.05 abstract: Ordered hashes for Perl license: perl generated_by: ExtUtils::MakeMaker version 6.36 distribution_type: module requires: Test: 0 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 author: - Marcus Holland-Moritz Tie-Hash-Indexed-0.05/typemap0000644000175000001440000000156410663555277014561 0ustar mhxusers################################################################################ # # $Project: /Tie-Hash-Indexed $ # $Author: mhx $ # $Date: 2006/01/21 12:06:58 +0100 $ # $Revision: 3 $ # $Source: /typemap $ # ################################################################################ # # Copyright (c) 2002-2003 Marcus Holland-Moritz. All rights reserved. # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # ################################################################################ TYPEMAP IXHV * T_OBJECT OUTPUT T_OBJECT sv_setref_pv($arg, CLASS, (void*)$var); INPUT T_OBJECT if (sv_isobject($arg) && SvTYPE(SvRV($arg)) == SVt_PVMG) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type, tmp); } else Perl_croak(aTHX_ \"${Package}::$func_name(): $var is not a blessed SV reference\"); Tie-Hash-Indexed-0.05/MANIFEST0000644000175000001440000000033010663555313014265 0ustar mhxusersChanges Indexed.xs lib/Tie/Hash/Indexed.pm Makefile.PL MANIFEST ppport.h README t/101_basic.t t/102_storable.t t/103_bugs.t TODO typemap META.yml Module meta-data (added by MakeMaker)