summaryrefslogtreecommitdiff
path: root/eg
diff options
context:
space:
mode:
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>1997-03-26 07:04:34 +1200
committerChip Salzenberg <chip@atlantic.net>1997-03-26 07:04:34 +1200
commit54310121b442974721115f93666234a200f5c7e4 (patch)
tree99b5953030ddf062d77206ac0cf8ac967e7cbd93 /eg
parentd03407ef6d8e534a414e9ce92c6c5c8dab664a40 (diff)
downloadperl-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/RunMeFirst29
-rw-r--r--eg/cgi/clickable_image.cgi26
-rw-r--r--eg/cgi/cookie.cgi88
-rw-r--r--eg/cgi/crash.cgi6
-rw-r--r--eg/cgi/customize.cgi92
-rw-r--r--eg/cgi/diff_upload.cgi68
-rw-r--r--eg/cgi/file_upload.cgi63
-rw-r--r--eg/cgi/frameset.cgi81
-rw-r--r--eg/cgi/index.html111
-rw-r--r--eg/cgi/internal_links.cgi33
-rw-r--r--eg/cgi/javascript.cgi105
-rw-r--r--eg/cgi/monty.cgi83
-rw-r--r--eg/cgi/multiple_forms.cgi54
-rw-r--r--eg/cgi/nph-clock.cgi18
-rw-r--r--eg/cgi/popup.cgi32
-rw-r--r--eg/cgi/save_state.cgi67
-rw-r--r--eg/cgi/tryit.cgi35
-rw-r--r--eg/cgi/wilogo.gif.uu14
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/>/&gt;/g; s/</&lt;/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