Table of Content
1. introduction
2. scripts
3. printing
4. name
5. operator
6. control/loop
7. expression / pattern matching
8. regular expression methcharacters
9. files
10. subroutines function
11. package and module
12. reference
13. oo
14. DBM and DB hooks
15. DB programming
16. interface with the system
17. writing with pictures
18. networking programming
19. CGI and web
#######################
chap01 : introduction
#######################
---------------------
example01
---------------------
#! /bin/sh
perl -v
---------------------
example02
---------------------
#! /bin/sh
perl -V
#######################
chap02 : scripts
#######################
---------------------
example01
---------------------
#! /bin/sh
perl -e 'print "hello dolly\n";' # UNIX
# perl -e "print qq/hello dolly\n/;" # Windows
---------------------
example02
---------------------
#! /bin/sh
more emp.first
echo # Print a blank line
perl -ne 'print;' emp.first # Windows: use double quotes
echo # Print a blank line
perl -ne 'print if /^Igor/;' emp.first # Windows: use double quotes
---------------------
example03
---------------------
#! /bin/sh
# Unix
date | perl -ne 'print "Today is $_";'
# Windows
# date /T | perl -ne "print qq/Today is $_/;"
---------------------
example04
---------------------
#! /bin/sh
perl -ne 'print;' < emp.first
perl -ne 'print' emp.first > emp.temp
---------------------
example05
---------------------
#! /bin/sh
# Unix
perl -ne 'print if /Igor;' # Windows: use double quotes
perl -ce 'print if /Igor/;'
# Windows
# perl -ne "print if /Igor;" # Windows: use double quotes
# perl -ce "print if /Igor/;"
---------------------
example06
---------------------
# This is a comment
print "hello"; # And this is a comment
---------------------
example07
---------------------
#! /bin/sh
cat first.perl
perl -c first.perl
chmod +x first.perl
./first.perl
PATH="$PATH:."
first.perl
---------------------
example08
---------------------
#! /bin/sh
more first.perl
perl first.perl
---------------------
example09
---------------------
#! /bin/sh
pl2bat greetme.pl greetme.bat
# ./greetme
cat greetme.bat
#######################
chap03 : printing
#######################
---------------------
example01
---------------------
print "Hello", "world", "\n";
print "Hello world\n";
---------------------
example02
---------------------
# This is a Perl script.
print Hello, world, "\n";
---------------------
example03
---------------------
# This is a Perl script.
print STDOUT Hello, world, "\n";
---------------------
example04
---------------------
#! /usr/bin/perl
# Program to illustrate printing literals
print "The price is $100.\n";
print "The price is \$100.\n";
print "The price is \$",100, ".\n";
print "The binary number is converted to: ",0b10001,".\n";
print "The octal number is converted to: ",0777,".\n";
print "The hexadecimal number is converted to: ",0xAbcF,".\n";
print "The unformatted number is ", 14.56, ".\n";
---------------------
example05
---------------------
#! /usr/bin/perl
print "***\tIn double quotes\t***\n"; # backslash interpretation
print '%%%\t\tIn single quotes\t\t%%%\n'; # All characters are
# printed as literals
print "\n"
---------------------
example06
---------------------
#! /usr/bin/perl
print "\a\t\tThe \Unumber\E \LIS\E ",0777,".\n";
---------------------
example07
---------------------
#! /usr/bin/perl
# Program name: literals.perl
# written to test special literals
print "We are on line number ", __LINE__, ".\n";
print "The name of this file is ",__FILE__,".\n";
__END__
And this stuff is just a bunch of chitter-chatter that is to be
ignored by Perl.
The __END__ literal is like ctrl-d or \004.
---------------------
example08
---------------------
#! /usr/bin/perl
# Program name: literals.perl2
# written to test special literal __DATA__
print <DATA>;
__DATA__
This line will be printed.
And so will this one.
---------------------
example09
---------------------
#! /bin/sh
perl -w warnme
---------------------
example10
---------------------
#! /usr/bin/perl
# Program name: warnme2
use warnings;
print STDOUT Ellie, what\'s up?;
---------------------
example11
---------------------
#! /usr/bin/perl
# Program: stricts.test
# Script to demonstrate the strict pragma
use strict "subs";
$name = Ellie; #Unquoted word Ellie
print "Hi $name.\n";
---------------------
example12
---------------------
#! /usr/bin/perl
printf("The name is %s and the number is %d\n", "John", 50);
---------------------
example13
---------------------
#! /usr/bin/perl
printf "Hello to you and yours %s!\n","Sam McGoo!";
printf("%-15s%-20s\n", "Jack", "Sprat");
printf "The number in decimal is %d\n", 45;
printf "The formatted number is |%10d|\n", 100;
printf "The number printed with leading zeros is |%010d|\n", 5;
printf "Left-justified the number is |%-10d|\n", 100;
printf "The number in octal is %o\n",15;
printf "The number in hexadecimal is %x\n", 15;
printf "The formatted floating point number is |%8.2f|\n",
14.3456;
printf "The floating point number is |%8f|\n", 15;
printf "The character is %c\n", 65;
---------------------
example14
---------------------
#! /usr/bin/perl
$string = sprintf("The name is: %10s\nThe number is: %8.2f\n",
"Ellie", 33);
print "$string";
---------------------
example15
---------------------
# This is a Perl script.
$price=1000; # A variable is assigned a value.
print <<EOF;
The consumer commented, "As I look over my budget, I'd say
the price of $price is right. I'll give you \$500 to start."\n
EOF
print <<'FINIS';
The consumer commented, "As I look over my budget, I'd say
the price of $price is too much.\n I'll settle for $500."
FINIS
print << x 4;
Here's to a new day.
Cheers!
print "\nLet's execute some commands.\n";
# If terminator is in back quotes, will execute OS commands
print <<`END`;
echo Today is
date
END
---------------------
example16
---------------------
#! /usr/bin/perl
# The HTML tags are embedded in the here document to avoid using
# multiple print statements
print <<EOF; # here document in a CGI script
Content-type: text/html
<HTML><HEAD><TITLE>Town Crier</TITLE></HEAD>
<H1><CENTER>Hear ye, hear ye, Sir Richard cometh!!</CENTER></H1>
</HTML>
EOF
#######################
chap04 : name
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
# Scalar, array, and hash assignment
$salary=50000;#Scalar assignment
@months=('Mar', 'Apr', 'May'); # Array assignment
%states= (# Hash assignment
CA => 'California',
ME => 'Maine',
MT => 'Montana',
NM => 'New Mexico',
);
print "$salary\n";
print "@months\n";
print "$months[0], $months[1], $months[2]\n";
print "$states{CA}, $states{NM}\n";
print $x + 3, "\n";# $x just came to life!
print "***$name***\n";# $name is born!
---------------------
example02
---------------------
#! /usr/bin/perl
# Double quotes
$num=5;
print "The number is $num.\n";
print "I need \$5.00.\n";
print "\t\tI can't help you.\n";
---------------------
example03
---------------------
#! /usr/bin/perl
# Single quotes
print 'I need $100.00.', "\n";
print 'The string literal, \t, is used to represent a tab.',
"\n";
print 'She cried, "Help me!"', "\n";
---------------------
example04
---------------------
#! /usr/bin/perl
# Backquotes and command substitution
print "The date is ", `date` ; # Win32 users: `date /T`
print "The date is `date`", ".\n"; # Back quotes will be treated as literals
$directory=`pwd`; # Win32 users: `cd`
print "\nThe current directory is $directory.";
---------------------
example05
---------------------
#! /usr/bin/perl
# Using alternative quotes
print 'She cried, "I can\'t help you!"',"\n"; # Clumsy
print qq/She cried, "I can't help you!" \n/; # qq for double quotes
print qq/I need $5.00\n/; # Really need single quotes for a literal dollar sign to print
print q/I need $5.00\n/; # What about backslash interpretation?
print qq/\n/, q/I need $5.00/,"\n";
print q!I need $5.00!,"\n";
print "The present working directory is ", `pwd`;
print qq/Today is /, qx/date/;
print "The hour is ", qx{date +%H};
---------------------
example06
---------------------
#! /usr/bin/perl
$number=150;
$name="Jody Savage";
---------------------
example07
---------------------
#! /usr/bin/perl
$var="net";
print "${var}work\n";
---------------------
example08
---------------------
#! /usr/bin/perl
# Initializing scalars and printing their values
$num = 5;
$friend = "John Smith";
$money = 125.75;
$now = `date`; # Backquotes for command substitution
$month="Jan";
print "$num\n";
print "$friend\n";
print "I need \$$money.\n"; # Protecting our money
print qq/$friend gave me \$$money.\n/;
print qq/The time is $now/;
print "The month is ${month}uary.\n"; # Curly braces shield the variable
---------------------
example09
---------------------
#! /usr/bin/perl
$name="Tommy";
print "OK \n" if defined $name;
---------------------
example10
---------------------
#! /usr/bin/perl
$name="Tommy";
undef $name;
print "OK \n" if defined $name;
---------------------
example11
---------------------
#! /bin/sh
perl -ne 'print' emp.names
echo
perl -ne 'print $_' emp.names
---------------------
example12
---------------------
#! /usr/bin/perl
@name=("Guy", "Tom", "Dan", "Roy");
@list=(2..10);
@grades=(100, 90, 65, 96, 40, 75);
@items=($a, $b, $c);
@empty=();
$size=@items;
@mammals = qw/dogs cats cows/;
@fruit = qw(apples pears peaches);
---------------------
example13
---------------------
#! /usr/bin/perl
$indexsize=$#grades;
$#grades=3;
$#grades=$[ - 1;
@grades=();
---------------------
example14
---------------------
#! /usr/bin/perl
@digits=(0 .. 10);
@letters=( 'A' .. 'Z' );
@alpha=( 'A' .. 'Z', 'a' .. 'z' );
@n=( -5 .. 20 );
---------------------
example15
---------------------
#! /usr/bin/perl
# Populating an array and printing its values
@names=('John', 'Joe', 'Jake'); # @names=qw/John Joe Jake/;
print @names, "\n"; # prints without the separator
print "Hi $names[0], $names[1], and $names[2]!\n";
$number=@names; # The scalar is assigned the number
# of elements in the array
print "There are $number elements in the \@names array.\n";
print "The last element of the array is $names[$number - 1].\n";
print "The last element of the array is $names[$#names].\n";
# Remember, the array index starts at zero!!
@fruit = qw(apples pears peaches plums);
print "The first element of the \@fruit array is $fruit[0]; the second element is $fruit[1].\n";
print "Starting at the end of the array: @fruit[-1, -3]\n";
---------------------
example16
---------------------
#! /usr/bin/perl
# Array slices
@names=('Tom', 'Dick', 'Harry', 'Pete' );
@pal=@names[1,2,3]; # slice -- @names[1..3] also O.K.
print "@pal\n\n";
($friend[0], $friend[1], $friend[2])=@names; # Array slice
print "@friend\n";
---------------------
example17
---------------------
#! /usr/bin/perl
# Array slices
@colors=('red','green','yellow','orange');
($c[0], $c[1],$c[3], $c[5])=@colors; # The slice
print "**********\n";
print @colors,"\n"; # prints entire array, but does
# not separate elements
print "@colors,\n"; # quoted, prints the entire array with
# elements separated
print "**********\n";
print $c[0]."\n"; # red
print $c[1],"\n"; # green
print $c[2],"\n"; # undefined
print $c[3],"\n"; # yellow
print $c[4],"\n"; # undefined
print $c[5],"\n"; # orange
print "**********\n" ;
print "The size of the \@c array is ", $#c + 1,".\n";
---------------------
example18
---------------------
#! /usr/bin/perl
# A two-dimensional array consisting of 4 rows and 3 columns.
@matrix=( [ 3 , 4, 10 ], # Each row is an unnamed list
[ 2, 7, 12 ],
[ 0, 3, 4 ],
[ 6, 5, 9 ],
) ;
print "@matrix\n";
print "Row 0, column 0 is $matrix[0][0].\n";
# can also be written - $matrix[0]->[0]
print "Row 1, column 0 is $matrix[1][0].\n";
# can also be written - $matrix[1]->[0]
for($i=0; $i < 4; $i++){
for($x=0; $x < 3; $x++){
print "$matrix[$i][$x] ";
}
print "\n";
}
---------------------
example19
---------------------
#! /usr/bin/perl
# An list of lists.
@record=( "Adams", [2, 1, 0, 0],
"Edwards", [1, 0, 3, 2],
"Howard", [3 ,3 ,2,0 ],
);
print "In the first game $record[0] batted $record[1]->[0].\n";
print "In the first game $record[2] batted $record[3]->[0].\n";
print "In the first game $record[4] batted $record[5]->[0].\n";
---------------------
example20
---------------------
#! /usr/bin/perl
%seasons=(Sp=>'Spring', Su=>'Summer', F=>'Fall', W=> 'Winter');
%days=('Mon'=> 'Monday'=>'Tue'=>'Tuesday' =>'Wed',);
$days{'Wed'}="Wednesday";
$days{5}="Friday";
---------------------
example21
---------------------
#! /usr/bin/perl
# Assigning keys and values to a hash
%department = (
Eng => 'Engineering', # Eng is the key,
# Engineering is the value
M => 'Math',
S => 'Science',
CS => 'Computer Science',
Ed => 'Education',
);
$department = $department{'M'};
$school = $department{'Ed'};
print "I work in the $department section\n" ;
print "Funds in the $school department are being cut.\n";
print qq/I'm currently enrolled in a $department{CS} course.\n/;
print qq/The department associative array looks like this:\n/;
print %department, "\n"; #The printout is not in the expected order due to internal hashing
---------------------
example22
---------------------
#! /usr/bin/perl
# Hash slices
%officer= ( NAME=>"Tom Savage",
SSN=>"510-222-3456",
DOB=>"05/19/66"
);
@info=qw(Marine Captain 50000);
@officer{'BRANCH', 'TITLE', 'SALARY'}=@info;
# This is a hash slice
@sliceinfo=@officer{'NAME','BRANCH','TITLE'};
# This is also a hash slice
print "The new values from the hash slice are: @sliceinfo\n\n";
print "The hash now looks like this:\n";
foreach $key ('NAME', 'SSN', 'DOB', 'BRANCH', 'TITLE', 'SALARY'){
printf "Key: %-10sValue: %-15s\n", $key, $officer{$key};
}
---------------------
example23
---------------------
#! /usr/bin/perl
# Nested hashes
# values
# keys key value key value
%students=( Math => { Joe => 100, Joan => 95 },
Science => { Bill => 85, Dan => 76 }
);
print "On the math test Joan got ";
print qq/$students{Math}->{Joan}.\n/;
print "On the science test Bill got ";
print qq/$students{Science}->{Bill}.\n/;
---------------------
example24
---------------------
#! /usr/bin/perl
# Anonymous arrays as keys in a hash
%grades=(Math => [ 90, 100, 94 ],
Science => [ 77, 87, 86 ],
English => [ 65, 76, 99, 100 ],
);
print %grades, "\n";
print "The third math grade is: $grades{Math}->[2]\n";
print "All of the science grades are: @{$grades{Science}}\n";
---------------------
example25
---------------------
#! /usr/bin/perl
# An array of hashes
@stores=( { Boss =>"Ari Goldberg",
Employees => 24,
Registers => 10,
Sales => 15000.00,
},
{ Boss =>"Ben Chien",
Employees => 12,
Registers => 5,
Sales => 3500.00,
},
);
print "The number of elements in the array: ",
$#stores + 1, "\n"; # The number of the last subscript + 1
for($i=0; $i< $#stores + 1; $i++){
print $stores[$i]->{"Boss"},"\n"; # Accessing an element of the array
print $stores[$i]->{"Employees"},"\n";
print $stores[$i]->{"Registers"},"\n";
print $stores[$i]->{"Sales"},"\n";
print "-" x 20 ,"\n";
}
---------------------
example26
---------------------
#! /usr/bin/perl
# Getting a line of input from the keyboard.
print "What is your name? ";
$name = <STDIN>;
print "What is your father's name? ";
$paname=<>;
print "Hello respected one, $paname";
---------------------
example27
---------------------
#! /usr/bin/perl
# Getting rid of the trailing newline. Use chomp instead of chop.
print "Hello there, and what is your name? ";
$name = <STDIN>;
print "$name is a very high class name.\n";
chop($name); # Removes the last character no matter what it is.
print "$name is a very high class name.\n\n";
chop($name);
print "$name has been chopped a little too much.\n";
print "What is your age? ";
chomp($age=<STDIN>); # Removes the last character if
# it is the newline.
chomp($age); # The last character is not removed
# unless a newline
print "For $age, you look so young!\n";
---------------------
example28
---------------------
#! /usr/bin/perl
# Reading input in a requested number of bytes
print "Describe your favorite food in 10 bytes or less.\n";
print "If you type less than 10 characters, press Ctrl-d on a line by itself.\n";
$number=read(STDIN, $favorite, 10);
print "You just typed: $favorite\n";
print "The number of bytes read was $number.\n";
---------------------
example29
---------------------
#! /usr/bin/perl
# Getting only one character of input
print "Answer y or n ";
$answer=getc; # Gets one character from stdin
$restofit=<>; # What remains in the input buffer is assigned $restofit.
print "$answer\n";
print "The characters left in the input buffer were: $restofit\n";
---------------------
example30
---------------------
#! /usr/bin/perl
# Assigning input to an array
print "Tell me everything about yourself.\n ";
@all = <STDIN>;
print "@all";
print "The number of elements in the array are: ", $#all + 1,
".\n";
print "The first element of the array is:
$all[0]";
---------------------
example31
---------------------
#! /usr/bin/perl
# Assign input to a hash
$course_number=101;
print "What is the name of course 101?";
chomp($course{$course_number} = <STDIN>);
print %course, "\n";
---------------------
example32
---------------------
#! /usr/bin/perl
# Chopping and chomping a list
@line=("red", "green", "orange");
chop(@line); # chops the last character off each
# string in the list
print "@line\n";
@line=( "red", "green", "orange");
chomp(@line); # chomps the newline off each string in the list
print "@line\n";
---------------------
example33
---------------------
#! /usr/bin/perl
@names = qw(Tom Raul Steve Jon);
print "Hello $names[1]\n", if exists $names[1];
print "Out of range!\n", if not exists $names[5];
---------------------
example34
---------------------
#! /usr/bin/perl
# Searching for patterns in a list
@list = (tomatoes, tomorrow, potatoes, phantom, Tommy);
$count = grep( /tom/i, @list);
@items= grep( /tom/i, @list);
print "Found items: @items\nNumber found: $count\n";
---------------------
example35
---------------------
#! /usr/bin/perl
# Joining each elements of a list with colons
$name="Joe Blow";
$birth="11/12/86";
$address="10 Main St.";
print join(":", $name, $birth, $address ), "\n";
---------------------
example36
---------------------
#! /usr/bin/perl
# Joining each element of a list with a newline
@names=('Dan','Dee','Scotty','Liz','Tom');
@names=join("\n", sort(@names));
print @names,"\n";
---------------------
example37
---------------------
#! /usr/bin/perl
# Mapping a list to an expression
@list=(0x53,0x77,0x65,0x64,0x65,0x6e,012);
@words = map chr, @list;
print @words;
@n = (2, 4, 6, 8);
@n = map $_ * 2 + 6, @n;
print "@n\n";
---------------------
example38
---------------------
#! /usr/bin/perl
# Map using a block
open(FH, "datebook.master") or die;
@lines=<FH>;
@fields = map { split(":") } @lines;
foreach $field (@fields){
print $field,"\n";
}
---------------------
example39
---------------------
#! /usr/bin/perl
# Removing an element from the end of a list
@names=("Bob", "Dan", "Tom", "Guy");
print "@names\n";
$got = pop(@names); # pops off last element of the array
print "$got\n";
print "@names\n";
---------------------
example40
---------------------
#! /usr/bin/perl
# Adding elements to the end of a list
@names=("Bob", "Dan", "Tom", "Guy");
push(@names, Jim, Joseph, Archie);
print "@names \n";
---------------------
example41
---------------------
#! /usr/bin/perl
# Removing elements from front of a list
@names=("Bob", "Dan", "Tom", "Guy");
$ret = shift @names;
print "@names\n";
print "The item shifted is $ret.\n";
---------------------
example42
---------------------
#! /usr/bin/perl
# Splicing out elements of a list
@colors=(red, green, purple, blue, brown);
print "The original array is @colors\n";
@discarded = splice(@colors, 2, 2);
print "The elements removed after the splice are: @discarded.\n";
print "The spliced array is now @colors.\n";
---------------------
example43
---------------------
#! /usr/bin/perl
# Splicing and replacing elements of a list
@colors=(red, green, purple, blue, brown);
print "The original array is @colors\n";
@lostcolors=splice(@colors, 2, 3, yellow, orange);
print "The removed items are @lostcolors\n";
print "The spliced array is now @colors\n";
---------------------
example44
---------------------
#! /usr/bin/perl
# Splitting a scalar on whitespace and creating a list
$line="a b c d e";
@letter=split(' ',$line);
print "The first letter is $letter[0]\n";
print "The second letter is $letter[1]\n";
---------------------
example45
---------------------
#! /usr/bin/perl
# Splitting up $_
while(<DATA>){
@line=split(":");
print "$line[0]\n";
}
__DATA__
Betty Boop:245-836-8357:635 Cutesy Lane, Hollywood, CA 91464:6/23/23:14500
Igor Chevsky:385-375-8395:3567 Populus Place, Caldwell, NJ 23875:6/18/68:23400
Norma Corder:397-857-2735:74 Pine Street, Dearborn, MI 23874:3/28/45:245700
Jennifer Cowan:548-834-2348:583 Laurel Ave., Kingsville, TX 83745:10/1/35:58900
Fred Fardbarkle:674-843-1385:20 Park Lane, Duluth, MN 23850:4/12/23:78900
---------------------
example46
---------------------
#! /usr/bin/perl
# Splitting up $_ and creating an unnamed list
while(<DATA>){
($name,$phone,$address,$bd,$sal)=split(":");
print "$name\t $phone\n" ;
}
__DATA__
Betty Boop:245-836-8357:635 Cutesy Lane, Hollywood, CA 91464:6/23/23:14500
Igor Chevsky:385-375-8395:3567 Populus Place, Caldwell, NJ 23875:6/18/68:23400
Norma Corder:397-857-2735:74 Pine Street, Dearborn, MI 23874:3/28/45:245700
Jennifer Cowan:548-834-2348:583 Laurel Ave., Kingsville, TX 83745:10/1/35:58900
Fred Fardbarkle:674-843-1385:20 Park Lane, Duluth, MN 23850:4/12/23:78900
---------------------
example47
---------------------
#! /usr/bin/perl
# Many ways to split a scalar to create a list
$string= "Joe Blow:11/12/86:10 Main St.:Boston, MA:02530";
@line=split(":", $string); # the string delimiter is a colon
print @line,"\n";
print "The guy's name is $line[0].\n";
print "The birthday is $line[1].\n\n";
@str=split(":", $string, 2);
print $str[0],"\n"; # the first element of the array
print $str[1],"\n"; # the rest of the array because limit is 2
print $str[2],"\n"; # nothing is printed
@str=split(":", $string); # Limit not stated will be one more
# than total number of fields
print $str[0],"\n";
print $str[1],"\n";
print $str[2],"\n";
print $str[3],"\n";
print $str[4],"\n";
print $str[5],"\n";
( $name, $birth, $address )=split(":", $string);
# limit is implicitly 4, one more than
# the number of fields specified
print $name , "\n";
print $birth,"\n";
print $address,"\n";
---------------------
example48
---------------------
#! /usr/bin/perl
# Sorting a list
@string=(4.5, x, 68, a, B, c, 10, 1000, 1);
@string_sort=sort(@string);
print "@string_sort\n";
sub numeric { $a <=> $b ; }
@number_sort=sort numeric 1000, -22.5, 10, 55, 0;
print "@number_sort\n";a
---------------------
example49
---------------------
#! /usr/bin/perl
# Sorting numbers with an unamed subroutine
@sorted_numbers= sort {$a <=> $b} (3,4,1,2);
print "The sorted numbers are: @sorted_numbers", ".\n";
---------------------
example50
---------------------
#! /usr/bin/perl
# Reversing the elements of an array
@names=("Bob", "Dan", "Tom", "Guy");
print "@names \n";
@reversed=reverse(@names),"\n";
print "@reversed\n";
---------------------
example51
---------------------
#! /usr/bin/perl
# Putting new elements at the front of a list
@names=(Jody, Bert, Tom) ;
unshift(@names, Liz, Daniel);
print "@names\n";
---------------------
example52
---------------------
#! /usr/bin/perl
# The keys function and a hash
%weekday= (
'1'=> 'Monday',
'2'=>'Tuesday',
'3'=>'Wednesday',
'4'=>'Thursday',
'5'=>'Friday',
'6'=>'Saturday',
'7'=>'Sunday',
);
foreach $key ( keys(%weekday) ) {print "$key ";}
print "\n";
foreach $key ( sort keys(%weekday) ) {print "$key ";}
print "\n";
---------------------
example53
---------------------
#! /usr/bin/perl
# The values function and a hash
%weekday= (
'1'=> 'Monday',
'2'=>'Tuesday',
'3'=>'Wednesday',
'4'=>'Thursday',
'5'=>'Friday',
'6'=>'Saturday',
'7'=>'Sunday',
);
foreach $value ( values(%weekday)){print "$value ";}
print "\n";
---------------------
example54
---------------------
#! /usr/bin/perl
#
# Example of using each function in Associative Arrays
#
%weekday=(
'Mon' => 'Monday',
'Tue' => 'Tuesday',
'Wed' => 'Wednesday',
'Thu' => 'Thursday',
'Fri' => 'Friday',
'Sat' => 'Saturday',
'Sun' => 'Sunday',
);
while(($key,$value)=each(%weekday)){
print "$key = $value\n";
}
---------------------
example55
---------------------
#! /usr/bin/perl
%employees=("Nightwatchman" => "Joe Blow",
"Janitor" => "Teddy Plunger",
"Clerk" => "Sally Olivetti",
);
$layoff=delete $employees{"Janitor"};
print "We had to let $layoff go.\n";
print "Our remaining staff includes: ";
print "\n";
while(($key, $value)=each(%employees)){
print "$key: $value\n";
}
---------------------
example56
---------------------
#! /usr/bin/perl
%employees=( "Nightwatchman" => "Joe Blow",
"Janitor" => "Teddy Plunger",
"Clerk" => "Sally Olivetti",
);
print "The Nightwatchman exists.\n" if exists
$employees{"Nightwatchman"};
print "The Clerk exists.\n" if exists $employees{"Clerk"};
print "The Boss does not exist.\n" if ! exists
$employees{"Boss"};
---------------------
example57
---------------------
#! /usr/bin/perl
# Loading an Associative Array from a file.
open(NAMES,"emp.names2") || die "Can't open emp.names2: $!\n";
while(<NAMES>){
( $num, $name )= split(' ', $_, 2);
$realid{$num} = $name;
}
close NAMES;
while(1){
print "Please choose a number from the list of names? ";
chomp($num=<STDIN>);
last unless $num;
print $realid{$num},"\n";
}
---------------------
example58
---------------------
#! /usr/bin/perl
foreach $key (keys(%ENV)) {
print "$key\n";
}
print "\nYour login name $ENV{'LOGNAME'}\n";
$pwd=$ENV{'PWD'};
print "\n", $pwd, "\n";
---------------------
example59
---------------------
#! /usr/bin/perl
sub handler {
local($sig) = @_; # first argument is signal name
print "Caught SIG$sig -- shutting down\n";
exit(0);
}
$SIG{'INT'} = 'handler'; # Catch ^C
print "Here I am!\n";
sleep(10);
$SIG{'INT'}='DEFAULT';
#######################
chap05 : operator
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
$x = " 12hello!!" + "4abc\n";
print "$x";
print "\n";
$y = ZAP . 5.5;
print "$y\n";
---------------------
example02
---------------------
#! /usr/bin/perl
$x = 5 + 4 * 12 / 4;
print "The result is $x\n";
---------------------
example03
---------------------
#! /usr/bin/perl
$name="Dan";
$line="*";
$var=0; # assign 0 to var
$var += 3; # add 3 to $var; same as $var=$var+3
print "\$var += 3 is $var \n";
$var -= 1; # subtract one from $var
print "\$var -= 1 is $var\n";
$var **= 2; # square $var
print "\$var squared is $var\n";
$var %= 3;# modulus
print "The remainder of \$var/3 is $var\n";
$name .= "ielle"; # concatenate string "Dan" and "ielle"
print "$name is the girl's version of Dan.\n";
$line x= 10;# repetition; print 10 stars
print "$line\n";
printf "\$var is %.2f\n", $var=4.2 + 4.69;
---------------------
example04
---------------------
#! /usr/bin/perl
$x = 5;
$y = 4;
$result = $x > $y;
print "$result\n";
$result = $x < $y; # this is 0 or "", depending on the version of Perl
print "$result\n";
---------------------
example05
---------------------
#! /usr/bin/perl
$fruit1 = "pear";
$fruit2 = "peaR";
$result = $fruit1 gt $fruit2;
print "$result\n";
$result = $fruit1 lt $fruit2;
print "$result\n";
---------------------
example06
---------------------
#! /usr/bin/perl
$x = 5;
$y = 4;
$result = $x == $y;
print "$result\n";
$result = $x != $y;
print "$result\n";
$result = $x <=> $y;
print "$result\n";
$result = $y <=> $x;
print "$result\n";
---------------------
example07
---------------------
#! /usr/bin/perl
$str1 = "A";
$str2 = "C";
$result = $str1 eq $str2;
print "$result\n";
$result = $str1 ne $str2;
print "$result\n";
$result = $str1 cmp $str2;
print "$result\n";
$result = $str2 cmp $str1;
print "$result\n";
$str1 = "C"; # Now both strings are equal.
$result = $str1 cmp $str2;
print "$result\n";
---------------------
example08
---------------------
#! /usr/bin/perl
# Don' t use == when you should use eq!
$x = "yes";
$y = "no";
print "Is yes equal to no? If so, say 1; if not say 'null'.\n";
print "The result is: ",$x == $y,"\n"; # should be $x eq $y
---------------------
example09
---------------------
#! /usr/bin/perl
# short circuit operators
$num1=50;
$num2=100;
$num3=0;
print $num1 && $num3, "\n"; # result is 0
print $num3 && $num1, "\n"; # result is 0
print $num1 && $num2, "\n"; # result is 100
print $num2 && $num1, "\n\n"; # result is 50
print $num1 || $num3, "\n"; # result is 50
print $num3 || $num1, "\n"; # result is 50
print $num1 || $num2, "\n"; # result is 50
print $num2 || $num1, "\n" # result is 100
---------------------
example10
---------------------
#! /usr/bin/perl
# Examples of using the word operators:
$num1=50;
$num2=100;
$num3=0;
print "Output using the word operators.\n\n";
print "$num1 and $num2: ",($num1 and $num2), "\n";
print "$num1 or $num3: ", ($num1 or $num3), "\n";
print "$num1 xor $num3: ",($num1 xor $num3), "\n";
print "not $num3: ", (not $num3), "\n";
print "\n";
---------------------
example11
---------------------
#! /usr/bin/perl
# Precedence with word operators and short circuit operators
$x=5;
$y=6;
$z=0;
$result=$x && $y && $z; # precedence of = lower than &&
print "Result: $result\n";
$result2 = $x and $y and $z; # precedence of = higher than and
print "Result: $result2\n";
$result3 = ( $x and $y and $z );
print "Result: $result3\n";
---------------------
example12
---------------------
#! /usr/bin/perl
printf "%d\n", 4 * 5 / 2;
printf "%d\n", 5 ** 3;
printf "%d\n", 5 + 4 - 2 * 10;
printf "%d\n", (5 + 4 - 2 ) * 10;
printf "%d\n", 11 % 2;
---------------------
example13
---------------------
#! /usr/bin/perl
$x=5; $y=0;
$y=++$x; # add one to $x first; then assign to $y
print "Pre-increment:\n";
print "y is $y\n";
print "x is $x\n";
print "-----------------------\n";
$x=5;
$y=0;
print "Post-increment:\n";
$y=$x++; # assign value in $x to $y; then add one to $x
print "y is $y\n";
print "x is $x\n";
---------------------
example14
---------------------
#! /usr/bin/perl
print 5 & 4,"\n"; # 101 & 100
print 5 & 0,"\n"; # 101 & 000
print 4 & 0,"\n"; # 100 & 000
print 0 & 4,"\n"; # 000 & 100
print "=" x 10, "\n"; # print 10 equal signs
print 1 | 4,"\n"; # 001 & 100
print 5 | 0,"\n"; # 101 | 000
print 4 | 0,"\n"; # 100 | 000
print 0 | 4, "\n"; # 000 | 100
print "=" x 10, "\n"; # print 10 equal signs
print 5 ^ 4, "\n"; # 101 ^ 100
print 5 ^ 0, "\n"; # 101 ^ 000
print 4 ^ 0,"\n"; # 100 ^ 000
print 0 ^ 4,"\n"; # 000 ^ 100
---------------------
example15
---------------------
#! /usr/bin/perl
# Convert a number to binary
while (1) {
$mask = 0x80000000; # 32 bit machine
printf("Enter an unsigned integer: ");
chomp($num=<STDIN> || exit(0));
printf("Binary of %x hex is: ", $num);
for ($j = 0; $j < 32; $j++) {
$bit = ($mask & $num) ? 1 : 0;
printf("%d", $bit);
if ($j == 15){
printf("--");
}
$mask /=2; # $mask >>= 1; not portable
}
printf("\n");
}
---------------------
example16
---------------------
#! /usr/bin/perl
$y = '$x is true';
$z = '$x is false';
print $x ? $y : $z;
print "\n";
$x = 1;
print $x ? $y : $z;
print "\n";
---------------------
example17
---------------------
#! /usr/bin/perl
print "What is your age? ";
chomp($age=<STDIN>);
$price=($age > 60 ) ? 0 : 5.55;
printf "You will pay \$%.2f.\n", $price;
---------------------
example18
---------------------
#! /usr/bin/perl
print "What was your grade? ";
$grade = <STDIN>;
print $grade > 60 ? "Passed.\n" : "Failed.\n";
# or
# $grade > 60 ? print "Passed.\n" : print "Failed.\n";
---------------------
example19
---------------------
#! /bin/sh
perl -ne 'if ( 1 .. 3 ){print}' emp.names
perl -e 'print 0..10,"\n";'
perl -e '@alpha=('A' .. 'Z') ; print "@alpha", "\n";'
perl -e '@a=('a'..'z', 'A'..'Z') ; print "@a\n";'
perl -e '@n=( -5 .. 20 ) ; print "@n\n";'
---------------------
example20
---------------------
#! /usr/bin/perl
$x="pop";
$y="corn";
$z="*";
print $z x 10, "\n"; # print 10 stars
print $x . $y, "\n"; # concatenate "pop" and "corn"
print $z x 10, "\n"; # print 10 stars
print (($x . $y ." ") x 5 ); # concatenate "pop" and "corn"
# and print 5 times
print "\n";
print uc($x . $y), "!\n"; #convert string to uppercase
---------------------
example21
---------------------
#! /usr/bin/perl
$line="Happy New Year";
print substr($line, 6, 3),"\n"; # offset starts at zero
print index($line, "Year"),"\n";
print substr($line, index($line, "Year")),"\n";
substr($line, 0, 0)="Fred, ";
print $line,"\n";
substr($line, 0, 1)="Ethel";
print $line,"\n";
substr($line, -1, 1)="r to you!";
print $line,"\n";
$string="I'll eat a tomato tomorrow.\n";
print rindex($string, tom), "\n";
---------------------
example22
---------------------
#! /usr/bin/perl
$num=10;
srand(time|$$); # seed rand with the time or'ed to the pid of this process
while($num){ # srand not necessary in versions 5.004 and above
$lotto = int(rand(10)) + 1;
# returns a random number between 1 and 10
print "The random number is $lotto\n";
sleep 3;
$num--;
}
---------------------
example23
---------------------
#! /usr/bin/perl
$x=5 ; # starting point in a range of numbers
$y=15; # ending point
# Formula to produce random numbers between 5 and 15 inclusive
# $random = int(rand($y - $x + 1)) + $x;
# $random = int(rand(15 - 5 + 1)) + 5
while(1){
print int(rand($y - $x + 1)) + $x , "\n";
sleep 1;
}
#######################
chap06 : control/loop
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
$num1=1;
$num2=0;
$str1="hello";
$str2=""; # Null string
if ( $num1 ) {print "TRUE!\n"; $x++;} # $x and $y were
# initially assigned zero
if ( $num2 ) {print "FALSE! \n";$y++;} # never execute this block
if ( $str1 ) {print "TRUE AGAIN!\n";}
if ( $str2 ) {print "FALSE AGAIN!\n";}
print "Not Equal!\n" if $x != $y;
---------------------
example02
---------------------
#! /usr/bin/perl
print "What version of the operating system are you using? ";
chomp($os=<STDIN>);
if ( $os > 2.2 ) { print "Most of the bugs have been worked out!\n";}
else { print "Expect some problems.\n";}
---------------------
example03
---------------------
#! /usr/bin/perl
$hour=` date +%H` ;
if ( $hour >= 0 && $hour < 12 ){print "Good morning!\n";}
elsif ($hour == 12 ){print "Lunch time.\n";}
elsif ($hour > 12 && $hour < 17 ) {print "Siesta time.\n";}
else {print "Goodnight. Sweet dreams.\n";}
---------------------
example04
---------------------
#! /usr/bin/perl
$num1=1;
$num2=0;
$str1="hello";
$str2=""; # Null string
unless ( $num1 ) {print "TRUE!\n"; $x++;} # never execute this block
unless( $num2 ) {print "FALSE!\n"; $y++;}
unless ( $str1 ) {print "TRUE AGAIN!\n";}
unless( $str2 ) {print "FALSE AGAIN!\n";}
print "Not Equal!\n" unless $x == $y; # unless modifier and simple statement
---------------------
example05
---------------------
#! /bin/sh
PATH='$PATH:.'
excluder names
---------------------
example06
---------------------
#! /usr/bin/perl
$num=0; #initialize $num
while($num < 10 ){ # test expression;
# loop quits when expression is false or 0
print "$num ";
$num++; # update the loop variable $num; increment $num
}
print "\nOut of the loop.\n";
---------------------
example07
---------------------
#! /usr/bin/perl
$count=1; #Initialize variables
$beers=10;
$remain=$beers;
$where="on the shelf";
while($count <= $beers) {
if($remain == 1){print "$remain bottle of beer $where " ;}
else{ print "$remain bottles of beer $where $where ";}
print "Take one down and pass it all around.\n";
print "Now ", $beers - $count , " bottles of beer $where!\n";
$count++;
$remain--;
if ( $count > 10 ){print "Party's over. \n";}
}
print "\n";
---------------------
example08
---------------------
#! /usr/bin/perl
$num=0; #initialize
until ($num == 10 ){ # test expression; loop quits when expression is true or 1
print "$num ";
$num++; # update the loop variable $num; increment $num
}
print "\nOut of the loop.\n";
---------------------
example09
---------------------
#! /usr/bin/perl
print "Are you o.k.? ";
chomp($answer=<STDIN>);
until ($answer eq "yes" ){
sleep(1);
print "Are you o.k. yet? ";
chomp($answer=<STDIN>);
}
print "Glad to hear it!\n";
---------------------
example10
---------------------
#! /usr/bin/perl
$x = 1;
do {
print "$x ";
$x++;
} while ($x <= 10);
print "\n";
$y = 1;
do {
print "$y " ;
$y++;
} until ( $y > 10 );
print "\n";
---------------------
example11
---------------------
#! /usr/bin/perl
for ( $i=0; $i<10; $i++ ){ # initialize, test, and increment $i
print "$i ";
}
print "\nOut of the loop.\n";
---------------------
example12
---------------------
#! /usr/bin/perl
# Initialization, test, and increment, decrement of
# counters is done in one step.
for ( $count=1, $beers=10, $remain=$beers, $where="on the shelf";
$count <= $beers; $count++, $remain--){
if($remain == 1){print "$remain bottle of beer $where $where." ;}
else{ print "$remain bottles of beer $where $where.";}
print " Take one down and pass it all around.\n";
print "Now ", $beers - $count , " bottles of beer $where!\n";
if ( $count == 10 ){print "Party's over.\n";}
}
---------------------
example13
---------------------
#! /usr/bin/perl
foreach $pal ( 'Tom' , 'Dick' , 'Harry' , 'Pete' ) {
print "Hi $pal!\n";
}
---------------------
example14
---------------------
#! /usr/bin/perl
foreach $hour ( 1 .. 24 ){ # The range operator is used here
if ( $hour > 0 && $hour < 12){ print "Good-morning.\n"; }
elsif ( $hour == 12){ print "Happy Lunch.\n";}
elsif ( $hour > 12 && $hour < 17) { print "Good afternoon.\n"; }
else { print "Good-night.\n" ; }
}
---------------------
example15
---------------------
#! /usr/bin/perl
$str="hello";
@numbers = ( 1, 3, 5, 7, 9 );
print "The scalar \$str is initially $str.\n";
print "The array \@numbers is initially @numbers.\n";
foreach $str ( @numbers ){
$str+=5;
print "$str\n";
}
print "Out of the loop--\$str is $str.\n";
print "Out of the loop--The array \@numbers is now @numbers.\n";
---------------------
example16
---------------------
#! /usr/bin/perl
@colors=(red, green, blue, brown);
foreach ( @colors ) {
print "$_ ";
$_="YUCKY";
}
print "\n@colors\n";
---------------------
example17
---------------------
#! /usr/bin/perl
#!//usr/bin/perl
# Program that uses a label without a loop and the redo statement
ATTEMPT: {
print "Are you a great person? ";
chomp($answer = <STDIN> );
redo ATTEMPT unless $answer eq "yes" ;
}
---------------------
example18
---------------------
#! /usr/bin/perl
while(1){ # start an infinite loop
print "What was your grade? ";
$grade = <STDIN>;
if ( $grade < 0 || $grade > 100 ) {
print "Illegal choice\n";
next; # start control at the beginning of the innermost loop
}
if ( $grade > 89 && $grade < 101) { print "A\n"; }
elsif ( $grade > 79 && $grade < 90 ) { print "B\n"; }
elsif ( $grade > 69 && $grade < 80 ) { print "C\n"; }
elsif ( $grade > 59 && $grade < 70 ) { print "D\n"; }
else { print "You Failed."};
print "Do you want to enter another grade? (y/n) ";
chomp($choice = <STDIN>);
last if $choice ne "y";
# break out of the innermost loop if the condition is true
}
---------------------
example19
---------------------
#! /usr/bin/perl
ATTEMPT:{
print "What is the course number? ";
chomp($number = <STDIN>);
print "What is the course name? ";
chomp($course = <STDIN>);
$department{$number} = $course;
print "\nReady to quit? ";
chomp($answer = <STDIN>);
last if "$answer" eq "yes";
redo ATTEMPT;
}
$number = 101;
print "Course 101 is $department{$number}\n" if $number==101;
---------------------
example20
---------------------
#! /usr/bin/perl
OUT: while(1){
print "Inside OUT loop with i = ", ++$i ,"\n";
MID: while(1){
if ( $i == 5 ) { last OUT; }
print "Inside MID loop with i = ", ++$i ,"\n";
INNER: while(1){
if ( $i == 4 ){ next OUT; }
print "Inside INNER loop with i = ", ++$i ,"\n";
}
}
}
print "Out of all loops.\n";
---------------------
example21
---------------------
#! /usr/bin/perl
for ( $rows=5; $rows>=1; $rows-- ){
for ( $columns=1; $columns<=$rows; $columns++ ){
printf "*";
}
print "\n";
}
---------------------
example22
---------------------
#! /usr/bin/perl
# This script prints the average salary of employees
# earning over $50,000 annually
# There are 5 employees. If the salary falls below $50,000
# it is not included in the tally.
EMPLOYEE: for ($emp=1,$number=0; $emp <= 5; $emp++ ){
do { print "What is the monthly rate for employee #$emp? ";
print "(Type q to quit) ";
chomp($monthly=<STDIN>);
last EMPLOYEE if $monthly eq 'q';
next EMPLOYEE if (($year=$monthly * 12.00) <= 50000);
$number++;
$total_sal += $year;
next EMPLOYEE;
} while($monthly ne 'q');
}
unless($number == 0){
$average = $total_sal/$number;
print "There were $number employees who earned over \$50,000 annually.\n";
printf "Their average annual salary is \$%.2f.\n", $average;
} else {
print "None of the employees made over \$50,000\n";
}
---------------------
example23
---------------------
#! /usr/bin/perl
#
# Example using the continue block
#
for ($i=1; $i<=10; $i++) { # $i is incremented only once
if ($i==5){
print "\$i == $i\n";
next;
}
print "$i ";
}
print "\n"; print '=' x 35; print "\n";
# ---------------------------------------------------------
$i=1;
while ($i <= 10){
if ($i==5){
print "\$i == $i\n";
$i++; # $i must be incremented here or an infinite loop will start
next;
}
print "$i ";
$i++;
}
print "\n"; print '=' x 35; print "\n";
# ---------------------------------------------------------
$i=1;
while ($i <= 10){
if ($i==5){
print "\$i == $i\n";
next;
}
print "$i ";
} continue { $i++; }
print "\n";
---------------------
example24
---------------------
#! /usr/bin/perl
$hour=0;
while($hour < 24) {
SWITCH: { # SWITCH is just a user-defined label
$hour =~ /^[0-9]$|^1[0-1]$/ && do { print "Good-morning!\n";
last SWITCH;};
$hour == 12 && do {print "Lunch!\n";
last SWITCH;};
$hour =~ /1[3-7]/ && do {print "Siesta time!\n";
last SWITCH;};
$hour > 17 && do {print "Good night.\n";
last SWITCH;};
} # End of block labeled SWITCH
$hour++;
} # End of loop block
#######################
chap07 : expression / pattern matching
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
$_ = "abracadabca";
print /abc/, "\n";
print ?abc?, "\n";
---------------------
example02
---------------------
#! /usr/bin/perl
$x = 5;
print "$x\n" if $x == 5;
---------------------
example03
---------------------
#! /usr/bin/perl
$_ = "xabcy\n";
print if /abc/; # Could be written: print $_ if $_ =~ /abc/;
---------------------
example04
---------------------
#! /usr/bin/perl
$_ = "I lost my gloves in the clover.";
print "Found love in gloves!\n" if /love/;
# long form: if $_ =~ /love
---------------------
example05
---------------------
#! /usr/bin/perl
while(<DATA>){
print if /Norma/;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example06
---------------------
#! /usr/bin/perl
while(<DATA>){
if /Norma/ print;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example07
---------------------
#! /usr/bin/perl
$x=5;
print "$x\n" unless $x == 6;
---------------------
example08
---------------------
#! /usr/bin/perl
while(<DATA>){
print unless /Norma/;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example09
---------------------
#! /usr/bin/perl
$x=1;
print $x++,"\n" while $x != 5;
---------------------
example10
---------------------
#! /usr/bin/perl
$x=1;
print $x++,"\n" until $x == 5;
---------------------
example11
---------------------
#! /usr/bin/perl
@alpha=(a .. z, "\n");
print foreach @alpha;
---------------------
example12
---------------------
#! /usr/bin/perl
m/Good morning/;
/Good evening/;
/\/usr\/var\/adm/;
m#/usr/var/adm#;
m(Good evening);
m' $name';
---------------------
example13
---------------------
#! /usr/bin/perl
while(<DATA>){
print if /Betty/;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example14
---------------------
#! /usr/bin/perl
while(<DATA>){
print unless /Evich/;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example15
---------------------
#! /usr/bin/perl
while(<DATA>){
print if m#Jon#
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example16
---------------------
#! /usr/bin/perl
while(<DATA>){
print if m(Karen E);
}
$name="Jon";
$_=qq/$name is a good sport.\n/;
print if m'$name';
print if m"$name";
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example17
---------------------
#! /usr/bin/perl
$_ = "I lost my gloves in the clover, Love.";
@list=/love/g;
print "@list.\n";
---------------------
example18
---------------------
#! /usr/bin/perl
$_ = "I lost my gloves in the clover, Love.";
@list=/love/gi;
print "@list.\n";
---------------------
example19
---------------------
#! /usr/bin/perl
$_="San Francisco to Hong Kong";
/Francisco/; # Save 'Francisco' if it is found
print $&,"\n";
/to/;
print $`,"\n"; # Save what comes before the string 'to'
/to\s/; # \s represents a space
print $', "\n"; # Save what comes after the string 'to '
---------------------
example20
---------------------
#! /usr/bin/perl
$_="San Francisco to Hong Kong\n";
/Francisco # Searching for Francisco
/x;
print "Comments and spaces were removed and \$& is $&\n";
---------------------
example21
---------------------
#! /usr/bin/perl
$_ = "Igor Jon Dec Norma Igor Michael Dec jon dec igor Jon Igor 43000 dec\n";
$sal = 43000;
s/Igor/Boris/; print;
s/Igor/Boris/g; print;
s/norma/Jane/i; print;
s!Jon!Susan!; print;
s{Jon} <Susan>; print;
s/$sal/$sal * 1.1/e; print;
s/dec/"Dec" . "ember" # Replace "dec" or "Dec" with "December"
/eigx; print;
---------------------
example22
---------------------
#! /usr/bin/perl
while(<DATA>){
s/Norma/Jane/;
print;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example23
---------------------
#! /usr/bin/perl
while($_= <DATA>){
print if s/Igor/Ivan/;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example24
---------------------
#! /usr/bin/perl
while(<DATA>){
s#Igor#Boris#;
print;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example25
---------------------
#! /usr/bin/perl
while(<DATA>){
s(Blenheim) {Dobbins}i;
print;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example26
---------------------
#! /usr/bin/perl
# Without the g option
while(<DATA>){
print if s/Tom/Christian/; # First occurrence of Tom on each
# line is replaced with Christian
}
__END__
Tom Dave Dan Tom
Betty Tom Henry Tom
Igor Norma Tom Tom
---------------------
example27
---------------------
#! /usr/bin/perl
# With the g option
while(<DATA>){
print if s/Tom/Christian/g; # All occurrences of Tom on
# each line are replaced with
# Christian
}
__END__
Tom Dave Dan Tom
Betty Tom Henry Tom
Igor Norma Tom Tom
---------------------
example28
---------------------
#! /usr/bin/perl
# Matching with the i option
while(<DATA>){
print if /norma cord/i;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example29
---------------------
#! /usr/bin/perl
while(<DATA>){
print if s/igor/Daniel/i ;
}
__DATA__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example30
---------------------
#! /usr/bin/perl
# The e and g modifiers
while(<DATA>){
s/6/6 * 7.3/eg;
print;
}
__END__
Steve Blenheim 5
Betty Boop 4
Igor Chevsky 6
Norma Cord 1
Jon DeLoach 3
Karen Evich 66
---------------------
example31
---------------------
#! /usr/bin/perl
# The e modifier
$_=5;
s/5/6 * 4 - 22/e;
print "The result is: $_\n";
$_=1055;
s/5/3*2/eg;
print "The result is: $_\n";
---------------------
example32
---------------------
#! /usr/bin/perl
$_ = "Knock at heaven's door.\n";
s/knock/"knock, " x 2 . "knocking"/ei;
print "He's $_";
---------------------
example33
---------------------
#! /usr/bin/perl
# Saving in the $& special scalar
$_=5000;
s/$_/$& * 2/e;
print "The new value is $_.\n";
$_="knock at heaven's door.\n";
s/knock/"$&," x 2 . "$&ing"/ei;
print "He's $_";
---------------------
example34
---------------------
#! /usr/bin/perl
# Using the $_ scalar explicitly
while($_=<DATA>){
print $_ if $_ =~ /Igor/;
# print if /Igor/;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example35
---------------------
#! /usr/bin/perl
$name="Tommy Tuttle";
print "Hello Tommy\n" if $name =~ /Tom/; # prints Hello Tommy,
# if true
print "$name\n" if $name !~ /Tom/; # prints nothing if false
$name =~ s/T/M/; #substitute first 'T' with an 'M'
print "$name.\n";
$name="Tommy Tuttle";
print "$name\n" if $name =~ s/T/M/g; # substitute all 'T's'
# with 'M's'
print "What is Tommy's last name? ";
print "You got it!\n" if <STDIN> =~ /Tuttle/;
---------------------
example36
---------------------
#! /usr/bin/perl
$salary=50000;
$salary =~ s/$salary/$& * 1.1/e;
print "\$& is $&\n";
print "The salary is now \$$salary.\n";
---------------------
example37
---------------------
#! /usr/bin/perl
# Using split and pattern matching
while(<DATA>){
@line = split(":", $_);
print $line[0],"\n" if $line[1] =~ /408-/
# Using the pattern matching operator
}
__DATA__
Steve Blenheim:415-444-6677:12 Main St.
Betty Boop:303-223-1234:234 Ethan Ln.
Igor Chevsky:408-567-4444:3456 Mary Way
Norma Cord:555-234-5764:18880 Fiftieth St.
Jon DeLoach:201-444-6556:54 Penny Ln.
Karen Evich:306-333-7654:123 4th Ave.
---------------------
example38
---------------------
#! /usr/bin/perl
# Using split, an anonymous list, and pattern matching
while(<DATA>){
($name, $phone, $address) = split(":", $_);
print $name,"\n" if $phone =~ /408-/ # Using the pattern matching operator
}
__DATA__
Steve Blenheim:415-444-6677:12 Main St.
Betty Boop:303-223-1234:234 Ethan Ln.
Igor Chevsky:408-567-4444:3456 Mary Way
Norma Cord:555-234-5764:18880 Fiftieth St.
Jon DeLoach:201-444-6556:54 Penny Ln.
Karen Evich:306-333-7654:123 4th Ave.
---------------------
example39
---------------------
#! /usr/bin/perl
while($inputline =<DATA>){
($name, $phone, $address) = split(":", $inputline);
print "$name\n" if $phone =~ /408-/; # Using the pattern matching operator
print $inputline if $name =~ /^Karen/;
print if /^Norma/;
}
__DATA__
Steve Blenheim:415-444-6677:12 Main St.
Betty Boop:303-223-1234:234 Ethan Ln.
Igor Chevsky:408-567-4444:3456 Mary Way
Norma Cord:555-234-5764:18880 Fiftieth St.
Jon DeLoach:201-444-6556:54 Penny Ln.
Karen Evich:306-333-7654:123 4th Ave.
#######################
chap08 : regular expression methcharacters
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
$_ = 'abracadabra';
print if /^a...c/;
---------------------
example02
---------------------
#! /usr/bin/perl
# The dot metacharacter
while(<DATA>){
print "Found Norma!\n" if /N..ma/;
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example03
---------------------
#! /usr/bin/perl
# The s modifier and the newline
$_="Sing a song of sixpence\nA pocket full of rye.\n";
print $& if /pence./s;
print $& if /rye\../s;
print if s/sixpence.A/twopence, a/s;
---------------------
example04
---------------------
#! /usr/bin/perl
while(<DATA>){
print if /[A-Z][a-z]eve/;
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example05
---------------------
#! /usr/bin/perl
# The bracketed character class
while(<DATA>){
print if /[A-Za-z0-9_]/;
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example06
---------------------
#! /usr/bin/perl
# The bracket metacharacters and negation
while(<DATA>){
print if / [^123]0/
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example07
---------------------
#! /usr/bin/perl
# The metasymbol, \d
while(<DATA>){
print if /6\d\d/
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example08
---------------------
#! /usr/bin/perl
# Metacharacters and metasymbols
while(<DATA>){
print if /[ABC]\D/
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example09
---------------------
#! /usr/bin/perl
# The word metasymbols
while(<DATA>){
print if / \w\w\w\w \d/
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example10
---------------------
#! /usr/bin/perl
# The word metasymbols
while(<DATA>){
print if /\W\w\w\w\w\W/
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example11
---------------------
#! /usr/bin/perl
# The POSIX character classes
require 5.6.0;
while(<DATA>){
print if /[[:upper:]][[:alpha:]]+ [[:upper:]][[:lower:]]+/;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Betty Boop
Karen Evich
---------------------
example12
---------------------
#! /usr/bin/perl
# The \s metasymbol and whitespace
while(<DATA>){
print if s/\s/*/g;
}
print "\n";
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example13
---------------------
#! /usr/bin/perl
# The \S metasymbol and non-whitespace
while(<DATA>){
print if s/\S/*/g;
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example14
---------------------
#! /usr/bin/perl
# Escape sequences, \n and \t
while(<DATA>){
print if s/\n/\t/;
}
print "\n";
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example15
---------------------
#! /usr/bin/perl
# The zero or one quantifier
while(<DATA>){
print if / [0-9]\.?/;
}
__END__
Steve Blenheim 1.10
Betty Boop .5
Igor Chevsky 555.100
Norma Cord 4.01
Jonathan DeLoach .501
Karen Evich 601
---------------------
example16
---------------------
#! /usr/bin/perl
# The zero or more quantifier
while(<DATA>){
print if /\sB[a-z]*/;
}
__END__
Steve Blenheim 1.10
Betty Boop .5
Igor Chevsky 555.100
Norma Cord 4.01
Jonathan DeLoach .501
Karen Evich 601
---------------------
example17
---------------------
#! /usr/bin/perl
# The dot metacharacter and the zero or more quantifier
while(<DATA>){
print if s/[A-Z].*y/Tom/;
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example18
---------------------
#! /usr/bin/perl
# The one or more quantifier
while(<DATA>){
print if /5+/;
}
__END__
Steve Blenheim 1.10
Betty Boop .5
Igor Chevsky 555.100
Norma Cord 4.01
Jonathan DeLoach .501
Karen Evich 601
---------------------
example19
---------------------
#! /usr/bin/perl
# The one or more quantifier
while(<DATA>){
print if s/\w+/X/g;
}
__END__
Steve Blenheim 101
Betty Boop 201
Igor Chevsky 301
Norma Cord 401
Jonathan DeLoach 501
Karen Evich 601
---------------------
example20
---------------------
#! /usr/bin/perl
# Repeating patterns
while(<DATA>){
print if /5{1,3}/;
}
__END__
Steve Blenheim 1.10
Betty Boop .5
Igor Chevsky 555.100
Norma Cord 4.01
Jonathan DeLoach .501
Karen Evich 601
---------------------
example21
---------------------
#! /usr/bin/perl
# Repeating patterns
while(<DATA>){
print if /5{3}/;
}
__END__
Steve Blenheim 1.10
Betty Boop .5
Igor Chevsky 555.100
Norma Cord 4.01
Jonathan DeLoach .501
Karen Evich 601
---------------------
example22
---------------------
#! /usr/bin/perl
# Repeating patterns
while(<DATA>){
print if /5{1,}/;
}
__END__
Steve Blenheim 1.10
Betty Boop .5
Igor Chevsky 555.100
Norma Cord 4.01
Jonathan DeLoach .501
Karen Evich 601
---------------------
example23
---------------------
#! /usr/bin/perl
# Greedy and not greedy
$_="abcdefghijklmnopqrstuvwxyz";
s/[a-z]+/XXX/;
print $_, "\n";
$_="abcdefghijklmnopqrstuvwxyz";
s/[a-z]+?/XXX/;
print $_, "\n";
---------------------
example24
---------------------
#! /usr/bin/perl
# A greedy quantifier
$string="I got a cup of sugar and two cups of flour from the cupboard.";
$string =~ s/cup.*/tablespoon/;
print "$string\n";
# Turning off greed
$string="I got a cup of sugar and two cups of flour from the cupboard.";
$string =~ s/cup.*?/tablespoon/;
print "$string\n";
---------------------
example25
---------------------
#! /usr/bin/perl
# Beginning of line anchor
while(<DATA>){
print if /^[JK]/;
}
__END__
Steve Blenheim 1.10
Betty Boop .5
Igor Chevsky 555.100
Norma Cord 4.01
Jonathan DeLoach .501
Karen Evich 601
---------------------
example26
---------------------
#! /usr/bin/perl
# End of line anchor
while(<DATA>){
print if /10$/;
}
__END__
Steve Blenheim 1.10
Betty Boop .5
Igor Chevsky 555.10
Norma Cord 4.01
Jonathan DeLoach .501
Karen Evich 601
---------------------
example27
---------------------
#! /usr/bin/perl
# Word anchors or boundaries
while(<DATA>){
print if /\bJon/;
}
__END__
Steve Blenheim 1.10
Betty Boop .5
Igor Chevsky 555.100
Norma Cord 4.01
Jonathan DeLoach .501
Karen Evich 601
---------------------
example28
---------------------
#! /usr/bin/perl
# Beginning and end of word anchors
while(<DATA>){
print if /\bJon\b/;
}
__END__
Steve Blenheim 1.10
Betty Boop .5
Igor Chevsky 555.100
Norma Cord 4.01
Jonathan DeLoach .501
Karen Evich 601
---------------------
example29
---------------------
#! /usr/bin/perl
# Anchors and the m modifier
$_="Today is history.\nTomorrow will never be here.\n";
print if /^Tomorrow/; # Embedded newline
$_="Today is history.\nTomorrow will never be here.\n";
print if /\ATomorrow/; # Embedded newline
$_="Today is history.\nTomorrow will never be here.\n";
print if /^Tomorrow/m;
$_="Today is history.\nTomorrow will never be here.\n";
print if /\ATomorrow/m;
$_="Today is history.\nTomorrow will never be here.\n";
print if /history\.$/m;
---------------------
example30
---------------------
#! /usr/bin/perl
# Alternation: this, that, and the other thing
while(<DATA>){
print if /Steve|Betty|Jon/;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jonathan DeLoach
Karen Evich
---------------------
example31
---------------------
#! /usr/bin/perl
# Clustering or grouping
$_=qq/The baby says, "Mama, Mama, I can say Papa!"\n/;
print if s/(ma|pa)+/goo/gi;
---------------------
example32
---------------------
#! /usr/bin/perl
# Clustering or grouping
while(<DATA>){
print if /\s(12){3}$/;
}
__DATA__
Steve Blenheim 121212
Betty Boop 123
Igor Chevsky 123444123
Norma Cord 51235
Jonathan DeLoach123456
Karen Evich 121212456
---------------------
example33
---------------------
#! /usr/bin/perl
# Clustering or grouping
$_="Tom and Dan Savage and Ellie Main are cousins.\n";
print if s/Tom|Ellie Main/Archie/g;
$_="Tom and Dan Savage and Ellie Main are cousins.\n";
print if s/(Tom|Ellie) Main/Archie/g;
---------------------
example34
---------------------
#! /usr/bin/perl
# Clustering and anchors
while(<DATA>){
# print if /^Steve|Boop/;
print if /^(Steve|Boop)/;
}
__DATA__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jonathan DeLoach
Karen Evich
---------------------
example35
---------------------
#! /usr/bin/perl
# Remembering subpatterns
while(<DATA>){
s/([Jj]on)/$1athan/;
print;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example36
---------------------
#! /usr/bin/perl
# Remembering multiple subpatterns
while(<DATA>){
print if s/(Steve) (Blenheim)/$2, $1/
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jonathan DeLoach
Karen Evich
---------------------
example37
---------------------
#! /usr/bin/perl
# Reversing subpatterns
while(<DATA>){
s/([A-Z][a-z]+)\s([A-Z][a-z]+)/$2, $1/;
print;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example38
---------------------
#! /usr/bin/perl
# Metasymbols and subpatterns
while(<DATA>){
s/(\w+)\s(\w+)/$2, $1/;
print;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Betty Boop
---------------------
example39
---------------------
#! /usr/bin/perl
# Backreferencing
while(<DATA>){
($first, $last)=/(\w+) (\w+)/; # Could be: (\S+) (\S+)/
print "$last, $first\n";
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Betty Boop
---------------------
example40
---------------------
#! /usr/bin/perl
# The greedy quantifier
$string="ABCdefghiCxyzwerC YOU!";
$string=~s/.*C/HEY/;
print "$string", "\n";
---------------------
example41
---------------------
#! /usr/bin/perl
# Backreferencing and greedy quantifiers
$string="ABCdefghiCxyzwerC YOU!";
$string=~s/(.*C)(.*)/HEY/;
print $1, "\n";
print $2, "\n";
print "$string\n";
---------------------
example42
---------------------
#! /usr/bin/perl
# Backreferencing and greed
$fruit="apples pears peaches plums";
$fruit =~ /(.*)\s(.*)\s(.*)/;
print "$1\n";
print "$2\n";
print "$3\n";
print "-" x 30, "\n";
$fruit="apples pears peaches plums";
$fruit =~ /(.*?)\s(.*?)\s(.*?)\s/; # Turn off greedy quantifier
print "$1\n";
print "$2\n";
print "$3\n";
---------------------
example43
---------------------
#! /usr/bin/perl
$_="Tom Savage and Dan Savage are brothers.\n";
print if /(?:D[a-z]*|T[a-z]*) Savage/; # Perl will not capture
# the pattern
print $1,"\n"; # $1 has no value
---------------------
example44
---------------------
#! /usr/bin/perl
# A positive look ahead
$string="I love chocolate cake and chocolate ice cream.";
$string =~ s/chocolate(?= ice)/vanilla/;
print "$string\n";
$string="Tomorrow night Tom Savage and Tommy Johnson will leave for vacation.";
$string =~ s/Tom(?=my)/Jere/g;
print "$string\n";
---------------------
example45
---------------------
#! /usr/bin/perl
# Negative look ahead
while(<DATA>){
print if /^\w+\s(?![BC])/;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example46
---------------------
#! /usr/bin/perl
# A positive look behind
$string="I love chocolate cake, chocolate milk, and chocolate ice cream.";
$string =~ s/(?<= chocolate )milk/candy bars/;
print "$string\n";
$string="I love coffee, I love tea, I love the boys and the boys love me.";
$string =~ s/(?<=the boys) love/ don't like/;
print "$string\n";
---------------------
example47
---------------------
#! /usr/bin/perl
# A negative look behind
while(<DATA>){
print if /(?<!Betty) B[a-z]*/;
}
__END__
Steve Blenheim
Betty Boop
Igor Chevsky
Norma Cord
Jon DeLoach
Karen Evich
---------------------
example48
---------------------
#! /bin/sh
cat emp.data
echo
perl -ne 'tr/a-z/A-Z/;print;' emp.data
echo
perl -ne 'tr/0-9/:/; print;' emp.data
echo
perl -ne 'tr/A-Z/a-c/;print;' emp.data
echo
perl -ne 'y/A-Z/a-z/;print;' emp.data
---------------------
example49
---------------------
#! /bin/sh
perl -ne 'tr/ //; print;' emp.names
echo
perl -ne 'tr/ //d; print;' emp.names
---------------------
example50
---------------------
#! /bin/sh
perl -ne 'tr/0-9/*/; print;' emp.names
echo
perl -ne 'tr/0-9/*/c; print;' emp.names
echo
---------------------
example51
---------------------
#! /usr/bin/perl
# Also called file.colons
while (<DATA>){
tr/:/:/s;
print;
}
__DATA__
1:::Steve Blenheim
2::Betty Boop
3:Igor Chevsky
4:Norma Cord
5:::::Jon DeLoach
6:::Karen Evich
---------------------
example52
---------------------
#! /usr/bin/perl
use utf8;
$chr=11;
print "$chr is a digit.\n"if $chr =~ /\p{IsDigit}/;
$chr = "junk";
print "$chr is not a digit.\n"if $chr =~ /\P{IsDigit}/;
print "$chr is not a control character.\n"if $chr =~ /\P{IsCntrl}/;
#######################
chap09 : files
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
open(MYHANDLE, "myfile");
open (FH, "< /etc/passwd");
open MYHANDLE;
---------------------
example02
---------------------
#! /usr/bin/perl
open(INFILE, "datebook");
close(INFILE);
---------------------
example03
---------------------
#! /usr/bin/perl
# Uncomment these to try different usages of the die function
# open(MYHANDLE, "/etc/password") || die "Can't open: $!\n";
# open(MYHANDLE, "/etc/password") or die "Can't open: $!\n";
open(MYHANDLE, "/etc/password") || die "Can't open: $!";
---------------------
example04
---------------------
#! /usr/bin/perl
# open a file with a filehandle
open(FILE, "datebook") || die "Can't open datebook: $!\n";
while(<FILE>) {
print if /Sir Lancelot/;
}
close(FILE);
---------------------
example05
---------------------
#! /usr/bin/perl
# open a file with a filehandle
open(FILE, "datebook") || die "Can't open datebook: $!\n";
while($line = <FILE>) {
print "$line" if $line =~ /^Lori/;
}
close(FILE);
---------------------
example06
---------------------
#! /usr/bin/perl
# open a file with a filehandle
open(FILE, "< datebook") || die "Can't open datebook: $!\n";
@lines = <FILE>;
print @lines; # Contents of the entire file are printed.
print "\nThe datebook file contains ", $#lines + 1, " lines of text.\n";
close(FILE);
---------------------
example07
---------------------
#! /usr/bin/perl
open(MYOUTPUT, ">temp");
print MYOUTPUT "This text will be written to the temp file.\n";
close MYOUTPUT;
---------------------
example08
---------------------
#! /bin/sh
PATH=".:$PATH"
file.handle
cat newfile
cp newfile.orig newfile
---------------------
example09
---------------------
#! /usr/bin/perl
# This script copies one binary file to another.
# Note its use of binmode to set the mode of the file handle.
$infile="statsbar.gif";
open( INFILE, "<$infile" );
open( OUTFILE, ">outfile.gif" );
binmode( INFILE ); # crucial for binary files!
binmode( OUTFILE );
# binmode should be called after open() but before any I/O
# is done on the filehandle.
while ( read( INFILE, $buffer, 1024 ) ) {
print OUTFILE $buffer;
}
close( INFILE );
close( OUTFILE );
---------------------
example10
---------------------
#! /usr/bin/perl
open(APPEND, ">> temp");
---------------------
example11
---------------------
#! /bin/sh
cp newfile.orig newfile
cat newfile
echo
perl appender
cat newfile
---------------------
example12
---------------------
#! /usr/bin/perl
open (FILEOUT,">newfile") || die "Can' t open newfile: $!\n";
select(FILEOUT); # select the new filehandle for output
open (DB, "< datebook") || die "Can' t open datebook: $!\n";
while(<DB>) {
print ; # Output goes to FILEOUT, i.e. newfile
}
select(STDOUT); # Send output back to the screen
print "Good-bye.\n"; # Output goes to the screen
---------------------
example13
---------------------
#! /usr/bin/perl
# Program that uses file locking--UNIX
$LOCK_EX = 2;
$LOCK_UN = 8;
print "Adding an entry to the datafile.\n";
print "Enter the name: ";
chomp($name=<STDIN>);
print "Enter the address: ";
chomp($address=<STDIN>);
open(DB, ">>datafile") || die "Can't open: $!\n";
flock(DB, $LOCK_EX) || die ; # Lock the file
print DB "$name:$address\n";
flock(DB, $LOCK_UN) || die; # Unlock the file
---------------------
example14
---------------------
#! /usr/bin/perl
# Example using the seek function
open(FH,"datebook") or die "Can' t open: $!\n";
while($line=<FH>){ # loop through the whole file
chomp($line);
if ($line =~ /Lori/) { print "--$line--\n" ;}
}
seek(FH,0,0); # Start at the beginning of the file
while(<FH>) {
print if /Steve/;
}
---------------------
example15
---------------------
#! /usr/bin/perl
open(FH, "datebook") or die "Can't open datebook: $!\n";
while(<FH>){
last if /Norma/; # This is the last line that will be processed
}
seek(FH,0,1) or die; # Seeking from the current position
$line=<FH>; # This is where the read starts again.
print "$line";
close FH;
---------------------
example16
---------------------
#! /usr/bin/perl
open(FH, "datebook") or die "Can't open datebook: $!\n";
seek(FH,-13,2) or die;
while(<FH>){
print;
}
---------------------
example17
---------------------
#! /usr/bin/perl
# Example using the tell function
open(FH,"datebook") || die "Can't open: $!\n";
while ($line=<FH>) { # loop through the whole file
chomp($line);
if ($line =~ /^Lori/) {
$currentpos=tell;
print "The current byte position is $currentpos.\n";
print "$line\n\n";
}
}
seek(FH,$currentpos,0); # Start at the beginning of the file
@lines=(<FH>);
print @lines;
---------------------
example18
---------------------
#! /bin/sh
PATH=".:$PATH"
echo -n 1 > visitor_count
countem.pl
countem.pl
---------------------
example19
---------------------
#! /usr/bin/perl
# open for writing first, then reading
print "\n";
open(FH, "+>joker") || die;
print FH "This line is written to joker.\n";
seek(FH,0,0); # Goto the beginning of the file
while(<FH>) {
print; # reads from joker; the line is in $_
}
---------------------
example20
---------------------
#! /usr/bin/perl
# Program name: outfilter
open(MYPIPE, "| wc -w");
print MYPIPE "apples pears peaches";
close(MYPIPE);
---------------------
example21
---------------------
#! /usr/bin/perl
open(FOO, "| tr '[a-z]' '[A-Z]'");
print FOO "hello there\n";
close FOO; # if you don't close FOO, the output may be delaye\i d.
---------------------
example22
---------------------
#! /usr/bin/perl
open(FOO, "| sort +1| tr '[a-z]' '[A-Z]'"); # open the output filter
open(DB, "emp.names"); # open DB for reading
while(<DB>){ print FOO ; }
close FOO;
---------------------
example23
---------------------
#! /usr/bin/perl
# Program to redirect STDOUT from filter to a UNIX file
$| = 1; # Flush buffers
$tmpfile = "temp";
`cp emp.names data`; # Use the execute feature to copy a file
open(DB, "data") || die qq/Can' t open "data": $!\n/; # Open DB for reading
open(SAVED, ">&STDOUT") || die "$!\n"; # Save stdout
open(STDOUT, ">$tmpfile" ) || die "Can' t open: $!\n";
open(SORT, "| sort +1") || die; # Open output filter
while(<DB>){
print SORT; # Output is first sorted and then sent to temp.
}
close SORT;
close DB;
open(STDOUT, ">&SAVED") || die "Can't open";
# This output will go to the screen
print "Here we are printing to the screen again.\n";
rename("temp","data") || die "Can't rename temp to data.\n";
---------------------
example24
---------------------
#! /usr/bin/perl
# Program name: infilter
open(INPIPE, "date |"); # Windows (NT) use: date /T
$today = <INPIPE>;
print $today;
close(INPIPE);
---------------------
example25
---------------------
#! /usr/bin/perl
open(FINDIT, "find . -name 'perl*' -print |") || die "Couldn't execute find!\n";
while( $filename = <FINDIT> ){
print $filename;
}
---------------------
example26
---------------------
#! /usr/bin/perl
# Opening an input filter on a Win32 platform
open(LISTDIR, 'dir "C:\perl" |' ) || die;
@filelist = <LISTDIR>;
foreach $file ( @filelist ){
print $file;
}
---------------------
example27
---------------------
#! /bin/sh
PATH=".:$PATH"
perl.arg
perl.arg f1 f2 f3 f4 f5
---------------------
example28
---------------------
#! /bin/sh
PATH=".:$PATH"
cat file1
echo
cat file2
echo
cat file3
echo
argv.test file1 file2 file3
---------------------
example29
---------------------
#! /bin/sh
PATH=".:$PATH"
grab.pl
echo
grab.pl 'norma' datebook
echo
grab.pl 'Sir Lancelot' datebook
echo
grab.pl '^.... ' datebook
echo
grab.pl Steve d*
---------------------
example30
---------------------
#! /bin/sh
PATH=".:$PATH"
cp /etc/passwd db
checkon
checkon joe
checkon $USER
---------------------
example31
---------------------
#! /usr/bin/perl
open ( DB, "names") || die "Can't open names: $! ";
while(<DB>){
print if /Norma/ .. eof; # .. is the range operator
}
---------------------
example32
---------------------
#! /bin/sh
PATH=".:$PATH"
cat file4
echo
cat file5
echo
eof.pl file4 file5
---------------------
example33
---------------------
#! /bin/sh
PATH=".:$PATH"
cat names
echo
inplace names
echo
cat names
mv names.bak names
---------------------
example34
---------------------
#! /bin/sh
PATH=".:$PATH"
ls -l perl.test
ls -l afile
echo
perl.test
#######################
chap10 : subroutines function
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
sub greetme { print "Welcome, Valkommen till, Benvenue a!\n";}
&greetme if defined &greetme;
print "Program continues....\n";
&greetme;
print "More program here.\n";
&bye;
sub bye { print "Bye, hej da, adieu.\n"; }
&bye;
---------------------
example02
---------------------
#! /usr/bin/perl
$name="Ellie";
print "Hello $name.\n";
bye(); # Without parens or an ampersand, bye would be a bare
# word causing a warning message when -w is used.
sub bye{
print "Bye $name.\n";
}
---------------------
example03
---------------------
#! /usr/bin/perl
sub bye; # Forward reference
$name="Ellie";
print "Hello $name.\n";
bye; # Call subroutine without the ampersand
sub bye{
print "Bye $name\n";
}
---------------------
example04
---------------------
#! /usr/bin/perl
# Script: perlsub_sub2
# Variables used in subroutines are global by default.
sub bye { print "Bye $name\n"; $name="Tom";}
# subroutine definition
$name="Ellie";
print "Hello to you and yours!\n";
&bye ;
print "Out of the subroutine. Hello $name.\n";
# $name is now Tom
&bye;
---------------------
example05
---------------------
#! /usr/bin/perl
# Passing arguments
$first="Charles";
$last="Dobbins";
&greeting ( $first, $last );
sub greeting{
print "@_", "\n";
print "Welcome to the club, $_[0] $_[1]!\n";
}
---------------------
example06
---------------------
#! /usr/bin/perl
# Program to demonstrate how @_ references values.
sub params{
print 'The values in the @_ array are ', "@_\n";
print "The first value is $_[0]\n";
print "The last value is ", pop(@_),"\n";
foreach $value ( @_ ) {
$value+=5;
print "The value is $value", "\n";
}
}
print "Give me 5 numbers : ";
@n=split(' ',<STDIN>);
¶ms(@n);
print "Back in main\n";
print "The new values are @n \n";
---------------------
example07
---------------------
#! /usr/bin/perl
$first=Per;
$last=Lindberg;
&greeting ( $first, $last ) ; # Call the greeting subroutine
print "---$fname---\n" if defined $fname; # $fname is local to
# sub greeting.
# Subroutine defined
sub greeting{
local ($fname, $lname) = @_ ;
print "Welcome $fname!!\n";
}
---------------------
example08
---------------------
#! /usr/bin/perl
# The scope of my variables
my $name = "Raimo";
print "$name\n";
{ # Enter block
print "My name is $name\n";
my $name = "Elizabeth";
print "Now name is $name\n";
my $love = "Christina";
print "My love is $love.\n";
} # Exit block
print "$name is back.\n";
print "I can't see my love,$love, out here.\n";
---------------------
example09
---------------------
#! /usr/bin/perl
# Difference between my and local
$friend = Louise; # global variables
$pal = Danny;
print "$friend and $pal are global.\n";
sub guests {
my $friend=Pat;
local $pal=Chris;
print "$friend and $pal are welcome guests.\n";
&who_is_it; # call subroutine
}
sub who_is_it {
print "You still have your global friend, $friend, here.\n";
print "But your pal is now $pal.\n";
}
&guests; # call subroutine
print "Global friends are back: $friend and $pal.\n";
---------------------
example10
---------------------
#! /usr/bin/perl
use strict "vars";
my $name = "Ellie"; # my (lexical) variables are ok
@friends = qw(Tom Stefan Bin Marie);
# global variables not allowed
local $newspaper = "The Globe"; # local variables are not allowed
print "My name is $name and our friends are @friends.\n";
---------------------
example11
---------------------
#! /usr/bin/perl
use strict "vars";
my $name = "Ellie"; # All variables are lexical in scope
our @friends = qw(Tom Stefan Bin Marie);
our $newspaper = "The Globe";
print "$name and $friends[0] read the $newspaper.\n";
---------------------
example12
---------------------
#! /usr/bin/perl
# Program name: prototypes
# Testing prototyping
my $a=5;
my $b=6;
my $c=7;
@list=(100,200,300);
sub myadd($$) { # myadd requires two scalar arguments
my($x, $y)=@_;
print $x + $y,"\n";
}
myadd($a, $b); # Ok
myadd(5, 4); # Ok
myadd($a, $b, $c); # Too many arguments
---------------------
example13
---------------------
#! /usr/bin/perl
# Prototypes
sub mynumbs(@$;$); # Declaration with prototype
@list=(1,2,3);
mynumbs(@list, 25);
sub mynumbs(@$;$) { # Match the prototypes
my ($scalar)=pop(@_);
my(@arr) = @_;
print "The array is: @arr","\n";
print "The scalar is $scalar\n";
}
---------------------
example14
---------------------
#! /usr/bin/perl
sub MAX {
my($max) = shift(@_);
foreach $foo ( @_ ){
$max = $foo if $max < $foo;
print $max,"\n";
}
print "------------------------------\n";
$max;
}
sub MIN {
my($min) = pop( @_ );
foreach $foo ( @_ ) {
$min = $foo if $min > $foo;
print $min,"\n";
}
print "------------------------------\n";
return $min;
}
my $biggest = &MAX ( 2, 3, 4, 10, 100, 1 );
my $smallest= &MIN ( 200, 2, 12, 40, 2, 20 );
print "The biggest is $biggest and the smallest is $smallest.\n";
---------------------
example15
---------------------
#! /usr/bin/perl
$colors="rainbow";
@colors=("red", "green", "yellow" );
&printit(*colors); # Which color is this?
sub printit{
local(*whichone)=@_; # Must use local, not my with globs
print *whichone, "\n"; # The package is main
$whichone="Prism of Light"; # Alias for the scalar
$whichone[0]="PURPLE"; # Alias for the array
}
print "Out of subroutine.\n";
print "\$colors is $colors.\n";
print "\@colors is @colors.\n";
---------------------
example16
---------------------
#! /usr/bin/perl
# Revisiting Example 10.6 -- Now using typeglob
print "Give me 5 numbers: ";
@n = split(' ', <STDIN>);
¶ms(*n);
sub params{
local(*arr)=@_;
print 'The values of the @arr array are ', @arr, "\n";
print "The first value is $arr[0]\n";
print "the last value is ", pop(@arr), "\n";
foreach $value(@arr){
$value+=5;
print "The value is $value.\n";
}
}
print "Back in main\n";
print "The new values are @n.\n";
---------------------
example17
---------------------
#! /usr/bin/perl
open(READMEFILE, "file1") || die;
&readit(*READMEFILE); # Passing a filehandle to a subroutine
sub readit{
local(*myfile)=@_; # myfile is an alias for READMEFILE
while(<myfile>){
print;
}
}
---------------------
example18
---------------------
#! /usr/bin/perl
# References And Type Glob
@list=(1, 2, 3, 4, 5);
$list="grocery";
*arr = \@list; # *arr is a reference only to the array @list
print @arr, "\n";
print "$arr\n"; # not a scalar reference
sub alias {
local (*a) = @_; # Must use local, not my
$a[0] = 7;
pop @a;
}
&alias(*arr); # Call the subroutine
print "@list\n";
$num=5;
*scalar=\$num; # *scalar is a reference to the scalar $num
print "$scalar\n";
---------------------
example19
---------------------
#! /usr/bin/perl
$num=5;
$p = \$num; # the backslash operator means "adddress of"
print 'The address assigned $p is ', $p, "\n";
print "The value stored at that address is $$p\n";
---------------------
example20
---------------------
#! /usr/bin/perl
@toys = qw( Buzzlightyear Anakin Thomas Pokemon );
$num = @toys;
%movies=("Toy Story"=>"US",
"Thomas"=>"England",
"Pokemon"=>"Japan",
);
$ref1 = \$num; # scalar pointer
$ref2 = \@toys; # array pointer
$ref3= \%movies; # hash pointer
print "There are $$ref1 toys.\n"; # dereference pointers
print "They are: @$ref2.\n";
while( ($key, $value) = each ( %$ref3 )){
print "$key--$value\n";
}
print "His favorite toys are $ref2->[0] and $ref2->[3].\n";
print "The Pokemon movie was made in $ref3->{Pokemon}.\n";
---------------------
example21
---------------------
#! /usr/bin/perl
# Hard References (Pointers)
# When assigning to a scalar, the backslash operator gets the
# address of the variable
@list=(1, 2, 3, 4, 5);
$name="Nicklas";
$ptr1 = \@list; # $ptr1 is assigned the address of @list
$ptr2 = \$name; # $ptr2 is assigned the address of $name
print q(The value of $ptr1 is: ), $ptr1, "\n";
print q(The array values $ptr1 is pointing at are:), "@$ptr1\n";
print q(The value of $ptr2 is: ), $ptr2, "\n";
print q(The scalar value $ptr2 is pointing to is: ),$$ptr2, "\n";
&fun($ptr1, $ptr2); # Call the subroutine ; pass pointers
sub fun {
my ($arrayptr, $scalarptr) = @_; # Use my, not local
print q(In subroutine: $arrayptr is: ), $arrayptr,"\n";
print q(In subroutine: $scalarptr is:), $scalarptr, "\n";
$arrayptr->[0] = 7; # Assign to the array with a pointer.
pop @$arrayptr; # Pop the array
$$scalarptr = "Andreas"; # Assign to the scalar with a pointer
print "$$scalarptr @$arrayptr\n";
}
print "Out of subroutine.\n";
print "Now \@list is: @list\n";
print "Now \$name is $name\n";
---------------------
example22
---------------------
#! /usr/bin/perl
# This script demonstrates the use of hard references
# when passing arrays. Instead of passing the entire
# array, a hard reference (pointer) is passed.
# The value of the last expression is returned.
my @list1=(1 .. 100);
my @list2=(5, 10 , 15, 20);
print "The total is: ", &addemup( \@list1, \@list2) , ".\n"; # two pointers
sub addemup{
my( $arr1, $arr2) = (shift, shift) ; # The two pointers are shifted from @_
my $total = 0;
print $arr1, "\n" ;
print $arr2, "\n";
foreach $num ( @$arr1 ){
$total1+=$num;
}
foreach $num ( @$arr2) {
$total2+=$num;
}
$total1 + $total2; # The expression is evaluated and returned
}
---------------------
example23
---------------------
#! /usr/bin/perl
sub AUTOLOAD {
my(@arguments)=@_;
$args=join(', ', @arguments);
print "$AUTOLOAD was never defined.\n";
print "The arguments passed were $args.\n";
}
$driver="Jody";
$miles=50;
$gallons=5;
&mileage($driver, $miles, $gallons); # Call to an undefined subroutine
---------------------
example24
---------------------
#! /usr/bin/perl
# Program to call a subroutine without defining it.
sub AUTOLOAD {
my(@arguments) = @_;
my($package, $command)=split("::",$AUTOLOAD, 2);
return `$command @arguments`; # Command substitution
}
$day=date("+%D"); # date is an undefined subroutine
chomp $day;
print "Today is $day.\n";
print cal(3,2003); # cal is an undefined subroutine
---------------------
example25
---------------------
#! /usr/bin/perl
# Program to demonstrate BEGIN and END subroutines
chdir("/stuff") || die "Can't cd: $!\n";
BEGIN{ print "Welcome to my Program.\n"};
END{ print "Bailing out somewhere near line ",__LINE__, ". So long.\n"};
---------------------
example26
---------------------
#! /usr/bin/perl
# The subs module
use subs qw(fun1 fun2 );
fun1;
fun2;
sub fun1{
print "In fun1\n";
}
sub fun2{
print "In fun2\n";
}
#######################
chap11 : package and module
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
# Package main
use strict "vars";
use warnings;
our ( @friends, @dogs, $key, $value ); # declaring variables
my($name,$pal,$money);
$name="Susanne";
@friends=qw(Joe Jeff Jan );
@dogs = qw(Guyson Lara Junior);
local $main::dude="Ernie"; # Keep strict happy
$pal = "Linda"; # Not in the symbol table
$money = 1000;
while(($key, $value) = each (%main::)){
# Look at main's symbol table
print "$key:\t$value\n";
}
---------------------
example02
---------------------
#! /usr/bin/perl
# Default package is main
@town = (Boston, Chico, Tampa);
$friend=Mary;
print "In main: \$friend is $friend\n";
package boy; # package declaration
$name=Steve;
print "In boy \$name is $name.\n";
$main::friend=Patricia;
print "In boy \@town is @::town\n";
package main; # package declaration
print "In main: \$name is $name\n";
print "In main: \$name is $boy::name\n";
print "In main: \$friend is $friend.\n";
---------------------
example03
---------------------
#! /usr/bin/perl
# Package declarations
$name="Suzanne"; # These variables are in package main
$num=100;
package friend; # package declaration
sub welcome {
print "Who is your pal? ";
chomp($name=<STDIN>);
print "Welcome $name!\n";
print "\$num is $num.\n"; # unknown to this package.\n";
print "Where is $main::name?\n\n";
}
package main; # package declaration; back in main
&friend::welcome; # Call subroutine
print "Back in main package \$name is $name\n";
print "Switch to friend package, Bye ",$friend::name,"\n";
print "Bye $name\n\n";
package birthday; # package declaration
$name=Beatrice;
print "Happy Birthday, $name.\n";
print "No, $::name and $friend::name, it is not your birthday!\n";
---------------------
example04
---------------------
#! /bin/sh
perl -V
echo; echo
perl -e 'print "@INC\n"'
---------------------
example05
---------------------
#! /bin/sh
# This is an MS-DOS batch file
perl -V
perl -e "print qq/@INC\n/"
---------------------
example06
---------------------
# This is excerpted from the perl library -- pwd.pl
#
# Usage:
# require "pwd.pl";
# &initpwd;
# ...
# &chdir($newdir);
package pwd;
sub main'initpwd {
if ($ENV{'PWD'}) {
local($dd,$di) = stat('.');
local($pd,$pi) = stat($ENV{'PWD'});
return if $di == $pi && $dd == $pd;
}
chop($ENV{'PWD'} = 'pwd');
}
sub main'chdir {
local($newdir) = shift;
if (chdir $newdir) {
if ($newdir =~ m#^/#) {
$ENV{'PWD'} = $newdir;
} else {
local(@curdir) = split(m#/#,$ENV{'PWD'});
@curdir = '' unless @curdir;
foreach $component (split(m#/#, $newdir)) {
next if $component eq '.';
pop(@curdir),next if $component eq '..';
}
$ENV{'PWD'} = join('/',@curdir) || '/';
}
} else {
0; # return value
}
}
1;
---------------------
example07
---------------------
#! /usr/bin/perl
require "ctime.pl";
require "pwd.pl";
&initpwd; # Call the subroutine
printf "The present working directory is %s\n", $ENV{PWD};
&chdir("../..");
printf "The present working directory is %s\n", $ENV{PWD};
$today=&ctime(time);
print "$today";
---------------------
example08
---------------------
#! /usr/bin/perl
# Program name: midterms
# This program will call a subroutine from another file
unshift(@INC, "./mylib");
require "average.pl";
print "Enter your midterm scores.\n";
@scores=split(' ' , <STDIN>);
# The ave subroutine is found in a file called average.pl
printf "The average is %.1f.\n", $average=&ave(@scores);
---------------------
example09
---------------------
#! /usr/bin/perl
use English; # Use English words to replace
# special Perl variables
print "The pid is $PROCESS_ID.\n";
print "The pid is $PID.\n";
print "The real uid $REAL_USER_ID.\n";
print "This version of perl is ", ($PERL_VERSION > 3) ? $PERL_VERSION : join('.', unpack(c3,$PERL_VERSION)),".\n";
---------------------
example10
---------------------
package Carp;
# This package implements handy routines
# for modules that wish to throw
# exceptions outside of the current package.
require Exporter;
@ISA = Exporter;
@EXPORT = qw(confess croak carp);
sub longmess {
my $error = shift;
my $mess = "";
my $i = 2;
my ($pack,$file,$line,$sub);
while (($pack,$file,$line,$sub) = caller($i++)) {
$mess .= "\t$sub " if $error eq "called";
$mess .= "$error at $file line $line\n";
$error = "called";
}
$mess || $error;
}
sub shortmess {
my $error = shift;
my ($curpack) = caller(1);
my $i = 2;
my ($pack,$file,$line,$sub);
while (($pack,$file,$line,$sub) = caller($i++)) {
return "$error at $file line $line\n"
if $pack ne $curpack;
}
longmess $error;
}
sub confess { die longmess @_; }
sub croak { die shortmess @_; }
sub carp { warn shortmess @_; }
1;
---------------------
example11
---------------------
#! /usr/bin/perl
use Carp qw(croak);
print "Give me a grade: ";
$grade = <STDIN>;
try($grade); # Call subroutine
sub try{
my($number)=@_;
croak "Illegal value: " if $number < 0 || $number > 100;
}
---------------------
example12
---------------------
package Me;
use strict; use warnings;
require 5.6.0; # Make sure we're a version of Perl no older than 5.6
require Exporter; # Exporter.pm allows routines to be imported by others
our @ISA=qw(Exporter); # ISA is a list of packages needed by this package
our @EXPORT_OK=qw(hello goodbye ); # list of your subroutines to export
sub hello { my($name)=shift; print "Hi there, $name.\n" };
sub goodbye { my($name)=shift; print "Good-bye $name.\n";}
sub do_nothing { print "Didn't print anything. Not in EXPORT list\n";}
1;
---------------------
example13
---------------------
#! /bin/sh
rm -r Exten.dir
h2xs -A -n Exten.dir
cd Exten.dir
echo
ls
echo
more Exten.dir.pm
#######################
chap12 : reference
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
# Program using symbolic references
# use strict "refs";
$language="english"; # hard reference
$english="Brooklyn";
print "Your native tongue is $language. \n";
print "But you speak with a ${$language} accent.\n";
# symbolic reference
print "--------------------------\n";
print qq/What's wrong with a $english accent.\n/;
eval "\$$language=British ;"; # symbolic reference
print "Why don't you try a $english accent? \n";
---------------------
example02
---------------------
#! /usr/bin/perl
# Program using symbolic references
use strict "refs";
$language="english"; # hard reference
$english="Brooklyn";
print "Your native tongue is $language. \n";
print "But you speak with a ${$language} accent.\n";
# symbolic reference
print "--------------------------\n";
print qq/What's wrong with a $english accent.\n/;
eval "\$$language=British ;"; # symbolic reference
print "Why don't you try an $english accent? \n";
---------------------
example03
---------------------
#! /usr/bin/perl
$num=5;
$p = \$num;
print 'The address assigned $p is ', $p, "\n";
print "The value stored at that address is $$p\n";
---------------------
example04
---------------------
#! /usr/bin/perl
@toys = qw( Buzzlightyear Woody Thomas Barney );
$num = @toys;
$ref1 = \$num;
$ref2 = \@toys;
print "There are $$ref1 toys.\n"; # de-reference pointers
print "They are: @$ref2.\n";
print "His favorite toy is $ref2->[0].\n";
---------------------
example05
---------------------
#! /usr/bin/perl
# Program passes the address of an array instead of
# the whole array.
print "Give me 5 numbers: ";
my @n = split(' ', <STDIN>);
¶ms(\@n); # Pass a reference
sub params{
my($arref) = shift;
print 'The values of the @arref array are ', @$arref, "\n";
print "The first value is $arref->[0]\n";
print "The last value is ", pop(@$arref), "\n";
foreach $value(@$arref){
$value+=5;
print "The value is $value.\n";
}
}
print "Back in main\n";
print "The new values are @n.\n";
---------------------
example06
---------------------
#! /usr/bin/perl
my $arrayref = [ 'Woody', 'Buzz', 'Bo', 'Mr. Potato Head' ];
print "The value of the reference, \$arrayref is ",
$arrayref, "\n";
print "$arrayref->[3]", "\n";
print $$arrayref[3], "\n";
# All of these examples de-reference $arrayref
print ${$arrayref}[3], "\n";
---------------------
example07
---------------------
#! /usr/bin/perl
my $hashref = { Name=>"Woody",
Type=>"Cowboy"
};
print $hashref->{Name}, "\n\n";
print keys %$hashref, "\n";
print values %$hashref, "\n";
---------------------
example08
---------------------
#! /usr/bin/perl
# Program to demonstrate a reference to a list with a nested list.
my $arrays = [ '1', '2', '3', [ 'red', 'blue', 'green' ]];
for($i=0;$i<3;$i++){
print $arrays->[$i],"\n";
}
for($i=0;$i<3;$i++){
print $arrays->[3]->[$i],"\n";
}
print "@{$arrays}\n";
print "--@{$arrays->[3]}--", "\n";
---------------------
example09
---------------------
#! /usr/bin/perl
# Program to demonstrate a reference to a two-dimensional array.
my $matrix = [
[ 0, 2, 4],
[ 4, 1, 32 ],
[12, 15, 17 ]
] ;
print "Row 3 column 2 is $matrix->[2]->[1].\n";
print "De-referencing with two loops.\n";
for($x=0;$x<3;$x++){
for($y=0;$y<3;$y++){
print "$matrix->[$x]->[$y] ";
}
print "\n";
}
print "\n";
print "De-refencing with one loop.\n";
for($i = 0; $i < 3; $i++){
print "@{$matrix->[$i]}", "\n";
}
$p=\$matrix; # Reference to a reference
print "De-referencing a reference to reference.\n";
print ${$p}->[1]->[2], "\n";
---------------------
example10
---------------------
#! /usr/bin/perl
my $petref = [ { name=>"Rover",
type=>"dog",
owner=>"Mr. Jones",
},
{ name=>"Sylvester",
type=>"cat",
owner=>"Mrs. Black",
}
];
print "The first pet's name is $petref->[0]->{name}.\n";
print "Printing an array of hashes.\n";
for($i=0; $i<2; $i++){
while(($key,$value)=each %{$petref->[$i]} ){
print "$key -- $value\n";
}
print "\n";
}
print "Adding a hash to the array.\n";
push @{$petref},{ owner =>"Mrs. Crow", name=>"Tweety",
type=>"bird" };
while(($key,$value)=each %{$petref->[2]}){
print "$key -- $value\n";
}
---------------------
example11
---------------------
#! /usr/bin/perl
# Program to demonstrate a hash containing anonymous hashes.
my $hashref ={
Math=>{
Anna => 100,
Hao => 95,
Rita => 85,
},
Science => {
Sam => 78,
Lou => 100,
Vijay =>98,
},
};
print "Anna got $hashref->{Math}->{Anna} on the Math test.\n";
$hashref->{Science}->{Lou}=90;
print "Lou's grade was changed to $hashref->{Science}->{Lou}.\n";
print "The nested hash of Math students and grades is: ";
print %{$hashref->{Math}}, "\n"; # prints the nested hash, Math
foreach $key (keys %{$hashref}){
print "Outer key: $key \n";
while(($nkey,$nvalue)=each(%{$hashref->{$key}})){
printf "\tInner key: %-5s -- Value: %-8s\n",
$nkey,$nvalue;
}
}
---------------------
example12
---------------------
#! /usr/bin/perl
# A hash with a nested hash keys and anonymous arrays of values
my $hashptr = { Teacher=>{Subjects=>[ qw(Science Math English) ]},
Musician=>{Instruments=>[ qw(piano flute harp)]},
};
# Teacher and Musician are keys.
# The values consist of nested hashes.
print $hashptr->{Teacher}->{Subjects}->[0],"\n";
print "@{$hashptr->{Musician}->{Instruments}}\n";
---------------------
example13
---------------------
#! /usr/bin/perl
my $subref = sub { print @_ ; };
&$subref(' a' ,' b' ,' c' );
print "\n";
---------------------
example14
---------------------
#! /usr/bin/perl
my $name="Tommy";
{ my $name = "Grandfather";
my $age = 86;
$ref = sub{ return "$name is $age.\n";} # anonymous subroutine
}
print "\$name is $name\n";
print &$ref;
---------------------
example15
---------------------
#! /usr/bin/perl
# closure
sub paint {
my $color = shift; # @_ array is shifted
my $item = sub { # pointer to an anonymous subroutine
my $thing=shift;
print "Paint the $thing $color.\n";
};
return $item; # Returns a closure
}
my $p1=paint("red"); # Creates a closure
my $p2=paint("blue"); # Creates a closure
$p1->("flower");
$p2->("sky");
---------------------
example16
---------------------
#! /usr/bin/perl
@toys = qw(Buzzlightyear Woody Bo);
$num = @toys; # number of elements in @toys is assigned to $num
gifts( \$num, \@toys ); # passing by reference
sub gifts {
my($n, $t) = @_; # localizing the reference with ' my'
print "There are $$n gifts: ";
print "@$t\n";
push(@$t, 'Janey' , 'Slinky');
}
print "The original array was changed to: @toys\n";
---------------------
example17
---------------------
#! /usr/bin/perl
# This script demonstrates the use of hard references
# when passing arrays. instead of passing the entire
# array, a reference is passed.
# The value of the last expression is returned.
my @list1=(1 .. 100);
my @list2=(5, 10 , 15, 20);
print "The total is : ", &addemup( \@list1, \@list2) , ".\n"; # two pointers
sub addemup{
my( $arr1, $arr2) = @_; # @_ contains two pointers (references)
my ($total1, $total2);
print $arr1, "\n" ;
print $arr2, "\n";
foreach $num ( @$arr1 ){
$total1+=$num;
}
foreach $num ( @$arr2) {
$total2+=$num;
}
$total1 + $total2; # The expression is evaluated and returned
}
---------------------
example18
---------------------
#! /usr/bin/perl
open(README, "/etc/passwd") || die;
&readit(\*README); # reference to a typeglob
sub readit {
my ($passwd)=@_;
print "\$passwd is a $passwd.\n";
while(<$passwd>){
print;
}
close($passwd);
}
seek(README,0,0) || die "seek: $!\n";
---------------------
example19
---------------------
#! /usr/bin/perl
sub gifts; # Forward declaration
$num = 5;
$junk = "xxx";
@toys = qw/ Budlightyear Woody Thomas/ ;
gifts( \$num, \@toys, $junk );
sub gifts {
my( $n, $t, $j) = @_;
print "\$n is a reference.\n" if ref($n);
print "\$t is a reference.\n" if ref($t);
print "\$j is a not a reference.\n" if ref($j);
printf "\$n is a reference to a %s.\n", ref($n);
printf"\$t is a reference to an %s.\n", ref($t);
}
#######################
chap13 : oo
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
package main;
$name = "Susan";
my $birthyear = 1942;
package nosy;
print "Hello $main::name.\n";
print "You were born in $main::birthyear?\n";
---------------------
example02
---------------------
# Bless tags a reference with a package name and returns back the reference
$class = 'SomePackage';
&blessref;
sub blessref {
my $reference = {};
return bless($reference, $class);
}
---------------------
example03
---------------------
#! /usr/bin/perl
package Employee; # Package declaration
my $ref= { name=>"Tom", # Anonymous hash: the data for the package
salary=>25000, # Describes what the object will look like
};
# The hash referenced by $ref is the object. It is blessed into
# the package; i.e. an internal tag is created to track the
# package to which it belongs.
bless($ref, Employee);
print "The bless function tags the hash with its package name.\n";
print "The value of \$ref is: $ref.\n";
print "The ref function returns the class (package) name:", ref($ref), ".\n";
print "The employee's name is $ref->{name}.\n"; # Use the reference
---------------------
example04
---------------------
#! /usr/bin/perl
#----------------------------------------------------------------
# This would normally be a separate module file named Employee.pm
# The files are put together to make this a single example
package Employee; # class
sub new { # class method called a constructor
my $class = shift;
my $ref={ Name=>undef, # Attributes of the object
Salary=>undef, # Values will be assigned later
};
bless($ref, $class); # $ref now references an object in this class
return $ref; # A reference to the object is returned
}
1; # This is necessary if Employee.pm is a separate file
#----------------------------------------------------------------
#! /usr/bin/perl # This would be the first line of a separate program file
# This would be a separate file that uses the module Employee.pm
package main; # This would be: use Employee;
# call the new method and create the object
# my $empref = new Employee; # Here's another valid syntax to call the method
my $empref = Employee->new;
$empref->{Name}="Dan Savage"; # Use the object
$empref->{Salary}=75000;
print "\$empref in main belongs to class ", ref($empref),".\n";
print "Name is $empref->{Name}.\n";
print "Salary is $empref->{Salary}.\n";
---------------------
example05
---------------------
#! /usr/bin/perl
#---------------------------------------------------------------------
package Employee;
sub new{ # Class/Static method
my $class = shift;
my $ref={}; # Anonymous and empty hash
bless($ref);
return $ref;
}
sub set_name{ # Instance/Virtual method
my $self = shift;
print "\$self is a class ", ref($self)," reference.\n";
$self->{Name} = shift;
}
sub display_name {
my $self = shift;
# The object reference is the first argument
print $self->{Name},"\n";
}
1; # This is necessary at the end of all perl library and module files
#---------------------------------------------------------------------
#! /usr/bin/perl
# The user of the class Employee
package main; # With separate files change this to: use Employee;
my $emp = Employee->new; # Call class method
$emp->set_name ("Tom Savage"); # Call instance method
$emp->display_name; # Call instance method
---------------------
example06
---------------------
#! /usr/bin/perl
#-------------------------------------------------------------------
# No Startup Line - This file is normally read in from another perl script
# This would normally be a separate file called Employee.pm
# It is included here to be more concise
package Employee;
sub new{ # Constructor method
my $class = shift;
my ($name, $salary) = @_; # Instance variables
my $ref={Name=>$name, # Instance variables to initialize the object
Salary=>$salary,
};
bless($ref, $class);
return $ref;
}
sub display_object {# An instance method
my $self = shift; # The name of the object is passed
while( ($key, $value)=each %$self){
print "$key: $value \n";
}
}
1; # This would be necessary if the package were a separate file
#-------------------------------------------------------------------
#! /usr/bin/perl
# User of the class is normally a separate program file
package main; # Normally the would be written as: use Employee;
# Documentation explaining how to use the employee
# package is called the public interface.
# It tells the programmer how to use the class.
# To create an Employee object requires two arguments,
# a name and salary.
# my $emp1 = new Employee("Tom Savage", 250000);
# Invoking constructor--two ways.
my $emp1 = Employee->new("Tom Savage", 250000);
my $emp2 = Employee->new("Devin Quigley", 55000);
# Two objects have been created.
$emp1->display_object;
$emp2->display_object;
print "$emp1, $emp2\n";
---------------------
example07
---------------------
#! /usr/bin/perl
#-----------------------------------------------------------------------
package Employee;
# Program to demonstrate passing arguments to an instance method.
# When the method is called the user can select what he wants returned.
sub new{ # Constructor
my $class = shift;
my ($name, $salary, $extension) = @_;
my $ref={ Name=>$name,
Salary=>$salary,
Extension=>$extension,
};
return bless($ref, $class);
}
sub display { # Instance method
my $self = shift; # Object reference is the first argument
foreach $choice (@_){
print "$choice: $self->{$choice}\n";
}
}
1;
#-----------------------------------------------------------------------
#! /usr/bin/perl
# Program to demonstrate passing arguments to an instance method.
# When the method is called the user can select what he wants returned.
# User of the class--Another program
package main;
# use Employee;
my $emp = new Employee("Tom Savage", 250000, 5433);
$emp->display (Name, Extension); # Passing arguments to instance method
---------------------
example08
---------------------
#! /usr/bin/perl
# User of Employee.pm -- See Example 13.9
use Employee;
use warnings;
use strict;
my($name, $extension, $address, $basepay, $employee);
print "Enter the employee's name. ";
chomp($name=<STDIN>);
print "Enter the employee's phone extension. ";
chomp($extension=<STDIN>);
print "Enter the employee's address. ";
chomp($address=<STDIN>);
print "Enter the employee's basepay. ";
chomp($basepay=<STDIN>);
$employee = new Employee(
Name=>$name, # Passing parameters as a hash
Address=>$address,
Extension=>$extension,
PayCheck=>$basepay,
);
print "\n\nThe statistics for $name are: \n";
$employee->get_stats;
---------------------
example09
---------------------
# Module Employee.pm
package Employee;
use Carp;
sub new {
my $class = shift;
my(%params)=@_; # Receiving the hash that was passed
my $objptr={
Name=>$params{Name} || croak("No name assigned"),
Extension=>$params{Extension} ,
Address=>$params{Address},
PayCheck=>$params{PayCheck} || croak("No pay assigned"),
((defined $params{IdNum})
? (IdNum=>$params{IdNum})
: (IdNum=>"Employee's id not provided")
),
};
return bless($objptr,$class);
}
sub get_stats{
my $self=shift;
while( ($key, $value)=each %$self){
print $key, " = ", $value, "\n";
}
print "\n";
}
1;
---------------------
example10
---------------------
# Perl Module File: Cat.pm
package Cat;
sub new{ # Constructor
my $class=shift;
my $dptr={};
bless($dptr, $class);
}
sub set_attributes{ # Access Methods
my $self= shift;
$self->{Name}="Sylvester";
$self->{Owner}="Mrs. Black";
$self->{Type}="Siamese";
$self->{Sex}="Male";
}
sub get_attributes{
my $self = shift;
print "-" x 20, "\n";
print "Stats for the Cat\n";
print "-" x 20, "\n";
while(($key,$value)=each( %$self)){
print "$key is $value. \n";
}
print "-" x 20, "\n";
}
1;
#--------------------------------------------------------------------
# Perl Module File: Dog.pm
package Dog;
sub new{ # Constructor
my $class=shift;
my $dptr={};
bless($dptr, $class);
}
sub set_attributes{
my $self= shift;
my($name, $owner, $breed)=@_;
$self->{Name}="$name";
$self->{Owner}="$owner";
$self->{Breed}="$breed";
}
sub get_attributes{
my $self = shift;
print "x" x 20, "\n";
print "All about $self->{Name}\n";
while(($key,$value)= each( %$self)){
print "$key is $value.\n";
}
print "x" x 20, "\n";
}
1;
#--------------------------------------------------------------------
---------------------
example11
---------------------
#! /usr/bin/perl
use Cat; # use the Cat.pm module
use Dog; # use the Dog.pm module
my $dogref = Dog->new; # polymorphism
my $catref= Cat->new;
$dogref->set_attributes("Rover", "Mr. Jones", "Mutt");
$catref->set_attributes; # polymorphism
$dogref->get_attributes;
$catref->get_attributes;
---------------------
example12
---------------------
#! /usr/bin/perl
#---------------------------------------------------------------------
# The Cat class
package Cat;
sub new{ # The Cat' s constructor
my $class = shift;
my $ref = {};
return bless ($ref, $class);
}
sub set_attributes{ # Giving the cat some attributes, a name and a voice
my $self = shift;
$self->{Name} = "Sylvester";
$self->{Talk}= "Meow purrrrrr.... ";
}
sub speak { # Retrieving the cat's attributes
my $self = shift;
print "$self->{Talk} I'm the cat called $self->{Name}.\n";
}
1;
#---------------------------------------------------------------------
# The Dog class
package Dog;
sub new{ # The Dog's Constructor
my $class = shift;
my $ref = {};
return bless ($ref, $class);
}
sub set_attributes{ # Giving the Dog some attributes
my $self = shift;
$self->{Name} = "Lassie";
$self->{Talk}= "Bow Wow, woof woof.... ";
}
sub speak { # Retrieving the Dog' s attributes
my $self = shift;
print "$self->{Talk} I'm the dog called $self->{Name}.\n";
}
1;
#---------------------------------------------------------------------
#! /usr/bin/perl
# The program file
# This example demonstrates why to use the object-oriented
# syntax rather than the colon-colon syntax when passing
# arguments to methods.
# use Cat; # These lines need to be un-commented for separate files
# use Dog;
$mydog = new Dog; # Calling the Dog' s constructor
$mycat = new Cat; # Calling the Cat' s constructor
$mydog->set_attributes; # Calling the Dog' s access methods
$mycat->set_attributes; # Calling the Cat' s access methods
$mydog->speak;
$mycat->speak;
print "\nNow we make a mistake in passing arguments.\n\n";
Cat::speak($mydog); # Perl goes Cat class to find the method
---------------------
example13
---------------------
#! /usr/bin/perl
#-------------------------------------------------------------------
package Employee;
sub new{
my $class = shift;
$ref={Name=>undef,
Salary=>undef,
};
bless($ref, $class);
return $ref;
}
sub DESTROY{
my $self = shift;
print "$self->{Name}\n";
delete $self->{Name}; # Remove the (object);
print "Hash Name entry has been destroyed. Bailing out...\n"
if ( ! exists $self->{Name});
}
#-------------------------------------------------------------------
#! /usr/bin/perl
# User of the class
package main; # or replace with: use Employee;
$empref = new Employee; # Create the object
$empref->{Name}="Dan Savage";
$empref->{Salary}=10000;
print "Name is $empref->{Name}.\n";
print "Salary is $empref->{Salary}.\n";
---------------------
example14
---------------------
#! /usr/bin/perl
# Example of attempting inheritance without updating the @ISA array.
{ package Grandpa;
$name = "Gramps";
sub greetme {
print "Hi $Child::name, I'm your $name from package Grandpa.\n";
}
}
{ package Parent;
# This package is empty.
}
{ package Child;
$name = "Baby";
print "Hi, I'm $name in the Child Package here.\n";
Parent->greetme(); # Use method invocation syntax
}
---------------------
example15
---------------------
#! /usr/bin/perl
# Example of attempting inheritance by updating the @ISA array.
{ package Grandpa;
$name = "Gramps";
sub greetme {
print "Hi $Child::name I'm your $name from package Grandpa.\n";
}
}
{ package Parent;
@ISA=qw(Grandpa); # Grandpa is a package in the @ISA array.
# This package is empty.
}
{ package Child;
$name = "Baby";
print "Hi I'm $name in the Child Package here.\n";
Parent->greetme(); # Parent::greetme() will fail.
}
---------------------
example16
---------------------
#! /usr/bin/perl
{ package Grandpa;
$name = "Gramps";
sub greetme {
print "Hi $Child::name I'm your $name from package Grandpa.\n";
}
}
{ package Parent;
sub AUTOLOAD{
print "$_[0]: $_[1] and $_[2]\n";
print "You know us after all!\n";
print "The unheard of subroutine is called $AUTOLOAD.\n"
};
}
{ package Child;
$AUTOLOAD=Grandpa->greetme();
$name = "Baby";
print "Hi I'm $name in the Child Package here.\n";
Parent->unknown("Mom", "Dad"); # undefined subroutine
}
---------------------
example17
---------------------
#! /usr/bin/perl
{ package Grandpa;
$name = "Gramps";
sub greetme {
print "Hi $Child::name I'm your $name from package Grandpa.\n";
}
}
{ package Parent;
# This package is empty.
}
{ package Child;
$name = "Baby";
print "Hi I'm $name in the Child Package here.\n";
Parent->greetme();
}
package UNIVERSAL;
sub AUTOLOAD {
print "The UNIVERSAL lookup package.\n";
Grandpa->greetme();
}
---------------------
example18
---------------------
#! /usr/bin/perl
use Salesman;
use strict;
use warnings;
# Create two salesman objects
print "Entering data for the first salesman.\n";
my $salesguy1=Salesman->new;
$salesguy1->set_data;
print "\nEntering data for the second salesman.\n";
my $salesguy2=Salesman->new;
$salesguy2->set_data;
print "\nHere are the statistics for the first salesman.\n";
$salesguy1->get_data;
print "\nHere are the statistics for the second salesman.\n";
$salesguy2->get_data;
---------------------
example19
---------------------
# Module Employee.pm
package Employee;
use strict;
use warnings;
# Constructor method
sub new {
my $class = shift;
my $self = {_Name=>undef,
_Address=>undef,
_BasePay=>undef,
};
return bless($self, $class);
}
# Instance/access methods
sub set_data{
my $self=shift;
print "Enter the name of the employee. ";
chomp($self->{_Name}=<STDIN>);
print "Enter the address of $self->{_Name}. ";
chomp($self->{_Address}=<STDIN>);
print "Enter the monthly base pay for $self->{_Name}. ";
chomp($self->{_BasePay}=<STDIN>);
}
sub get_data{
my $self=shift;
my ($key,$value);
print "Name = $self->{_Name}.\n";
while(($key,$value)=each(%$self)){
$key =~ s/_//;
print "$key = $value.\n" unless $key eq "Name";
}
print "\n";
}
1;
---------------------
example20
---------------------
# Module Salesman.pm
package Salesman;
use strict;
use warnings;
BEGIN{unshift(@INC, "./Baseclass");};
our @ISA=qw( Employee);
use Employee;
print "The salesman is an employee.\n"
if Salesman->isa('Employee');
print "The salesman can display its properties.\n"
if Salesman->can('get_data');
sub new { # Constructor for Salesman
my ($class)= shift;
my $emp = new Employee;
$emp->set_data;
print "Before blessing package is: ", ref($emp), "\n";
bless($emp, $class);
print "After blessing package is: ", ref($emp), "\n";
return $emp;
}
sub set_data{
my $self=shift;
my $calc_ptr = sub{ my($base, $comm, $bonus)=@_;
return $base+$comm+$bonus; };
print "Enter $self->{_Name}'s commission for this month. ";
chomp($self->{_Commission}=<STDIN>);
print "Enter $self->{_Name}'s bonuses for this month. ";
chomp($self->{_Bonuses}=<STDIN>);
print "Enter $self->{_Name}'s sales region. ";
chomp($self->{_Region}=<STDIN>);
$self->{_PayCheck}=&$calc_ptr( $self->{_BasePay},
$self->{_Commission},
$self->{_Bonuses}
);
}
1;
---------------------
example21
---------------------
#! /usr/bin/perl
#---------------------------------------------------------------------
package Employee; # Base class
use strict;
use warnings;
sub new { # Employee' s constructor is defined
my $class = shift;
my %params = @_;
my $self = { Name=>$params{"Name"},
Salary=>$params{"Salary"},
};
bless ($self, $class);
}
sub display { # Instance method
my $self = shift;
my $key;
foreach $key ( @_ ){
print "$key: $self->{$key}\n";
}
print "The class using this display method is ", ref($self),"\n";
}
1;
#---------------------------------------------------------------------
package Salesman; # Derived class
use strict;
use warnings;
# use Employee; # Uncomment this if the files are separate
our @ISA=qw (Exporter Employee);
sub new { # Constructor in derived Salesman class
my $class = shift;
my (%params) = @_;
my $self = new Employee(%params); # Call constructor in base class
$self->{Commission} = $params{Commission};
bless ( $self, $class ); # Rebless the object into the derived class
}
sub set_Salary {
my $self = shift;
$self->{Salary}=$self->{Salary} + $self->{Commission};
}
sub display{ # Override method with subroutine
my $self = shift;
my @args = @_;
print "Stats for the Salesman\n";
print "-" x 25, "\n";
$self->Employee::display(@args); # Access to the overridden method.
}
1;
#---------------------------------------------------------------------
#! /usr/bin/perl
# This is the driver program
use strict;
use warnings;
# use Salesman; # Uncomment this if the files are separate
my $emp = new Salesman ( "Name", "Tom Savage",
# Call to the constructor
"Salary", 50000,
"Commission", 1500,
);
$emp->set_Salary; # Call to the access method
$emp->display( "Name" , "Salary", "Commission"); # Call Salesman' s display
---------------------
example22
---------------------
#! /usr/bin/perl
=head1 NAME
Math::BigFloat - Arbitrary length float math package
=head1 SYNOPSIS
use Math::BigFloat;
$f = Math::BigFloat->new($string);
$f->fadd(NSTR) return NSTR addition
$f->fsub(NSTR) return NSTR subtraction
$f->fmul(NSTR) return NSTR multiplication
$f->fdiv(NSTR[,SCALE]) returns NSTR division to SCALE places
$f->fneg() return NSTR negation
$f->fabs() return NSTR absolute value
$f->fcmp(NSTR) return CODE compare undef,<0,=0,>0
$f->fround(SCALE) return NSTR round to SCALE digits
$f->ffround(SCALE) return NSTR round at SCALEth place
$f->fnorm() return (NSTR) normalize
$f->fsqrt([SCALE]) return NSTR sqrt to SCALE places
=head1 DESCRIPTION
All basic math operations are overloaded if you declare your big
floats as
$float = new Math::BigFloat "2.123123123123123123123123123123123";
=over 2
=item number format
canonical strings have the form /[+-]\d+E[+-]\d+/ . Input values can
have embedded whitespace.
=item Error returns 'NaN'
An input parameter was "Not a Number" or divide by zero or sqrt of
negative number.
=item Division is computed to
C<max($Math::BigFloat::div_scale,length(dividend)+length(divisor))>
digits by default.
Also used for default sqrt scale.
=item Rounding is performed
according to the value of
C<$Math::BigFloat::rnd_mode>:
trunc truncate the value
zero round towards 0
+inf round towards +infinity (round up)
-inf round towards -infinity (round down)
even round to the nearest, .5 to the even digit
odd round to the nearest, .5 to the odd digit
The default is C<even> rounding.
=back
=head1 BUGS
The current version of this module is a preliminary version of the
real thing that is currently (as of perl5.002) under development.
The printf subroutine does not use the value of
C<$Math::BigFloat::rnd_mode> when rounding values for printing.
Consequently, the way to print rounded values is
to specify the number of digits both as an
argument to C<ffround> and in the C<%f> printf string,
as follows:
printf "%.3f\n", $bigfloat->ffround(-3);
=head1 AUTHOR
Mark Biggar
=cut
---------------------
example23
---------------------
#! /bin/sh
PERLLIB=`perl -e 'use Math::BigFloat; $_=$INC{q#Math/BigFloat.pm#}; s#/Math.*$##; print;'`
perl -e "print join qq/\n/,@INC;"
echo; echo
ls -C $PERLLIB
echo
ls -C $PERLLIB/Math
---------------------
example24
---------------------
# Excerpted from the package Math::BigFloat.pm
package Math::BigFloat;
use Math::BigInt;
use Exporter; # just for use to be happy
@ISA = (Exporter);
$VERSION = '0.01'; # never had version before
use overload
'+' => sub {new Math::BigFloat &fadd},
'-' => sub {new Math::BigFloat
$_[2]? fsub($_[1],${$_[0]}) : fsub(${$_[0]},$_[1])},
'<=>' => sub {$_[2]? fcmp($_[1],${$_[0]}) : fcmp(${$_[0]},$_[1])},
'cmp' => sub {$_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
'*' => sub {new Math::BigFloat &fmul},
'/' => sub {new Math::BigFloat
$_[2]? scalar fdiv($_[1],${$_[0]}) :
scalar fdiv(${$_[0]},$_[1])},
'neg' => sub {new Math::BigFloat &fneg},
'abs' => sub {new Math::BigFloat &fabs},
qw(
"" stringify
0+ numify) # Order of arguments unsignificant
;
sub new {
my ($class) = shift;
my ($foo) = fnorm(shift);
bless \$foo, $class;
}
# < Methods continue here. Just a few methods are excerpted. >
# addition
sub fadd { #(fnum_str, fnum_str) return fnum_str
local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1]));
if ($x eq 'NaN' || $y eq 'NaN') {
'NaN';
} else {
local($xm,$xe) = split('E',$x);
local($ym,$ye) = split('E',$y);
($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
&norm(Math::BigInt::badd($ym,$xm.('0' x ($xe-$ye))),$ye);
}
}
# subtraction
sub fsub { #(fnum_str, fnum_str) return fnum_str
fadd($_[$[],fneg($_[$[+1]));
}
# division
# args are dividend, divisor, scale (optional)
# result has at most max(scale, length(dividend), length(divisor)) digits
sub fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
{
local($x,$y,$scale) = (fnorm($_[$[]),fnorm($_[$[+1]),$_[$[+2]);
if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
'NaN';
} else {
local($xm,$xe) = split('E',$x);
local($ym,$ye) = split('E',$y);
$scale = $div_scale if (!$scale);
$scale = length($xm)-1 if (length($xm)-1 > $scale);
$scale = length($ym)-1 if (length($ym)-1 > $scale);
$scale = $scale + length($ym) - length($xm);
&norm(&round(Math::BigInt::bdiv($xm.('0' x $scale),$ym),
Math::BigInt::babs($ym)),
$xe-$ye-$scale);
}
}
# < Methods continue here. Just a few methods are excerpted. >
# square root by Newtons method.
sub fsqrt { #(fnum_str[, scale]) return fnum_str
local($x, $scale) = (fnorm($_[$[]), $_[$[+1]);
if ($x eq 'NaN' || $x =~ /^-/) {
'NaN';
} elsif ($x eq '+0E+0') {
'+0E+0';
} else {
local($xm, $xe) = split('E',$x);
$scale = $div_scale if (!$scale);
$scale = length($xm)-1 if ($scale < length($xm)-1);
local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
while ($gs < 2*$scale) {
$guess = fmul(fadd($guess,fdiv($x,$guess,$gs*2)),".5");
$gs *= 2;
}
new Math::BigFloat &fround($guess, $scale);
}
}
1;
---------------------
example25
---------------------
#! /usr/bin/perl
use Math::BigFloat; # BigFloat.pm is in the Math directory
$number = "000.95671234e-21";
$mathref = new Math::BigFloat("$number"); # Create the object
print "\$mathref is in class ", ref($mathref), "\n"; # Where is the object
print $mathref->fnorm(), "\n"; # Use methods from the class
print "The sum of $mathref + 500 is:\n\t", $mathref->fadd("500"), "\n";
print "Division using overloaded operator:\n\t", $mathref / 200.5, "\n";
print "Division using fdiv method:\n\t", $mathref->fdiv("200.5"), "\n";
print "Enter a number ";
chop($numstr = <STDIN>);
if ( $mathref->fadd($numstr) eq "NaN" ){
print "You didn't enter a number.\n"
};
# Return value of NaN means the string is not a number,
# or you divided by zero, or you took the square root
# of a negative number.
#######################
chap14 : DBM and DB hooks
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
#---------------------------------------------------------------------
package Square; # File is Square.pm
sub TIESCALAR{
my $class = shift;
my $data = shift;
bless(\$data,$class);
}
sub FETCH{
my $self = shift;
$$self **= 2;
}
sub STORE{
my $self = shift;
$$self = shift;
}
1;
#---------------------------------------------------------------------
#! /usr/bin/perl
# User program
package main; # For separate file replace with: use Square;
$object=tie $squared, 'Square', 5; # Call constructor TIESCALAR
print "object is $object.\n";
print $squared,"\n"; # Call FETCH three times
print $squared,"\n";
print $squared,"\n";
print "----------------------------\n";
$squared=3; # Call STORE
print $squared,"\n"; # Call FETCH
print $squared,"\n";
print $squared,"\n";
untie $squared; # Break the tie that binds the scalar to the object
---------------------
example02
---------------------
#! /usr/bin/perl
#---------------------------------------------------------------------
# File: MarkUp.pm
package MarkUp;
sub TIESCALAR { # Constructor ties a scalar
my $class = shift;
my $markup = shift;
my $cost = 0;
my $mcost = [ $markup, $cost ];
return bless ( $mcost, $class);
}
sub STORE {
my $self = shift;
# First argument is a reference to the object
my $amount = shift;
# Second argument is the value assigned to $cost
$self->[1] = $amount * $self->[0]; # Returns a scalar
}
sub FETCH {
my $self = shift;
# First argument is a reference to the object
return $self->[1];
# The pointer is derefenced; returns a scalar
}
sub DESTROY {
print "The object is being destroyed.\n";
}
1;
#---------------------------------------------------------------------
#! /usr/bin/perl
# This is the user/driver program
package main; # use Markup;
$object = tie $cost, 'MarkUp', 1.15;
# Ties the variable $cost to the MarkUp package
# Whenever the variable $cost is accessed, it will be passed
# to the FETCH and STORE methods and its value manipulated by
# the object it is tied to. A scalar must be returned by
# FETCH and STORE if tying to a scalar. The constructor
# can bless a reference to any data type, not specifically
# a scalar.
print "What is the price of the material? ";
$cost = <STDIN>;
# Could have said: $object->STORE(34)
# or could have said: (tied $cost)->STORE(34);
printf "The cost to you after markup is %.2f.\n", $cost;
# Could have said: $object->FETCH
untie $cost; # $cost is now a normal scalar
# The DESTROY method is called automatically when the program exits.
---------------------
example03
---------------------
#! /usr/bin/perl
#---------------------------------------------------------------------
package Temp;
sub TIEARRAY {
my $class = shift; # shifting the @_ array
my $obj = [ ];
bless ($obj, $class);
}
# Access methods
sub FETCH {
my $self=shift;
my $indx = shift;
return $self->[$indx];
}
sub STORE {
my $self = shift;
my $indx= shift;
my $F = shift; # The Farenheit temperature
$self->[$indx]=($F - 32) / 1.8; # Magic works here!
}
1;
#---------------------------------------------------------------------
#! /usr/bin/perl
# The user/driver program
package main; # use Temp;
tie @list, "Temp";
print "Beginning Fahrenheit: ";
chomp($bf = <STDIN>);
print "Ending temp: ";
chomp($ef = <STDIN>);
print "Increment value: ";
chomp($ic = <STDIN>);
print "\n";
print "\tConversion Table\n";
print "\t----------------\n";
for($i=$bf;$i<=$ef;$i+=$ic){
$list[$i]=$i;
printf"\t$i F. = %.2f C.\n", $list[$i];
}
---------------------
example04
---------------------
#! /usr/bin/perl
# Example using tie with a hash
#---------------------------------------------------------------------
package House;
sub TIEHASH { # Constructor method
my $class = shift; # shifting the @_ array
my $price = shift;
my $color = shift;
my $rooms = shift;
print "I'm the constructor in class $class.\n";
my $house = { Color=>$color, # data for the tied hash
Price=>$price,
Rooms=>$rooms,
};
bless $house, $class;
}
sub FETCH { # Access methods
my $self=shift;
my $key=shift;
print "Fetching a value.\n";
return $self->{$key};
}
sub STORE {
my $self = shift;
my $key = shift;
my $value = shift;
print "Storing a value.\n";
$self->{$key}=$value;
}
1;
#---------------------------------------------------------------------
#! /usr/bin/perl
# User/driver program
package main; # For separate files change this to: use House;
# The arguments following the package name are
# are passed as a list to the tied hash
# Usage: tie hash, package, argument list
# The hash %home is tied to the package House.
tie %home, "House", 155000, "Yellow", 9;
# Calls the TIEHASH constructor
print qq/The original color of the house: $home{"Color"}\n/;
# Calls FETCH method
print qq/The number of rooms in the house: $home{"Rooms"}\n/;
print qq/The price of the house is: $home{"Price"}\n/;
$home{"Color"}="beige with white trim"; # Calls STORE method
print "The house has been painted. It is now $home{Color}.\n";
untie(%home); # Removes the object
---------------------
example05
---------------------
#! /usr/bin/perl
#---------------------------------------------------------------------
# File is House.pm
package House;
sub TIEHASH {
my $class = shift;
print "I'm the constructor in package $class\n";
my $houseref = {};
bless $houseref, $class;
}
sub FETCH {
my $self=shift;
my $key=shift;
return $self->{$key};
}
sub STORE {
my $self = shift;
my $key = shift;
my $value = shift;
$self->{$key}=$value;
}
sub FIRSTKEY{
my $self = shift;
my $tmp = scalar keys %{$self};
return each %{$self};
}
sub NEXTKEY{
$self=shift;
each %{$self};
}
1;
#---------------------------------------------------------------------
#! /usr/bin/perl
# File is mainfile
package main; # For separate files change this to: use House;
tie %home, "House";
$home{"Price"} = 55000; # Assign and Store the data
$home{"Rooms"} = 11;
# Fetch the data
print "The number of rooms in the house: $home{Rooms}\n";
print "The price of the house is: $home{Price}\n";
foreach $key (keys(%home)){
print "Key is $key\n";
}
while( ($key, $value) = each(%home)){
# Calls to FIRSTKEY and NEXTKEY
print "Key=$key, Value=$value\n";
}
untie(%home);
---------------------
example06
---------------------
use SDBM_File;
dbmopen(%myhash, "mydbmfile", 0666);
tie(%myhash, SDBM_File, "mydbmfile", O_RDWR|O_CREAT, 0640);
---------------------
example07
---------------------
#! /usr/bin/perl
# Program name: makestates.pl
# This program creates the database using the dbm functions
use AnyDBM_File; # Let Perl pick the right dbm for your system
dbmopen(%states, "statedb", 0666 ) || die "Trouble: $!";
# create or open the database
TRY: {
print "Enter the abbreviation for your state. ";
chomp($abbrev=<STDIN>);
$abbrev = uc $abbrev; # Make sure abbreviation is uppercase
print "Enter the name of the state. ";
chomp($state=<STDIN>);
lc $state;
$states{$abbrev}="\u$state"; # Assign values to the database
print "Another entry? ";
$answer = <STDIN>;
redo TRY if $answer =~ /Y|y/;
}
dbmclose(%states); # Close the database
---------------------
example08
---------------------
#! /usr/bin/perl
# Program name: getstates.pl
# This program fetches the data from the database and generates a report
use AnyDBM_File;
dbmopen(%states, "statedb", 0666); #open the database
@sortedkeys=sort keys %states; # sort the database by keys
foreach $key ( @sortedkeys ){
$value=$states{$key};
$total++;
write;
}
dbmclose(%states); # close the database
format STDOUT_TOP=
Abbreviation State
==============================
.
format STDOUT=
@<<<<<<<<<<<<<<@<<<<<<<<<<<<<<<
$key, $value
.
format SUMMARY=
==============================
Number of states:@###
$total
.
$~=SUMMARY;
write;
---------------------
example09
---------------------
#! /usr/bin/perl
# Program name: remstates.pl
# dbmopen is an older method of opening a dbm file but simpler
# than using tie and the SDBM_File module provided
# in the standard Perl library
use AnyDBM_File;
dbmopen(%states, "statedb", 0666) || die "Trouble: $!";
TRY: {
print "Enter the abbreviation for the state to remove. ";
chomp($abbrev=<STDIN>);
$abbrev = uc $abbrev; # Make sure abbreviation is uppercase
delete $states{"$abbrev"};
print "$abbrev removed.\n";
print "Another entry? ";
$answer = <STDIN>;
redo TRY if $answer =~ /Y|y/;
}
dbmclose(%states);
---------------------
example10
---------------------
#! /usr/bin/perl
use Fcntl;
use SDBM_File;
tie(%address, 'SDBM_File', 'email.dbm', O_RDWR|O_CREAT, 0644) || die $!;
print "The package the hash is tied to: ",ref tied %address,"\n";
print "Enter the email address.\n";
chomp($email=<STDIN>);
print "Enter the first name of the addressee.\n";
chomp($firstname=<STDIN>);
$firstname = lc $firstname;
$firstname = ucfirst $firstname;
$address{"$email"}=$firstname;
while( ($email, $firstname)=each(%address)){
print "$email, $firstname\n";
}
untie %address;
#######################
chap15 : DB programming
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
# Program name: ex1.pl
# Perl program accessing Microsoft SQL Server via ADO and ODBC
# 1st create a DSN named "MSS_pubs" as previously described.
# Make sure your database server is running before trying the program
print "hi from $0\n";
print ("\t ADO with DSN \"MSS_pubs\" on the local MS SQL Server database \n");
print ("\t Execute: SELECT job_id, job_desc, min_lvl, max_lvl FROM jobs \n\n");
print "\n";
use OLE;
$conn = CreateObject OLE "ADODB.Connection" || # Create ADO auto object
die "Error on ADO CreateObject: $!" ;
$conn->Open('MSS_pubs' ); # Connect to DSN
if ( $conn->{State} != 1 ) { # 1 is adStateOpen, 0 is adStateClosed
die ("\t Connection Not Open. Make sure the server is running.\n\n");
}
$sql="SELECT job_id, job_desc, min_lvl, max_lvl FROM jobs "; # SQL Statement to run
$rs = $conn->Execute($sql); # Execute the query
print ("job_id\tjob_desc\t\t\tmin_lvl\tmax_lvl\n"); # Print header for output
while( ! $rs->EOF() ) { # Fetch each row, one at a time until reach end of rs
print ( $rs->Fields(job_id)->Value, "\t" );
printf( "%-30s\t", $rs->Fields(job_desc)->Value );
print ( $rs->Fields(min_lvl)->Value, "\t" );
print ( $rs->Fields(max_lvl)->Value, "\n" );
$rs->MoveNext; # Move to the next row of the recordset
}
$rs->Close; # close the recordset
$conn->Close; # close the connection
# Last line of file
---------------------
example02
---------------------
#! /c/perl/bin/perl
# Program name: ex2.pl
# ADO program using pass-through SQL to execute DDL and DML statements
use OLE;
############## Subroutine PrintPersonsTable();
sub PrintPersonsTable{
$sql = "SELECT personid , pname , city FROM persons; ";
$rs = $conn->Execute($sql) || warn "*** SELECT ERROR *** $!";
print (" personid\t pname \t city\n");
print (" --------\t -------------\t ---------\n");
while ( ! $rs->EOF() ) # Fetch each row
{ # Print each column value
print ("\t", $rs->Fields(personid)->Value , "\t ");
print ( $rs->Fields(pname)->Value , "\t ");
print ( $rs->Fields(city)->Value , "\n");
$rs->MoveNext;
}
$rs->Close;
print ("\n");
} ############## end Subroutine PrintPersonsTable
print ("\tADO DSN-Less to pubs database on local MS SQL Server database. \n");
print ("\tThis program uses ADO to execute DDL and DML statements \n");
print "\n";
$conn = CreateObject OLE "ADODB.Connection" || # Create ADO auto object
die "Error on ADO CreateObject: $!" ;
$conn->Open("server=(local);driver={SQL Server};UID=sa;PWD=;database=pubs;DSN=;");
## To go directly from OLE DB to MSS, remove the line above and uncomment next line
## $conn->Open("Provider=SQLOLEDB.1;Password=;User ID=sa;Initial Catalog=pubs;Data Source=(local)");
if ( $conn->{State} != 1 ) { # 1 is adStateOpen, 0 is asStateClosed
die ("\t Connection Not Open. Make sure the server is started.\n\n");
}
#################################### DROP TABLE persons
$sql = "DROP TABLE persons ";
$conn->Execute($sql) || warn "*** DROP TABLE ERROR *** $!";
#################################### CREATE TABLE persons
$sql = "CREATE TABLE persons (
personidINTEGER PRIMARY KEY ,
pname VARCHAR(15) NOT NULL,
city VARCHAR(15)
); ";
$conn->Execute($sql) || warn "*** CREATE TABLE ERROR *** $!";
#################################### INSERT 2 rows
$sql = "INSERT INTO persons VALUES ( 1 , 'Carol Smith' , 'Boston');
INSERT INTO persons VALUES ( 2 , 'Sam Jones' , 'Detroit' ); ";
$conn->Execute($sql) || warn "*** INSERT ERROR *** $!";
PrintPersonsTable();
#################################### UPDATE 1 row
$sql = "UPDATE persons SET city = 'Seattle' WHERE personid = 2; ";
$conn->Execute($sql) || warn "*** UPDATE ERROR *** $!";
PrintPersonsTable();
#################################### DELETE 1 row
$sql = "DELETE FROM persons WHERE personid = 1; ";
$conn->Execute($sql) || warn "*** DELETE ERROR *** $!";
PrintPersonsTable();
$conn->Close
# Last line of file
---------------------
example03
---------------------
#! /c/perl/bin/perl
# Program name: ex3.pl
# Perl program accessing Microsoft SQL Server via DBI and ODBC
# Make sure your database server is running before trying the program
print ("\t DBI with DSN \"MSS_pubs\" on the local MS SQL Server database\n");
print ("\t Executes: SELECT job_id, job_desc, min_lvl, max_lvl FROM jobs \n\n");
use DBI;
my $dbh = DBI->connect('dbi:odbc:MSS_pubs', 'sa', '', 'ODBC ') # dbh=Database Handle
|| die "\tError on DBI->connect. \n\tMake sure the server is running!!\n\t$DBI::ERRSTR" ;
$sql = "SELECT job_id, job_desc, min_lvl, max_lvl FROM jobs "; # SQL Statement to run
my $sth = $dbh->prepare($sql); # sth = Statement Handle
$sth->execute();
my $dat; # Create a local variable to hold returned row data
print ("job_id\tjob_desc\t\t\tmin_lvl\tmax_lvl\n"); # Print header for output
while ( $dat = $sth->fetchrow_hashref ) # Fetch each row
{ # Print each column value
print ("$dat->{job_id}\t");
printf("%-30s\t",$dat->{job_desc}); # Could save each column value into
print ("$dat->{min_lvl}\t"); # a program variable, e.g.,
print ("$dat->{max_lvl}\n"); # $v_jobid = $dat->{job_id}
}
$sth->finish;
$dbh->disconnect;
# Last line of file
---------------------
example04
---------------------
#! /c/perl/bin/perl
# Program name: ex4.pl
# DBI program using pass-through SQL to execute DDL and DML statements
use DBI;
print ("\t DBI with DSN \"MSS_pubs\" on the local MS SQL Server database\n");
print ("\t This will execute DDL and DML statements using pass-through SQL \n\n");
## dbh = Database Handle
my $dbh = DBI->connect('dbi:odbc:MSS_pubs', 'sa', '', 'ODBC')
|| die "\tError on DBI->connect. \n\tMake sure the server is running!!\n\t";
######## Subroutine PrintPersonsTable();
sub PrintPersonsTable{
$sql = "SELECT personid , pname , city FROM persons; ";
my $sth = $dbh->prepare($sql);
$sth->execute() || warn "*** SELECT ERROR *** $!";
print (" personid\t pname \t city\n");
print (" --------\t ---------------\t ---------\n");
my $dat; # Create a local variable to hold returned row data
while ( $dat = $sth->fetchrow_hashref ) # Fetch each row
{ # Print each column value
print ("\t$dat->{personid}\t ");
print ("$dat->{pname}\t ");
print ("$dat->{city}\n");
}
print ("\n");
} #### end Subroutine PrintPersonsTable
#################################### DROP TABLE persons
$sql = "DROP TABLE persons ";
my $sth = $dbh->prepare($sql); # sth = Statement Handle
$sth->execute() || warn "*** DROP TABLE ERROR *** $!";
#################################### CREATE TABLE persons
$sql = "CREATE TABLE persons (
personidINTEGER PRIMARY KEY ,
pnameVARCHAR(15) NOT NULL,
city VARCHAR(15)
); ";
my $sth = $dbh->prepare($sql);
$sth->execute() || warn "*** CREATE TABLE ERROR *** $!";
#################################### INSERT 2 rows
$sql = "INSERT INTO persons VALUES ( 1 , 'Carol Smith' , 'Boston');
INSERT INTO persons VALUES ( 2 , 'Sam Jones' , 'Detroit' ); ";
my $sth = $dbh->prepare($sql);
$sth->execute() || warn "*** INSERT ERROR *** $!";
PrintPersonsTable();
#################################### UPDATE 1 row
$sql = "UPDATE persons SET city = 'Seattle' WHERE personid = 2; ";
my $sth = $dbh->prepare($sql); # sth = Statement Handle
$sth->execute() || warn "*** UPDATE ERROR *** $!";
PrintPersonsTable();
#################################### DELETE 1 row
$sql = "DELETE FROM persons WHERE personid = 1; ";
my $sth = $dbh->prepare($sql); # sth = Statement Handle
$sth->execute() || warn "*** DELETE ERROR *** $!";
PrintPersonsTable();
$sth->finish;
$dbh->disconnect
# Last line of file
---------------------
example05
---------------------
#! /c/perl/bin/perl
# Program name: ex5.pl
# Perl program accessing Oracle via ADO and ODBC
# 1st create a DSN named "ORA_scott" as previously described.
# Make sure your database server is running before trying the program
print "hi from $0\n";
print ("\t ADO with DSN \"ORA_scott\" on the Oracle server named \"CAT\" \n");
print ("\t Execute: SELECT ename, empno, job, deptno FROM emp \n\n");
print("\t ** If connect fails and server is running, change ODBC Driver **\n");
print "\n";
use OLE;
$conn = CreateObject OLE "ADODB.Connection" || # Create ADO auto object
die "Error on ADO CreateObject: $!" ;
$conn->Open('ORA_scott' ); # Connect to DSN
if ( $conn->{State} != 1 ) { # 1 is adStateOpen , 0 is asStateClosed
die ("\t Connection Not Open. \n\t Make sure the server is started.\n\n");
}
$sql = "SELECT ename, empno, job, deptno FROM emp "; # SQL Statement to run
$rs = $conn->Execute($sql ); # Execute the query
print ("ename\t empno job\t\tdeptno\n");
while( !$rs->EOF() ) { # Fetch each row, one at a time
printf( "%-11s\t", $rs->Fields(ENAME)->Value );
print ( $rs->Fields(EMPNO)->Value, " " ); # Oracle ADO permits lower
printf( "%-9s\t", $rs->Fields(JOB)->Value ); # or uppercase column names
print ( $rs->Fields(deptno)->Value, "\t" );
print ("\n");
$rs->MoveNext;
}
$rs->Close;
$conn->Close;
# Last line of file
---------------------
example06
---------------------
#! /c/perl/bin/perl
# Program name: ex6.pl
use OLE;
############## Subroutine PrintPersonsTable();
sub PrintPersonsTable{
$sql = "SELECT personid , pname , city FROM persons ";
$rs = $conn->Execute($sql) || warn "*** SELECT ERROR *** $!";
print (" personid\t pname \t city\n");
print (" --------\t -------------\t ---------\n");
while ( ! $rs->EOF() ) # Fetch each row
{ # Print each column value
print ("\t", $rs->Fields(PERSONID)->Value , "\t ");
print ( $rs->Fields(PNAME)->Value , "\t "); # Oracle ADO permits lower
print ( $rs->Fields(city)->Value , "\n"); # or uppercase column names
$rs->MoveNext;
}
$rs->Close;
print ("\n");
} ############## end Subroutine PrintPersonsTable
print ("\tADO DSN-Less to scott/tiger on the Oracle server named \"CAT\" \n");
print ("\tThis program uses ADO to execute DDL and DML statements \n\n");
print("\t ** If connect fails and server is running, change ODBC Driver **\n");
print "\n";
$conn = CreateObject OLE "ADODB.Connection" || # Create ADO auto object
die "Error on ADO CreateObject: $!" ;
# Next line uses DSN-less ODBC connection to scott/tiger on the Oracle server "CAT"
$conn->Open("server=CAT;driver={Microsoft ODBC for Oracle};UID=scott; PWD=tiger;DSN=;");
## To go directly from OLE DB to MSS, remove line above and uncomment line below
## $conn->Open("Provider=MSDAORA.1;Password=tiger;User ID=scott;Data Source=CAT");
if ( $conn->{State} != 1 ) { # 1 is adStateOpen , 0 is asStateClosed
die ("\t Connection Not Open. \n\t Make sure the server is started.\n\n");
}
#################################### DROP TABLE persons
$sql = "DROP TABLE persons ";
$conn->Execute($sql) || warn "*** DROP TABLE ERROR *** $!";
#################################### CREATE TABLE persons
$sql = "CREATE TABLE persons (
personidINTEGER PRIMARY KEY ,
pnameVARCHAR(15) NOT NULL,
city VARCHAR(15)
) ";
$conn->Execute($sql) || warn "*** CREATE TABLE ERROR *** $!";
#################################### INSERT 2 rows
$sql = "INSERT INTO persons VALUES ( 1 , 'Carol Smith' , 'Boston') ";
$conn->Execute($sql) || warn "*** INSERT ERROR *** $!";
$sql = "INSERT INTO persons VALUES ( 2 , 'Sam Jones' , 'Detroit' ) ";
$conn->Execute($sql) || warn "*** INSERT ERROR *** $!";
PrintPersonsTable();
#################################### UPDATE 1 row
$sql = "UPDATE persons SET city = 'Seattle' WHERE personid = 2 ";
$conn->Execute($sql) || warn "*** UPDATE ERROR *** $!";
PrintPersonsTable();
#################################### DELETE 1 row
$sql = "DELETE FROM persons WHERE personid = 1 ";
$conn->Execute($sql) || warn "*** DELETE ERROR *** $!";
PrintPersonsTable();
$conn->Close
# Last line of file
---------------------
example07
---------------------
#! /c/perl/bin/perl
# Program name: ex7.pl
# Perl program accessing Oracle via DBI and ODBC
# Make sure the database server is running before trying the program
print ("\t DBI with DSN \"ORA_scott\" on the Oracle server named \"CAT\" \n");
print ("\t Execute: SELECT ename, empno, job, deptno FROM emp \n");
print ("\t ** If connect fails and server is running, change ODBC Driver **\n");
print "\n";
use DBI;
my $dbh = DBI->connect('dbi:odbc:ORA_scott', 'scott', 'tiger', 'ODBC ')
|| die "***\tError on DBI->connect.Make sure the server is running!!";
# $dbh = Database Handle
$sql = "SELECT ename, empno, job, deptno FROM emp "; # SQL Statement to run
my $sth = $dbh->prepare($sql ); # $sth = Statement Handle
$sth->execute( );
my $dat; # Create a local variable to hold returned row data
print ("ename\t empno job\t\tdeptno\n"); # Print header for output
while ( $dat = $sth->fetchrow_hashref ) # Fetch each row
{ # Print each column value
printf("%-11s", $dat->{ENAME} ); # In Oracle must use UPPERCASE
print ("$dat->{EMPNO} "); # for column names
printf("%-9s\t", $dat->{JOB} );
print ("$dat->{DEPTNO}\t");
print ("\n");
}
# Last line of file
---------------------
example08
---------------------
#! /c/perl/bin/perl
# Program name: ex8.pl
use DBI;
print ("\t DBI with DSN \"ORA_scott\" on Oracle server named \"CAT\" \n");
print ("\t This will execute DDL and DML statements using pass-through SQL \n\n");
## dbh = Database Handle
my $dbh = DBI->connect('dbi:odbc:ORA_scott', 'scott', 'tiger', 'ODBC')
|| die "***\tError on DBI->connect. Make sure the server is running!!";
######## Subroutine PrintPersonsTable();
sub PrintPersonsTable{
$sql = "SELECT personid , pname , city FROM persons ";
# No ; SQL terminator in Oracle
my $sth = $dbh->prepare($sql);
$sth->execute() || warn "*** SELECT ERROR *** \n\t $!";
print (" personid\t pname \t city\n");
print (" --------\t -------------\t ---------\n");
my $dat; # Create a local variable to hold returned row data
while ( $dat = $sth->fetchrow_hashref ) # Fetch each row
{ # Print each column value
print ("\t$dat->{PERSONID}\t ");
print ("$dat->{PNAME}\t "); # Remember: UPPERCASE column names in Oracle
print ("$dat->{CITY}\n");
}
print ("\n");
} #### end Subroutine PrintPersonsTable
#################################### DROP TABLE persons
$sql = "DROP TABLE persons ";
my $sth = $dbh->prepare($sql); # sth = Statement Handle
$sth->execute() || warn "*** DROP TABLE ERROR *** \n\t $!";
#################################### CREATE TABLE persons
$sql = "CREATE TABLE persons (
personidINTEGER PRIMARY KEY ,
pnameVARCHAR(15) NOT NULL,
city VARCHAR(15)
)" ;
my $sth = $dbh->prepare($sql);
$sth->execute() || warn "*** CREATE TABLE ERROR *** \n\t $!";
#################################### INSERT 2 rows
$sql = "INSERT INTO persons VALUES ( 1 , 'Carol Smith' , 'Boston') ";
my $sth = $dbh->prepare($sql);
$sth->execute() || warn "*** INSERT ERROR *** \n\t $!";
$sql = "INSERT INTO persons VALUES ( 2 , 'Sam Jones' , 'Detroit' ) ";
my $sth = $dbh->prepare($sql);
$sth->execute() || warn "*** INSERT ERROR *** \n\t $!";
PrintPersonsTable();
#################################### UPDATE 1 row
$sql = "UPDATE persons SET city = 'Seattle' WHERE personid = 2 ";
my $sth = $dbh->prepare($sql); # sth = Statement Handle
$sth->execute() || warn "*** UPDATE ERROR *** \n\t $!";
PrintPersonsTable();
#################################### DELETE 1 row
$sql = "DELETE FROM persons WHERE personid = 1 ";
my $sth = $dbh->prepare($sql); # sth = Statement Handle
$sth->execute() || warn "*** DELETE ERROR *** \n\t $!";
PrintPersonsTable();
$sth->finish;
$dbh->disconnect
# Last line of file
#######################
chap16 : interface with the system
#######################
---------------------
example01
---------------------
#! /bin/sh
perldoc File::Copy.pm
---------------------
example02
---------------------
#! /usr/bin/perl
use File::Spec;
$pathname=File::Spec->catfile("C:","Perl","lib","CGI");
print "$pathname\n";
---------------------
example03
---------------------
#! /c/perl/bin/perl
use Win32::File;
$File='C:\Drivers';
Win32::File::GetAttributes($File, $attr) or die;
print "The attribute value returned is: $attr.\n";
if ( $attr ){
if ($attr & READONLY){
print "File is readonly.\n";
}
if ($attr & ARCHIVE){
print "File is archive.\n";
}
if ($attr & HIDDEN){
print "File is hidden .\n";
}
if ($attr & SYSTEM){
print "File is a system file.\n";
}
if ($attr & COMPRESSED){
print "File is compressed .\n";
}
if ($attr & DIRECTORY){
print "File is a directory.\n";
}
if ($attrib & NORMAL){
print "File is normal.\n";
}
if ($attrib & OFFLINE){
print "File is normal.\n";
}
if ($attrib & TEMPORARY){
print "File is temporary.\n";
}
} else{
print Win32::FormatMessage(Win32::GetLastError),"\n";
}
---------------------
example04
---------------------
#! /usr/bin/perl
use File::Find;
find(\&wanted, '/httpd', '/ellie/testing' );
sub wanted{
-d $_ && print "$File::Find::name\n";
}
---------------------
example05
---------------------
#! /c/perl/bin/perl
# Windows
use File::Find;
use Win32::File;
# Works on both FAT and NTFS file systems.
&File::Find::find(\&wanted,"C:\\httpd", "C:\\ellie\\testing");
sub wanted{
(Win32::File::GetAttributes($_,$attr)) &&
($attr & DIRECTORY) &&
print "$File::Find::name\n";
}
---------------------
example06
---------------------
#! /bin/sh
# Unix
perl -e 'mkdir("joker", 0755);'
# Windows
# perl -e "mkdir(joker);"
echo
ls -ld joker
---------------------
example07
---------------------
#! /bin/sh
PATH=".:$PATH"
makeit
makeit joker
makeit cabinet
ls -d cabinet
---------------------
example08
---------------------
#! /bin/sh
# Unix
perl -e 'rmdir("joke") || die qq(joke: $!\n)'
perl -e 'rmdir("joker") || die qq(joker: $!\n)'
perl -e 'rmdir("joker") || die qq(joker: $!\n)'
# Windows
# perl -e "rmdir(joker) || die qq(joker: $!\n);"
---------------------
example09
---------------------
#! /bin/sh
# UNIX
pwd
perl -e 'chdir "/home/unknown/ELLIE/WORK"; print `pwd`'
pwd
perl -e 'chdir "fooler" || die "Cannot cd to fooler: $!\n"'
# Windows
# cd
# perl -e "chdir 'fooler' || die qq(Cannot cd to fooler: $!\n);"
---------------------
example10
---------------------
#! /usr/bin/perl
opendir(MYDIR, "joker");
---------------------
example11
---------------------
#! /usr/bin/perl
opendir(DIR, "..") || die "Can't open: $!\n";
# open parent directory
@parentfiles=readdir(DIR);
# gets a list of the directory contents
closedir(DIR); # closes the filehandle
foreach $file ( @parentfiles )
# prints each element of the array
{ print "$file\n";}
---------------------
example12
---------------------
#! /usr/bin/perl
opendir(DIR, "."); # opens the current directory
while( $myfile=readdir(DIR) ){
$spot=telldir(DIR);
if ( "$myfile" eq ".login" ) {
print "$myfile\n";
last;
}
}
rewinddir(DIR);
seekdir(DIR, $spot);
$myfile=readdir(DIR);
print "$myfile\n";
---------------------
example13
---------------------
#! /bin/sh
perl -e '$count=chmod 0755, "foo.p", "boo.p" ;print "$count files changed.\n"'
echo
ls -l foo.p boo.p
---------------------
example14
---------------------
#! /usr/bin/perl
$uid=9496;
$gid=40;
$number=chown($uid, $gid, 'foo.p', 'boo.p');
print "The number of files changed is $number.\n";
---------------------
example15
---------------------
#! /bin/sh
perl -e 'printf("The umask is %o.\n", umask);'
perl -e 'umask 027; printf("The new mask is %o.\n", umask);'
---------------------
example16
---------------------
#! /bin/sh
perl -e 'link("dodo", "newdodo");'
ls -li dodo newdodo
---------------------
example17
---------------------
#! /usr/bin/perl
unlink('a','b','c') || die "remove: $!\n";
$count=unlink <*.c>;
print "The number of files removed was $count\n";
---------------------
example18
---------------------
#! /bin/sh
perl -e 'unlink("new") if -e "new";'
perl -e 'symlink("/home/jody/test/old", "new");'
ls -ld new
---------------------
example19
---------------------
#! /bin/sh
perl -e 'print readlink("new"), "\n"';
---------------------
example20
---------------------
#! /usr/bin/perl
rename ("tmp", "datafile");
---------------------
example21
---------------------
#! /bin/sh
PATH=".:$PATH"
ls -l brandnewfile
echo
update.pl
echo
ls -l brandnewfile
---------------------
example22
---------------------
#! /usr/bin/perl
# Using stat with a file handle
open(MYFILE, "perl1") || die "Can't open: $!\n";
@statistics=stat(MYFILE);
print "@statistics\n";
close MYFILE;
# Using stat with a file name
@stats=stat("perl1");
printf("The inode number is %d and the uid is %d.\n", $stats[1], $stats[4]);
print "The file has read and write permissions.\n", if -r _ && -w _;
---------------------
example23
---------------------
#! /usr/bin/perl
# Windows
# Since UNIX and Windows treat files differently,
# some of the fields here are
# blank or values returned are not meaningful
@stats = stat("C:\\ellie\\testing");
# Unix
@stats = stat("./testing");
print "Device: $stats[0]\n";
print "Inode #: $stats[1]\n";
print "File mode: $stats[2]\n";
print "# Hard links: $stats[3]\n";
print "Owner ID: $stats[4]\n";
print "Group ID: $stats[5]\n";
print "Device ID: $stats[6]\n";
print "Total size: $stats[7]\n";
print "Last access time: $stats[8]\n";
print "Last modify time: $stats[9]\n";
print "Last change inode time: $stats[10]\n";
print "Block size: $stats[11]\n";
print "Number of blocks: $stats[11]\n";
---------------------
example24
---------------------
#! /usr/bin/perl
open(PASSWD, "./etc/passwd") || die "Can't open: $!\n";
$bytes=read (PASSWD, $buffer, 50);
print "The number of bytes read is $bytes.\n";
print "The buffer contains: \n$buffer";
print "\n";
---------------------
example25
---------------------
#! /usr/bin/perl
open(PASSWD, "./etc/passwd") || die "Can't open: $!\n";
while ( chomp($line = <PASSWD>) ){
print "---$line---\n" if $line =~ /root/;
}
seek(PASSWD, 0, 0) || die "$!\n"; # start back at the beginning
# of the file at first byte
while(<PASSWD>){print if /ellie/;}
close(PASSWD);
---------------------
example26
---------------------
#! /usr/bin/perl
open(PASSWD, "./etc/passwd") || die "Can't open: $!\n";
while ( chomp($line = <PASSWD>) ){
if ( $line =~ /sync/){
$current = tell;
print "---$line---\n";
}
}
printf "The position returned by tell is %d.\n", $current;
seek(PASSWD, $current, 0);
while(<PASSWD>){
print;
}
---------------------
example27
---------------------
#! /usr/bin/perl
$bytes=pack("c5", 80,101,114, 108, 012);
print "$bytes\n";
---------------------
example28
---------------------
#! /usr/bin/perl
$string=pack("A15A3", "hey","you"); # ASCII string, space padded
print "$string\n";
---------------------
example29
---------------------
#! /usr/bin/perl
# Program to uuencode a file and then uudecode it.
open(PW, "./etc/passwd") || die "Can't open: $!\n";
open(CODEDPW, ">codedpw") || die "Can't open: $!\n";
while(<PW>){
$uuline=pack("u*", $_);
print CODEDPW $uuline;
}
close PW;
close CODEDPW;
open(UUPW, "codedpw") || die "Can't open: $!\n";
while(<UUPW>){
print;
}
close UUPW;
print "\n\n";
open(DECODED, "codedpw") || die;
while(<DECODED>){
@decodeline = unpack("u*", $_);
print "@decodeline";
}
---------------------
example30
---------------------
#! /usr/bin/perl
$ints=pack("i3", 5,-10,15);
open(BINARY, "+>binary" ) || die;
print BINARY "$ints";
seek(BINARY, 0,0) || die;
while(<BINARY>){
($n1,$n2,$n3)=unpack("i3", $_);
print "$n1 $n2 $n3\n";
}
---------------------
example31
---------------------
john:aYD17IsSjBMyGg:9495:41:John Doe:/home/dolphin/john:/bin/ksh
---------------------
example32
---------------------
#! /usr/bin/perl
# UNIX
foreach $key (keys(%ENV)){
print "$key\n";}
print "Your login name is $ENV{'LOGNAME'}\n";
$pwd=$ENV{'PWD'};
print "The present working directory is $pwd", "\n";
---------------------
example33
---------------------
#! /usr/bin/perl
# Windows
while(($key,$value)=each(%ENV)){
print "$key: $value\n" if $key =~ /^P/;
}
---------------------
example34
---------------------
#! /usr/bin/perl
# UNIX ps command
$flags = '-aux';
# if running System V, use ps -ef
$flags = '-ef';
open(PROC, "ps $flags |" ) || die "$!\n";
print STDOUT <PROC>;
---------------------
example35
---------------------
#! /usr/bin/perl
$loginname=getlogin || (getpwuid($<))[0]|| die "Not a user here!!";
print "Your loginname is $loginname.\n";
---------------------
example36
---------------------
#! /usr/bin/perl
print "The pid of this process is $$\n";
print "The parent pid of this process is ", getppid,"\n";
---------------------
example37
---------------------
#! /usr/bin/perl
printf "The PID of the Perl program running this script is %d\n", $$;
printf "The PPID, parent's pid (Shell), is %d\n", getppid;
printf "The process group's pid is %d\n", getpgrp(0);
---------------------
example38
---------------------
#! /usr/bin/perl
$niceval = getpriority(0,0);
print "The priority, nice value, for this process is $niceval\n";
---------------------
example39
---------------------
#! /usr/bin/perl
$niceval = getpriority(0,0);
print "The nice value for this process is $niceval.\n";
setpriority(0,0, ( $niceval + 5 ));
printf "The nice value for this process is now %d\n", getpriority(0,0);
---------------------
example40
---------------------
# Windows batch file
net help
net user
---------------------
example41
---------------------
#! /c/perl/bin/perl
use Win32::NetAdmin qw(GetUsers UserGetAttributes) ;
GetUsers("", FILTER_NORMAL_ACCOUNT,\%hash)or die;
foreach $key(sort keys %hash){
print "$key\n";
}
---------------------
example42
---------------------
#! /usr/bin/perl
while( @info=getpwent) {
print "$info[0]\n" if $info[1]=~/\*+/;
}
---------------------
example43
---------------------
#! /usr/bin/perl
foreach $name ( "root", "bin", "ellie" ){
if (($login, $passwd, $uid)=getpwnam($name)){
print "$login--$uid\n";
}
}
---------------------
example44
---------------------
#! /usr/bin/perl
foreach $num ( 1 .. 10 ){
if (($login, $passwd, $uid)=getpwuid($num)){
print "$login--$uid\n";}
}
---------------------
example45
---------------------
#! /usr/bin/perl
printf "User time in this program %2.3f seconds\n", (times)[0];
printf "System time in this program %2.3f seconds\n", (times)[1];
---------------------
example46
---------------------
#! /usr/bin/perl
($sec, $min, $hour, $monthday, $month, $year, $weekday, $yearday,
$isdaylight) = gmtime;
print "The weekday is $weekday and the month is $month.\n";
print "The time in California since midnight is ", `date "+%H:%M"`;
print "The Greenwich Mean Time is $hour:$min since midnight\n";
print "Daylight saving is in effect.\n" if $isdaylight;
---------------------
example47
---------------------
#! /bin/sh
perl -e "print scalar (localtime), qq/\n/;"
---------------------
example48
---------------------
#! /usr/bin/perl
($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst)= localtime(time);
%weekday=(
# day starts at zero
"0"=> "Sunday",
"1"=>"Monday",
"2"=>"Tuesday",
"3"=>"Wednesday",
"4"=> "Thursday",
"5"=>"Friday",
"6"=>"Saturday",
);
if ( $hour > 12 ){
print "The hour is ", $hour - 12 ,":$min o'clock.\n";
} else {
print "The hour is $hour:$min o'clock.\n";
}
print qq/The day is $weekday{"$wday"}.\n/;
printf "The year is %d.\n", 1900+$year;
print "The isdst is $isdst.\n";
---------------------
example49
---------------------
#! /usr/bin/perl
$return_val=fork;
if ( $return_val == 0 ){
print "This is the child process; return value is $return_val.\n";
}
elsif ( defined $return_val ){
print "This is the parent process; return value is $return_val.\n";
}
else{
die "fork error: $!\n";
}
---------------------
example50
---------------------
#! /usr/bin/perl
exec 'echo hi there you!';
print "hello";
exec 'ls *.c';
print "hello.";
---------------------
example51
---------------------
#! /usr/bin/perl
$return_val=fork;
if ( $return_val == 0 ){ # In child
print "This is the child process; return value is $return_val.\n";
exec "/bin/date" || die "exec failed: $!\n";
} elsif ( defined $return_val ) { # In parent
print "This is the parent process; return value is $return_val.\n";
$pid = wait;
print "Back in parent process.\n";
print "The deceased child's pid is $pid.\n";
} else {
die "fork error: $!\n";
}
---------------------
example52
---------------------
#! /bin/sh
PATH=".:$PATH"
args.p
echo $?
---------------------
example53
---------------------
#! /usr/bin/perl
use warnings;
$return_value = system("start C:\\'Program Files'\\Netscape\\Communicator\\Program\\netscape.exe");
print "Program continues; Netscape is running.\n";
print "The return_value from system is $return_value.\n";
---------------------
example54
---------------------
#! /c/perl/bin/perl
use warnings;
use Win32;
$|=1;
$Application="C:/mksnt/date.exe";
$CommandLine="date +%D";
$status=Win32::Spawn($Application, $CommandLine, $ProcessID);
if ($status != 0){
print "pid is $ProcessID.\n";
} else {
print "Didn't spawn $Application.\n";
print Win32::FormatMessage(Win32::GetLastError), "\n";
}
---------------------
example55
---------------------
#! /c/perl/bin/perl
use Win32::Process;
use Win32;
sub ErrorReport{
print Win32::FormatMessage( Win32::GetLastError() );
}
Win32::Process::Create($ProcessObj,
"C:\\windows\\notepad.exe", "notepad myfile.txt", 0,
NORMAL_PRIORITY_CLASS, ".") || die ErrorReport();
print "Notepad has started\n";
print "The exit code is: ",
$ProcessObj->GetExitCode($ExitCode),"\n";
---------------------
example56
---------------------
#! /bin/sh
PATH="`pwd`:$PATH"
cd /usr/include; /usr/bin/h2ph *.h sys/*.h asm/*.h bits/*.h
phtest.pl
---------------------
example57
---------------------
#! /usr/bin/perl
print "The hour is ",`date`;
@d=`date`;
print $d[0];
@d=split(/ /,`date`);
print "$d[0]\n";
$machine=`uname -n`;
print "$machine";
---------------------
example58
---------------------
#! /usr/bin/perl
use Shell qw(pwd ls date); # Shell commands listed
print "Today is ", date();
print "The time is ", date("+%T");
print "The present working directory is ", pwd;
$list=ls( "-aF");
print $list;
---------------------
example59
---------------------
#! /usr/bin/perl
system("cal 1 2001");
print "Happy New Year!\n";
---------------------
example60
---------------------
#! /usr/bin/perl
print "Hello there\n";
print "The name of this machine is ";
system ("uname -n"); # buffer is not flushed
print "The time is ", `date`;
---------------------
example61
---------------------
#! /usr/bin/perl
$|=1; #set special variable to flush the output buffer
print "Hello there\n";
print "The name of this machine is ";
system ("uname -n");
print "The time is ", `date`;
---------------------
example62
---------------------
#! /usr/bin/perl
$price=100;
# no quotes around terminator EOF are same as double quotes
print <<EOF; # Variables are expanded
The price of $price is right.
EOF
# The variable is not expanded if terminator is enclosed in single quotes
print <<'FINIS';
The price of $price is right.
FINIS
print << x 4; # prints the line 4 times
Christmas is coming!
# Blank line is necessary here as terminating string
print <<`END`; # If terminator is in back quotes, will execute UNIX commands
echo hi there
echo -n "The time is "
date
END
---------------------
example63
---------------------
#! /usr/bin/perl
@myfiles=<*.[1-5]>;
print "@myfiles\n";
foreach $file ( <p??l[1-5]*>){
print "$file\n" if -T $file;
}
---------------------
example64
---------------------
#! /bin/sh
perl -e 'while(glob("p???[1-5]")) {print "$_\n";}'
echo
# The lines from the script are run as a shell here document
perl << 'HERE'
while ( glob("p???[1-5]")){
print "$_\n";
}
HERE
---------------------
example65
---------------------
#! /usr/bin/perl
die "Can't cd to junk: $!\n" unless chdir "/usr/bin/junk";
---------------------
example66
---------------------
#! /usr/bin/perl
die unless chdir '/plop' ;
---------------------
example67
---------------------
#! /usr/bin/perl
chdir '/plop' || die "Stopped";
---------------------
example68
---------------------
#! /usr/bin/perl
# The eval function will evaluate each line you type
# and return the result. It's as though you are
# running a little independent Perl script.
# Program name: plsh
print "> "; # print the prompt
while(<STDIN>){
$result=eval ; # eval evaluates the expression $_
warn $@ if $@; # If an error occurs, it will be assigned to $@
print "$result\n" if $result;
print "> ";# print the prompt
}
---------------------
example69
---------------------
#! /usr/bin/perl
print "Give me a number.";
chop($a=<STDIN>);
print "Give me a divisor.";
chop($b=<STDIN>);
eval{ die unless $answer = $a/$b ; };
warn $@ if $@;
printf "Division of %.2f by %.2f is %.2f.\n",$a,$b,
$answer if $answer ;
print "I'm here now. Good-day!\n";
---------------------
example70
---------------------
#! /usr/bin/perl
eval<<'EOF';
chdir "joker" || die "Can't cd: $!\n";
EOF
print "The error message from die: $@";
print "Program $0 still in progress.\n";
---------------------
example71
---------------------
#! /usr/bin/perl
sub handler{
local($sig) = @_; # first argument is signal name
print "Caught SIG$sig--shutting down\n";
exit(1);
}
$SIG{'INT'} = 'handler'; # Catch ^C
$SIG{'HUP'}='IGNORE';
print "Here I am!\n";
sleep(10);
$SIG{'INT'}='DEFAULT';
---------------------
example72
---------------------
#! /bin/bash
sleep 100 &
jobs -l
echo
procid=`jobs -l | perl -ne '/\+\s+(\d+)/; print $1;'`
perl -e "kill 9, $procid"
---------------------
example73
---------------------
#! /usr/bin/perl
alarm(1);
print "In a Forever Loop!\n";
for (;;){ printf "Counting...%d\n", $x++;}
---------------------
example74
---------------------
#! /usr/bin/perl
$|=1; # flush output buffer
alarm(5);
print "Taking a snooze...\n";
sleep 100;
print "\07 Wake up now.!\n";
#######################
chap17 : writing with pictures
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
$name="Tommy";
$age=25;
$salary=50000.00;
$now="03/14/97";
# Format Template
format STDOUT=
---------------------REPORT-------------------------4
Name: @<<<<<< Age:@## Salary:@#####.## Date:@<<<<<<<<<<
$name, $age, $salary, $now
.
# End Template
write;
print "Thanks for coming. Bye.\n";
---------------------
example02
---------------------
#! /usr/bin/perl
$name="Tommy";
$age=25;
$salary=50000.00;
$now="03/14/94";
open(REPORT, ">report" ) || die "report: $!\n";
# REPORT filehandle is opened for writing
format REPORT= # REPORT is also used for the format filehandle
-----------------------
| EMPLOYEE INFORMATION |
-----------------------
Name: @<<<<<<
$name
-----------------------
Age:@###
$age
-----------------------
Salary:@#####.##
$salary
-----------------------
Date:@>>>>>>>>>>
$now
-----------------------
.
write REPORT; # The write function sends output to the file
# associated with the REPORT filehandle
---------------------
example03
---------------------
#! /usr/bin/perl
format STDOUT=
-----------------------
| EMPLOYEE INFORMATION |
-----------------------
Name: @<<<<<<<<<<<<
$name
-----------------------
Age:@##
$age
-----------------------
Salary:@#####.##
$salary
-----------------------
Date:@>>>>>>>>>>
$start
.
open(DB, "datafile" ) || die "datafile: $!\n";
while(<DB>){
($name, $age, $salary, $start)=split(":");
write ;
}
---------------------
example04
---------------------
#! /usr/bin/perl
open(DB, "datafile" ) || die "datafile: $!\n";
format STDOUT_TOP=
-@||-
$%
-----------------------
| EMPLOYEE INFORMATION |
-----------------------
.
format STDOUT=
Name: @<<<<<<<<<<<<<
$name
-----------------------
Age:@##
$age
-----------------------
Salary:@#####.##
$salary
-----------------------
Date:@>>>>>>>
$start
-----------------------
.
while(<DB>){
($name, $age, $salary, $start)=split(":");
write ;
}
---------------------
example05
---------------------
#! /usr/bin/perl
open(DB, "datafile" ) || die "datafile: $!\n";
open(OUT, ">outfile" )|| die "outfile: $!\n";
format OUT_TOP= # New Filehandle
-@||-
$%
-----------------------
| EMPLOYEE INFORMATION |
-----------------------
.
format OUT=
Name: @<<<<<<<<<<<<<
$name
-----------------------
Age:@##
$age
-----------------------
Salary:@#####.##
$salary
-----------------------
Date:@>>>>>>>
$start
-----------------------
.
while(<DB>){
($name, $age, $salary, $start)=split(":");
write OUT;
}
---------------------
example06
---------------------
#! /usr/bin/perl
# write an awklike report
open(MYDB, "> mydb") || die "Can't open mydb: $!\n";
$oldfilehandle= select(MYDB); # MYDB is selected as the filehandle for write
format MYDB_TOP =
DATEBOOK INFO
Name Phone Birthday Salary
_______________________________________________________
.
format MYDB =
@<<<@<<<<<<<<<<<<<<<<@<<<<<<<<<<<<@|||||||||@#######.##
$., $name, $phone, $bd, $sal
.
format SUMMARY =
_______________________________________________________
The average salary for all employees is $@######.##.
$total/$count
The number of lines left on the page is @###.
$-
The default page length is @###.
$=
.
open(DB,"datebook") || die "Can't open datebook: $!";
while(<DB>){
( $name, $phone, $address, $bd, $sal )=split(/:/);
write ;
$count++;
$total+=$sal;
}
close DB;
$~=SUMMARY; # New report format for MYDB filehandle
write;
select ($oldfilehandle); # STDOUT is now selected for further writes or prints
print "Report Submitted on " , `date`;
---------------------
example07
---------------------
#! /usr/bin/perl
$song="To market,\nto market,\nto buy a fat pig.\n";
format STDOUT=
@*
$song
@*
"\nHome again,\nHome again,\nJiggity, Jig!\n"
.
write;
---------------------
example08
---------------------
#! /usr/bin/perl
$name="Hamlet";
print "What is your favorite line from Hamlet? ";
$quote = <STDIN>;
print "\n";
format STDOUT=
Play: @<<<<<<<<<< Quotation: ^<<<<<<<<<<<<<<<<<<
$name, $quote
^<<<<<<<<<<<<<<<<<<
$quote
^<<<<<<<<<<<<<<<<<<
$quote
~ ^<<<<<<<<<<<<<<<<<<
$quote
.
write;
---------------------
example09
---------------------
#! /usr/bin/perl
$name="Hamlet";
print "What is your favorite line from Hamlet? ";
$quote = <STDIN>;
print "\n";
format STDOUT=
Play: @<<<<<<<<<< Quotation: ^<<<<<<<<<<<<<<<<<<
$name, $quote
~~ ^<<<<<<<<<<<<<<<<<<
$quote
.
write;
---------------------
example10
---------------------
#! /usr/bin/perl
dbmopen(%myhash, "mydbfile", 0666);
---------------------
example11
---------------------
#! /usr/bin/perl
# Program name: makestates
# This program creates the database using the dbm functions
use AnyDBM_File;
dbmopen(%states, "statedb", 0666) || die "Couldn't open database: $!";
TRY: {
print "Enter the abbreviation for your state. ";
chomp($abbrev=<STDIN>);
$abbrev = uc $abbrev; # Make sure abbreviation is uppercase
print "Enter the name of the state. ";
chomp($state=<STDIN>);
lc $state;
$states{$abbrev}="\u$state";
# Make first letter of state uppercase
print "Another entry? ";
$answer = <STDIN>;
redo TRY if $answer =~ /Y|y/;
}
dbmclose(%states);
---------------------
example12
---------------------
#! /usr/bin/perl
# Program name: getstates
# This program fetches the data from the database
# and generates a report
use AnyDBM_File;
format STDOUT_TOP=
Abbreviation State
==============================
.
format STDOUT=
@<<<<<<<<<<<<<<@<<<<<<<<<<<<<<<
$key, $value
.
format SUMMARY=
==============================
Number of states:@###
$total
.
dbmopen(%states, "statedb", 0666);
@sortedkeys=sort keys %states;
foreach $key ( @sortedkeys ){
$value=$states{$key};
$total++;
write;
}
dbmclose(%states);
$~=SUMMARY;
write;
---------------------
example13
---------------------
#! /usr/bin/perl
use AnyDBM_File;
dbmopen(%states, "statedb", 0666) || die "Couldn't open database: $!";
TRY: {
print "Enter the abbreviation for the state to remove. ";
chomp($abbrev=<STDIN>);
$abbrev = uc $abbrev; # Make sure abbreviation is uppercase
delete $states{"$abbrev"};
print "$abbrev removed.\n";
print "Another entry? ";
$answer = <STDIN>;
redo TRY if $answer =~ /Y|y/;
}
dbmclose(%states);
#######################
chap18 : networking programming
#######################
---------------------
example01
---------------------
#! /usr/bin/perl
$bytes=pack("c4", 80,101,114,108);
print "$bytes\n";
---------------------
example02
---------------------
#! /usr/bin/perl
while (($name, $aliases, $proto ) = getprotoent){
printf "name=%-5s,aliases=%-6sproto=%-8s\n", $name, $aliases, $proto;
}
---------------------
example03
---------------------
#! /usr/bin/perl
($name, $aliases, $proto ) = getprotobyname('tcp');
print "name=$name\taliases=$aliases\t$protocol number=$proto\n",
---------------------
example04
---------------------
#! /usr/bin/perl
($name, $aliases, $proto) = getprotobynumber(0);
print "name=$name\taliases=$aliases\tprotocol number=$proto\n",
---------------------
example05
---------------------
#! /usr/bin/perl
setservent(1);
($name, $aliases, $port, $proto) = getservent;
print "Name=$name\nAliases=$aliases\nPort=$port\nProtocol=$proto\n";
# program continues here
# retrieves the next entry in /etc/services
($name, $aliases, $port, $proto) = getservent;
print "Name=$name\nAliases=$aliases\nPort=$port\nProtocol=$proto\n";
endservent;
---------------------
example06
---------------------
#! /usr/bin/perl
($name,$aliases,$port,$protocol)=getservbyname('telnet', 'tcp');
---------------------
example07
---------------------
#! /usr/bin/perl
print "What is the port number? ";
chop($PORT=<>);
print "What is the protocol? ";
chop($PROTOCOL=<>);
($name, $aliases, $port, $proto ) = getservbyport( $PORT, $PROTOCOL);
print "The getservbyport function returns:
name=$name
aliases=$aliases
port number=$port
prototype=$protocol\n";
---------------------
example08
---------------------
#! /usr/bin/perl
while ( ($name, $aliases, $addrtype, $length, @addrs) = gethostent ){
($a, $b, $c, $d) = unpack ( 'C4', $addrs[0]);
print "The name of the host is $name.\n";
print "Local host address (unpacked) $a.$b.$c.$d\n";
}
---------------------
example09
---------------------
#! /usr/bin/perl
$address=pack("C4", 127,0,0,1);
($name, $aliases, $addrtype, $length, @addrs) = gethostbyaddr($address,2);
($a, $b, $c, $d) = unpack ('C4', $addrs[0]);
print "Hostname is $name and the Internet Address is $a.$b.$c.$d.\n";
---------------------
example10
---------------------
#! /usr/bin/perl
($name, $aliases, $addtrtype, $length, @addrs)=gethostbyname("dolphin");
print "Host address for $name is: ", join('.',unpack("c4",$addrs[0])), "\n";
---------------------
example11
---------------------
#! /bin/sh
ls -lF greetings
---------------------
example12
---------------------
#! /usr/bin/perl
$AF_UNIX=1;
$SOCK_STREAM=1;
$PROTOCOL=0;
socket(COMM_SOCKET, $AF_UNIX, $SOCK_STREAM, $PROTOCOL);
---------------------
example13
---------------------
#! /usr/bin/perl
bind(COMM_SOCKET, "./tserv");
bind(COMM_SOCKET, $socket_address);
---------------------
example14
---------------------
#! /usr/bin/perl
listen(SERVERSOCKET, 5);
---------------------
example15
---------------------
#! /usr/bin/perl
accept (NEWSOCK, RENDEZ_SOCK);
---------------------
example16
---------------------
#! /usr/bin/perl
connect(CLIENTSOCKET, "/home/unknown/sock" );
connect(CLIENTSOCKET, $packed_address);
---------------------
example17
---------------------
#! /usr/bin/perl
shutdown(COMM_SOCK, 2);
---------------------
example18
---------------------
#! /usr/bin/perl
# The server and the client are on the same machine.
print "Server Started.\n";
$AF_UNIX=1; # The domain is AF_UNIX
$SOCK_STREAM=1; # The type is SOCK_STREAM
$PROTOCOL=0; # Protocol 0 is accepted as the "correct protocol"
# by most systems.
socket(SERVERSOCKET, $AF_UNIX, $SOCK_STREAM, $PROTOCOL) ||
die " Socket $!\n";
print "socket OK\n";
$name="./greetings"; # The name of the socket is associated within
# the file system
unlink "./greetings" || warn "$name: $!\n";
bind(SERVERSOCKET, $name) || die "Bind $!\n";
print "bind OK\n";
listen(SERVERSOCKET, 5)|| die "Listen $!\n";
print "listen OK\n";
while(1){
accept(NEWSOCKET, SERVERSOCKET )|| die "Accept $!\n";
# accept client connection
$pid=fork || die "Fork: $!\n";
if ($pid == 0 ){
print NEWSOCKET "Greetings from your server!!\n";
close(NEWSOCKET);
exit(0);
} else{
close (NEWSOCKET);
}
}
---------------------
example19
---------------------
#! /usr/bin/perl
print "Hi I'm the client\n";
$AF_UNIX=1;
$SOCK_STREAM=1;
$PROTOCOL=0;
socket(CLIENTSOCKET, $AF_UNIX, $SOCK_STREAM, $PROTOCOL) ||
die "Couldn't get socket: $!";
$name="./greetings";
do{
# client connects with server
$result = connect(CLIENTSOCKET, "$name" );
if ($result != 1 ){
sleep(1);
}
}while($result != 1 ); # Loop until a connection is made
read(CLIENTSOCKET, $buf, 500);
print STDOUT "$buf\n";
close (CLIENTSOCKET);
exit(0);
---------------------
example20
---------------------
#! /usr/bin/perl -T
# Program name: timeserver -- a Time Server program,
# opens a Rendezvous Socket on port 9876
# and waits for a client to connect.
# When each client connects, this server determines the machine
# time on its host and writes the value on the communication
# socket to the client.
#
# Usage: timeserver [port number]
#
use strict;
use warnings;
my($port, $AF_INET, $SOCK_STREAM, $sockaddr, # Variable declarations
$name, $aliases, $proto, $this, $now);
($port)=@ARGV;
$port=9876 unless $port;
$AF_INET=2;
$SOCK_STREAM = 1;
$sockaddr = 'S n a4 x8';
($name,$aliases,$proto)=getprotobyname('tcp');
if($port !~ /^\d+$/){
($name, $aliases, $port)=getservbyport($port,'tcp');
}
print "Port = $port\n";
$this = pack($sockaddr, $AF_INET, $port, "\0\0\0\0");
select(COMM_SOCK); $| = 1; select(STDOUT);
# Create R_SOCKET, the rendezvous socket descriptor
socket(R_SOCKET, $AF_INET, $SOCK_STREAM, $proto ) ||
die "socket: $!\n";
# Bind R_SOCKET to my address, $this
bind(R_SOCKET, $this) || die "bind: $!\n";
listen(R_SOCKET, 5) || die "connect: $!\n";
# Infinite loop - wait until client connects, then serve the client
while(1){
accept(COMM_SOCK, R_SOCKET) || die "$!\n";
$now = time;
print COMM_SOCK $now;
}
---------------------
example21
---------------------
#! /usr/bin/perl
# Program name: timeclient -- a client for the Time Server program,
# creates a socket and connects it to the server on port 9876.
# The client then expects the server to write the server's
# host time onto the socket. The client simply does
# a read on its socket, SOCK, to get the server's time.
#
# Usage: timeclient [server_host_name]
#
print "Hi, I'm in Perl program \'client\' \n";
($them) = @ARGV;
$them = 'localhost' unless $them;
$port = 9876 ; # timeserver is at this port number
$AF_INET = 2;
$SOCK_STREAM = 1;
$sockaddr = 'S n a4 x8';
($name, $aliases, $proto) = getprotobyname('tcp');
($name,$aliases, $port, $proto)=getservbyname($port, 'tcp')
unless $port =~ /^\d+$/;
($name,$aliases, $type, $len, $thataddr)=gethostbyname($them);
$that = pack($sockaddr, $AF_INET, $port, $thataddr);
# Make the socket filehandle.
if ( socket(SOCK, $AF_INET, $SOCK_STREAM, $proto ) ){
print "socket ok\n";
} else { die $!; }
# Call up the server.
if(connect(SOCK, $that)){
print "connect ok.\n";
} else { die $!;}
# Set socket to be command buffered.
select(SOCK); $| = 1; select (STDOUT);
# Now we're connected to the server, let's read her host time
$hertime = <SOCK>;
close(SOCK);
print "Server machine time is: $hertime\n";
@now = localtime($hertime);
print "\t$now[2]:$now[1] ", $now[4]+1,"/$now[3]/$now[5]\n";
---------------------
example22
---------------------
#! /usr/bin/perl -Tw
# Program name: timeserver -- a Time Server program, opens a Rendezvous
# Socket on port 29688 and waits for a client to connect.
# When each client connects, this server determines the machine
# time on its host and writes the value on the communication
# socket to the client.
#
# Usage: timeserver
#
require 5.6.0;
use strict;
use Socket;
use FileHandle;
my($this, $now);
my $port = shift || 29688;
$this = pack('Sna4x8', AF_INET, $port, "\0\0\0\0");
print "Port = $port\n";
my $prototype = getprotobyname('tcp');
socket(SOCKET, PF_INET, SOCK_STREAM, $prototype) ||
die "socket: $!\n";
print "Socket o.k.\n";
bind(SOCKET, $this) || die "bind: $!\n";
print "Bind o.k.\n";
listen(SOCKET, SOMAXCONN) || die "connect: $!\n";
print "Listen o.k.\n";
COMM_SOCKET->autoflush;
SOCKET->autoflush;
# Infinite loop - wait until client connects,
# then serve the client
while(1){
print "In loop.\n";
accept(COMM_SOCKET, SOCKET) || die "$!\n";
print "Accept o.k.\n";
$now = time;
print COMM_SOCKET $now;
}
---------------------
example23
---------------------
#! /usr/bin/perl -Tw
# Program name: timeclient -- a client for the Time Server program,
# creates a socket and connects it to the server on
# port 29688.
# The client then expects the server to write server's
# host time onto the socket, so the client simply does
# a read on its socket, SOCK, to get the server's time
#
#
# Usage: timeclient [server_host_name]
#
require 5.6.0;
use Socket;
use FileHandle;
use strict;
my($remote, $port, @thataddr, $that,$them, $proto,@now, $hertime);
print "Hi, I'm in perl program \'client\' \n";
$remote = shift || 'localhost' ;
$port = 29688 ; # timeserver is at this port number
@thataddr=gethostbyname($remote);
$that = pack('Sna4x8', AF_INET, $port, $thataddr[4]);
$proto = getprotobyname('tcp');
# Make the socket filehandle.
if ( socket(SOCK, PF_INET, SOCK_STREAM, $proto ) ){
print "socket ok\n";
} else { die $!; }
# Call up the server.
if (connect(SOCK, $that)) {
print "connect ok.\n";
} else { die $!;}
# Set socket to be command buffered.
SOCK->autoflush;
# Now we're connected to the server, let's read her host time
$hertime = <SOCK>;
close(SOCK);
print "Server machine time is: $hertime\n";
@now = localtime($hertime);
print "\tTime-$now[2]:$now[1] ",
"Date-",$now[4]+1,"/$now[3]/$now[5]\n";
#######################
chap19 : CGI and web
#######################
---------------------
example01
---------------------
GET /pub HTTP/1.0
Connection: Keep-Alive
User-Agent: Mozilla/4.0Gold
Host: severname.com
Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg,*/*
---------------------
example02
---------------------
HTTP/1.1 200 OK
Server: Apache/1.2b8
Date: Mon, 22 Jan 2001 13:43:22 GMT
Last-modified: Mon, 01 Dec 2000 12:15:33
Content-length: 288
Accept-Ranges: bytes
Connection: close
Content-type: text/html
<HTML><HEAD><TITLE>Hello World!</TITLE>
---continue with body---
</HTML>
Connection closed by foreign host.
---------------------
example03
---------------------
susan - - [06/Jul/1997:14:32:23 -0700] "GET /cgi-bin/tryit.cgi HTTP/1.0" 500 633
susan - - [16/Jun/1997:11:27:32 -0700] "GET /cgi-bin/hello.cgi HTTP/1.0" 200 1325
susan - - [07/Jul/1997:09:03:20 -0700] "GET /htdocs/index.html HTTP/1.0" 404 170
---------------------
example04
---------------------
http://www.cis.ohio-state.edu/htbin/rfc2068.html
http://127.0.0.1/Sample.html
ftp://oak.oakland.edu/pub/
file:/opt/apache_1.2b8/htdocs/index.html
http://susan/cgi-bin/form.cgi?string=hello+there
---------------------
example05
---------------------
<HTML>
<HEAD>
<TITLE>Hyper Test</Title>
</HEAD>
<BODY>
<H1>Hello To You and Yours!</H1>
<H2 ALIGN="center">Welcome
</H2>
<P>Life is good. Today is <I>Friday.</I></P>
</BODY>
</HTML>
---------------------
example06
---------------------
#! /usr/bin/perl
# Program name: perlscript
print "Content-type: text/html\n\n"; # The HTTP header
print "<HTML><HEAD><TITLE> CGI/Perl First Try</TITLE></HEAD>\n";
print "<BODY BGCOLOR=Black TEXT=White>\n";
print "<H1><CENTER> Howdy, World! </CENTER></H1>\n";
print "<H2><CENTER> It's ";
print "<!--comments -->"; # This is how HTML comments are included
print `date`; # Execute the UNIX date command
print "and all's well.\n";
print "</H2></BODY></HTML>\n";
---------------------
example07
---------------------
#! /bin/sh
PATH=".:$PATH"
perl -c perlscript
---------------------
example08
---------------------
[Mon Jul 20 10:44:04 1998] access to /opt/apache_1.2b8/cgi-bin/submit-form failed for susan, reason: Premature end of script headers
[Mon Sep 14 11:11:32 1998] httpd: caught SIGTERM, shutting down
[Fri Sep 25 16:13:11 1998] Server configured -- resuming normal operations
Bare word found where operator expected at welcome.pl line 21, near "/font></TABLE" (Missing operator before TABLE?)
syntax error at welcome.pl line 21, near "<TH><"
syntax error at welcome.pl line 24, near "else"
[Fri Sep 25 16:16:18 1998] access to /opt/apache_1.2b8/cgi-bin/visit_count.pl failed for susan, reason: Premature end of script headers
---------------------
example09
---------------------
susan - - [08/Oct./1999:10:45:36 -0700]
"GET /cog-bin/visit_count.pl HTTP/1.0" 500 388
susan - - [08/Oct./1999:10:45:59 -0700]
"GET /cgi-bin/visit_count.pl HTTP/1.0" 200 426
---------------------
example10
---------------------
<HTML>
<HEAD>
<TITLE>TESTING ENV VARIABLES</TITLE>
</HEAD>
<BODY>
<P>
<H1> Major Test </H1>
<P> If you would like to see the environment variables<BR>
being passed on by the server, click .
<A HREF="http://localhost/cgi-bin/env.cgi">here</A>
<P>Text continues here...
</BODY>
</HTML>
---------------------
example11
---------------------
#! /usr/bin/perl
# Program name: env.cgi
print "Content type: text/plain\n\n";
print "CGI/1.1 test script report:\n\n";
# Print out all the environment variables
while(($key, $value)=each(%ENV) ){
print "$key = $value\n";
}
---------------------
example12
---------------------
<HTML><HEAD>
<TITLE>First CGI Form</TITLE></HEAD>
<HR>
<FORM ACTION="/cgi-bin/bookstuff/form1.cgi">
<P><B> Type your name here:
<INPUT TYPE="text" NAME="namestring" SIZE=50>
<P><BR> Talk about yourself here: <BR>
<TEXTAREA NAME="comments" ROWS=5 COLS=50>I was born...
</TEXTAREA>
</B>
<P> Choose your food:
<INPUT TYPE="radio" NAME="choice" VALUE="burger">Hamburger
<INPUT TYPE="radio" NAME="choice" VALUE="fish">Fish
<INPUT TYPE="radio" NAME="choice" VALUE="steak">Steak
<INPUT TYPE="radio" NAME="choice" VALUE="yogurt">Yogurt
<P> <B>Choose a work place:</B> <BR>
<INPUT TYPE="checkbox" NAME="place" VALUE="LA">Los Angeles
<BR>
<INPUT TYPE="checkbox" NAME="place" VALUE="SJ">San Jose
<BR>
<INPUT TYPE="checkbox" NAME="place" VALUE="SF" Checked>San
Francisco
<P>
<B>Choose a vacation spot:</B>
<SELECT NAME="location"> <OPTION SELECTED VALUE="hawaii"> Hawaii
<OPTION VALUE="bali">Bali
<OPTION VALUE="maine">Maine
<OPTION VALUE="paris">Paris
</SELECT> <P>
<INPUT TYPE="SUBMIT" VALUE="Submit">
<INPUT TYPE="RESET" VALUE="Clear">
</FORM> </HTML>
---------------------
example13
---------------------
<HTML><HEAD><TITLE>First CGI Form</TITLE></HEAD>
<HR>
<FORM ACTION="/cgi-bin/form1.cgi" METHOD=GET>
<! When user presses "submit", cgi script is called to process
input >
Please enter your name: <BR>
<INPUT TYPE="text" SIZE=50 NAME="Name">
<P>
Please enter your phone number: <BR>
<INPUT TYPE="text" SIZE=30 NAME="Phone">
<P>
<INPUT TYPE=SUBMIT VALUE="Send">
<INPUT TYPE=RESET VALUE="Clear">
</FORM>
</HTML>
---------------------
example14
---------------------
#! /usr/bin/perl
# The CGI script that will process the form information sent from the server
print "Content-type: text/html\n\n";
print "First CGI form :\n\n";
# Print out only the QUERY_STRING environment variable
while(($key, $value)=each(%ENV)){
print "<H3>$key = <I>$valu e</I></H3><BR>" if $key eq "QUERY_STRING";
}
---------------------
example15
---------------------
# What you see in the Location Box of the browser:
http://servername/cgi-bin/form1.cgi?Name=Christian+Dobbins&Phone=543-123-4567
# What the server sends to the browser in the ENV hash value,
QUERY_STRING:
QUERY_STRING=Name=Christian+Dobbins&Phone=543-123-4567
---------------------
example16
---------------------
#! /usr/bin/perl
# A URL-encoded string
# Name=Christian+Dobbins&Phone=510-456-1234&Sign=Virgo
$ENV{QUERY_STRING} ="Name=Christian+Dobbins&Phone=510-456-1234&Sign=Virgo";
@key_value = split(/&/, $ENV{QUERY_STRING} );
print "@key_value\n";
foreach $pair ( @key_value){
$pair =~ tr/+/ /;
($key, $value) = split(/=/, $pair);
print "\t$key: $value\n";
}
print "\n";
# Another URL-Encoded String
# string=Joe+Smith%3A%2450%2c000%3A02%2F03%2F77
$input="string=Joe+Smith%3A%2450%2c000%3A02%2F03%2F77";
$input=~s/%(..)/pack("c", hex($1))/ge;
print $input,"\n";
---------------------
example17
---------------------
<HTML><HEAD><TITLE>CGI Form</TITLE></HEAD><BODY>
<HR>
<FORM ACTION="http://127.0.0.1/cgi-bin/getmethod.cgi" METHOD=GET>
<! When user presses "submit", cgi script is called to process
input >
Please enter your name: <BR>
<INPUT TYPE="text" SIZE=50 NAME=Name>
<P>
Plese enter your salary ($####.##): <BR>
<INPUT TYPE="text" SIZE=30 NAME=Salary>
<P>
Plese enter your birth date (mm/dd/yy): <BR>
<INPUT TYPE="text" SIZE=30 NAME=Birthdate>
<P>
<INPUT TYPE=SUBMIT>
<INPUT TYPE=RESET>
</FORM>
</BODY></HTML>
---------------------
example18
---------------------
#! /usr/bin/perl
# The CGI script that processes the form shown in Example 8.12.
print "Content-type: text/html\n\n";
print "<H2><U>Decoding the query string</U></H2>";
# Getting the input
$inputstring=$ENV{QUERY_STRING};
print "<B>Before decoding:</B><BR>";
print "<H3>$inputstring</H3>";
# Translate + signs to space
$inputstring =~ tr/+/ /;
# Decoding the hexidecimal characters
$inputstring =~ s/%(..)/pack("C", hex($1))/ge;
# After decoding %xy
print "-" x 80, "<BR>";
print "<B>After decoding <I>%xy</I>:</B>";
print "<H3\b >$inputstring</H3>";
# Extracting the + and & and creating key/value pairs
@key_value=split(/&/, $inputstring);
foreach $pair ( @key_value){
($key, $value) = split(/=/, $pair);
$input{$key} = $value; # Creating a hash
}
# After decoding
print "-" x 80, "<BR>";
print "<B>After decoding + and &:</B>";
while(($key, $value)=each(%input)){
print "<H3\b >$key: <I\b >$valu e</I></H3>";
}
print "<B>Now what do we want to do with this information?"
---------------------
example19
---------------------
<HTML>
<HEAD>
<TITLE>CGI Form</TITLE>
<HR>
<FORM ACTION="http://127.0.0.1/cgi-bin/postmethod.cgi"
METHOD=POST>
<!When user presses "submit", cgi script is called to process
input >
Please enter your name: <BR>
<INPUT TYPE="text" SIZE=50 NAME=Name>
<P>
Please enter your salary ($####.##): <BR>
<INPUT TYPE="text" SIZE=30 NAME=Salary>
<P>
Please enter your birth date (mm/dd/yy): <BR>
<INPUT TYPE="text" SIZE=30 NAME=Birthdate>
<P>
<INPUT TYPE=SUBMIT>
<INPUT TYPE=RESET>
</FORM>
</HTML>
---------------------
example20
---------------------
#! /usr/bin/perl
print "Content-type: text/html\n\n";
print "<H2><U>Decoding the query string</U></H2>";
#Getting the input
if ( $ENV{REQUEST_METHOD} eq 'GET' ){
$inputstring=$ENV{QUERY_STRING};
} else {
read(STDIN, $inputstring, $ENV{'CONTENT_LENGTH'});
}
print "<B>Before decoding:</B><BR>";
print "<H3>$inputstring</H3>";
# Replace + signs with spaces
$inputstring =~ tr/+/ /;
#Decoding the hexadecimal characters
$inputstring =~ s/%(..)/pack("C", hex($1))/ge;
# After decoding %xy
print "-" x 80, "<BR>";
print "<B>After decoding <I>%xy</I>:</B>";
print "<H3>$inputstring</H3>";
# Extracting the & and = to create key/value pairs
@key_value=split(/&/, $inputstring);
foreach $pair ( @key_value){
($key, $value) = split(/=/, $pair);
$input{$key} = $value; # Creating a hash to save the data
}
# After decoding
print "-" x 80, "<BR>";
print "<B>After decoding + and &:</B>";
while(($key, $value) = each(%input) ){
# Printing the contents of the hash
print "<H3>$key: <I>$value</I></H3>";
}
print "<B>Now what do we want to do with this information?";
---------------------
example21
---------------------
<!- From the HTML form where the email information is collected ->
<FORM METHOD="post" ACTION="http://127.0.0.1/cgi-bin/submit-form">
<INPUT TYPE="hidden" NAME="xemailx"
VALUE="elizabeth@ellieq.com">
<INPUT TYPE="hidden" NAME="xsubject"
VALUE="Course Registration">
<INPUT TYPE="hidden" NAME="xgoodbyex"
VALUE="Thank you for registering.">
<P>
<A NAME="REGISTRATION">
<TABLE CELLSPACING=0 CELLPADDING=0>
<TR>
<TD ALIGN=right><B>First Name:</B></TD>
<TD ALIGN=left><INPUT TYPE=text NAME="first_name*" VALUE="">
</TD>
</TR>
<TR> <TD ALIGN=right><B>Last Name:</B></TD>
<TD ALIGN=left><INPUT TYPE=text NAME="last_name*"
VALUE=""></TD>
</TR>
<TR>
<TD ALIGN=right><B>Company:</B></TD>
<TD ALIGN=left><INPUT TYPE=text SIZE=30 NAME="company*"
VALUE=""></TD>
</TR>
<TR>
<TD ALIGN=right><B>Address1:</B></TD>
<TD ALIGN=left><INPUT TYPE=text SIZE=30
NAME="address1*" VALUE=""></TD>
</TR>
<TR>
<TD ALIGN=right><B>Address2:</B></TD>
<TD ALIGN=left><INPUT TYPE=text SIZE=30 NAME="address2"
VALUE=""></TD>
</TR>
<TR>
<TD ALIGN=right><B>City/Town:</B></TD>
<TD ALIGN=left><INPUT TYPE=text SIZE=30 NAME="city*"
VALUE=""></TD>
</TR>
<TR>
<TD ALIGN=right><B>State/Province:</B></TD>
<TD ALIGN=left><INPUT TYPE=text SIZE=10 NAME="state"
VALUE=""><FONT SIZE=-1> Abbreviation or code</TD></TR>
<TR>
<TD ALIGN=right><B>Postal/Zip Code:</B></TD>
<TD ALIGN=left><INPUT TYPE=text SIZE=10 NAME="zip"
VALUE=""></TD>
</TR>
---------------------
example22
---------------------
#! /usr/bin/perl
# From a CGI script
# An HTML Form was first created and processed to get the name of the
# user who will receive the email, the person it's from, and the
# subject
$mailprogram="/usr/lib/sendmail"; # Your mail program goes here
$sendto="$input{xemailx}"; # Mailing address goes here
$from="$input{xmailx}";
$subject="$input{xsubject}";
open(MAIL, "|$mailprogram -t -oi") || die "Can't open mail program: $!\n";
# -t option takes the headers from the lines following the mail
# command -oi options prevent a period at the beginning of a
# line from meaning end of
# input
print MAIL "To: $sendto\n";
print MAIL "From: $from\n";
print MAIL "Subject: $subject\n\n";
print MAIL <<EOF; # Start a "here document"
Registration Information for $input{$first_name}
$input{$last_name}:
Date of Registration: $today
-----------------------------------------------
First Name: $input{$first_name}
Last Name: $input{$last_name}
Street Address: $input{$address}
City: $input{$city}
State/Province: $input{$state}
<Rest of Message goes here>
EOF
close MAIL; # Close the filter
---------------------
example23
---------------------
#! /usr/bin/perl
# From a CGI script
use Mail::Mailer;
my $mailobj = new Mail::Mailer("smtp", Server=>"www.ellie.com");
$mailobj->open( {
To => $emailaddress,
From => $sender,
Subject => "Testing email..."
} );
# The mail message is created in a here document
print $mailobj <<EOM;
This is a test to see if the Mail::Mailer module is working for us.
Thank you for participating in this little experiment!
EOM
close $mailobj;
---------------------
example24
---------------------
<!- Portion of the HTML form showing the email hyperlink ->
</MENU>
<P>
Students unable to send appropriate payment information will be
dropped from the class unceremoniously.
<P>
<I>
If you would like to speak to one of our staff, please dial
+1(530)899-1824.
<BR>
If you have a question , <A HREF="mailto:elizabeth@ellieq.com">click
here.</A>
<BR>
<I><FONT SIZE=2>Provide as much detail in your request as possible,
so that we may reply quickly and as informatively as possible.</I>
</TD>
</TR>
<BR>
<BR>If you would like to speak with someone, please dial +1(530) 899-1824.
<HR>
---------------------
example24.html
---------------------
<!- Portion of the HTML form showing the email hyperlink ->
</MENU>
<P>
Students unable to send appropriate payment information will be
dropped from the class unceremoniously.
<P>
<I>
If you would like to speak to one of our staff, please dial
+1(530)899-1824.
<BR>
If you have a question , <A HREF="mailto:elizabeth@ellieq.com">click
here.</A>
<BR>
<I><FONT SIZE=2>Provide as much detail in your request as possible,
so that we may reply quickly and as informatively as possible.</I>
</TD>
</TR>
<BR>
<BR>If you would like to speak with someone, please dial +1(530) 899-1824.
<HR>
---------------------
example25
---------------------
<HTML>
<HEAD>
<Title>Testing Env Variables</title>
</HEAD>
<BODY>
<P>
<H1> Major Test </h1>
<P> If You Would Like To See The Environment Variables<Br>
Being Passed On By The Server, Click .
<A Href="Http://susan/cgi-bin/pathinfo.cgi/color=red/size=small">here</a>
<P>
Text Continues Here...
</BODY>
</HTML>
---------------------
example26
---------------------
#! /usr/bin/perl
# The CGI Script
print "Content type: text/html\n\n";
print "CGI/1.0 test script report:\n\n";
print "The argument count is ", $#ARGV + 1, ".\n";
print "The arguments are @ARGV.\n";
# Print out all the environment variables
while(($key, $value)=each(%ENV)){
print "$key = $value\n";
}
print "=" x 30, "\n";
print "$ENV{PATH_INFO}\n";
$line=$ENV{PATH_INFO};
$line=~tr/\// /;
@info = split(" ", $line);
print "$info[0]\n";
eval "\$$info[0]\n";
print $color;
---------------------
example27
---------------------
<!--#exec cgi="/cgi-bin/joker/motto"-->
---------------------
example28
---------------------
<HTML>
<HEAD>
<Meta Http-equiv="Pragma" Content="No-cache">
<Title>cgi And Ssi Test</title>
</head>
<Body Bgcolor="#ffffff">
<H1>cgi And Ssi Test</h1>
<Hr>
<H2>standard Cgi Test</h2>
You Are Visitor # <Img Src="/cgi-bin/visitor.exe"><P>
<Hr>
<H2>Server Side Include s</h2>
If Server Side Includes Are Enabled, You Will See Data Values
Below:
<P>
The Date Is: <!--#echo Var="Date_local"-- ><Br>
The Current Version Of The Server Is:
<!--#echo Var="Server_software"-- ><Br>
The CGI Gateway Version Is:
<!--#echo Var="Gateway_interface"-- ><Br>
The Server Name Is: <!--#echo Var="Server_name"-- ><Br>
This File Is Called: <!--#echo Var="Document_name"-- ><Br>
This File's Url Is: <!--#echo Var= "Document_uri"-- ><Br>
The Query String Is:
<!--# Echo Var="Query_string_unescaped"-- ><Br>
This File Was Last Modified:
<!--#echo Var="Last_modified"-- ><Br>
The Size Of The Unprocessed File Is
!--#fsize Virtual="/test.shtml"-- ><Br>
You Are Using <!--#echo Var="Http_user_agent"-- ><Br>
You Came From <!--#echo Var="Http_referer"-- ><P>
<Br>
<Input Type="Submit" Value="Go!">
</FORM>
<HR>
</BODY>
</HTML>
---------------------
example29
---------------------
#! /usr/bin/perl
use CGI;
$obj=new CGI; # Create the CGI object
print $obj->header, # Use functions to create the HTML page
$obj->start_html("Object oriented syntax"),
$obj->h1("This is a test..."),
$obj->h2("This is a test..."),
$obj->h3("This is a test..."),
$obj->end_html;
---------------------
example30
---------------------
#! /usr/bin/perl
use CGI qw(:standard); # Function oriented style uses a set of
# standard functions
print header,
start_html("Function oriented syntax"),
h1("This is a test..."),
h2("This is a test..."),
h3("This is a test..."),
end_html;
---------------------
example31
---------------------
#! /usr/bin/perl
# Named Arguments
use CGI qw(:standard);
print popup_menu(-name=>' place' ,
-values=>[' Hawaii' ,' Europe' ,' Mexico' , ' Japan' ],
-default=>' Hawaii' ,
);
@countries = (' Hawaii', ' Europe', ' Mexico', ' Japan');
print popup_menu(-name=>' place' ,
-values=> \@countries,
-default=>' Hawaii' ,
);
---------------------
example32
---------------------
#! /usr/bin/perl
# The CGI script
# Shortcut calling styles with HTML methods
use CGI qw(:standard); # Function oriented style print header
print
start_html("Testing arguments"), "\n",
b(), "\n",
p(), "\n",
p("purple", "green", "blue"), "\n",
p("This is a string"), "\n",
p({-align=>center}, "red", "green", "yellow"), "\n",
p({-align=>left}, ["red","green","yellow"]), "\n",
end_html, "\n";
---------------------
example33
---------------------
#! /usr/bin/perl
# Program name: talkaboutyou.pl
use CGI qw(:standard);
print header;
print start_html(-title=>' Using the Function-Oriented Syntax' ,
-BGCOLOR=>' yellow' );
print img({-src=>' /Images/GreenBalloon.gif' , -align=>LEFT}),
h1("Let's Hear From You!"),
h2("I'm interested."),
start_form,
"What's your name? ", textfield(' name' ),
p,
"What's your occupation? ", textfield(' job' ),
p,
"Select a vacation spot. ",
popup_menu(-name=>' place' ,
-values=>[' Hawaii' ,' Europe' ,' Mexico' , ' Japan' ],
),
p,
submit,
end_form;
print hr;
if ( param() ){ # If the form has been filled out,
# there are parameters
print "Your name is ", em(param(' name' )),
p,
"Your occupation is ", em(param(' job' )),
p,
"Your vacation spot is", em(param(' place' )),
hr;
}
---------------------
example34
---------------------
#! /bin/sh
perl talkaboutyou.pl
perl talkaboutyou.pl < /dev/null
# perl talkaboutyou.pl ' '
---------------------
example35
---------------------
#! /usr/bin/perl
use CGI;
# Create the object
$query = new CGI;
# parses the input (from both POST and GET methods and stores it into
# a perl5 object called $query.
print $query->header;
print $query->start_html("Forms and Textfields");
print $query->h2("Example: The textfield method");
&print_form($query);
&do_work($query) if ($query->param);
print $query->end_html;
sub print_form{
my($query) = @_;
print $query->startform;
print "What is your name? ";
print $query->textfield('name'); # A simple text field
print $query->br();
print "What is your occupation? ";
print $query->textfield(
-name=>'occupation', # Giving values to the textfield
-default=>'Retired',
-size=>60,
-maxlength=>120,
);
print $query->br();
print $query->submit('action', 'Enter ');
print $query->reset();
print $query->endform;
print $query->hr();
}
sub do_work{
my ($query) = @_;
my (@values, $key);
print $query->("<H2>Here are the settings</H2>");
foreach $key ($query->param ){
print "$key: \n";
@values=$query->param($key);
print join(", ",@values), "<BR>";
}
}
---------------------
example36
---------------------
#! /usr/bin/perl
use CGI;
$query = new CGI;
print $query->header;
print $query->start_html("The Object Oriented CGI and Forms");
print "<H2>Example using Forms with Checkboxe s</H2>\n";
&print_formstuff($query);
&do_work($query) if ($query->param);
print $query->end_html;
sub print_formstuff{
my($query) = @_;
print $query->startform;
print "What is your name? ";
print $query->textfield(' name' ); # A simple text field
print "<BR>";
print "Are you married? <BR>";
print $query->checkbox(-name=>'Married',
-label=>'If not, click me' ); # Simple checkbox
print "<BR><BR>";
print "What age group(s) do you hang out with? <BR>";
print $query->checkbox_group(-name=>' age_group' ,
-values=>[ ' 12-18' , ' 19-38' , ' 39-58' ,' 59-100' ],
-default=>[ ' 19-38' ],
-linebreak=>' true' ,
);
print $query->submit(' action' , ' Select' );
print $query->reset(' Clear' );
print $query->endform;
print "<HR>\n";
}
sub do_work{
my ($query) = @_;
my (@values, $key);
print "<H2>Here are the settings</H2>";
foreach $key ($query->param){
print "$key: \n";
@values=$query->param($key);
print join(", ",@values ), "<BR>";
}
}
---------------------
example37
---------------------
#! /usr/bin/perl
use CGI;
$query = new CGI;
print $query->header;
print $query->start_html("The Object-Oriented CGI and Forms");
print "<H2>Example using Forms with Radio Buttons</H2>\n";
&print_formstuff($query);
&do_work($query) if ($query->param);
print $query->end_html;
sub print_formstuff{
my($query) = @_;
print $query->startform;
print "What is your name? ";
print $query->textfield(' name' ); # A simple text field
print "<BR>";
print "Select your favorite color? <BR>";
print $query->radio_group(-name=>' color' ,
-values=>[ ' red' , ' green' , ' blue' ,' yellow' ],
-default=>' green' ,
-linebreak=>' true' ,
);
print $query->submit(' action' , ' submit' );
print $query->reset(' Clear' );
print $query->endform;
print "<HR>\n";
}
sub do_work{
my ($query) = @_;
my (@values, $key);
print "<H2>Here are the settings</H2>";
foreach $key ($query->param){
print "$key: \n";
@values=$query->param($key);
print join(", ",@values), "<BR>";
}
}
---------------------
example38
---------------------
#! /usr/bin/perl
# The -labels Parameter -- Segment from CGI script
use CGI;
$query = new CGI;
print $query->startform;
print "What is your name? ";
print $query->textfield(' name' ); # A simple text field
print "<BR>";
print "We're at a cross section. Pick your light.<BR>";
print $query->radio_group(-name=>' color' ,
-values=>[ ' red' , ' green' , ' yellow' ],
-linebreak=>' true' ,
-labels=>{red=>' stop' ,
green=>' go' ,
yellow=>' warn' ,
},
-default=>' green' ,
);
print $query->submit(' action' , ' submit' );
print $query->reset(' Clear' );
print $query->endform;
---------------------
example39
---------------------
#! /usr/bin/perl
use CGI;
$query = new CGI;
print $query->header;
print $query->start_html("The Object-Oriented CGI and Forms");
print "<H2>Example using Forms with Popup Menu s</H2>\n";
&print_formstuff($query);
&do_work($query) if ($query->param);
print $query->end_html;
sub print_formstuff{
my($query) = @_;
print $query->startform;
print "What is your name? ";
print $query->textfield(' name' ); # A simple text field
print "<BR>";
print "Select your favorite color? <BR>";
print $query->popup_menu( -name=>' color' ,
-values=>[ ' red' , ' green' , ' blue' ,' yellow' ],
-default=>' green' ,
# -labels=>'\%labels' ,
);
print $query->submit(' action' , ' submit' );
print $query->reset(' Clear' );
print $query->endform;
print "<HR>\n";
}
sub do_work{
my ($query) = @_;
my (@values, $key);
print "<H2>Here are the settings</H2>";
foreach $key ($query->param){
print "$key: \n";
@values=$query->param($key);
print join(", ",@values), "<BR>";
}
}
---------------------
example40
---------------------
#! /usr/bin/perl
use CGI;
BEGIN{ use CGI::Carp qw(fatalsToBrowser carpout);
open(LOG,">>errors.log") ||die "Couldn' t open log file\n";
carpout(LOG);
}
$query = new CGI;
# <Program continues here>
---------------------
example41
---------------------
#! /usr/bin/perl
use CGI;
BEGIN{ use CGI::Carp qw(fatalsToBrowser carpout);
open(LOG,">>errors.log") || die "Couldn't open log file\n";
carpout(LOG);
sub handle_errors {
my $msg = shift;
print "<h1>Software Error Alert!!</h1>";
print "<h2>Your program sent this error:<br><I>
$msg</h2></I>";
}
}
set_message(\&handle_errors );
die("Testing error messages from CGI script.\n");
---------------------
example42
---------------------
(Contents of the errors.log file created by carpout)
carpout.pl syntax OK
[Thu Feb 8 18:27:48 2001] C:\httpd\CGI-BIN\carpout.pl: Testing err rom CGI script.
[Thu Feb 8 18:30:01 2001] C:\httpd\CGI-BIN\carpout.pl: <h1>Testing es from CGI script.
[Thu Feb 8 18:55:53 2001] C:\httpd\CGI-BIN\carpout.pl: Undefined s in::set_message called at C:\httpd\CGI-BIN\carpout.pl line 11.
[Thu Feb 8 18:55:53 2001] C:\httpd\CGI-BIN\carpout.pl: BEGIN faile n aborted at C:\httpd\CGI-BIN\carpout.pl line 12.
[Thu Feb 8 18:56:49 2001] carpout.pl: Undefined subroutine &main:: alled at carpout.pl line 11.
[Thu Feb 8 18:56:49 2001] carpout.pl: BEGIN failed--compilation ab out.pl line 12.
---------------------
example43
---------------------
#! /usr/bin/perl
# A simple CGI script to demonstrate setting and retrieving a cookie.
# Run the program twice: the first time to set the cookie on the
# client side, and second to retrieve the cookie from the browser
# and get its value from the environment variable,
# $ENV{HTTP_COOKIE, coming from the server.
my $name = "Ellie";
my $expiration_date = "Friday, 17-Feb-01 00:00:00: GMT";
my $path = "/cgi-bin";
print "Set-Cookie: shopper=$name, expires=$expiration_date, path=$path\n";
print "Content-type: text/html\n\n";
print <<EOF;
<html><head><Title>Cookie Test</Title></Head>
<body>
<h1>Chocolate chip cookie!!</h1>
<h2>Got milk?</h2>
<hr>
<p>
What's in the HTTP_COOKIE environment variable?
<br>
$ENV{HTTP_COOKIE}
<p>
<hr>
</body></html>
EOF
---------------------
example44
---------------------
#! /usr/bin/perl
use CGI;
$query = new CGI;
if ( $query->param && $query->param(' color' ) ne ""){
$color=$query->param(' color' ) ; # Did the user pick a color
} elsif ( $query->cookie(' preference' )){ # Is there a cookie already?
$color=$query->cookie(' preference' ); # then go get it!
} else {
$color=' yellow' ;
} # set a default background color if
# a cookie doesn' t exist, and the user didn' t
# select a preference
$cookie=$query->cookie(-name=>' preference' ,
# Set the cookie values
-value=>"$color",
-expires=>' +30d' ,
);
print $query->header(-cookie=>$cookie);
# Setting the HTTP cookie header
print $query->start_html(-title=>"Using Cookies",
-bgcolor=>"$color",
);
print $query->h2("Example: Making Cookies");
&print_prompt($query);
&do_work($query) if ($query->param);
print $query->end_html;
print "\n";
sub print_prompt{
my($query) = @_;
print $query->startform;
print "What is your name? ";
print $query->textfield(-name=>' name' ,
-size=>30); # A simple text field
print "<BR>";
print "What is your occupation? ";
print $query->textfield(-name=>' occupation' , # Giving values
-default=>' Retired' , # to the textfield
-size=>30,
-maxlength=>120);
print "<BR>";
print "What is your favorite color? ";
print $query->textfield(-name=>' color' ); # Giving values
print $query->br();
print $query->submit(' action' , ' Enter ' );
print $query->reset();
print $query->endform;
print $query->hr();
}
sub do_work{
my ($query) = @_;
my (@values, $key);
print "<H2>Here are the settings</H2>";
foreach $key ($query->param){
print "$key: \n";
@values=$query->param($key);
print join(", ",@values), "<BR>";
}
}
---------------------
example45
---------------------
Set-Cookie: preference=yellow; path=/form1CGI.cgi; expires=Sun, 17-Sep-2000 09:46:26 GMT
---------------------
example46
---------------------
#! /usr/bin/perl
use CGI qw(:standard);
print header;
print start_html(-title=>' Using header Methods' ),
h1("Let' s find out about this session!"),
p,
h4 "Your server is called ", server_name(),
p,
"Your server port number is ", server_port(),
p,
"This script name is: ", script_name(),
p,
"Your browser is ", user_agent( ), "and it' s out of date!",
p,
"The query string looks like this: ", query_string( ),
p,
"Where am I? Your URL is: \n", url( ),
p,
"Cookies set: ", raw_cookie();
print end_html;
