#LrngPerl3Files
# Extracts the publisher's files for Learning Perl, 3rd Edition.

# Prompt for location:
print 'Enter the folder in which to create the "LrngPerl3Files" folder\n';
print '(or hit <ENTER> to accept the default of "C:\perl"): ';

$folder = <STDIN>;
chomp $folder;

# The default location:
if ($folder eq '') {
	$folder = 'c:\perl';
}

# Create the folders:
mkdir ("$folder\\LrngPerl3Files"), 0755 or 
	die "Cannot make $folder\\LrngPerl3Files: $!";
mkdir ("$folder\\LrngPerl3Files\\sample_files"), 0755 or 
	die "Cannot make $folder\\LrngPerl3Files\\sample_files: $!";
mkdir ("$folder\\LrngPerl3Files\\sample_files\\text_files"), 0755 or 
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\text_files: $!";

#------------------
# Make fake_date:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\fake_date") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\fake_date: $!";
print OUT <<'!';
#!/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";
!

close OUT;

#------------------
# Make lnr_example:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\lnr_example") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\lnr_example: $!";
print OUT <<'!';
#!/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";
!

close OUT;

#------------------
# Make numbers:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\numbers") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\numbers: $!";
print OUT <<'!';
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
!

close OUT;

#------------------
# Make pattern_test:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\pattern_test") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\pattern_test: $!";
print OUT <<'!';
#!/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";
    }

}
!

close OUT;

#------------------
# Make Readme:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\Readme") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\Readme: $!";
print OUT <<'!';
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.

!

close OUT;

#------------------
# Make sortable_hash:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\sortable_hash") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\sortable_hash: $!";
print OUT <<'!';
# 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
};

!

close OUT;

#------------------
# Make which_dbm:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\which_dbm") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\which_dbm: $!";
print OUT <<'!';
#!/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;

!

close OUT;

#------------------
# Make text_files\\bamm-bamm:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\text_files\\bamm-bamm") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\text_files\\bamm-bamm: $!";
print OUT <<'!';
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

!

close OUT;

#------------------
# Make text_files\\barney:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\text_files\\barney") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\text_files\\barney: $!";
print OUT <<'!';
barney 1
barney 2
barney 3
barney 4
barney 5 (barney fife?)
barney 6

!

close OUT;

#------------------
# Make text_files\\betty:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\text_files\\betty") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\text_files\\betty: $!";
print OUT <<'!';
betty 1
betty 2
betty 3
betty 4
betty 5

!

close OUT;

#------------------
# Make text_files\\dino:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\text_files\\dino") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\text_files\\dino: $!";
print OUT <<'!';
dino 1
dino 2
dino 3
dino 4

!

close OUT;

#------------------
# Make text_files\\fred:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\text_files\\fred") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\text_files\\fred: $!";
print OUT <<'!';
fred 1
fred 2
fred 3
fred 4

!

close OUT;

#------------------
# Make text_files\\pebbles:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\text_files\\pebbles") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\text_files\\pebbles: $!";
print OUT <<'!';
pebbles 1
pebbles 2
pebbles 3
pebbles 4
pebbles 5
pebbles 6
pebbles 7

!

close OUT;

#------------------
# Make text_files\\sample_text:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\text_files\\sample_text") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\text_files\\sample_text: $!";
print OUT <<'!';
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

!

close OUT;

#------------------
# Make text_files\\wilma:
open (OUT, ">$folder\\LrngPerl3Files\\sample_files\\text_files\\wilma") or
	die "Cannot make $folder\\LrngPerl3Files\\sample_files\\text_files\\wilma: $!";
print OUT <<'!';
wilma 1
wilma 2
wilma 3
wilma 4
wilma 5

!

close OUT;

print "Successful extraction...\n";

END {
	# Pause to read message:
	$q = <STDIN>;
}