Perl/FAQ/Ссылки и записи

Материал из Wiki.crossplatform.ru

Перейти к: навигация, поиск
Perl ·

Содержание

[править] 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)
 
}
 
#-----------------------------