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;
No comments:
Post a Comment