diff options
author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1997-03-26 07:04:34 +1200 |
---|---|---|
committer | Chip Salzenberg <chip@atlantic.net> | 1997-03-26 07:04:34 +1200 |
commit | 54310121b442974721115f93666234a200f5c7e4 (patch) | |
tree | 99b5953030ddf062d77206ac0cf8ac967e7cbd93 /eg | |
parent | d03407ef6d8e534a414e9ce92c6c5c8dab664a40 (diff) | |
download | perl-54310121b442974721115f93666234a200f5c7e4.tar.gz |
[inseperable changes from patch from perl-5.003_95 to perl-5.003_86]
[editor's note: this commit was prepared manually so may differ in
minor ways to other inseperable changes commits]
CORE LANGUAGE CHANGES
Title: "Support $ENV{PERL5OPT}"
From: Chip Salzenberg
Files: perl.c pod/perldiag.pod pod/perldelta.pod pod/perlrun.pod
Title: "Implement void context, in which C<wantarray> is undef"
From: Chip Salzenberg
Files: cop.h doop.c dump.c global.sym gv.c op.c op.h perl.c
pod/perlcall.pod pod/perldelta.pod pod/perlfunc.pod
pod/perlguts.pod pod/perlsub.pod pp.c pp_ctl.c pp_hot.c
pp_sys.c proto.h
Title: "Don't look up &AUTOLOAD in @ISA when calling plain function"
From: Chip Salzenberg
Files: global.sym gv.c lib/Text/ParseWords.pm pod/perldelta.pod
pp_hot.c proto.h t/op/method.t
Title: "Allow closures to be constant subroutines"
From: Chip Salzenberg
Files: op.c
Title: "Make C<scalar(reverse)> mean C<scalar(reverse $_)>"
From: Chip Salzenberg
Files: pp.c
Title: "Fix lexical suicide from C<my $x = $x> in sub"
From: Chip Salzenberg
Files: op.c
Title: "Make "Unrecog. char." fatal, and update its doc"
From: Chip Salzenberg
Files: pod/perldiag.pod toke.c
CORE PORTABILITY
Title: "safefree() mismatch"
From: Roderick Schertler
Msg-ID: <21338.859653381@eeyore.ibcinc.com>
Date: Sat, 29 Mar 1997 11:36:21 -0500
Files: util.c
(applied based on p5p patch as commit id 9b9b466fb02dc96c81439bafbb3b2da55238cfd2)
Title: "Win32 update (seven patches)"
From: Gurusamy Sarathy and Nick Ing-Simmons
Files: EXTERN.h MANIFEST win32/Makefile win32/perl.mak
win32/perl.rc win32/perldll.mak win32/makedef.pl
win32/modules.mak win32/win32io.c win32/bin/pl2bat.bat
OTHER CORE CHANGES
Title: "Report PERL* environment variables in -V and perlbug"
From: Chip Salzenberg
Files: perl.c utils/perlbug.PL
Title: "Typo in perl.c: Printing NO_EMBED for perl -V"
From: Gisle Aas
Msg-ID: <199703301922.VAA13509@furubotn.sn.no>
Date: Sun, 30 Mar 1997 21:22:11 +0200
Files: perl.c
(applied based on p5p patch as commit id b6c639e4b1912ad03b9b10ba9518d96bd0a6cfaf)
Title: "Don't let C<$var = $var> untaint $var"
From: Chip Salzenberg
Files: pp_hot.c pp_sys.c sv.h t/op/taint.t
Title: "Fix autoviv bug in C<my $x; ++$x->{KEY}>"
From: Chip Salzenberg
Files: pp_hot.c
Title: "Re: 5.004's new srand() default seed"
From: Hallvard B Furuseth
Msg-ID: <199703302219.AAA20998@bombur2.uio.no>
Date: Mon, 31 Mar 1997 00:19:13 +0200 (MET DST)
Files: pp.c
(applied based on p5p patch as commit id d7d933a26349f945f93b2f0dbf85b773d8ca3219)
Title: "Re: embedded perl and top_env problem "
From: Gurusamy Sarathy
Msg-ID: <199703280031.TAA05711@aatma.engin.umich.edu>
Date: Thu, 27 Mar 1997 19:31:42 -0500
Files: gv.c interp.sym perl.c perl.h pp_ctl.c pp_sys.c scope.h util.c
(applied based on p5p patch as commit id f289f7d2518e7a8a82114282e774adf50fa6ce85)
Title: "Define and use new macro: boolSV()"
From: Tim Bunce
Files: gv.c lib/ExtUtils/typemap os2/os2.c pp.c pp_hot.c pp_sys.c
sv.c sv.h universal.c vms/vms.c
Title: "Re: strict @F"
From: Hallvard B Furuseth
Msg-ID: <199703252110.WAA16038@bombur2.uio.no>
Date: Tue, 25 Mar 1997 22:10:33 +0100 (MET)
Files: toke.c
(applied based on p5p patch as commit id dfd44a5c8c8dd4c001c595debfe73d011a96d844)
Title: "Try harder to identify errors at EOF"
From: Chip Salzenberg
Files: toke.c
Title: "Minor string change in toke.c: 'bareword'"
From: lvirden@cas.org
Msg-ID: <1997Mar27.130247.1911552@hmivax.humgen.upenn.edu>
Date: Thu, 27 Mar 1997 13:02:46 -0500 (EST)
Files: toke.c
(applied based on p5p patch as commit id 9b56c8f8085a9e773ad87c6b3c1d0b5e39dbc348)
Title: "Improve diagnostic on \r in program text"
From: Chip Salzenberg
Files: pod/perldiag.pod toke.c
Title: "Make Sock_size_t typedef work right"
From: Chip Salzenberg
Files: perl.h pp_sys.c
LIBRARY AND EXTENSIONS
Title: "New module constant.pm"
From: Tom Phoenix
Files: MANIFEST lib/constant.pm op.c pp.c t/pragma/constant.t
Title: "Remove chat2"
From: Chip Salzenberg
Files: MANIFEST lib/chat2.inter lib/chat2.pl
Title: "Include CGI.pm 2.32"
From: Chip Salzenberg
Files: MANIFEST eg/cgi/* lib/CGI.pm lib/CGI/Apache.pm
lib/CGI/Carp.pm lib/CGI/Fast.pm lib/CGI/Push.pm
lib/CGI/Switch.pm
UTILITIES
Title: "Tom C's Pod::Html and html tools, as of 30 March 97"
From: Chip Salzenberg
Files: MANIFEST installhtml lib/Pod/Html.pm pod/pod2html.PL
Title: "Fix path bugs in installhtml"
From: Robin Barker <rmb1@cise.npl.co.uk>
Msg-ID: <3180.9703270906@tempest.cise.npl.co.uk>
Date: Thu, 27 Mar 97 09:06:14 GMT
Files: installhtml
Title: "Make perlbug say that it's only for core Perl bugs"
From: Chip Salzenberg
Files: utils/perlbug.PL
DOCUMENTATION
Title: "Document autouse and constant; update diagnostics"
From: Chip Salzenberg
Files: pod/perldelta.pod
Title: "Suggest to upgraders that they try '-w' again"
From: Hallvard B Furuseth
Msg-ID: <199703251901.UAA15982@bombur2.uio.no>
Date: Tue, 25 Mar 1997 20:01:26 +0100 (MET)
Files: pod/perldelta.pod
(applied based on p5p patch as commit id 4176c059b9ba6b022e99c44270434a5c3e415b73)
Title: "Improve and update documentation of constant subs"
From: Tom Phoenix <rootbeer@teleport.com>
Msg-ID: <Pine.GSO.3.96.970331122546.14185C-100000@kelly.teleport.com>
Date: Mon, 31 Mar 1997 13:05:54 -0800 (PST)
Files: pod/perlsub.pod
Title: "Improve documentation of C<return>"
From: Chip Salzenberg
Files: pod/perlfunc.pod pod/perlsub.pod
Title: "perlfunc.pod patch"
From: Gisle Aas
Msg-ID: <199703262159.WAA17531@furubotn.sn.no>
Date: Wed, 26 Mar 1997 22:59:23 +0100
Files: pod/perlfunc.pod
(applied based on p5p patch as commit id 35a731fcbcd7860eb497d6598f3f77b8746319c4)
Title: "Use 'while (defined($x = <>)) {}', per <gnat@frii.com>"
From: Chip Salzenberg
Files: configpm lib/Term/Cap.pm perlsh pod/perlipc.pod pod/perlop.pod
pod/perlsub.pod pod/perlsyn.pod pod/perltrap.pod
pod/perlvar.pod win32/bin/search.bat
Title: "Document and test C<%> behavior with negative operands"
From: Chip Salzenberg
Files: pod/perlop.pod t/op/arith.t
Title: "Update docs on $]"
From: Chip Salzenberg
Files: pod/perlvar.pod
Title: "perlvar.pod patch"
From: Gisle Aas
Msg-ID: <199703261254.NAA10237@bergen.sn.no>
Date: Wed, 26 Mar 1997 13:54:00 +0100
Files: pod/perlvar.pod
(applied based on p5p patch as commit id 0aa182cb0caa3829032904b9754807b1b7418509)
Title: "Fix example of C<or> vs. C<||>"
From: Chip Salzenberg
Files: pod/perlsyn.pod
Title: "Pod usage and spelling patch"
From: Larry W. Virden
Files: pod/*.pod
Title: "Pod updates"
From: "Cary D. Renzema" <caryr@mxim.com>
Msg-ID: <199703262353.PAA01819@macs.mxim.com>
Date: Wed, 26 Mar 1997 15:53:22 -0800 (PST)
Files: pod/*.pod
(applied based on p5p patch as commit id 5695b28edc67a3f45e8a0f25755d07afef3660ac)
Diffstat (limited to 'eg')
-rw-r--r-- | eg/cgi/RunMeFirst | 29 | ||||
-rw-r--r-- | eg/cgi/clickable_image.cgi | 26 | ||||
-rw-r--r-- | eg/cgi/cookie.cgi | 88 | ||||
-rw-r--r-- | eg/cgi/crash.cgi | 6 | ||||
-rw-r--r-- | eg/cgi/customize.cgi | 92 | ||||
-rw-r--r-- | eg/cgi/diff_upload.cgi | 68 | ||||
-rw-r--r-- | eg/cgi/file_upload.cgi | 63 | ||||
-rw-r--r-- | eg/cgi/frameset.cgi | 81 | ||||
-rw-r--r-- | eg/cgi/index.html | 111 | ||||
-rw-r--r-- | eg/cgi/internal_links.cgi | 33 | ||||
-rw-r--r-- | eg/cgi/javascript.cgi | 105 | ||||
-rw-r--r-- | eg/cgi/monty.cgi | 83 | ||||
-rw-r--r-- | eg/cgi/multiple_forms.cgi | 54 | ||||
-rw-r--r-- | eg/cgi/nph-clock.cgi | 18 | ||||
-rw-r--r-- | eg/cgi/popup.cgi | 32 | ||||
-rw-r--r-- | eg/cgi/save_state.cgi | 67 | ||||
-rw-r--r-- | eg/cgi/tryit.cgi | 35 | ||||
-rw-r--r-- | eg/cgi/wilogo.gif.uu | 14 |
18 files changed, 1005 insertions, 0 deletions
diff --git a/eg/cgi/RunMeFirst b/eg/cgi/RunMeFirst new file mode 100644 index 0000000000..c96d79eb62 --- /dev/null +++ b/eg/cgi/RunMeFirst @@ -0,0 +1,29 @@ +#!/usr/local/bin/perl + +# Make a world-writeable directory for saving state. +$ww = 'WORLD_WRITABLE'; +unless (-w $ww) { + $u = umask 0; + mkdir $ww, 0777; + umask $u; +} + +# Decode the sample image. +for $bin (qw(wilogo.gif)) { + unless (open UU, "$bin.uu") { warn "Can't open $bin.uu: $!\n"; next } + unless (open BIN, "> $bin") { warn "Can't create $bin: $!\n"; next } + $_ = <UU>; + while (<UU>) { + chomp; + last if /^end/; + print BIN unpack "u", $_; + } + close BIN; + close UU; +} + +# Create symlinks from *.txt to *.cgi for documentation purposes. +foreach (<*.cgi>) { + ($target = $_) =~ s/cgi$/txt/; + symlink $_, $target unless -e $target; +} diff --git a/eg/cgi/clickable_image.cgi b/eg/cgi/clickable_image.cgi new file mode 100644 index 0000000000..81daf09690 --- /dev/null +++ b/eg/cgi/clickable_image.cgi @@ -0,0 +1,26 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; +print $query->header; +print $query->start_html("A Clickable Image"); +print <<END; +<H1>A Clickable Image</H1> +</A> +END +print "Sorry, this isn't very exciting!\n"; + +print $query->startform; +print $query->image_button('picture',"./wilogo.gif"); +print "Give me a: ",$query->popup_menu('letter',['A','B','C','D','E','W']),"\n"; # +print "<P>Magnification: ",$query->radio_group('magnification',['1X','2X','4X','20X']),"\n"; +print "<HR>\n"; + +if ($query->param) { + print "<P>Magnification, <EM>",$query->param('magnification'),"</EM>\n"; + print "<P>Selected Letter, <EM>",$query->param('letter'),"</EM>\n"; + ($x,$y) = ($query->param('picture.x'),$query->param('picture.y')); + print "<P>Selected Position <EM>($x,$y)</EM>\n"; +} + +print $query->end_html; diff --git a/eg/cgi/cookie.cgi b/eg/cgi/cookie.cgi new file mode 100644 index 0000000000..98adda196e --- /dev/null +++ b/eg/cgi/cookie.cgi @@ -0,0 +1,88 @@ +#!/usr/local/bin/perl + +use CGI qw(:standard); + +@ANIMALS=sort qw/lion tiger bear pig porcupine ferret zebra gnu ostrich + emu moa goat weasel yak chicken sheep hyena dodo lounge-lizard + squirrel rat mouse hedgehog racoon baboon kangaroo hippopotamus + giraffe/; + +# Recover the previous animals from the magic cookie. +# The cookie has been formatted as an associative array +# mapping animal name to the number of animals. +%zoo = cookie('animals'); + +# Recover the new animal(s) from the parameter 'new_animal' +@new = param('new_animals'); + +# If the action is 'add', then add new animals to the zoo. Otherwise +# delete them. +foreach (@new) { + if (param('action') eq 'Add') { + $zoo{$_}++; + } elsif (param('action') eq 'Delete') { + $zoo{$_}-- if $zoo{$_}; + delete $zoo{$_} unless $zoo{$_}; + } +} + +# Add new animals to old, and put them in a cookie +$the_cookie = cookie(-name=>'animals', + -value=>\%zoo, + -expires=>'+1h'); + +# Print the header, incorporating the cookie and the expiration date... +print header(-cookie=>$the_cookie); + +# Now we're ready to create our HTML page. +print start_html('Animal crackers'); + +print <<EOF; +<h1>Animal Crackers</h1> +Choose the animals you want to add to the zoo, and click "add". +Come back to this page any time within the next hour and the list of +animals in the zoo will be resurrected. You can even quit Netscape +completely! +<p> +Try adding the same animal several times to the list. Does this +remind you vaguely of a shopping cart? +<p> +<em>This script only works with Netscape browsers</em> +<p> +<center> +<table border> +<tr><th>Add/Delete<th>Current Contents +EOF + ; + +print "<tr><td>",start_form; +print scrolling_list(-name=>'new_animals', + -values=>[@ANIMALS], + -multiple=>1, + -override=>1, + -size=>10),"<br>"; +print submit(-name=>'action',-value=>'Delete'), + submit(-name=>'action',-value=>'Add'); +print end_form; + +print "<td>"; +if (%zoo) { # make a table + print "<ul>\n"; + foreach (sort keys %zoo) { + print "<li>$zoo{$_} $_\n"; + } + print "</ul>\n"; +} else { + print "<strong>The zoo is empty.</strong>\n"; +} +print "</table></center>"; + +print <<EOF; +<hr> +<ADDRESS>Lincoln D. Stein</ADDRESS><BR> +<A HREF="./">More Examples</A> +EOF + ; +print end_html; + + diff --git a/eg/cgi/crash.cgi b/eg/cgi/crash.cgi new file mode 100644 index 0000000000..64f03c7b3d --- /dev/null +++ b/eg/cgi/crash.cgi @@ -0,0 +1,6 @@ +#!/usr/local/bin/perl + +use CGI::Carp qw(fatalsToBrowser); + +# This line invokes a fatal error message at compile time. +foo bar baz; diff --git a/eg/cgi/customize.cgi b/eg/cgi/customize.cgi new file mode 100644 index 0000000000..d932f4ba23 --- /dev/null +++ b/eg/cgi/customize.cgi @@ -0,0 +1,92 @@ +#!/usr/local/bin/perl + +use CGI qw(:standard :html3); + +# Some constants to use in our form. +@colors=qw/aqua black blue fuschia gray green lime maroon navy olive + purple red silver teal white yellow/; +@sizes=("<default>",1..7); + +# recover the "preferences" cookie. +%preferences = cookie('preferences'); + +# If the user wants to change the background color or her +# name, they will appear among our CGI parameters. +foreach ('text','background','name','size') { + $preferences{$_} = param($_) || $preferences{$_}; +} + +# Set some defaults +$preferences{'background'} = $preferences{'background'} || 'silver'; +$preferences{'text'} = $preferences{'text'} || 'black'; + +# Refresh the cookie so that it doesn't expire. This also +# makes any changes the user made permanent. +$the_cookie = cookie(-name=>'preferences', + -value=>\%preferences, + -expires=>'+30d'); +print header(-cookie=>$the_cookie); + +# Adjust the title to incorporate the user's name, if provided. +$title = $preferences{'name'} ? + "Welcome back, $preferences{name}!" : "Customizable Page"; + +# Create the HTML page. We use several of Netscape's +# extended tags to control the background color and the +# font size. It's safe to use Netscape features here because +# cookies don't work anywhere else anyway. +print start_html(-title=>$title, + -bgcolor=>$preferences{'background'}, + -text=>$preferences{'text'} + ); + +print basefont({SIZE=>$preferences{size}}) if $preferences{'size'} > 0; + +print h1($title),<<END; +You can change the appearance of this page by submitting +the fill-out form below. If you return to this page any time +within 30 days, your preferences will be restored. +END + ; + +# Create the form +print hr(), + start_form, + + "Your first name: ", + textfield(-name=>'name', + -default=>$preferences{'name'}, + -size=>30),br, + + table( + TR( + td("Preferred"), + td("Page color:"), + td(popup_menu(-name=>'background', + -values=>\@colors, + -default=>$preferences{'background'}) + ), + ), + TR( + td(''), + td("Text color:"), + td(popup_menu(-name=>'text', + -values=>\@colors, + -default=>$preferences{'text'}) + ) + ), + TR( + td(''), + td("Font size:"), + td(popup_menu(-name=>'size', + -values=>\@sizes, + -default=>$preferences{'size'}) + ) + ) + ), + + submit(-label=>'Set preferences'), + hr; + +print a({HREF=>"/"},'Go to the home page'); + diff --git a/eg/cgi/diff_upload.cgi b/eg/cgi/diff_upload.cgi new file mode 100644 index 0000000000..913f9ca179 --- /dev/null +++ b/eg/cgi/diff_upload.cgi @@ -0,0 +1,68 @@ +#!/usr/local/bin/perl + +$DIFF = "/usr/bin/diff"; +$PERL = "/usr/bin/perl"; + +use CGI qw(:standard); +use CGI::Carp; + +print header; +print start_html("File Diff Example"); +print "<strong>Version </strong>$CGI::VERSION<p>"; + +print <<EOF; +<H1>File Diff Example</H1> +Enter two files. When you press "submit" their diff will be +produced. +EOF + ; + +# Start a multipart form. +print start_multipart_form; +print "File #1:",filefield(-name=>'file1',-size=>45),"<BR>\n"; +print "File #2:",filefield(-name=>'file2',-size=>45),"<BR>\n"; +print "Diff type: ",radio_group(-name=>'type', + -value=>['context','normal']),"<br>\n"; +print reset,submit(-name=>'submit',-value=>'Do Diff'); +print endform; + +# Process the form if there is a file name entered +$file1 = param('file1'); +$file2 = param('file2'); + +$|=1; # for buffering +if ($file1 && $file2) { + $realfile1 = tmpFileName($file1); + $realfile2 = tmpFileName($file2); + print "<HR>\n"; + print "<H2>$file1 vs $file2</H2>\n"; + + print "<PRE>\n"; + $options = "-c" if param('type') eq 'context'; + system "$DIFF $options $realfile1 $realfile2 | $PERL -pe 's/>/>/g; s/</</g;'"; + close $file1; + close $file2; + print "</PRE>\n"; +} + +print <<EOF; +<HR> +<A HREF="../cgi_docs.html">CGI documentation</A> +<HR> +<ADDRESS> +<A HREF="/~lstein">Lincoln D. Stein</A> +</ADDRESS><BR> +Last modified 17 July 1996 +EOF + ; +print end_html; + +sub sanitize { + my $name = shift; + my($safe) = $name=~/([a-zA-Z0-9._~#,]+)/; + unless ($safe) { + print "<strong>$name is not a valid Unix filename -- sorry</strong>"; + exit 0; + } + return $safe; +} diff --git a/eg/cgi/file_upload.cgi b/eg/cgi/file_upload.cgi new file mode 100644 index 0000000000..1f9eaec332 --- /dev/null +++ b/eg/cgi/file_upload.cgi @@ -0,0 +1,63 @@ +#!/usr/local/bin/perl + +use CGI qw(:standard); +use CGI::Carp; + +print header(); +print start_html("File Upload Example"); +print strong("Version "),$CGI::VERSION,p; + +print h1("File Upload Example"), + 'This example demonstrates how to prompt the remote user to + select a remote file for uploading. ', + strong("This feature only works with Netscape 2.0 browsers."), + p, + 'Select the ',cite('browser'),' button to choose a text file + to upload. When you press the submit button, this script + will count the number of lines, words, and characters in + the file.'; + +@types = ('count lines','count words','count characters'); + +# Start a multipart form. +print start_multipart_form(), + "Enter the file to process:", + filefield('filename','',45), + br, + checkbox_group('count',\@types,\@types), + p, + reset,submit('submit','Process File'), + endform; + +# Process the form if there is a file name entered +if ($file = param('filename')) { + $tmpfile=tmpFileName($file); + print hr(), + h2($file), + h3($tmpfile); + my($lines,$words,$characters,@words) = (0,0,0,0); + while (<$file>) { + $lines++; + $words += @words=split(/\s+/); + $characters += length($_); + } + close $file; + grep($stats{$_}++,param('count')); + if (%stats) { + print strong("Lines: "),$lines,br if $stats{'count lines'}; + print strong("Words: "),$words,br if $stats{'count words'}; + print strong("Characters: "),$characters,br if $stats{'count characters'}; + } else { + print strong("No statistics selected."); + } +} + +print hr(), + a({href=>"../cgi_docs.html"},"CGI documentation"), + hr, + address( + a({href=>'/~lstein'},"Lincoln D. Stein")), + br, + 'Last modified July 17, 1996', + end_html; + diff --git a/eg/cgi/frameset.cgi b/eg/cgi/frameset.cgi new file mode 100644 index 0000000000..ff730268e9 --- /dev/null +++ b/eg/cgi/frameset.cgi @@ -0,0 +1,81 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; +print $query->header; +$TITLE="Frameset Example"; + +# We use the path information to distinguish between calls +# to the script to: +# (1) create the frameset +# (2) create the query form +# (3) create the query response + +$path_info = $query->path_info; + +# If no path information is provided, then we create +# a side-by-side frame set +if (!$path_info) { + &print_frameset; + exit 0; +} + +# If we get here, then we either create the query form +# or we create the response. +&print_html_header; +&print_query if $path_info=~/query/; +&print_response if $path_info=~/response/; +&print_end; + + +# Create the frameset +sub print_frameset { + $script_name = $query->script_name; + print <<EOF; +<html><head><title>$TITLE</title></head> +<frameset cols="50,50"> +<frame src="$script_name/query" name="query"> +<frame src="$script_name/response" name="response"> +</frameset> +EOF + ; + exit 0; +} + +sub print_html_header { + print $query->start_html($TITLE); +} + +sub print_end { + print qq{<P><hr><A HREF="cgi_docs.html">Go to the documentation</A>}; + print $query->end_html; +} + +sub print_query { + $script_name = $query->script_name; + print "<H1>Frameset Query</H1>\n"; + print $query->startform(-action=>"$script_name/response",-TARGET=>"response"); + print "What's your name? ",$query->textfield('name'); + print "<P>What's the combination?<P>", + $query->checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe']); + + print "<P>What's your favorite color? ", + $query->popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + "<P>"; + print $query->submit; + print $query->endform; +} + +sub print_response { + print "<H1>Frameset Result</H1>\n"; + unless ($query->param) { + print "<b>No query submitted yet.</b>"; + return; + } + print "Your name is <EM>",$query->param(name),"</EM>\n"; + print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n"; + print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n"; +} + diff --git a/eg/cgi/index.html b/eg/cgi/index.html new file mode 100644 index 0000000000..9eafd5f108 --- /dev/null +++ b/eg/cgi/index.html @@ -0,0 +1,111 @@ +<HTML> <HEAD> +<TITLE>More Examples of Scripts Created with CGI.pm</TITLE> +</HEAD> + +<BODY> +<H1>More Examples of Scripts Created with CGI.pm</H1> + +<H2> Basic Non Sequitur Questionnaire</H2> +<UL> + <LI> <A HREF="tryit.cgi">Try the script</A> + <LI> <A HREF="tryit.txt">Look at its source code</A> +</UL> + +<H2> Advanced Non Sequitur Questionnaire</H2> +<UL> + <LI> <A HREF="monty.cgi">Try the script</A> + <LI> <A HREF="monty.txt">Look at its source code</A> +</UL> + +<H2> Save and restore the state of a form to a file</H2> +<UL> + <LI> <A HREF="save_state.cgi">Try the script</A> + <LI> <A HREF="save_state.txt">Look at its source code</A> +</UL> + +<H2> Read the coordinates from a clickable image map</H2> +<UL> + <LI> <A HREF="clickable_image.cgi">Try the script</A> + <LI> <A HREF="clickable_image.txt">Look at its source code</A> +</UL> + +<H2> Multiple independent forms on the same page</H2> +<UL> + <LI> <A HREF="multiple_forms.cgi">Try the script</A> + <LI> <A HREF="multiple_forms.txt">Look at its source code</A> +</UL> + +<H2> How to maintain state on a page with internal links</H2> +<UL> + <LI> <A HREF="internal_links.cgi">Try the script</A> + <LI> <A HREF="internal_links.txt">Look at its source code</A> +</UL> + +<h2>Echo fatal script errors to the browser</h2> +<ul> + <li><a href="crash.cgi">Try the script</a> + <li><a href="crash.txt">Look at its source code</a> +</ul> + +<EM>The Following Scripts only Work with Netscape 2.0 & Internet Explorer only!</EM> + +<H2> Prompt for a file to upload and process it</H2> +<UL> + <LI> <A HREF="file_upload.cgi">Try the script</A> + <LI> <A HREF="file_upload.txt">Look at its source code</A> +</UL> + +<h2> A Continuously-Updated Page using Server Push</h2> +<ul> + <li><a href="nph-clock.cgi">Try the script</a> + <li><a href="nph-clock.txt">Look at its source code</a> +</ul> + +<h2>Compute the "diff" between two uploaded files</h2> +<ul> + <li><a href="diff_upload.cgi">Try the script</a> + <li><a href="diff_upload.txt">Look at its source code</a> +</ul> + +<h2>Maintain state over a long period with a cookie</h2> +<ul> + <li><a href="cookie.cgi">Try the script</a> + <li><a href="cookie.txt">Look at its source code</a> +</ul> + +<h2>Permanently customize the appearance of a page</h2> +<ul> + <li><a href="customize.cgi">Try the script</a> + <li><a href="customize.txt">Look at its source code</a> +</ul> + +<h2> Popup the response in a new window</h2> +<ul> + <li><a href="popup.cgi">Try the script</a> + <li><a href="popup.txt">Look at its source code</a> +</ul> + +<h2> Side-by-side form and response using frames</h2> +<ul> + <li><a href="frameset.cgi">Try the script</a> + <li><a href="frameset.txt">Look at its source code</a> +</ul> + +<h2>Verify the Contents of a fill-out form with JavaScript</h2> +<ul> + <li><a href="javascript.cgi">Try the script</a> + <li><a href="javascript.txt">Look at its source code</a> +</ul> + +<HR> +<MENU> + <LI> <A HREF="../cgi_docs.html">CGI.pm documentation</A> + <LI> <A HREF="../CGI.pm.tar.gz">Download the CGI.pm distribution</A> +</MENU> +<HR> +<ADDRESS>Lincoln D. Stein, lstein@genome.wi.mit.edu<br> +<a href="/">Whitehead Institute/MIT Center for Genome Research</a></ADDRESS> +<!-- hhmts start --> +Last modified: Mon Dec 2 06:23:25 EST 1996 +<!-- hhmts end --> +</BODY> </HTML> diff --git a/eg/cgi/internal_links.cgi b/eg/cgi/internal_links.cgi new file mode 100644 index 0000000000..4806966842 --- /dev/null +++ b/eg/cgi/internal_links.cgi @@ -0,0 +1,33 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; + +# We generate a regular HTML file containing a very long list +# and a popup menu that does nothing except to show that we +# don't lose the state information. +print $query->header; +print $query->start_html("Internal Links Example"); +print "<H1>Internal Links Example</H1>\n"; +print "Click <cite>Submit Query</cite> to create a state. Then scroll down and", + " click on any of the <cite>Jump to top</cite> links. This is not very exciting."; + +print "<A NAME=\"start\"></A>\n"; # an anchor point at the top + +# pick a default starting value; +$query->param('amenu','FOO1') unless $query->param('amenu'); + +print $query->startform; +print $query->popup_menu('amenu',[('FOO1'..'FOO9')]); +print $query->submit,$query->endform; + +# We create a long boring list for the purposes of illustration. +$myself = $query->self_url; +print "<OL>\n"; +for (1..100) { + print qq{<LI>List item #$_ <A HREF="$myself#start">Jump to top</A>\n}; +} +print "</OL>\n"; + +print $query->end_html; + diff --git a/eg/cgi/javascript.cgi b/eg/cgi/javascript.cgi new file mode 100644 index 0000000000..20496c0e80 --- /dev/null +++ b/eg/cgi/javascript.cgi @@ -0,0 +1,105 @@ +#!/usr/local/bin/perl + +# This script illustrates how to use JavaScript to validage fill-out +# forms. +use CGI qw(:standard); + +# Here's the javascript code that we include in the document. +$JSCRIPT=<<EOF; + // validate that the user is the right age. Return + // false to prevent the form from being submitted. + function validateForm() { + var today = new Date(); + var birthday = validateDate(document.form1.birthdate); + if (birthday == 0) { + document.form1.birthdate.focus() + document.form1.birthdate.select(); + return false; + } + var milliseconds = today.getTime()-birthday; + var years = milliseconds/(1000 * 60 * 60 * 24 * 365.25); + if ((years > 20) || (years < 5)) { + alert("You must be between the ages of 5 and 20 to submit this form"); + document.form1.birthdate.focus(); + document.form1.birthdate.select(); + return false; + } + // Since we've calculated the age in years already, + // we might as well send it up to our CGI script. + document.form1.age.value=Math.floor(years); + return true; + } + + // make sure that the contents of the supplied + // field contain a valid date. + function validateDate(element) { + var date = Date.parse(element.value); + if (0 == date) { + alert("Please enter date in format MMM DD, YY"); + element.focus(); + element.select(); + } + return date; + } + + // Compliments, compliments + function doPraise(element) { + if (element.checked) { + self.status=element.value + " is an excellent choice!"; + return true; + } else { + return false; + } + } + + function checkColor(element) { + var color = element.options[element.selectedIndex].text; + if (color == "blonde") { + if (confirm("Is it true that blondes have more fun?")) + alert("Darn. That leaves me out."); + } else + alert(color + " is a fine choice!"); + } +EOF + ; + +# here's where the execution begins +print header; +print start_html(-title=>'Personal Profile',-script=>$JSCRIPT); + +print h1("Big Brother Wants to Know All About You"), + strong("Note: "),"This page uses JavaScript and requires", + "Netscape 2.0 or higher to do anything special."; + +&print_prompt(); +print hr; +&print_response() if param; +print end_html; + +sub print_prompt { + print start_form(-name=>'form1', + -onSubmit=>"return validateForm()"),"\n"; + print "Birthdate (e.g. Jan 3, 1972): ", + textfield(-name=>'birthdate', + -onBlur=>"validateDate(this)"),"<p>\n"; + print "Sex: ",radio_group(-name=>'gender', + -value=>[qw/male female/], + -onClick=>"doPraise(this)"),"<p>\n"; + print "Hair color: ",popup_menu(-name=>'color', + -value=>[qw/brunette blonde red gray/], + -default=>'red', + -onChange=>"checkColor(this)"),"<p>\n"; + print hidden(-name=>'age',-value=>0); + print submit(); + print end_form; +} + +sub print_response { + import_names('Q'); + print h2("Your profile"), + "You are a ",b($Q::age)," year old ",b($Q::color,$Q::gender),".", + "You should be ashamed of yourself for lying so ", + "blatantly to big brother!", + hr; +} + diff --git a/eg/cgi/monty.cgi b/eg/cgi/monty.cgi new file mode 100644 index 0000000000..b7c0f6a8f6 --- /dev/null +++ b/eg/cgi/monty.cgi @@ -0,0 +1,83 @@ +#!/usr/local/bin/perl + +use CGI; + +$query = new CGI; + +print $query->header; +print $query->start_html("Example CGI.pm Form"); +print "<H1> Example CGI.pm Form</H1>\n"; +&print_prompt($query); +&do_work($query); +&print_tail; +print $query->end_html; + +sub print_prompt { + my($query) = @_; + + print $query->start_multipart_form; + print "<EM>What's your name?</EM><BR>"; + print $query->textfield('name'); + print $query->checkbox('Not my real name'); + + print "<P><EM>Where can you find English Sparrows?</EM><BR>"; + print $query->checkbox_group( + -name=>'Sparrow locations', + -values=>[England,France,Spain,Asia,Hoboken], + -linebreak=>'yes', + -defaults=>[England,Asia]); + + print "<P><EM>How far can they fly?</EM><BR>", + $query->radio_group( + -name=>'how far', + -values=>['10 ft','1 mile','10 miles','real far'], + -default=>'1 mile'); + + print "<P><EM>What's your favorite color?</EM> "; + print $query->popup_menu(-name=>'Color', + -values=>['black','brown','red','yellow'], + -default=>'red'); + + print $query->hidden('Reference','Monty Python and the Holy Grail'); + + print "<P><EM>What have you got there?</EM><BR>"; + print $query->scrolling_list( + -name=>'possessions', + -values=>['A Coconut','A Grail','An Icon', + 'A Sword','A Ticket'], + -size=>5, + -multiple=>'true'); + + print "<P><EM>Any parting comments?</EM><BR>"; + print $query->textarea(-name=>'Comments', + -rows=>10, + -columns=>50); + + print "<P>",$query->reset; + print $query->submit('Action','Shout'); + print $query->submit('Action','Scream'); + print $query->endform; + print "<HR>\n"; + } + +sub do_work { + my($query) = @_; + my(@values,$key); + + print "<H2>Here are the current settings in this form</H2>"; + + foreach $key ($query->param) { + print "<STRONG>$key</STRONG> -> "; + @values = $query->param($key); + print join(", ",@values),"<BR>\n"; + } +} + +sub print_tail { + print <<END; +<HR> +<ADDRESS>Lincoln D. Stein</ADDRESS><BR> +<A HREF="/">Home Page</A> +END + ; +} diff --git a/eg/cgi/multiple_forms.cgi b/eg/cgi/multiple_forms.cgi new file mode 100644 index 0000000000..b38bf93e96 --- /dev/null +++ b/eg/cgi/multiple_forms.cgi @@ -0,0 +1,54 @@ +#!/usr/local/bin/perl + +use CGI; + +$query = new CGI; +print $query->header; +print $query->start_html('Multiple Forms'); +print "<H1>Multiple Forms</H1>\n"; + +# Print the first form +print $query->startform; +$name = $query->remote_user || 'anonymous@' . $query->remote_host; + +print "What's your name? ",$query->textfield('name',$name,50); +print "<P>What's the combination?<P>", + $query->checkbox_group('words',['eenie','meenie','minie','moe']); +print "<P>What's your favorite color? ", + $query->popup_menu('color',['red','green','blue','chartreuse']), + "<P>"; +print $query->submit('form_1','Send Form 1'); +print $query->endform; + +# Print the second form +print "<HR>\n"; +print $query->startform; +print "Some radio buttons: ",$query->radio_group('radio buttons', + [qw{one two three four five}],'three'),"\n"; +print "<P>What's the password? ",$query->password_field('pass','secret'); +print $query->defaults,$query->submit('form_2','Send Form 2'),"\n"; +print $query->endform; + +print "<HR>\n"; + +$query->import_names('Q'); +if ($Q::form_1) { + print "<H2>Form 1 Submitted</H2>\n"; + print "Your name is <EM>$Q::name</EM>\n"; + print "<P>The combination is: <EM>{",join(",",@Q::words),"}</EM>\n"; + print "<P>Your favorite color is <EM>$Q::color</EM>\n"; +} elsif ($Q::form_2) { + print <<EOF; +<H2>Form 2 Submitted</H2> +<P>The value of the radio buttons is <EM>$Q::radio_buttons</EM> +<P>The secret password is <EM>$Q::pass</EM> +EOF + ; +} +print qq{<P><A HREF="./">Other examples</A>}; +print qq{<P><A HREF="../cgi_docs.html">Go to the documentation</A>}; + +print $query->end_html; + + + diff --git a/eg/cgi/nph-clock.cgi b/eg/cgi/nph-clock.cgi new file mode 100644 index 0000000000..55a2fbe545 --- /dev/null +++ b/eg/cgi/nph-clock.cgi @@ -0,0 +1,18 @@ +#!/usr/local/bin/perl -w + +use CGI::Push qw(:standard :html3); + +do_push(-next_page=>\&draw_time,-delay=>1); + +sub draw_time { + my $time = `/bin/date`; + return start_html('Tick Tock'), + div({-align=>CENTER}, + h1('Virtual Clock'), + h2($time) + ), + hr, + a({-href=>'index.html'},'More examples'), + end_html(); +} + diff --git a/eg/cgi/popup.cgi b/eg/cgi/popup.cgi new file mode 100644 index 0000000000..88cea1da9c --- /dev/null +++ b/eg/cgi/popup.cgi @@ -0,0 +1,32 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; +print $query->header; +print $query->start_html('Popup Window'); + + +if (!$query->param) { + print "<H1>Ask your Question</H1>\n"; + print $query->startform(-target=>'_new'); + print "What's your name? ",$query->textfield('name'); + print "<P>What's the combination?<P>", + $query->checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','moe']); + + print "<P>What's your favorite color? ", + $query->popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + "<P>"; + print $query->submit; + print $query->endform; + +} else { + print "<H1>And the Answer is...</H1>\n"; + print "Your name is <EM>",$query->param(name),"</EM>\n"; + print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n"; + print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n"; +} +print qq{<P><A HREF="cgi_docs.html">Go to the documentation</A>}; +print $query->end_html; diff --git a/eg/cgi/save_state.cgi b/eg/cgi/save_state.cgi new file mode 100644 index 0000000000..be79051bd6 --- /dev/null +++ b/eg/cgi/save_state.cgi @@ -0,0 +1,67 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; + +print $query->header; +print $query->start_html("Save and Restore Example"); +print "<H1>Save and Restore Example</H1>\n"; + +# Here's where we take action on the previous request +&save_parameters($query) if $query->param('action') eq 'SAVE'; +$query = &restore_parameters($query) if $query->param('action') eq 'RESTORE'; + +# Here's where we create the form +print $query->startform; +print "Popup 1: ",$query->popup_menu('popup1',[qw{red green purple magenta orange chartreuse brown}]),"\n"; +print "Popup 2: ",$query->popup_menu('popup2',[qw{lion tiger bear zebra potto wildebeest frog emu gazelle}]),"\n"; +print "<P>"; +$default_name = $query->remote_addr . '.sav'; +print "Save/restore state from file: ",$query->textfield('savefile',$default_name),"\n"; +print "<P>"; +print $query->submit('action','SAVE'),$query->submit('action','RESTORE'); +print "<P>",$query->defaults; +print $query->endform; + +# Here we print out a bit at the end +print $query->end_html; + +sub save_parameters { + local($query) = @_; + local($filename) = &clean_name($query->param('savefile')); + if (open(FILE,">$filename")) { + $query->save(FILE); + close FILE; + print "<STRONG>State has been saved to file $filename</STRONG>\n"; + print "<P>If you remember this name you can restore the state later.\n"; + } else { + print "<STRONG>Error:</STRONG> couldn't write to file $filename: $!\n"; + } +} + +sub restore_parameters { + local($query) = @_; + local($filename) = &clean_name($query->param('savefile')); + if (open(FILE,$filename)) { + $query = new CGI(FILE); # Throw out the old query, replace it with a new one + close FILE; + print "<STRONG>State has been restored from file $filename</STRONG>\n"; + } else { + print "<STRONG>Error:</STRONG> couldn't restore file $filename: $!\n"; + } + return $query; +} + + +# Very important subroutine -- get rid of all the naughty +# metacharacters from the file name. If there are, we +# complain bitterly and die. +sub clean_name { + local($name) = @_; + unless ($name=~/^[\w\._\-]+$/) { + print "<STRONG>$name has naughty characters. Only "; + print "alphanumerics are allowed. You can't use absolute names.</STRONG>"; + die "Attempt to use naughty characters"; + } + return "WORLD_WRITABLE/$name"; +} diff --git a/eg/cgi/tryit.cgi b/eg/cgi/tryit.cgi new file mode 100644 index 0000000000..155cd72a59 --- /dev/null +++ b/eg/cgi/tryit.cgi @@ -0,0 +1,35 @@ +#!/usr/local/bin/perl + +use CGI ':standard'; + +print header; +print start_html('A Simple Example'), + h1('A Simple Example'), + start_form, + "What's your name? ",textfield('name'), + p, + "What's the combination?", + p, + checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','minie']), + p, + "What's your favorite color? ", + popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + p, + submit, + end_form, + hr; + +if (param()) { + print + "Your name is: ",em(param('name')), + p, + "The keywords are: ",em(join(", ",param('words'))), + p, + "Your favorite color is: ",em(param('color')), + hr; +} +print a({href=>'../cgi_docs.html'},'Go to the documentation'); + diff --git a/eg/cgi/wilogo.gif.uu b/eg/cgi/wilogo.gif.uu new file mode 100644 index 0000000000..a183bc02d5 --- /dev/null +++ b/eg/cgi/wilogo.gif.uu @@ -0,0 +1,14 @@ +begin 644 wilogo.gif +M1TE&.#=A7@!$`(```'X2F?___RP`````7@!$```"_D2.J<#MKF)ZU,A3,[OO +M(IUY']A%9"6AW$F)+#2]Y:BNLF6_\;WMH<?#I72^VP+D"@*)F&"O25KRDM&B +M[%C-7;4_J)*6'4ZE&O`W8"1OQ5UGPWRBIKDPM!MW9J]-[;LUKL;$5W.'YQ3( +M(O<&-^>F*(A55\BX%UEI^;<VB0BH1RFX2=<IELE4^*0'N?-I>OJ8N%(*Z^4G +M.OJJ>8HZ.(>;JRMD><E[!KQHB^3;:APL6Z8\RKPK/)O:*-WLW&7]*\UYR]J) +M?<P=1MR-_6VN76,WGAV^32W^3CZ_SCY3;W__C-R^CU^\%M#T!9PVL(ZZ&>X" +M%A1XSM]!A?T8/C0T$1XMJG\B&G+,"-&C/(VS0(842;`)M'S>_OE8F#"=2S#* +M8LHLAS'D1Y,42UGY9O,F-T:X@@JEE@D1RW>/D@8R.DZ-+*E0CQ:9JJ5JU!SQ +MR&BU2D.;E*4'ER0TNY%G2A/Y.G[=VG%81+5K_UG$21<A6;=YP9'5B++O7:@7 +M\]J5]]?DX7:)%<]5%=B/55>-GQW55;$8L\RW6J8-9>QM7<^A/SMZK!ESY$,+ +(KPA.EJ```#L` +` +end |