package CircList; use strict; use warnings; sub new { my( $pkg ) = @_; bless { list => {}, cur => undef, # cursor. Circular lists don't really have a "root" }, $pkg } # if the list is currently empty, after_id must be undef. # otherwise, after_id must NOT be undef. sub insert { my( $self, $id, $value, $after_id ) = @_; if ( defined $self->{'cur'} ) { defined $after_id or die "Can't insert ($id => $value): previous node not specified."; exists $self->{'list'}{$after_id} or die "Can't insert ($id => $value): no previous id '$after_id' in list."; exists $self->{'list'}{$id} and die "Can't insert ($id => $value): id ($id => $self->{'list'}{$id}{'value'}) already exists!"; # link in a new node: $self->{'list'}{$id} = { id => $id, value => $value, next_id => $self->{'list'}{$after_id}{'next_id'}, }; $self->{'list'}{$after_id}{'next_id'} = $id; } else { defined $after_id and die "Can't insert ($id => $value): no previous id '$after_id' (list is currently empty)."; # link in the first node: $self->{'list'}{$id} = { id => $id, value => $value, next_id => $id, }; $self->{'cur'} = $id; } $self->{'list'}{$id} } sub find_prev { my( $self, $id ) = @_; $self->{'list'}{$id} or die "Id '$id' does not exist in list!"; for ( keys %{ $self->{'list'} } ) { $self->{'list'}{$_}{'next_id'} eq $id and return $_; } die "Integrity fault: '$id' is not the next_id of any node in list!"; } # relatively expensive sub remove # return ( id, value ) pair { my( $self, $id ) = @_; $self->{'list'}{$id} or die "Id '$id' does not exist in list!"; my $prev_id = $self->find_prev($id); if ( $prev_id eq $id ) { # special case: removing the last node in the list $self->{'cur'} = undef; } else { # re-link to skip the one being removed: $self->{'list'}{$prev_id}{'next_id'} = $self->{'list'}{$id}{'next_id'}; $self->{'cur'} eq $id and $self->{'cur'} = $self->{'list'}{$id}{'next_id'}; } my $val = $self->{'list'}{$id}{'value'}; delete $self->{'list'}{$id}; ( $id, $val ) } # (could be generalized to accept a pattern, or some other criteria tester) sub look_up # return ( id, value ) pair { my( $self, $id ) = @_; $self->{'list'}{$id} or die "Id '$id' does not exist in list!"; ( $id, $self->{'list'}{$id}{'value'} ) } sub traverse_from { my( $self, $id, $callback ) = @_; $self->{'list'}{$id} or die "Id '$id' does not exist in list!"; my $cur_id = $id; do { $callback->( $cur_id, $self->{'list'}{$cur_id}{'value'} ); $cur_id = $self->{'list'}{$cur_id}{'next_id'}; } while $cur_id ne $id; } # example: package main; my $l = new CircList; $l->insert( 'alpha', 1 ); $l->insert( 'gamma', 3, 'alpha' ); $l->insert( 'beta', 2, 'alpha' ); $l->traverse_from( 'beta', sub { print "( @_ )\n" } );