PLEAC-Perl 教程 - Records and references (Perl进阶者极力推荐)-优快云博客

本文深入探讨了Perl中的引用概念，包括如何创建和使用不同类型的引用，如数组引用、哈希引用等，并介绍了引用在数据结构管理和文件操作中的应用。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

11. References and Records

Introduction

#-----------------------------
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,
       };
#-----------------------------

Taking References to Arrays

#-----------------------------
$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
}
#-----------------------------

Making Hashes of Arrays

#-----------------------------
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} }
                : ();
#-----------------------------

Taking References to Hashes

#-----------------------------
$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
} 
#-----------------------------

Taking References to Functions

#-----------------------------
$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.
#-----------------------------

Taking References to Scalars

#-----------------------------
$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";

}
#-----------------------------

Creating Arrays of Scalar References

#-----------------------------
@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
}
#-----------------------------

Using Closures Instead of Objects

#-----------------------------
$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;
}
#-----------------------------

Creating References to Methods

#-----------------------------
$mref = sub { $obj->meth(@_) }; 
# later...  
$mref->("args", "go", "here");
#-----------------------------
$sref = /$obj->meth;
#-----------------------------
$cref = $obj->can("meth");
#-----------------------------

Constructing Records

#-----------------------------
$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]});

}
#-----------------------------

Reading and Writing Hash Records to Text Files

#-----------------------------
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 });
} 
#-----------------------------

Printing Data Structures

#-----------------------------
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', 

      '.'

];
#-----------------------------

Copying Data Structures

#-----------------------------
use Storable;

$r2 = dclone($r1);
#-----------------------------
@original = ( /@a, /@b, /@c );
@surface = @original;
#-----------------------------
@deep = map { [ @$_ ] } @original;
#-----------------------------
use Storable qw(dclone); 
$r2 = dclone($r1);
#-----------------------------
%newhash = %{ dclone(/%oldhash) };
#-----------------------------

Storing Data Structures to Disk

#-----------------------------
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);
#-----------------------------

Transparently Persistent Data Structures

#-----------------------------
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;
#-----------------------------

Program: Binary Trees

#-----------------------------
# 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)
}

#-----------------------------