#----------------------------- print $$sref; # prints the scalar value that the reference $sref refers to $$sref = 3; # assigns to $sref's referent #----------------------------- print ${$sref}; # prints the scalar $sref refers to ${$sref} = 3; # assigns to $sref's referent #----------------------------- $aref = \@array; #----------------------------- $pi = \3.14159; $$pi = 4; # runtime error #----------------------------- $aref = [ 3, 4, 5 ]; # new anonymous array $href = { "How" => "Now", "Brown" => "Cow" }; # new anonymous hash #----------------------------- undef $aref; @$aref = (1, 2, 3); print $aref; ARRAY(0x80c04f0) #----------------------------- $a[4][23][53][21] = "fred"; print $a[4][23][53][21]; fred print $a[4][23][53]; ARRAY(0x81e2494) print $a[4][23]; ARRAY(0x81e0748) print $a[4]; ARRAY(0x822cd40) #----------------------------- $op_cit = cite($ibid) or die "couldn't make a reference"; #----------------------------- $Nat = { "Name" => "Leonhard Euler", "Address" => "1729 Ramanujan Lane\nMathworld, PI 31416", "Birthday" => 0x5bb5580, }; #----------------------------- |
#----------------------------- $aref = \@array; $anon_array = [1, 3, 5, 7, 9]; $anon_copy = [ @array ]; @$implicit_creation = (2, 4, 6, 8, 10); #----------------------------- push(@$anon_array, 11); #----------------------------- $two = $implicit_creation->[0]; #----------------------------- $last_idx = $#$aref; $num_items = @$aref; #----------------------------- $last_idx = $#{ $aref }; $num_items = scalar @{ $aref }; #----------------------------- # check whether $someref contains a simple array reference if (ref($someref) ne 'ARRAY') { die "Expected an array reference, not $someref\n"; } print "@{$array_ref}\n"; # print original data @order = sort @{ $array_ref }; # sort it push @{ $array_ref }, $item; # append new element to orig array #----------------------------- sub array_ref { my @array; return \@array; } $aref1 = array_ref(); $aref2 = array_ref(); #----------------------------- print $array_ref->[$N]; # access item in position N (best) print $$array_ref[$N]; # same, but confusing print ${$array_ref}[$N]; # same, but still confusing, and ugly to boot #----------------------------- @$pie[3..5]; # array slice, but a little confusing to read @{$pie}[3..5]; # array slice, easier (?) to read #----------------------------- @{$pie}[3..5] = ("blackberry", "blueberry", "pumpkin"); #----------------------------- $sliceref = \@{$pie}[3..5]; # WRONG! #----------------------------- foreach $item ( @{$array_ref} ) { # $item has data } for ($idx = 0; $idx <= $#{ $array_ref }; $idx++) { # $array_ref->[$idx] has data } #----------------------------- |
#----------------------------- push(@{ $hash{"KEYNAME"} }, "new value"); #----------------------------- foreach $string (keys %hash) { print "$string: @{$hash{$string}}\n"; } #----------------------------- $hash{"a key"} = [ 3, 4, 5 ]; # anonymous array #----------------------------- @values = @{ $hash{"a key"} }; #----------------------------- push @{ $hash{"a key"} }, $value; #----------------------------- @residents = @{ $phone2name{$number} }; #----------------------------- @residents = exists( $phone2name{$number} ) ? @{ $phone2name{$number} } : (); #----------------------------- |
#----------------------------- $href = \%hash; $anon_hash = { "key1" => "value1", "key2" => "value2", ... }; $anon_hash_copy = { %hash }; #----------------------------- %hash = %$href; $value = $href->{$key}; @slice = @$href{$key1, $key2, $key3}; # note: no arrow! @keys = keys %$href; #----------------------------- if (ref($someref) ne 'HASH') { die "Expected a hash reference, not $someref\n"; } #----------------------------- foreach $href ( \%ENV, \%INC ) { # OR: for $href ( \(%ENV,%INC) ) { foreach $key ( keys %$href ) { print "$key => $href->{$key}\n"; } } #----------------------------- @values = @$hash_ref{"key1", "key2", "key3"}; for $val (@$hash_ref{"key1", "key2", "key3"}) { $val += 7; # add 7 to each value in hash slice } #----------------------------- |
#----------------------------- $cref = \&func; $cref = sub { ... }; #----------------------------- @returned = $cref->(@arguments); @returned = &$cref(@arguments); #----------------------------- $funcname = "thefunc"; &$funcname(); #----------------------------- my %commands = ( "happy" => \&joy, "sad" => \&sullen, "done" => sub { die "See ya!" }, "mad" => \&angry, ); print "How are you? "; chomp($string = <STDIN>); if ($commands{$string}) { $commands{$string}->(); } else { print "No such command: $string\n"; } #----------------------------- sub counter_maker { my $start = 0; return sub { # this is a closure return $start++; # lexical from enclosing scope }; } $counter = counter_maker(); for ($i = 0; $i < 5; $i ++) { print &$counter, "\n"; } #----------------------------- $counter1 = counter_maker(); $counter2 = counter_maker(); for ($i = 0; $i < 5; $i ++) { print &$counter1, "\n"; } print &$counter1, " ", &$counter2, "\n"; 0 1 2 3 4 5 0 #----------------------------- sub timestamp { my $start_time = time(); return sub { return time() - $start_time }; } $early = timestamp(); sleep 20; $later = timestamp(); sleep 10; printf "It's been %d seconds since early.\n", $early->(); printf "It's been %d seconds since later.\n", $later->(); #It's been 30 seconds since early. # #It's been 10 seconds since later. #----------------------------- |
#----------------------------- $scalar_ref = \$scalar; # get reference to named scalar #----------------------------- undef $anon_scalar_ref; $$anon_scalar_ref = 15; #----------------------------- $anon_scalar_ref = \15; #----------------------------- print ${ $scalar_ref }; # dereference it ${ $scalar_ref } .= "string"; # alter referent's value #----------------------------- sub new_anon_scalar { my $temp; return \$temp; } #----------------------------- $sref = new_anon_scalar(); $$sref = 3; print "Three = $$sref\n"; @array_of_srefs = ( new_anon_scalar(), new_anon_scalar() ); ${ $array[0] } = 6.02e23; ${ $array[1] } = "avocado"; print "\@array contains: ", join(", ", map { $$_ } @array ), "\n"; #----------------------------- $var = `uptime`; # $var holds text $vref = \$var; # $vref "points to" $var if ($$vref =~ /load/) {} # look at $var, indirectly chomp $$vref; # alter $var, indirectly #----------------------------- # check whether $someref contains a simple scalar reference if (ref($someref) ne 'SCALAR') { die "Expected a scalar reference, not $someref\n"; } #----------------------------- |
#----------------------------- @array_of_scalar_refs = ( \$a, \$b ); #----------------------------- @array_of_scalar_refs = \( $a, $b ); #----------------------------- ${ $array_of_scalar_refs[1] } = 12; # $b = 12 #----------------------------- ($a, $b, $c, $d) = (1 .. 4); # initialize @array = (\$a, \$b, \$c, \$d); # refs to each scalar @array = \( $a, $b, $c, $d); # same thing! @array = map { \my $anon } 0 .. 3; # allocate 4 anon scalarresf ${ $array[2] } += 9; # $c now 12 ${ $array[ $#array ] } *= 5; # $d now 20 ${ $array[-1] } *= 5; # same; $d now 100 $tmp = $array[-1]; # using temporary $$tmp *= 5; # $d now 500 #----------------------------- use Math::Trig qw(pi); # load the constant pi foreach $sref (@array) { # prepare to change $a,$b,$c,$d ($$sref **= 3) *= (4/3 * pi); # replace with spherical volumes } #----------------------------- |
#----------------------------- $c1 = mkcounter(20); $c2 = mkcounter(77); printf "next c1: %d\n", $c1->{NEXT}->(); # 21 printf "next c2: %d\n", $c2->{NEXT}->(); # 78 printf "next c1: %d\n", $c1->{NEXT}->(); # 22 printf "last c1: %d\n", $c1->{PREV}->(); # 21 printf "old c2: %d\n", $c2->{RESET}->(); # 77 #----------------------------- sub mkcounter { my $count = shift; my $start = $count; my $bundle = { "NEXT" => sub { return ++$count }, "PREV" => sub { return --$count }, "GET" => sub { return $count }, "SET" => sub { $count = shift }, "BUMP" => sub { $count += shift }, "RESET" => sub { $count = $start }, }; $bundle->{"LAST"} = $bundle->{"PREV"}; return $bundle; } #----------------------------- |
#----------------------------- $mref = sub { $obj->meth(@_) }; # later... $mref->("args", "go", "here"); #----------------------------- $sref = \$obj->meth; #----------------------------- $cref = $obj->can("meth"); #----------------------------- |
#----------------------------- $record = { NAME => "Jason", EMPNO => 132, TITLE => "deputy peon", AGE => 23, SALARY => 37_000, PALS => [ "Norbert", "Rhys", "Phineas"], }; printf "I am %s, and my pals are %s.\n", $record->{NAME}, join(", ", @{$record->{PALS}}); #----------------------------- # store record $byname{ $record->{NAME} } = $record; # later on, look up by name if ($rp = $byname{"Aron"}) { # false if missing printf "Aron is employee %d.\n", $rp->{EMPNO}; } # give jason a new pal push @{$byname{"Jason"}->{PALS}}, "Theodore"; printf "Jason now has %d pals\n", scalar @{$byname{"Jason"}->{PALS}}; #----------------------------- # Go through all records while (($name, $record) = each %byname) { printf "%s is employee number %d\n", $name, $record->{EMPNO}; } #----------------------------- # store record $employees[ $record->{EMPNO} ] = $record; # lookup by id if ($rp = $employee[132]) { printf "employee number 132 is %s\n", $rp->{NAME}; } #----------------------------- $byname{"Jason"}->{SALARY} *= 1.035; #----------------------------- @peons = grep { $_->{TITLE} =~ /peon/i } @employees; @tsevens = grep { $_->{AGE} == 27 } @employees; #----------------------------- # Go through all records foreach $rp (sort { $a->{AGE} <=> $b->{AGE} } values %byname) { printf "%s is age %d.\n", $rp->{NAME}, $rp->{AGE}; # or with a hash slice on the reference printf "%s is employee number %d.\n", @$rp{'NAME','EMPNO'}; } #----------------------------- # use @byage, an array of arrays of records push @{ $byage[ $record->{AGE} ] }, $record; #----------------------------- for ($age = 0; $age <= $#byage; $age++) { next unless $byage[$age]; print "Age $age: "; foreach $rp (@{$byage[$age]}) { print $rp->{NAME}, " "; } print "\n"; } #----------------------------- for ($age = 0; $age <= $#byage; $age++) { next unless $byage[$age]; printf "Age %d: %s\n", $age, join(", ", map {$_->{NAME}} @{$byage[$age]}); } #----------------------------- |
#----------------------------- FieldName: Value #----------------------------- foreach $record (@Array_of_Records) { for $key (sort keys %$record) { print "$key: $record->{$key}\n"; } print "\n"; } #----------------------------- $/ = ""; # paragraph read mode while (<>) { my @fields = split /^([^:]+):\s*/m; shift @fields; # for leading null field push(@Array_of_Records, { map /(.*)/, @fields }); } #----------------------------- |
#----------------------------- DB<1> $reference = [ { "foo" => "bar" }, 3, sub { print "hello, world\n" } ]; DB<2> x $reference 0 ARRAY(0x1d033c) 0 HASH(0x7b390) 'foo' = 'bar'> 1 3 2 CODE(0x21e3e4) - & in ???> #----------------------------- use Data::Dumper; print Dumper($reference); #----------------------------- D<1> x \@INC 0 ARRAY(0x807d0a8) 0 '/home/tchrist/perllib' 1 '/usr/lib/perl5/i686-linux/5.00403' 2 '/usr/lib/perl5' 3 '/usr/lib/perl5/site_perl/i686-linux' 4 '/usr/lib/perl5/site_perl' 5 '.' #----------------------------- { package main; require "dumpvar.pl" } *dumpvar = \&main::dumpvar if __PACKAGE__ ne 'main'; dumpvar("main", "INC"); # show both @INC and %INC #----------------------------- @INC = ( 0 '/home/tchrist/perllib/i686-linux' 1 '/home/tchrist/perllib' 2 '/usr/lib/perl5/i686-linux/5.00404' 3 '/usr/lib/perl5' 4 '/usr/lib/perl5/site_perl/i686-linux' 5 '/usr/lib/perl5/site_perl' 6 '.' ) %INC = ( 'dumpvar.pl' = '/usr/lib/perl5/i686-linux/5.00404/dumpvar.pl' 'strict.pm' = '/usr/lib/perl5/i686-linux/5.00404/strict.pm' ) #----------------------------- use Data::Dumper; print Dumper(\@INC); $VAR1 = [ '/home/tchrist/perllib', '/usr/lib/perl5/i686-linux/5.00403', '/usr/lib/perl5', '/usr/lib/perl5/site_perl/i686-linux', '/usr/lib/perl5/site_perl', '.' ]; #----------------------------- |
#----------------------------- use Storable; $r2 = dclone($r1); #----------------------------- @original = ( \@a, \@b, \@c ); @surface = @original; #----------------------------- @deep = map { [ @$_ ] } @original; #----------------------------- use Storable qw(dclone); $r2 = dclone($r1); #----------------------------- %newhash = %{ dclone(\%oldhash) }; #----------------------------- |
#----------------------------- use Storable; store(\%hash, "filename"); # later on... $href = retrieve("filename"); # by ref %hash = %{ retrieve("filename") }; # direct to hash #----------------------------- use Storable qw(nstore); nstore(\%hash, "filename"); # later ... $href = retrieve("filename"); #----------------------------- use Storable qw(nstore_fd); use Fcntl qw(:DEFAULT :flock); sysopen(DF, "/tmp/datafile", O_RDWR|O_CREAT, 0666) or die "can't open /tmp/datafile: $!"; flock(DF, LOCK_EX) or die "can't lock /tmp/datafile: $!"; nstore_fd(\%hash, *DF) or die "can't store hash\n"; truncate(DF, tell(DF)); close(DF); #----------------------------- use Storable; use Fcntl qw(:DEFAULT :flock); open(DF, "< /tmp/datafile") or die "can't open /tmp/datafile: $!"; flock(DF, LOCK_SH) or die "can't lock /tmp/datafile: $!"; $href = retrieve(*DF); close(DF); #----------------------------- |
#----------------------------- use MLDBM qw(DB_File); use Fcntl; tie(%hash, 'MLDBM', 'testfile.db', O_CREAT|O_RDWR, 0666) or die "can't open tie to testfile.db: $!"; # ... act on %hash untie %hash; #----------------------------- use MLDBM qw(DB_File); use Fcntl; tie(%hash, 'MLDBM', 'testfile.db', O_CREAT|O_RDWR, 0666) or die "can't open tie to testfile.db: $!"; #----------------------------- # this doesn't work! $hash{"some key"}[4] = "fred"; # RIGHT $aref = $hash{"some key"}; $aref->[4] = "fred"; $hash{"some key"} = $aref; #----------------------------- |
#----------------------------- # download the following standalone program #!/usr/bin/perl -w # bintree - binary tree demo program use strict; my($root, $n); # first generate 20 random inserts while ($n++ < 20) { insert($root, int(rand(1000)) } # now dump out the tree all three ways print "Pre order: "; pre_order($root); print "\n"; print "In order: "; in_order($root); print "\n"; print "Post order: "; post_order($root); print "\n"; # prompt until EOF for (print "Search? "; <>; print "Search? ") { chomp; my $found = search($root, $_); if ($found) { print "Found $_ at $found, $found->{VALUE}\n" } else { print "No $_ in tree\n" } } exit; ######################################### # insert given value into proper point of # provided tree. If no tree provided, # use implicit pass by reference aspect of @_ # to fill one in for our caller. sub insert { my($tree, $value) = @_; unless ($tree) { $tree = {}; # allocate new node $tree->{VALUE} = $value; $tree->{LEFT} = undef; $tree->{RIGHT} = undef; $_[0] = $tree; # $_[0] is reference param! return; } if ($tree->{VALUE} > $value) { insert($tree->{LEFT}, $value) } elsif ($tree->{VALUE} < $value) { insert($tree->{RIGHT}, $value) } else { warn "dup insert of $value\n" } # XXX: no dups } # recurse on left child, # then show current value, # then recurse on right child. sub in_order { my($tree) = @_; return unless $tree; in_order($tree->{LEFT}); print $tree->{VALUE}, " "; in_order($tree->{RIGHT}); } # show current value, # then recurse on left child, # then recurse on right child. sub pre_order { my($tree) = @_; return unless $tree; print $tree->{VALUE}, " "; pre_order($tree->{LEFT}); pre_order($tree->{RIGHT}); } # recurse on left child, # then recurse on right child, # then show current value. sub post_order { my($tree) = @_; return unless $tree; post_order($tree->{LEFT}); post_order($tree->{RIGHT}); print $tree->{VALUE}, " "; } # find out whether provided value is in the tree. # if so, return the node at which the value was found. # cut down search time by only looking in the correct # branch, based on current value. sub search { my($tree, $value) = @_; return unless $tree; if ($tree->{VALUE} == $value) { return $tree; } search($tree->{ ($value < $tree->{VALUE}) ? "LEFT" : "RIGHT"}, $value) } #----------------------------- |