dslinux/user/perl/lib/CGI/eg RunMeFirst caution.xbm clickable_image.cgi cookie.cgi crash.cgi customize.cgi diff_upload.cgi dna_small_gif.uu file_upload.cgi frameset.cgi index.html internal_links.cgi javascript.cgi make_links.pl monty.cgi multiple_forms.cgi nph-clock.cgi nph-multipart.cgi popup.cgi save_state.cgi tryit.cgi wilogo_gif.uu

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:25 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/lib/CGI/eg
In directory antilope:/tmp/cvs-serv17422/lib/CGI/eg

Added Files:
	RunMeFirst caution.xbm clickable_image.cgi cookie.cgi 
	crash.cgi customize.cgi diff_upload.cgi dna_small_gif.uu 
	file_upload.cgi frameset.cgi index.html internal_links.cgi 
	javascript.cgi make_links.pl monty.cgi multiple_forms.cgi 
	nph-clock.cgi nph-multipart.cgi popup.cgi save_state.cgi 
	tryit.cgi wilogo_gif.uu 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: crash.cgi ---
#!/usr/local/bin/perl

use CGI::Carp qw(fatalsToBrowser);

# This line invokes a fatal error message at compile time.
foo bar baz;

--- NEW FILE: customize.cgi ---
#!/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');
print end_html;

--- NEW FILE: javascript.cgi ---
#!/usr/local/bin/perl

# This script illustrates how to use JavaScript to validate 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 claim to be 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;
}


