PLEAC-Perl 教程 - Subroutines (Perl进阶者极力推荐)

最新推荐文章于 2024-09-24 23:38:45 发布
最新推荐文章于 2024-09-24 23:38:45 发布
阅读量792 收藏
点赞数
分类专栏： C & Perl 文章标签： perl autoload subroutine date variables returning
<script type="text/javascript"> </script> <script type="text/javascript" src="http://pagead2.googlesyndication.com/pagead/show_ads.js"> </script>

10. Subroutines

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

#-----------------------------
bsdplus
关注
专栏目录
Perl基础学习08之perl子程序subroutines，return函数
qq_21478261的博客
04-16 523
Perl中子程序定义、调用、参数传递及子程序中return函数使用。
Note of Learning Perl--Subroutines
03-18
在Perl编程语言中，子程序（Subroutines）是代码重用的关键元素，它们允许我们将复杂任务分解为更小、更易于管理的块。了解和掌握子程序的使用，是提升Perl编程效率的重要步骤。 1. **定义子程序** 在Perl中，我们...
Subroutine 子程序 Perl 第四章
diedai7174的博客
07-18 284
子程序的定义是全局的，不需要事先声明。若重复定义子程序，后面的覆盖前面的。 sub marine { $n +=1; print " Hello ,sailor number $_ ! "; } 调用：&marine; 返回值：最后一次的运算结果会被当作返回值。 变量：所有变量默认为全局变量 参数：@_为subroutine 的私有变量。若恰有全局变量...
perl 总结
fdsafwagdagadg6576的专栏
06-29 3344
小括号 ()是给数组或者hash赋值 整个hash的初始化,用小括号%hash=("foo",35,"bar","12.4"); 列表赋值 ($fred,$barney)=qw (a b c d); ($fred,$barney)=@_; @line=();是置空数组,hash，list 置空都是() 中括号 数组下标[] 对匿名列表的引用：将列表的()替换为[]：my $arr
Sed、Awk单行脚本快速参考
aqi2014的专栏
11-18 452
文本间隔：  # 在每一行后面增加一空行 sed G  awk '{printf("%s\n\n",$0)}'  # 将原来的所有空行删除并在每一行后面增加一空行。 # 这样在输出的文本中每一行后面将有且只有一空行。 sed '/^$/d;G'  awk '!/^$/{printf("%s\n\n",$0)}' # 在每一行后面增加两行空行 sed 'G;G'  awk '{printf
Perl一行式：文本编解码、替换
weixin_30602505的博客
01-09 480
perl一行式程序系列文章：Perl一行式 文本大小写转换 全部字符转换成大写或小写，有几种方式： # 转大写 $ perl -nle 'print uc' file.log $ perl -ple '$_ = uc' file.log $ perl -nle 'print "\U$_"' file.log # 转小写 $ perl -nle 'print lc' file.log $ per...
PLEAC-Perl 教程 - CGI Programming (Perl进阶者极力推荐)
OpenBSD 咨询与维护
05-06 1588
19. CGI Programming<!--google_ad_client = "pub-5143338080895292";/* 728x90, created 4/10/08 */google_ad_slot = "6675122003";google_ad_width = 728;google_ad_height = 90;//--> <script ty
PLEAC-Perl 教程 - Numbers (Perl进阶者极力推荐)
OpenBSD 咨询与维护
04-25 805
<!--google_ad_client = "pub-5143338080895292";/* 728x90, created 4/10/08 */google_ad_slot = "8165396160";google_ad_width = 728;google_ad_height = 90;//--> <script type="text/javascript"
无涯教程-Perl - Subroutines(子例程)
无涯教程
08-04 633
Perl编程语言中Subroutine子程序定义的一般形式如下:subbodyof调用该PerlSubroutine的典型方式如下-listofarguments在Perl 5.0之前的版本中，调用Subroutine的语法略有不同，如下所示。这仍然可以在Perl的最新版本中使用，但是不建议这样做，因为它会绕过Subroutine原型。listofarguments让我们看下面的示例，该示例定义一个简单的函数然后调用它。
Perl Text Editor:perl简单文本编辑器的源代码。-开源
05-13
开源的Perl文本编辑器提供了用户一个基于Perl语言实现的简单编辑工具，这使得开发者和爱好者能够查看、修改和学习其源代码，以理解Perl如何被用于创建交互式的用户界面。 在描述中提到的"01text0.pl"文件，很可能是...
perl5faq_in_perl6：Perl 5中对perlfaq的回答，但在Perl 6中
02-05
`perl5faq_in_perl6` 项目是针对 Perl 5 FAQ（常见问题解答）的一个翻译或转换工作，目的是将 Perl 5 中的解决方案和知识转化为 Perl 6 的语境。以下是一些关键知识点，涵盖了这两个版本的差异以及如何在 Perl 6 中...
wayne a arthurton's perl modules-开源
07-19
Perl是一种强大的脚本编程语言，尤其在处理文本和系统管理任务方面表现卓越。Wayne A Arthurton是一位活跃的Perl开发者，他为Perl社区贡献了许多有用的模块。这些模块通常是开源的，意味着它们的源代码对公众开放，...
828华为云征文｜使用Flexus X实例创建FDS+Nginx服务实现图片上传功能
最新发布
qq_53317005的博客
09-24 813
华为云推出的Flexus云服务器X系列，是在华为顶尖技术团队，特别是荣获国家科技进步奖的领军人物顾炯炯博士及其团队的主导下精心研发的。这款服务器深度融合了擎天QingTian架构的先进设计理念、瑶光云脑的智能优化能力，以及盘古大模型的强大计算能力，开创性地成为市场上首个以应用需求为核心驱动的灵活算力解决方案。
嵌入式学习之闪光的摆.zip
09-24
嵌入式学习，电子信息技术
cache的snoop vs directory，两种方式比较
09-24
cache的snoop vs directory，两种方式比较
基于java的博客系统的开题报告.docx
09-24
基于java的博客系统的开题报告.docx
基于Python, JavaScript和HTML的交互式背单词学习工具设计源码
09-24
该项目是一个基于Python, JavaScript和HTML的交互式背单词学习工具设计源码，主要使用JavaScript语言开发。项目包含27个文件，其中8个文本文件（txt），6个Python脚本（py），4个Markdown文档（md），3个JavaScript文件（js），2个JSON配置文件，1个Git忽略文件（gitignore），1个许可证文件（LICENSE），1个原型定义文件（proto）和1个HTML页面文件。这个工具旨在通过交互式学习提高用户的单词记忆效率。
Delphi 教程.txt Delphi 教程.txt Delphi 教程.txt Delphi 教程.txt Delphi
09-24
Delphi 教程.txt Delphi 教程.txt Delphi 教程.txt Delphi 教程.txt Delphi
PerlCookbook：Perl编程经典指南
《O'Reilly Perl Cookbook》是一本由Tom Christiansen和Nathan Torkington合著的经典Perl编程指南，于1998年8月首次出版。该书的ISBN为1-56592-243-3，共794页，专为深入理解和掌握Perl语言而设计。这本实用手册涵盖...
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值