README

These are the sample files for use with the third edition of the Llama
book (Learning Perl by Randal Schwartz and Tom Phoenix, available from
O'Reilly and Associates.) These files may be distributed under the same
licensing terms as Perl itself.

Enjoy!

    -- Randal and Tom


llama sample files version 1.1  10 june 2001.

bamm-bamm

bamm-bamm 1
bamm-bamm 2
bamm-bamm 3
bamm-bamm 4
bamm-bamm 5
bamm-bamm 6
bamm-bamm 7
bamm-bamm 8
bamm-bamm 9

barney

barney 1
barney 2
barney 3
barney 4
barney 5 (barney fife?)
barney 6

betty

betty 1
betty 2
betty 3
betty 4
betty 5

dino

dino 1
dino 2
dino 3
dino 4

ex01-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-

use 5.010;
use strict;
use warnings;

say "Hello World";

1;

ex01-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-

use 5.010;
use strict;
use warnings;

my @lines = `perldoc -u -f atan2`;

foreach (@lines) {
    s/\w<([^>]+)>/\U$1/g;
    print;
}

1;

ex02-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-

use 5.010;
use strict;
use diagnostics;

say 12.5 * 2 * 3.141592654;

1;

ex02-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-

use 5.010;
use strict;
use diagnostics;

chomp(my $radius = <STDIN>);

say $radius * 2 * 3.141592654;

1;

ex02-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-

use 5.010;
use strict;
use diagnostics;

chomp(my $radius = <STDIN>);

if ($radius < 0) {
    say 0;
} else {
    say $radius * 2 * 3.141592654;
}

1;

ex02-4.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-

use 5.010;
use strict;
use diagnostics;

print 'Please enter first number: ';

chomp(my $num1 = <STDIN>);

print 'Please enter second number: ';

chomp(my $num2 = <STDIN>);

say "The multiplication result is ${my $result = $num1 * $num2; \$result}";

1;

ex02-5.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-

use 5.010;
use strict;
use diagnostics;

print 'Please enter a string: ';

my $string = <STDIN>;

print 'Please enter times you want to duplicate: ';

chomp(my $times = <STDIN>);

print $string x $times;

1;

ex03-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-

use 5.010;
use diagnostics;
use strict;
use warnings;

print reverse <STDIN>;

1;

ex03-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-

use 5.010;
use diagnostics;
use strict;
use warnings;

my @names = qw/ fred betty barney dino wilma pebbles bamm-bamm /;
my @input = <STDIN>;

foreach (@input) {
    say $names[$_ - 1];
}

1;

ex03-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-

use 5.010;
use diagnostics;
use strict;
use warnings;

chomp(my @lines = sort <STDIN>);

say "@lines";

foreach (@lines) {
    say;
}

1;

ex04-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my @fred = qw{ 1 3 5 7 9};
my $fred_total = &total(@fred);
print "\@fred 的總合是 $fred_total。\n";
print " 請輸入一些數值，每列一個：";
my $user_total = &total(<STDIN>);
print " 以上數值的總和是 $user_total。\n";

sub total {
    my $sum = 0;
    foreach (@_) {
        $sum += $_;
    }
    $sum;
}

1;

ex04-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

sub total {
    my $sum = 0;
    foreach (@_) {
        $sum += $_;
    }
    $sum;
}

say "1 到 1000 的數值總和是 ", &total(1..1000);

1;

ex04-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

sub total {
    my $sum = 0;
    foreach (@_) {
        $sum += $_;
    }
    $sum;
}

sub above_average {
    my $average = &total(@_) / ($#_ + 1);
    my @array = ();
    foreach (@_) {
        if ($_ > $average) {
            push @array, $_;
        }
    }
    @array;
}

my @fred = &above_average(1..10);
print "\@fred 的內容為 @fred\n";
print "（結果應該是 6 7 8 9 10）\n";
my @barney = &above_average(100, 1..10);
print "\@barney 的內容為 @barney\n";
print "（結果應該是 100）\n";

1;

ex04-4.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

sub greet {
    state $guest;
    if ($guest) {
        say "Hi @_! $guest is also here!";
    } else {
        say "Hi @_! You are the first one here!";
    }
    ($guest) = @_;
}

greet( "Fred" );
greet( "Barney" );

1;

ex04-5.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

sub greet {
    state @guests;
    if (@guests) {
        say "Hi @_! I've seen: @guests";
    } else {
        say "Hi @_! You are the first one here!";
    }
    push @guests, @_;
}

greet( "Fred" );
greet( "Barney" );
greet( "Wilma" );
greet( "Betty" );

1;

ex05-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

foreach (reverse <>) {
    print;
}

1;

ex05-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

say "1234567890" x 8;

while (<>) {
    chomp;
    printf "%20s\n", $_;
}

1;

ex05-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

print "請輸入您要的欄寬：";

chomp(my $width = <STDIN>);

my $times = 8;

if ($width > $times * 10) {
    $times = ($width + 9) / 10;
}

say "1234567890" x $times;

while (<STDIN>) {
    chomp;
    printf "%".$width."s\n", $_;
}

1;

ex06-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my %namebook = qw {
    fred flintstone
    barney rubble
    wilma flintstone
};

chomp(my $name = <STDIN>);

if (exists $namebook{$name}) {
    say "$name $namebook{$name}";
} else {
    say "There is no $name";
}

1;

ex06-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my %counter;

while (<>) {
    chomp;
    $counter{$_}++;
}

foreach (sort keys %counter) {
    say "$_ => $counter{$_}";
}

1;

ex06-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;


my $max_length = 0;

foreach (keys %ENV) {
    my $length = length $_;
    if ($max_length < $length) {
        $max_length = $length;
    }
}

foreach (sort keys %ENV) {
    printf "%-*s %s\n", $max_length, $_, $ENV{$_};
}

1;

ex08-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

while (<>) {
    chomp;
    if (/match/) {
        say "符合: |$`<$&>$'|";
    } else {
        say "不符合: |$_|";
    }
}

1;

ex08-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

while (<>) {
    chomp;
    if (/\b\w*a\b/) {
        say "符合: |$`<$&>$'|";
    } else {
        say "不符合: |$_|";
    }
}

1;

ex08-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

while (<>) {
    chomp;
    if (/\b(\w*a)\b/) {
        say "\$1 裡面是 '$1'";
    } else {
        say "不符合: |$_|";
    }
}

1;

ex08-4.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

while (<>) {
    chomp;
    if (/\b(?<word>\w*a)\b/) {
        say "'word' 裡面是 '$+{word}'";
    } else {
        say "不符合: |$_|";
    }
}

1;

ex08-5.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

while (<>) {
    chomp;
    if (/\b(?<word>\w*a)\b(?<rest>.{0,5})/) {
        say "'word' 裡面是 '$+{word}' 之後是 '$+{rest}'";
    } else {
        say "不符合: |$_|";
    }
}

1;

ex08-6.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

while (<>) {
    chomp;
    print;
    say((/\s+$/) ? '$' : '');
}

1;

ex09-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my $what = 'fred|barney';

while (<>) {
    chomp;
    say if /($what){3}/;
}

1;

ex09-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my $in = $ARGV[0];

die "Usage: $0 <file>" unless $in;

my $out = $in;

$out =~ s/(.*)/$1.out/;

die "$in $!" unless open IN, "< $in";
die "$out $!" unless open OUT, "> $out";

while (<IN>) {
    s/Fred/Larry/ig;
    print OUT;
}

1;

ex09-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my $in = $ARGV[0];

die "Usage: $0 <file>" unless $in;

my $out = $in;

$out =~ s/(.*)/$1.out/;

die "$in $!" unless open IN, "< $in";
die "$out $!" unless open OUT, "> $out";

while (<IN>) {
    s/Fred/\\0/ig;
    s/Wilma/Fred/ig;
    s/\\0/Wilma/g;
    print OUT;
}

1;

ex09-4.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

$^I = '.bak';

while (<>) {
    if (/^#!/) {
        $_.= "## Copyright (C) 2010 by FourDollars\n"
    }
    print;
}

1;

ex09-5.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my %file;
$file{$_}++ foreach (@ARGV);

while (<>) {
    delete $file{$ARGV} if /^## Copyright/;
}

@ARGV = keys %file;

$^I = '.bak';

while (<>) {
    if (/^#!/) {
        $_.= "## Copyright (C) 2010 by FourDollars\n"
    }
    print;
}

1;

ex10-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my $magic = int(1 + rand 100);

while (<>) {
    chomp;
    last if /quit|exit/ or $_ eq '';
    if ($_ > $magic) {
        say '太高';
    } elsif ($_ < $magic) {
        say '太低';
    } else {
        say "答對囉！";
        last;
    }
}

1;

ex10-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my $magic = int(1 + rand 100);
my $debug = $ENV{'DEBUG'} // 1;

while (<>) {
    chomp;
    last if /quit|exit/ or $_ eq '';
    print "跟 $magic 比較: " if $debug;
    if ($_ > $magic) {
        say '太高';
    } elsif ($_ < $magic) {
        say '太低';
    } else {
        say "答對囉！";
        last;
    }
}

1;

ex10-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;


my $max_length = 0;

$ENV{'ZERO'} = 0;
$ENV{'EMPTY'} = '';
$ENV{'UNDEF'} = undef;

foreach (keys %ENV) {
    my $length = length $_;
    if ($max_length < $length) {
        $max_length = $length;
    }
}

foreach (sort keys %ENV) {
    printf "%-*s %s\n", $max_length, $_, $ENV{$_} // '(undefined)';
}

1;

ex11.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;
use Module::CoreList;

my %modules = %{ $Module::CoreList::version{5.008} };
say $_ foreach (sort keys %modules);

1;

ex12-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

foreach (@ARGV) {
    if ( ! -e $_ ) {
        say "$_ doesn't exist.";
        next;
    }
    print "$_ is ";
    print (( -R _ ) ? 'readable ' : 'unreadable ');
    print (( -W _ ) ? 'writable ' : 'unwritable ');
    print (( -X _ ) ? "executable\n" : "unexecutable\n");
}

1;

ex12-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my $file;
my $day = 0;

foreach (@ARGV) {
    my $tmp = -M $_;
    if ($tmp > $day) {
        $day = $tmp;
        $file = $_;
    }
}

if (defined $file) {
    say "最舊的檔案 $file 存在了 ".int($day)." 天";
} else {
    say '沒有檔案';
}

1;

ex12-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

foreach (@ARGV) {
    say "$_" if ( -W -R -O $_ );
}

1;

ex13-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

chomp(my $dir = <STDIN>);

if ($dir) {
    chdir $dir or die "$!";
} else {
    chdir or die "$!";
}

say foreach (<*>);

1;

ex13-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

chomp(my $dir = <STDIN>);

if ($dir) {
    chdir $dir or die "$!";
} else {
    chdir or die "$!";
}

say foreach (<.* *>);

1;

ex13-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

chomp(my $dir = <STDIN>);

if ($dir) {
    opendir DIR, $dir or die "$!";
} else {
    opendir DIR, $ENV{'HOME'} or die "$!";
}

my @files = sort readdir DIR;

say foreach (@files);

closedir DIR;

1;

ex13-4.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

unlink @ARGV;

1;

ex13-5.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

use File::Basename qw/ basename /;
use File::Spec::Functions qw/ catfile /;

my $file = shift @ARGV;
my $target = shift @ARGV;

if ( -d $target ) {
    $target = catfile($target, basename $file);
}

rename $file, $target or die "$!";

1;

ex13-6.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

use File::Basename qw/ basename /;
use File::Spec::Functions qw/ catfile /;

my $file = shift @ARGV;
my $target = shift @ARGV;

if ( -d $target ) {
    $target = catfile($target, basename $file);
}

link $file, $target or die "$!";

1;

ex13-7.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

use File::Basename qw/ basename /;
use File::Spec::Functions qw/ catfile /;

my %opt;
my $file = shift @ARGV;
if ($file eq '-s') {
    $opt{'symbolic'} = 1;
    $file = shift @ARGV;
}
my $target = shift @ARGV;

if ( -d $target ) {
    $target = catfile($target, basename $file);
}

if ($opt{'symbolic'}) {
    symlink $file, $target or die "$!";
} else {
    link $file, $target or die "$!";
}

1;

ex13-8.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

foreach (<.* *>) {
    say "$_ -> ".(readlink $_) if ( -l );
}

1;

ex14-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my @numbers = qw{ 17 1000 04 1.50 3.14159 -10 1.5 4 2001 90210 666 };

printf "%20g\n", $_ foreach sort { $a <=> $b } @numbers;

1;

ex14-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my %sortable_hash = qw{
    fred flintstone Wilma Flintstone Barney Rubble
    betty rubble Bamm-Bamm Rubble PEBBLES FLINTSTONE
};

sub by_fullname {
    "\L$sortable_hash{$a}" cmp "\L$sortable_hash{$b}"
        or
    "\L$a" cmp "\L$b";
}

say "$_ $sortable_hash{$_}" foreach sort by_fullname keys %sortable_hash;

1;

ex14-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

say "請輸入一串文字";
chomp(my $string = <STDIN>);

say "請輸入要找的文字";
chomp(my $needle = <STDIN>);

my $idx = 0;

while ($idx != -1) {
    $idx = index($string, $needle, $idx + 1);
    say $idx if $idx != -1;
}

1;

ex15-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my $magic = int(1 + rand 100);

while (1) {
    given (<>) {
        chomp;
        when (/quit|exit/ or $_ eq '') {
            say '離開';
            last;
        }
        when ($_ > $magic) {
            say '太高';
        }
        when ($_ < $magic) {
            say '太低';
        }
        default {
            say "答對囉！";
            last;
        }
    }
}

1;

ex15-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

say "請輸入一個數值";
chomp(my $number = <STDIN>);

$number ~~ /^\d+$/ or die "輸入的 '$number' 並非數值";

given ($number) {
    when ($_ % 3 == 0) { say "Fizz"; continue }
    when ($_ % 5 == 0) { say "Bin"; continue }
    when ($_ % 7 == 0) { say "Sausage"; continue }
}

1;

ex15-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

foreach (@ARGV) {
    when (-r) {say "$_ is readable."; continue }
    when (-w) {say "$_ is writable."; continue }
    when (-x) {say "$_ is executable."; continue }
}

1;

ex15-4.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

sub divisors {
    my $number = shift;
    my @divisors = ();
    foreach my $divisor ( 2 .. $number/2 ) {
        push @divisors, $divisor unless $number % $divisor;
    }
    return @divisors;
}

say "請輸入一個正整數數值";
chomp(my $number = <STDIN>);

given ($number) {
    when ( ! /^\d+$/ ) { say "這不是一個正整數數值" }
    my @divisors = divisors($number);
    my @empty = ();
    when ( @divisors ~~ @empty ) { say "這是一個質數" }
    default {
        say "因數有 @divisors";
    }
}

1;

ex15-5.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

sub divisors {
    my $number = shift;
    my @divisors = ();
    foreach my $divisor ( 2 .. $number/2 ) {
        push @divisors, $divisor unless $number % $divisor;
    }
    return @divisors;
}

say "請輸入一個正整數數值";
chomp(my $number = <STDIN>);

given ($number) {
    when ( ! /^\d+$/ ) { say "這不是一個正整數數值" }
    when ( 9527 ) { say "你好 9527"; continue }
    when ( % 2 == 1 ) { say "這是一個奇數"; continue }
    when ( % 2 == 0 ) { say "這是一個偶數"; continue }
    my @divisors = divisors($number);
    my @empty = ();
    when ( @divisors ~~ @empty ) { say "這是一個質數" }
    default {
        say "因數有 @divisors";
    }
}

1;

ex16-1.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

chdir "/";

system "ls -l";

1;

ex16-2.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

system "ls -l / >ls.out 2>ls.err";

1;

ex16-3.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

chomp(my $date = `date`);

given ($date) {
    when (/^(日|Sun|六|Sat)/) {
        say "出去玩";
    }
    default {
        say "去工作";
    }
}

1;

ex17.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

open FILE, "sample_files/text_files/sample_text" or die "$!";

chomp(my @lines = <FILE>);

close FILE;

while (1) {
    say "請輸入要比對的樣式:";
    chomp (my $regex = <STDIN>);
    last if $regex =~ /^\s*$/;
    my @matches = eval {
        grep /$regex/, @lines;
    };
    if ($@) {
        say "$@";
    } else {
        my $count = @matches;
        say "有 $count 筆比對成功";
        print "分別是\n", map "$_\n", @matches;
    }
}

1;

fake_date

#!/usr/bin/perl

# fake_date - fake like the system's date command

# If you don't have a Unix system with the "date" command, you may
# wish to install this one which will produce similar output. 

# Generally, you can make this executable and change the top line
# (as you would for any Perl program) and keep it in your current 
# working directory. (Calling commands from backticks doesn't work
# on MacPerl unless you have ToolServer or something similar; see
# the macperl POD file. Under Mac OS X and later, you should have
# a true date command, and shouldn't be using MacPerl.)

# This program is intended to be called from within backticks, as
# if it were the real date command, perhaps with code looking
# something like this:

#        chomp(my $date = `fake_date`);

my $date = localtime;

print "$date\n";

fred

fred 1
fred 2
fred 3
fred 4

lnr_example

#!/usr/bin/perl

# Interactive fun with last, next, and redo

print "Enter a blank line the first few times...\n\n";

foreach (1..10) {
    print "Iteration number $_.\n\n";
    print "Please choose: last, next, redo, or none of the above? ";
    chomp(my $choice = <STDIN>);
    print "\n";
    last if $choice =~ /last/i;
    next if $choice =~ /next/i;
    redo if $choice =~ /redo/i;
    print "That wasn't any of the choices... onward!\n\n";
}

print "That's all, folks!\n";

numbers

17 1000 04 1.50 3.14159
-10 1.5 4 2001 90210 666
9 0 2 1 0
2001 42 -40 98.6 2.71828

pattern_test

#!/usr/bin/perl -w

use strict;

# This next line of code is used when you get to Chapter 9.
my $what = 'fred|barney';

while (<>) {
    chomp;
    # If you want to try matching strings which may contain
    # newlines, here's the trick to use: Uncomment this next
    # line, then use a pound sign ("#") wherever you mean to
    # have a newline within your data string.
    # s/#/\n/g;

    if (/YOUR_PATTERN_GOES_HERE/) {
	print "Matched: |$`<$&>$'|\n";
	# If you need these for testing patterns with
	# memories, uncomment them as well
	# print "    And memory one got <$1>\n";
	# print "    And memory two got <$2>\n";
    } else {
	print "No match.\n";
    }

}

pebbles

pebbles 1
pebbles 2
pebbles 3
pebbles 4
pebbles 5
pebbles 6
pebbles 7

rename.pl

#! /usr/bin/env perl
# -*- coding: utf-8; indent-tabs-mode: nil; tab-width: 4; c-basic-offset: 4; -*-
# vim:fileencodings=utf-8:expandtab:tabstop=4:shiftwidth=4:softtabstop=4

use 5.010;
use diagnostics;
use strict;
use warnings;

my @files = glob "ex?-?.pl";

for (sort @files) {
    chomp;
    my $new = $_;
    $new =~ s/ex(\d)-(\d).pl/ex0$1-$2.pl/;
    system "git mv $_ $new";
}

1;

sample_text

this story is rendered all in lowercase so that you can search
for fred and barney in lowercase, as we usually do. some lines
mention a name like fred more than once so that you can search
for repeated words, for example. (don't actually try to read this
story, which is terribly inane, or you'll be disappointed. we
promise.)



- - - - - - - - - - - - - - - - - - - - - - - - - - - -

one evening, fred and barney were getting ready to go bowling.
wilma saw this and said to betty, "you should ask barney to take
you out to the hard rock cafe for pterodactyl burgers."

betty agreed. "barney and fred never think about us. we should
make it a double date."

"do you want to bring pebbles and bamm-bamm along?"

"sure," said betty. "they always like to play skee-ball."

so wilma found fred and told him, "hey, fred, you've been going
out bowling every night this week. betty and i want to go to the
hard rock cafe for pterodactyl burgers."

"but wilma," said fred, "barney and i need to go tonight. this is
the night that our league is pitted against the gravel pit
strikers. how about if i take you out on monday night?"

that wasn't good enough for wilma. "fred flintstone, if you think
i'm going to let you leave me at home with pebbles while you go
bowling for the tenth night in a row, you've got another think
coming. get cleaned up, because we're going."

-

meanwhile, at the rubbles' house, barney was having the same
discussion with betty. "i can't say no to you betty. but fred
said that if we can beat the gravel pit strikers tonight, we'll
qualify for the final round next month. the grand prize is a
romantic vacation on the rock of gibraltar. i want to win that
for you."

"oh, barney! you are so sweet. of course you can go bowling. do
you really think you'll win?"

"well, this is why fred and i have been practicing all week. but
you can't tell wilma what's going on, because fred made me
promise that he could surprise her."

"what are we going to do for tonight?" betty asked. "wilma wants
us all to go out to the hard rock cafe. what time do you have to
be at the alley?"

barney checked the time. "we aren't scheduled to start until half
past 8."

"that's it, then," said betty. i'll create a distraction at about
8. the alley is just around the corner from the restaurant, so
you and fred can sneak over there."

"i'll call fred and tell him our plan."

-

fred had come up with a plan of his own. with his bowling ball in
hand, he tiptoed towards the door, keeping an eye on the door to
the bathroom to see if wilma was coming. whoops! he tripped over
dino's tail. "arf arf arf" yelped the dogosaurus. "what was
that?" called wilma from the bathroom.

"nothing, nothing, dear," said fred, hurriedly hiding the bowling
ball behind his back. "i think dino just saw a mouse."

"a mouse! well, i should hope you'll catch it, we can't have any
mice around pebbles."

"no problem. i've caught it now," lied fred. "i'll just take it
outside and release it."

as he headed again toward the door, wilma emerged from the
bathroom. "what color is it?" she asked.

"uhm, black?" fred responded, holding the bowling ball behind his
back as he walked backwards towards the door.

"betty saw a black mouse last week. i wonder whether this is a
relative. let me see it."

"no, this one is more of a grey mouse, now that i think of it. no
possible relation. no reason for you to look at the mouse."

"fred flintstone, you let me see that mouse this minute!" cried
wilma.

the telephone rang. "you get that, wilma," said fred. "i'll be
back in a moment." he ducked outside.

wilma answered the phone. "hello?" she asked.

"uhm, yes." said barney on the other end of the line, disguising
his voice. "this is mister, uh, rarnard bubble calling from the
department of, uhm, mineral, uhm, transportation. i'm calling for
mister fred flintstone. is mister fred flintstone available to
come to the telephone?"

at that moment, fred rushed back into the house, having left the
bowling ball in the car. "it's for you, fred," said wilma.
"mister bubble from the department of mineral transportation."

"hello," fred said into the phone, not understanding.

"heya, fred," said barney. "betty and i have figured out what to
do. she'll distract wilma, and you and i can sneak over to the
bowling alley."

"yes, yes," said fred. wilma stood by, curious about this
conversation.

barney continued. "you and wilma go ahead to the restaurant.
after you're gone, betty and i will get your bowling ball and
bring it with us. where do you keep it?"

wilma was getting more curious. fred said, "well, that mineral, i
don't think i have any of it around the house right now."

"but fred," said barney, "it's a bowling ball, not a mineral."

"i'm sure i can't help you with that."

"fred, where do you keep your bowling ball? is it in the garage?"

"no, none in the garage, i'm sure of it."

wilma interrupted him. "fred, give me the phone. i'll take care
of this while you shave."

she pulled the phone away from fred in time to hear barney say,
"no, bamm-bamm, don't play with daddy's bowling ball!"

"barney, is that you?" she asked the phone.

"yep. i mean," said barney, hastily disguising his voice again,
"hello? hello? i think we have a bad connection. i think i just
heard someone named barney on the line. but there is no one named
barney here. no barney at all. put that bowling ball down,
bamm-bamm!"

end of story

sortable_hash

# This is the hash of first and last names to be used in the
# case-insensitive sorting exercise at the end of Chapter 15, Strings
# and Sorting. Copy this text into your program, or edit this file and
# save it under a new name.

my %last_name = qw{ 
	fred flintstone Wilma Flintstone Barney Rubble
	betty rubble Bamm-Bamm Rubble PEBBLES FLINTSTONE
};

which_dbm

#!/usr/bin/perl -w

# which_dbm - attempts to determine which DBM implementation is being used

# Copyright (C) 2001 Tom Phoenix <rootbeer@redcat.com>
# This program is intended to be used with Perl. It may be distributed
# under the same licensing terms as Perl itself.

use strict;
use Cwd;

my $VERSION = 1.1;

# This fetches a list of possible DBM implementations, like NDBM
sub possibles {
    my %hash;
    for my $dir (@INC) {
        opendir DIR, $dir or next;     # if it's not easy, it's not worth doing.
        for (readdir DIR) {
            $hash{$1}++ if /(.*?)_File\.pm$/;
        }
    }
    closedir DIR;
    delete $hash{AnyDBM};
    keys %hash;
}

# Since MacPerl can't easily use @ARGV
BEGIN {
    if (!@ARGV and $^O eq 'MacOS') {
        my @list = &possibles;
        my $choice = MacPerl::Pick(
            "Attempt which implementation?",
            "-default-", @list);
        # This should quit upon "cancel", but there doesn't
        # seem to be a way to distinguish that from making
        # no selection. So, tough.
        return unless defined $choice;
        return if $choice eq "-default-";
        @ARGV = $choice;
    }
}

# Command-line arg may be the name of a DBM implementation, such as GDBM,
# and that one will be used instead of the default if possible. 
BEGIN {
    return unless @ARGV;
    my $requested = $ARGV[0];
    $requested =~ s/(.*?)(?:_File)?(?:\.pm)?$/\U$1\E_File/;
    @AnyDBM_File::ISA = ($requested);
    eval 'use AnyDBM_File;';
    if ($@) {
        # Figure that the requested one wasn't available
	# so we'll take what we can get.
        @AnyDBM_File::ISA = ();
        eval 'use AnyDBM_File;';
    }
}

my $original_dir = getcwd;
my $temp_dir = "temp$$.$^T";

mkdir $temp_dir, 0755 or die "Can't mkdir: $!";
chdir $temp_dir or die "Can't chdir: $!";

{
    my %HASH;
    dbmopen %HASH, 'fred', 0644;
    $HASH{fred} = 'barney';
    dbmclose %HASH;
}

die "This program can't determine the DBM mode in use.\n"
    unless @AnyDBM_File::ISA == 1;
print <<"MESSAGE";
You seem to be using @AnyDBM_File::ISA.

To always request this implementation when you use dbmopen(), 
add this line near the top of your programs:

        use @AnyDBM_File::ISA;

MESSAGE

my @extensions = sort map {
    (my $copy = $_) =~ s/^fred//;
    $copy eq '' ? "[no extension]" : $copy;
} glob 'fred*';

if (@extensions == 0) {
    print "There seems to be something wrong with the DBM file.\n";
} elsif (@extensions == 1) {
    print "The file extension seems to be: @extensions\n\n";
} else {
    print "The file extensions seem to be: @extensions\n\n";
}

unlink glob 'fred*';
chdir $original_dir or die "Can't change back to original dir: $!";
rmdir $temp_dir;

print "You might have these implementations available:\n",
    map "    $_\n", &possibles();
print "\n";
print "See the AnyDBM_File manpage for more information.\n";

exit;

wilma

wilma 1
wilma 2
wilma 3
wilma 4
wilma 5