|
|
Perl/FAQ/Ссылки и записи
Материал из Wiki.crossplatform.ru
[править] 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)
}
#-----------------------------
|