--- NEW FILE: dna_small_gif.uu ---
begin 444 dna_small.gif
M1TE&.#=A)0`J`.<``+9%&Y<R0M<F'ID\,!<07%<G1:P<0Q`A2Q`P;"L9/L$:
M,"480N5"&RL7:4LD0T,G144[7BHL2B4?3\0I+"</)BQ.9KD0/S878\96$Z\@
M(:\1*RL:3L0W&QL?2#4?9>@_&A$_5<I"&C`A3*,3-A`//9X<)\@Q(L`@.#\E
M7K,R*R\T6)H++1L72T8=4207:T`G=JX..MD^&!$_;^)2$#T=7S`79AL7.A$3
M1-=%#^,Q&QT_:C8=1!L86]\R#4M":4H76R,515HZ4"477G at T,J\;(X(@/$\7
M."4A2N9;$"DZ6RL34-8I$34A73P86I84/\87%1`0/V,B2"0<0N!(%QPH91<6
M2=!5$3(=73(E23`/,!L4.=$Z'-MH%>`Y#3$=2"=#59M((H88,GP\/]X^&+$R
M$"(79"DF33(93"$86=%;&"T4/=Y"&\\A$Q4Z4!`62*T4-Q4B9+X1*BH96SP?
M1<0D/3(F<-TM$!`=5:H.(!<64C$W?#8J3*`S(S<@3=8V%K$](QT.6Q`43AL4
M1:$D,;<0,\X9&,8])\@=$A(U244S5U,D6Q<V;]\I&&<K/8!*.R044>=/#YH>
M08$I1B,09S$35R(:4C0?<19$7<D^#Q`>5!()-;4702M`=;56)A`25,0K%"X<
M83`N>K`H'HDS*1`40,M&%!<@7M,_$A<N2L)%%18E4^<M$A@=5=0Q$Q`E311*
M2L8E&2D<7Q\A7P\80B48,%E/8[1-'J4/-"H<3"PA1$,T?Q<15R44,R,A4AL/
M,^M4%2,07!L+,[\[&!P4520I:C(9.=54$[,2/M-)&RP?7M=(%1$J8<-,%2H@
M4B,=51436^]2"!X<1A<44RD</>E+#%0>0S0/:4PJ9I,F-6DG420Y<"@09R,0
M-V$R/R4M<:\H0!(H410Z:AT27&4Q9"L@;=1%(MA-$M5+#RL4+M8Z&AT<7[<:
M(-QA&2,36R$++B(84!0:5ALO:K$A.]X?&!$84V@;/SX<6Q`;2$(B2QD21W4J
M1=TW&@```````````````"P`````)0`J```(_@!]:(N'18\W%15T$1N'C)V?
M0_HH,<$G9YBX!C6<3;+T at AZ-)K@\O*"!KP^$>"KVA`L3*8P3)^5ZA)@B:AH+
M9];F7.$Q+!`!0=*<E3'5K(:EHS2N%"AP*Y(\&##H6(!A:!XU99B*H?%4IDF?
M!8'<"-F%9I*TH8A83:*TXYD!J83D$0ICI-NE(:O8I6&FJ$64$M5$M%!3PU,F
M2UJD"9I41E824WT2G?BV-!$(!`=,+<IF!P>.%",&P7J"9XB82L5,48F5K,:"
M'94FU='6;!*R3T->E"%&95DR"`/6P,I0PDF)0SG8($$RJN0R`FI(H7$A2]VD
M*^^L_6(T3U*V%XH"_AB:HDS8H$AO5 at R:P,8.I%^.:*AC(>Z!'":6RC`1L at W-
M%1Q/,%(.'5+1`<D^74R at P2#?T*'/$"%@\(L5Y?RAB!SO3#*,-6CL44\4]C1#
MR0Q3C&&"!AH08@(#:Y2C@`&1---,.#)\T84=R##`0",H++8#)34, at X80R:"`
M0A<]?'#.!";`TDH.8QBB0354A!,*)WI0\<D\YJRQ3PE[V",(.D#48$T9GO22
MA0.BC,)'*]3TP,`^\_#QA0P@>`/"*]=<HX\3"C!BAQV%5",$+Z0,0X,UL3SB
M#B[NN$'/,A&,$L,Y[-BASR(@<**("E^,0(<&;[QA0@^,3%",#2S8H,01_LX0
M`(0:W%`@13#TN+'#&LK at 0$T0VER##50*Q/%-%%&H$`0#K7"`!B^X/`),()F0
M0PNT[K#BRBS1-!("`^=,$8`D="B`QRW?1**+-I?(X$@(L(R2AQ8+Y,*#-*YX
MH(00'1Q!CSI,U'!%)^_%4(X&FUB at 01$.@*!#$I?4D48I&1BA!2*HD%))(.+T
MYTEOT3B#PB/U4(,$%QD0(<\QX^CRBC=)@%`!&+:<<TH&M*C1"RJX'-'.'`YX
M<H0@<)#"0CX+I%`*-%:4L at XFS`#[11M?U-))"&RP84LWZL!A1A^YH.*)!)3<
MHXX6L]P3"!I`H/!`*>90`PD.F'3SR at -AG)`&_A=3'"**#[J(P<<I at YCA2@32
M!,*+Q9H`(XT2'O2RS"CGS.U9!K>0^C0&S/#1""(ZI)'&*6,,$842N%Q!@3NK
M"R'%%4KP0D(Q?"`S!3)<I#!!".68$T(IMHP#>BVE(/$+)#-80<PTLBRP^@$>
M<+,`-[QH$LP+0_P!1C>=S("!,N>8XP<8H6131!B;3`#&#)"DTH(L5#P0S#W+
MQ)*`$K1HHD4^;E!2QP%:B``&4H$,/Y2C$Y*(1%0(00A)@```77B"*$0@#3>P
MP&PU4`,^H!","P!!$')0P^H6((I5L"$'.;``';[Q!@-\PP"<B$<]EG"(#*C"
M%-(@0":\L0U?D&`#_L50 at 33.(`4M4``=&4@'+-9!!P9JP`#9T$4H=*$+!#1B
M'3A(`SYH`81'B.,(XJ@"":0(CDRPH@/<"$88V+"%$N#A&)MPX0N2H`L]C&,<
MEW"$%6:0BCV at XPIH>$0?)M$`<92!%OG8Q3#@(`U2C*)%9-!`&`K`!!EP0 at 80
M2,0M;I$.:"C#"D. at P#UJ``]GT"*,K%B&*0+!@TFH8VV*0$(:_/`)?7@#'.'0
M at R[H8``\:&`,=NC"*"B@!2TTHP5]N((TEH&`<)B"!PU`0RQ(P8MNS``9K6@%
M'W31AG%$(BZ2&((PA-&#'I"A&`F8!DD\\`H6-,.,X'B'%,+R#FX4`PS&_L!$
M.4R0#7W<0@%O2,07$($#9 at C3"%C8P!5H88\]J$,"-E!;(.X at C5T<`!65V,40
M,'&(0C!"`1JP@"3TH`T9=&,5JRC$-]+1`U%TP@@[^,$>Z$&*0%1A%XFK`BFD
MX0L6Y"(#A_A$#[JPC@%\@1 at 02`(SJ#&&.`A@'\&$!AALX(4Y="`/TA"",UA!
M@%W<8!*\$`$@C%""+G1A"9AP!"<>9 at ME*)$0F\C!$I8`B3\TP@%'@$(QH$`"
M)8@#'(B0ACB`P`,@%&,'9"##)S`1!&)\`0)^&,,^+$`("QC"#D\X!":HX0!<
ML(`&-O!%,&H at BS#F0AI'`!LO^"`,/OS!%KJ0_H0HEA`E27Q#%T%X0"%"@`1E
M2,`!:F!%+Q#A!G)40A!HP`4OFK`#-13#`?I(QCW38(Q/9&``%0#!);01BE>$
M@!TZNL81$G`!-]2!&&5 at A1N&T0Q<,$$$%*!``BR1A5$PPPH<74$%]*`#$.RA
M`(VP@#`X$(`7``(%T=@`.5Q`C@:0`P[)D$4'$H`."MB#"908Q=X@,01B9$(7
MG'A%`#8!"QSL at PUAL,0==M"")CQCP4)0QQUDP806H&,!T]A!`EH at AC2P`P,^
MT`,*NN%-&&T!&L at X!!Y^<(4.D(,%E>A`,T20C#IXL`6-:,`5F+"#!W"@'%OH
MA`IJ$5(#;`(;AV/'FA103(EV+(,>GHB&&ZJ`!D'<X0[-N$(N@)$+4$C@`<(`
M$(&/<8Q;7$,1UT"``+>P!57`X1F9D`4<W$`"4MP@$ZYX\B-"004Y2$`.HT@%
M)@IAB#><0!]FB(<I.(&`(7P"%GPPQ3)F`0YB0"$0 at 8"")L!Q!RH`8A&AL,8L
BR!$$,@@#&5OX!1V.\85XA.,.,A##!T2!AP at LXP#;"`@`.P``
end

--- NEW FILE: monty.cgi ---
#!/usr/local/bin/perl
     
use CGI;
use CGI::Carp qw/fatalsToBrowser/;
 
$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_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(", ", at values),"<BR>\n";
    }
}
 
sub print_tail {
    print <<END;
<HR>
<ADDRESS>Lincoln D. Stein</ADDRESS><BR>
<A HREF="/">Home Page</A>
END
    ;
}

--- NEW FILE: caution.xbm ---
#define caution_width 32
#define caution_height 32
static char caution_bits[] = {
 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x00,0x00,0x00,0x10,0x01,
 0x00,0x00,0x08,0x07,0x00,0x00,0x08,0x0e,0x00,0x00,0x04,0x0e,0x00,0x00,0x04,
 0x1c,0x00,0x00,0x02,0x1c,0x00,0x00,0xe2,0x38,0x00,0x00,0xf1,0x39,0x00,0x00,
 0xf1,0x71,0x00,0x80,0xf0,0x71,0x00,0x80,0xf0,0xe1,0x00,0x40,0xf0,0xe1,0x00,
 0x40,0xf0,0xc1,0x01,0x20,0xf0,0xc1,0x01,0x20,0xf0,0x81,0x03,0x10,0xe0,0x80,
 0x03,0x10,0xe0,0x00,0x07,0x08,0xe0,0x00,0x07,0x08,0xe0,0x00,0x0e,0x04,0x00,
 0x00,0x0e,0x04,0xe0,0x00,0x1c,0x02,0xf0,0x01,0x1c,0x02,0xf0,0x01,0x38,0x01,
 0xe0,0x00,0x38,0x01,0x00,0x00,0x70,0x01,0x00,0x00,0x70,0xff,0xff,0xff,0x7f,
 0xf8,0xff,0xff,0x3f,0x00,0x00,0x00,0x00};

--- NEW FILE: file_upload.cgi ---
#!/usr/local/bin/perl -w

use strict 'refs';
use lib '..';
use CGI qw(:standard);
use CGI::Carp qw/fatalsToBrowser/;

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 or greater, or IE 4.0 or greater."),
    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.';

my @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 (my $file = param('filename')) {
    my %stats;
    my $tmpfile=tmpFileName($file);
    my $mimetype = uploadInfo($file)->{'Content-Type'} || '';
    print hr(),
          h2($file),
          h3($tmpfile),
          h4("MIME Type:",em($mimetype));

    my($lines,$words,$characters, at 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 cite("URL parameters: "),url_param();

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;


--- NEW FILE: frameset.cgi ---
#!/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="../index.html" TARGET="_top">More Examples</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";
}


--- NEW FILE: make_links.pl ---
#!/usr/local/bin/perl

# this is just a utility for creating symlinks from *.txt to *.cgi
# for documentation purposes.
foreach (<*.cgi>) {
    ($target=$_)=~s/cgi$/txt/;
    symlink $_,$target
}

--- NEW FILE: nph-multipart.cgi ---
#!/usr/local/bin/perl
use CGI qw/:push -nph/;
$| = 1;
print multipart_init(-boundary=>'----------------here we go!');
while (1) {
    print multipart_start(-type=>'text/plain'),
    "The current time is ",scalar(localtime),"\n",
    multipart_end;
    sleep 1;
}

--- NEW FILE: tryit.cgi ---
#!/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');
print end_html;



--- NEW FILE: clickable_image.cgi ---
#!/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;

--- NEW FILE: popup.cgi ---
#!/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;

--- NEW FILE: nph-clock.cgi ---
#!/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();
}


--- NEW FILE: save_state.cgi ---
#!/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->start_multipart_form;
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";
}

--- NEW FILE: cookie.cgi ---
#!/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;



--- NEW FILE: index.html ---
<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> Server Push</H2>
<ul>
  <li><a href="nph-multipart.cgi">Try the script</a>
  <li><a href="nph-multipart.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>
<em>This script deliberately generates a compile-time error.</em>
<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 Work with Netscape Navigator 2.0 and higher,
or Internet Explorer 3.0 and higher</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 with a cookie</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 at genome.wi.mit.edu<br>
<a href="/">Whitehead Institute/MIT Center for Genome Research</a></ADDRESS>
<!-- hhmts start -->
Last modified: Wed Jun 23 15:31:47 EDT 1999
<!-- hhmts end -->
</BODY> </HTML>

--- NEW FILE: diff_upload.cgi ---
#!/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;
}

--- NEW FILE: RunMeFirst ---
#!/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 $uu (<*.uu>) {
    unless (open UU, "<$uu") { warn "Can't open $uu: $!\n"; next }
    while (<UU>) {
        chomp;
	if (/^begin\s+\d+\s+(.+)$/) {
	    $bin = $1;
	    last;
	}
    }
    unless (open BIN, "> $bin") { warn "Can't create $bin: $!\n"; next }
    binmode BIN;
    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/i;
    symlink $_, $target unless -e $target;
}

--- NEW FILE: wilogo_gif.uu ---
begin 444 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 at D1RW>/D at 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

--- NEW FILE: internal_links.cgi ---
#!/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;


--- NEW FILE: multiple_forms.cgi ---
#!/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(",", at 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;







More information about the dslinux-commit mailing list