Initial commit

## Example files for the title:  

# Learning Perl 2nd Edition, by Tom Christiansen

[![Learning Perl 2nd Edition, by Tom Christiansen](http://akamaicovers.oreilly.com/images/9781565922846/cat.gif)](https://www.safaribooksonline.com/library/view/title/1565922840//)

The following applies to example files from material published by O’Reilly Media, Inc. Content from other publishers may include different rules of usage. Please refer to any additional usage rights explained in the actual example files or refer to the publisher’s website.

O'Reilly books are here to help you get your job done. In general, you may use the code in O'Reilly books in your programs and documentation. You do not need to contact us for permission unless you're reproducing a significant portion of the code. For example, writing a program that uses several chunks of code from our books does not require permission. Answering a question by citing our books and quoting example code does not require permission. On the other hand, selling or distributing a CD-ROM of examples from O'Reilly books does require permission. Incorporating a significant amount of example code from our books into your product's documentation does require permission.

We appreciate, but do not require, attribution. An attribution usually includes the title, author, publisher, and ISBN.

If you think your use of code examples falls outside fair use or the permission given here, feel free to contact us at <permissions@oreilly.com>.

Please note that the examples are not production code and have not been carefully testing. They are provided "as-is" and come with no warranty of any kind.

#!/usr/bin/perl

init_words();

print "what is your name? ";

$name = <STDIN>;

chomp($name);

if ($name =~ /^randal\b/i) { # back to the other way :-)

    print "Hello, Randal! How good of you to be here!\n";

} else {

    print "Hello, $name!\n"; # ordinary greeting

    print "What is the secret word? ";

    $guess = <STDIN>;

    chomp $guess;

    while (! good_word($name,$guess)) {

        print "Wrong, try again. What is the secret word? ";

        $guess = <STDIN>;

        chomp $guess;

    }

}

dbmopen (%last_good,"lastdb",0666);

$last_good{$name} = time;

dbmclose (%last_good);

sub init_words {

    while ($filename = <*.secret>) {

        open (WORDSLIST, $filename)|| 

                              die "can't open $filename: $!";

        if (-M WORDSLIST < 7.0) {

            while ($name = <WORDSLIST>) {

                chomp ($name);

                $word = <WORDSLIST>;

                chomp ($word);

                $words{$name} = $word;

            }

        } else { # rename the file so it gets noticed

            rename ($filename,"$filename.old") || 

                          die "can't rename $filename.old: $!";

        }

        close WORDSLIST;

    }

}

sub good_word {

    my($somename,$someguess) = @_; # name the parameters

    $somename =~ s/\W.*//; # delete everything after first word

    $somename =~ tr/A-Z/a-z/; # lowercase everything

    if ($somename eq "randal") { # should not need to guess

        return 1; # return value is true

    } elsif (($words{$somename} || "groucho") eq $someguess) {

        return 1; # return value is true

    } else {

        open (MAIL, "|mail YOUR_ADDRESS_HERE");

        print MAIL "bad news: $somename guessed $someguess\n";

        close MAIL;

        return 0; # return value is false

    }

}

#!/usr/bin/perl

dbmopen (%last_good,"lastdb",0666),;

foreach $name (sort keys %last_good) {

    $when = $last_good{$name};

    $hours = (time - $when) / 3600; # compute hours ago

    write;

}

format STDOUT =

User @<<<<<<<<<<<: last correct guess was @<<< hours ago.

$name, $hours

.

#!/usr/bin/perl

while ($filename = <*.secret>) {

    open (WORDSLIST, $filename) || 

                             die "can't open $filename: $!";

    if (-M WORDSLIST < 7.0) {

        while ($name = <WORDSLIST>) {

            chomp ($name);

            $word = <WORDSLIST>;

            chomp ($word);

            write; # invoke format STDOUT to STDOUT

         }

    }

    close (WORDSLIST);

}

format STDOUT =

@<<<<<<<<<<<<<<< @<<<<<<<<< @<<<<<<<<<<<

$filename, $name, $word

.

format STDOUT_TOP =

Page @<<

$%

Filename         Name       Word

================ ========== ============

.

#!/usr/bin/perl -w

use 5.004;

use strict;            # enforce declarations and quoting

use CGI qw(:standard); # import shortcuts

use Fcntl qw(:flock);  # imports LOCK_EX, LOCK_SH, LOCK_NB

sub bail {             # function to handle errors gracefully

    my $error = "@_";

    print h1("Unexpected Error"), p($error), end_html;

    die $error;

}

my(

    $CHATNAME, # name of guestbook file

    $MAXSAVE,  # how many to keep

    $TITLE,    # page title and header

    $cur,      # new entry in the guestbook

    @entries,  # all cur entries

    $entry,    # one particular entry

);

$TITLE = "Simple Guestbook";

$CHATNAME = "/usr/tmp/chatfile"; # wherever makes sense on your system

$MAXSAVE = 10;

print header, start_html($TITLE), h1($TITLE);

$cur = CGI->new();                         # current request

if ($cur->param("message")) {              # good, we got a message

    $cur->param("date", scalar localtime); # set to the current time

 @entries = ($cur);                        # save message to array

}

# open the file for read-write (preserving old contents)

open(CHANDLE, "+< $CHATNAME") || bail("cannot open $CHATNAME: $!");

# get exclusive lock on the guestbook (LOCK_EX == exclusive lock)

flock(CHANDLE, LOCK_EX) || bail("cannot flock $CHATNAME: $!");

# grab up to $MAXSAVE old entries, newest first

while (!eof(CHANDLE) && @entries < $MAXSAVE) {

    $entry = CGI->new(\*CHANDLE); # pass the filehandle by reference

    push @entries, $entry;

}

seek(CHANDLE, 0, 0) || bail("cannot rewind $CHATNAME: $!");

foreach $entry (@entries) {

    $entry->save(\*CHANDLE); # pass the filehandle by reference

}

truncate(CHANDLE, tell(CHANDLE)) || 

                                 bail("cannot truncate $CHATNAME: $!");

close(CHANDLE) || bail("cannot close $CHATNAME: $!");

print hr, start_form;         # hr() emits html horizontal rule: <HR>

print p("Name:", $cur->textfield(

    -NAME => "name"));

print p("Message:", $cur->textfield(

    -NAME => "message",

    -OVERRIDE => 1,           # clears previous message

    -SIZE => 50));

print p(submit("send"), reset("clear"));

print end_form, hr;

print h2("Prior Messages");

foreach $entry (@entries) {

    printf("%s [%s]: %s",

    $entry->param("date"),

    $entry->param("name"),

    $entry->param("message"));

    print br();

}

print end_html;