|
Perl/FAQ/Подпрограммы
Материал из Wiki.crossplatform.ru
[править] Introduction
#-----------------------------
sub hello {
$greeted++; # global variable
print "hi there!\n";
}
#-----------------------------
hello(); # call subroutine hello with no arguments/parameters
#-----------------------------
[править] Accessing Subroutine Arguments
#-----------------------------
sub hypotenuse {
return sqrt( ($_[0] ** 2) + ($_[1] ** 2) );
}
$diag = hypotenuse(3,4); # $diag is 5
#-----------------------------
sub hypotenuse {
my ($side1, $side2) = @_;
return sqrt( ($side1 ** 2) + ($side2 ** 2) );
}
#-----------------------------
print hypotenuse(3, 4), "\n"; # prints 5
@a = (3, 4);
print hypotenuse(@a), "\n"; # prints 5
#-----------------------------
@both = (@men, @women);
#-----------------------------
@nums = (1.4, 3.5, 6.7);
@ints = int_all(@nums); # @nums unchanged
sub int_all {
my @retlist = @_; # make safe copy for return
for my $n (@retlist) { $n = int($n) }
return @retlist;
}
#-----------------------------
@nums = (1.4, 3.5, 6.7);
trunc_em(@nums); # @nums now (1,3,6)
sub trunc_em {
for (@_) { $_ = int($_) } # truncate each argument
}
#-----------------------------
$line = chomp(<>); # WRONG
#-----------------------------
[править] Making Variables Private to a Function
#-----------------------------
sub somefunc {
my $variable; # $variable is invisible outside somefunc()
my ($another, @an_array, %a_hash); # declaring many variables at once
# ...
}
#-----------------------------
my ($name, $age) = @ARGV;
my $start = fetch_time();
#-----------------------------
my ($a, $b) = @pair;
my $c = fetch_time();
sub check_x {
my $x = $_[0];
my $y = "whatever";
run_check();
if ($condition) {
print "got $x\n";
}
}
#-----------------------------
sub save_array {
my @arguments = @_;
push(@Global_Array, \@arguments);
}
#-----------------------------
[править] Creating Persistent Private Variables
#-----------------------------
{
my $variable;
sub mysub {
# ... accessing $variable
}
}
#-----------------------------
BEGIN {
my $variable = 1; # initial value
sub othersub { # ... accessing $variable
}
}
#-----------------------------
{
my $counter;
sub next_counter { return ++$counter }
}
#-----------------------------
BEGIN {
my $counter = 42;
sub next_counter { return ++$counter }
sub prev_counter { return --$counter }
}
#-----------------------------
[править] Determining Current Function Name
#-----------------------------
$this_function = (caller(0))[3];
#-----------------------------
($package, $filename, $line, $subr, $has_args, $wantarray )= caller($i);
# 0 1 2 3 4 5
#-----------------------------
$me = whoami();
$him = whowasi();
sub whoami { (caller(1))[3] }
sub whowasi { (caller(2))[3] }
#-----------------------------
[править] Passing Arrays and Hashes by Reference
#-----------------------------
array_diff( \@array1, \@array2 );
#-----------------------------
@a = (1, 2);
@b = (5, 8);
@c = add_vecpair( \@a, \@b );
print "@c\n";
6 10
sub add_vecpair { # assumes both vectors the same length
my ($x, $y) = @_; # copy in the array references
my @result;
for (my $i=0; $i < @$x; $i++) {
$result[$i] = $x->[$i] + $y->[$i];
}
return @result;
}
#-----------------------------
unless (@_ == 2 && ref($x) eq 'ARRAY' && ref($y) eq 'ARRAY') {
die "usage: add_vecpair ARRAYREF1 ARRAYREF2";
}
#-----------------------------
[править] Detecting Return Context
#-----------------------------
if (wantarray()) {
# list context
}
elsif (defined wantarray()) {
# scalar context
}
else {
# void context
}
#-----------------------------
if (wantarray()) {
print "In list context\n";
return @many_things;
} elsif (defined wantarray()) {
print "In scalar context\n";
return $one_thing;
} else {
print "In void context\n";
return; # nothing
}
mysub(); # void context
$a = mysub(); # scalar context
if (mysub()) { } # scalar context
@a = mysub(); # list context
print mysub(); # list context
#-----------------------------
[править] Passing by Named Parameter
#-----------------------------
thefunc(INCREMENT => "20s", START => "+5m", FINISH => "+30m");
thefunc(START => "+5m", FINISH => "+30m");
thefunc(FINISH => "+30m");
thefunc(START => "+5m", INCREMENT => "15s");
#-----------------------------
sub thefunc {
my %args = (
INCREMENT => '10s',
FINISH => 0,
START => 0,
@_, # argument pair list goes here
);
if ($args{INCREMENT} =~ /m$/ ) { ..... }
}
#-----------------------------
[править] Skipping Selected Return Values
#-----------------------------
($a, undef, $c) = func();
#-----------------------------
($a, $c) = (func())[0,2];
#-----------------------------
($dev,$ino,$DUMMY,$DUMMY,$uid) = stat($filename);
#-----------------------------
($dev,$ino,undef,undef,$uid) = stat($filename);
#-----------------------------
($dev,$ino,$uid,$gid) = (stat($filename))[0,1,4,5];
#-----------------------------
() = some_function();
#-----------------------------
[править] Returning More Than One Array or Hash
#-----------------------------
($array_ref, $hash_ref) = somefunc();
sub somefunc {
my @array;
my %hash;
# ...
return ( \@array, \%hash );
}
#-----------------------------
sub fn {
.....
return (\%a, \%b, \%c); # or
return \(%a, %b, %c); # same thing
}
#-----------------------------
(%h0, %h1, %h2) = fn(); # WRONG!
@array_of_hashes = fn(); # eg: $array_of_hashes[2]->{"keystring"}
($r0, $r1, $r2) = fn(); # eg: $r2->{"keystring"}
#-----------------------------
[править] Returning Failure
#-----------------------------
return;
#-----------------------------
sub empty_retval {
return ( wantarray ? () : undef );
}
#-----------------------------
if (@a = yourfunc()) { ... }
#-----------------------------
unless ($a = sfunc()) { die "sfunc failed" }
unless (@a = afunc()) { die "afunc failed" }
unless (%a = hfunc()) { die "hfunc failed" }
#-----------------------------
ioctl(....) or die "can't ioctl: $!";
#-----------------------------
[править] Prototyping Functions
#-----------------------------
@results = myfunc 3, 5;
#-----------------------------
@results = myfunc(3, 5);
#-----------------------------
sub myfunc($);
@results = myfunc 3, 5;
#-----------------------------
@results = ( myfunc(3), 5 );
#-----------------------------
sub LOCK_SH () { 1 }
sub LOCK_EX () { 2 }
sub LOCK_UN () { 4 }
#-----------------------------
sub mypush (\@@) {
my $array_ref = shift;
my @remainder = @_;
# ...
}
#-----------------------------
mypush( $x > 10 ? @a : @b , 3, 5 ); # WRONG
#-----------------------------
mypush( @{ $x > 10 ? \@a : \@b }, 3, 5 ); # RIGHT
#-----------------------------
sub hpush(\%@) {
my $href = shift;
while ( my ($k, $v) = splice(@_, 0, 2) ) {
$href->{$k} = $v;
}
}
hpush(%pieces, "queen" => 9, "rook" => 5);
#-----------------------------
[править] Handling Exceptions
#-----------------------------
die "some message"; # raise exception
#-----------------------------
eval { func() };
if ($@) {
warn "func raised an exception: $@";
}
#-----------------------------
eval { $val = func() };
warn "func blew up: $@" if $@;
#-----------------------------
eval { $val = func() };
if ($@ && $@ !~ /Full moon!/) {
die; # re-raise unknown errors
}
#-----------------------------
if (defined wantarray()) {
return;
} else {
die "pay attention to my error!";
}
#-----------------------------
[править] Saving Global Values
#-----------------------------
$age = 18; # global variable
if (CONDITION) {
local $age = 23;
func(); # sees temporary value of 23
} # restore old value at block exit
#-----------------------------
$para = get_paragraph(*FH); # pass filehandle glob
$para = get_paragraph(\*FH); # pass filehandle by glob reference
$para = get_paragraph(*IO{FH}); # pass filehandle by IO reference
sub get_paragraph {
my $fh = shift;
local $/ = '';
my $paragraph = <$fh>;
chomp($paragraph);
return $paragraph;
}
#-----------------------------
$contents = get_motd();
sub get_motd {
local *MOTD;
open(MOTD, "/etc/motd") or die "can't open motd: $!";
local $/ = undef; # slurp full file;
local $_ = <MOTD>;
close (MOTD);
return $_;
}
#-----------------------------
return *MOTD;
#-----------------------------
my @nums = (0 .. 5);
sub first {
local $nums[3] = 3.14159;
second();
}
sub second {
print "@nums\n";
}
second();
0 1 2 3 4 5
first();
0 1 2 3.14159 4 5
#-----------------------------
sub first {
local $SIG{INT} = 'IGNORE';
second();
}
#-----------------------------
sub func {
local($x, $y) = @_;
#....
}
#-----------------------------
sub func {
my($x, $y) = @_;
#....
}
#-----------------------------
&func(*Global_Array);
sub func {
local(*aliased_array) = shift;
for (@aliased_array) { .... }
}
#-----------------------------
func(\@Global_Array);
sub func {
my $array_ref = shift;
for (@$array_ref) { .... }
}
#-----------------------------
[править] Redefining a Function
#-----------------------------
undef &grow; # silence -w complaints of redefinition
*grow = \&expand;
grow(); # calls expand()
{
local *grow = \&shrink; # only until this block exists
grow(); # calls shrink()
}
#-----------------------------
*one::var = \%two::Table; # make %one::var alias for %two::Table
*one::big = \&two::small; # make &one::big alias for &two::small
#-----------------------------
local *fred = \&barney; # temporarily alias &fred to &barney
#-----------------------------
$string = red("careful here");
print $string;
<FONT COLOR='red'>careful here</FONT>
#-----------------------------
sub red { "<FONT COLOR='red'>@_</FONT>" }
#-----------------------------
sub color_font {
my $color = shift;
return "<FONT COLOR='$color'>@_</FONT>";
}
sub red { color_font("red", @_) }
sub green { color_font("green", @_) }
sub blue { color_font("blue", @_) }
sub purple { color_font("purple", @_) }
# etc
#-----------------------------
@colors = qw(red blue green yellow orange purple violet);
for my $name (@colors) {
no strict 'refs';
*$name = sub { "<FONT COLOR='$name'>@_</FONT>" };
}
#-----------------------------
*$name = sub ($) { "<FONT COLOR='$name'>$_[0]</FONT>" };
#-----------------------------
[править] Trapping Undefined Function Calls with AUTOLOAD
#-----------------------------
sub AUTOLOAD {
use vars qw($AUTOLOAD);
my $color = $AUTOLOAD;
$color =~ s/.*:://;
return "<FONT COLOR='$color'>@_</FONT>";
}
#note: sub chartreuse isn't defined.
print chartreuse("stuff");
#-----------------------------
{
local *yellow = \&violet;
local (*red, *green) = (\&green, \&red);
print_stuff();
}
#-----------------------------
[править] Nesting Subroutines
#-----------------------------
sub outer {
my $x = $_[0] + 35;
sub inner { return $x * 19 } # WRONG
return $x + inner();
}
#-----------------------------
sub outer {
my $x = $_[0] + 35;
local *inner = sub { return $x * 19 };
return $x + inner();
}
#-----------------------------
[править] Program: Sorting Your Mail
#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# bysub1 - simple sort by subject
my(@msgs, @sub);
my $msgno = -1;
$/ = ''; # paragraph reads
while (<>) {
if (/^From/m) {
/^Subject:\s*(?:Re:\s*)*(.*)/mi;
$sub[++$msgno] = lc($1) || '';
}
$msgs[$msgno] .= $_;
}
for my $i (sort { $sub[$a] cmp $sub[$b] || $a <=> $b } (0 .. $#msgs)) {
print $msgs[$i];
}
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -n00
# bysub2 - awkish sort-by-subject
BEGIN { $msgno = -1 }
$sub[++$msgno] = (/^Subject:\s*(?:Re:\s*)*(.*)/mi)[0] if /^From/m;
$msg[$msgno] .= $_;
END { print @msg[ sort { $sub[$a] cmp $sub[$b] || $a <=> $b } (0 .. $#msg) ] }
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -00
# bysub3 - sort by subject using hash records
use strict;
my @msgs = ();
while (<>) {
push @msgs, {
SUBJECT => /^Subject:\s*(?:Re:\s*)*(.*)/mi,
NUMBER => scalar @msgs, # which msgno this is
TEXT => '',
} if /^From/m;
$msgs[-1]{TEXT} .= $_;
}
for my $msg (sort {
$a->{SUBJECT} cmp $b->{SUBJECT}
||
$a->{NUMBER} <=> $b->{NUMBER}
} @msgs
)
{
print $msg->{TEXT};
}
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -00
# datesort - sort mbox by subject then date
use strict;
use Date::Manip;
my @msgs = ();
while (<>) {
next unless /^From/m;
my $date = '';
if (/^Date:\s*(.*)/m) {
($date = $1) =~ s/\s+\(.*//; # library hates (MST)
$date = ParseDate($date);
}
push @msgs, {
SUBJECT => /^Subject:\s*(?:Re:\s*)*(.*)/mi,
DATE => $date,
NUMBER => scalar @msgs,
TEXT => '',
};
} continue {
$msgs[-1]{TEXT} .= $_;
}
for my $msg (sort {
$a->{SUBJECT} cmp $b->{SUBJECT}
||
$a->{DATE} cmp $b->{DATE}
||
$a->{NUMBER} <=> $b->{NUMBER}
} @msgs
)
{
print $msg->{TEXT};
}
#-----------------------------
|