#----------------------------- # http://www.perl.com/CPAN/ # http://www.perl.com:8001/bad/mojo.html # ftp://gatekeeper.dec.com/pub/misc/netlib.tar.Z # ftp://anonymous@myplace:gatekeeper.dec.com/pub/misc/netlib.tar.Z # file:///etc/motd #----------------------------- # http://mox.perl.com/cgi-bin/program?name=Johann&born=1685 #----------------------------- # http://mox.perl.com/cgi-bin/program #----------------------------- |
#----------------------------- # download the following standalone program #!/usr/bin/perl -w # hiweb - load CGI module to decode information given by web server use strict; use CGI qw(:standard escapeHTML); # get a parameter from a form my $value = param('PARAM_NAME'); # output a document print header(), start_html("Howdy there!"), p("You typed: ", tt(escapeHTML($value))), end_html(); #----------------------------- use CGI qw(:standard); $who = param("Name"); $phone = param("Number"); @picks = param("Choices"); #----------------------------- print header( -TYPE => 'text/plain', -EXPIRES => '+3d' ); #----------------------------- |
#-----------------------------
use CGI::Carp;
warn "This is a complaint";
die "But this one is serious";
#-----------------------------
BEGIN {
use CGI::Carp qw(carpout);
open(LOG, ">>/var/local/cgi-logs/mycgi-log")
or die "Unable to append to mycgi-log: $!\n";
carpout(*LOG);
}
#-----------------------------
use CGI::Carp qw(fatalsToBrowser);
die "Bad error here";
#-----------------------------
|
#----------------------------- # download the following standalone program #!/usr/bin/perl # webwhoami - show web users id print "Content-Type: text/plain\n\n"; print "Running as ", scalar getpwuid($>), "\n"; #----------------------------- #% perl -wc cgi-script # just compilation # #% perl -w cgi-script # parms from stdin #(offline mode: enter name=value pairs on standard input) # #name=joe # #number=10 # #^D # # #% perl -w cgi-script name=joe number=10 # run with mock form input #% perl -d cgi-script name=joe number=10 # ditto, under the debugger # ## POST method script in csh #% (setenv HTTP_METHOD POST; perl -w cgi-script name=joe number=10) ## POST method script in sh #% HTTP_METHOD=POST perl -w cgi-script name=joe number=10 #----------------------------- #% perl -MCGI -le 'print CGI->VERSION' #2.49 #----------------------------- $| = 1; #----------------------------- |
#-----------------------------
#!/usr/bin/perl -T
open(FH, "> $ARGV[0]") or die;
#-----------------------------
# Insecure dependency in open while running with -T switch at ...
#-----------------------------
$file = $ARGV[0]; # $file tainted
unless ($file =~ m#^([\w.-]+)$#) { # $1 is untainted
die "filename '$file' has invalid characters.\n";
}
$file = $1; # $file untainted
#-----------------------------
unless (-e $filename) { # WRONG!
open(FH, "> $filename");
# ...
}
#-----------------------------
|
#----------------------------- #Alias /perl/ /real/path/to/perl/scripts/ # #<Location /perl> #SetHandler perl-script #PerlHandler Apache::Registry #Options ExecCGI #</Location> # #PerlModule Apache::Registry #PerlModule CGI #PerlSendHeader On #----------------------------- #<Files *.perl> #SetHandler perl-script #PerlHandler Apache::Registry #Options ExecCGI #</Files> #----------------------------- |
#-----------------------------
system("command $input @files"); # UNSAFE
#-----------------------------
system("command", $input, @files); # safer
#-----------------------------
chomp($now = `date`);
#-----------------------------
@output = `grep $input @files`;
#-----------------------------
die "cannot fork: $!" unless defined ($pid = open(SAFE_KID, "|-"));
if ($pid == 0) {
exec('grep', $input, @files) or die "can't exec grep: $!";
} else {
@output = <SAFE_KID>;
close SAFE_KID; # $? contains status
}
#-----------------------------
open(KID_TO_READ, "$program @options @args |"); # UNSAFE
#-----------------------------
# add error processing as above
die "cannot fork: $!" unless defined($pid = open(KID_TO_READ, "-|"));
if ($pid) { # parent
while (<KID_TO_READ>) {
# do something interesting
}
close(KID_TO_READ) or warn "kid exited $?";
} else { # child
# reconfigure, then
exec($program, @options, @args) or die "can't exec program: $!";
}
#-----------------------------
open(KID_TO_WRITE, "|$program $options @args"); # UNSAFE
#-----------------------------
$pid = open(KID_TO_WRITE, "|-");
die "cannot fork: $!" unless defined($pid = open(KID_TO_WRITE, "|-"));
$SIG{ALRM} = sub { die "whoops, $program pipe broke" };
if ($pid) { # parent
for (@data) { print KID_TO_WRITE $_ }
close(KID_TO_WRITE) or warn "kid exited $?";
} else { # child
# reconfigure, then
exec($program, @options, @args) or die "can't exec program: $!";
}
#-----------------------------
|
#-----------------------------
print ol( li([ qw(red blue green)]) );
# <OL><LI>red</LI> <LI>blue</LI> <LI>green</LI></OL>
@names = qw(Larry Moe Curly);
print ul( li({ -TYPE => "disc" }, \@names) );
# <UL><LI TYPE="disc">Larry</LI> <LI TYPE="disc">Moe</LI>
#
# <LI TYPE="disc">Curly</LI></UL>
#-----------------------------
print li("alpha");
# <LI>alpha</LI>
print li( [ "alpha", "omega"] );
# <LI>alpha</LI> <LI>omega</LI>
#-----------------------------
use CGI qw(:standard :html3);
%hash = (
"Wisconsin" => [ "Superior", "Lake Geneva", "Madison" ],
"Colorado" => [ "Denver", "Fort Collins", "Boulder" ],
"Texas" => [ "Plano", "Austin", "Fort Stockton" ],
"California" => [ "Sebastopol", "Santa Rosa", "Berkeley" ],
);
$\ = "\n";
print "<TABLE> <CAPTION>Cities I Have Known</CAPTION>";
print Tr(th [qw(State Cities)]);
for $k (sort keys %hash) {
print Tr(th($k), td( [ sort @{$hash{$k}} ] ));
}
print "</TABLE>";
#-----------------------------
# <TABLE> <CAPTION>Cities I Have Known</CAPTION>
#
# <TR><TH>State</TH> <TH>Cities</TH></TR>
#
# <TR><TH>California</TH> <TD>Berkeley</TD> <TD>Santa Rosa</TD>
#
# <TD>Sebastopol</TD> </TR>
#
# <TR><TH>Colorado</TH> <TD>Boulder</TD> <TD>Denver</TD>
#
# <TD>Fort Collins</TD> </TR>
#
# <TR><TH>Texas</TH> <TD>Austin</TD> <TD>Fort Stockton</TD>
#
# <TD>Plano</TD></TR>
#
# <TR><TH>Wisconsin</TH> <TD>Lake Geneva</TD> <TD>Madison</TD>
#
# <TD>Superior</TD></TR>
#
# </TABLE>
#-----------------------------
print table
caption('Cities I have Known'),
Tr(th [qw(State Cities)]),
map { Tr(th($_), td( [ sort @{$hash{$_}} ] )) } sort keys %hash;
#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# salcheck - check for salaries
use DBI;
use CGI qw(:standard :html3);
$limit = param("LIMIT");
print header(), start_html("Salary Query"),
h1("Search"),
start_form(),
p("Enter minimum salary", textfield("LIMIT")),
submit(),
end_form();
if (defined $limit) {
$dbh = DBI->connect("dbi:mysql:somedb:server.host.dom:3306",
"username", "password")
or die "Connecting: $DBI::errstr";
$sth = $dbh->prepare("SELECT name,salary FROM employees
WHERE salary > $limit")
or die "Preparing: ", $dbh->errstr;
$sth->execute
or die "Executing: ", $sth->errstr;
print h1("Results"), "<TABLE BORDER=1>";
while (@row = $sth->fetchrow()) {
print Tr( td( \@row ) );
}
print "</TABLE>\n";
$sth->finish;
$dbh->disconnect;
}
print end_html();
#-----------------------------
|
#----------------------------- $url = "http://www.perl.com/CPAN/"; print "Location: $url\n\n"; exit; #----------------------------- # download the following standalone program #!/usr/bin/perl -w # oreobounce - set a cookie and redirect the browser use CGI qw(:cgi); $oreo = cookie( -NAME => 'filling', -VALUE => "vanilla crème", -EXPIRES => '+3M', # M for month, m for minute -DOMAIN => '.perl.com'); $whither = "http://somewhere.perl.com/nonesuch.html"; print redirect( -URL => $whither, -COOKIE => $oreo); #----------------------------- #Status: 302 Moved Temporarily # #Set-Cookie: filling=vanilla%20cr%E4me; domain=.perl.com; # # expires=Tue, 21-Jul-1998 11:58:55 GMT # #Date: Tue, 21 Apr 1998 11:55:55 GMT # #Location: http://somewhere.perl.com/nonesuch.html # #Content-Type: text/html # #B<<blank line here>> #----------------------------- # download the following standalone program #!/usr/bin/perl # os_snipe - redirect to a Jargon File entry about current OS $dir = 'http://www.wins.uva.nl/%7Emes/jargon'; for ($ENV{HTTP_USER_AGENT}) { $page = /Mac/ && 'm/Macintrash.html' || /Win(dows )?NT/ && 'e/evilandrude.html' || /Win|MSIE|WebTV/ && 'm/MicroslothWindows.html' || /Linux/ && 'l/Linux.html' || /HP-UX/ && 'h/HP-SUX.html' || /SunOS/ && 's/ScumOS.html' || 'a/AppendixB.html'; } print "Location: $dir/$page\n\n"; #----------------------------- use CGI qw(:standard); print header( -STATUS => '204 No response' ); #----------------------------- #Status: 204 No response # #Content-Type: text/html # #<blank line here> #----------------------------- #!/bin/sh cat <<EOCAT Status: 204 No response EOCAT #----------------------------- |
#----------------------------- # download the following standalone program #!/usr/bin/perl -w # dummyhttpd - start an HTTP daemon and print what the client sends use strict; use HTTP::Daemon; # need LWP-5.32 or better my $server = HTTP::Daemon->new(Timeout => 60); print "Please contact me at: <URL:", $server->url, ">\n"; while (my $client = $server->accept) { CONNECTION: while (my $answer = $client->get_request) { print $answer->as_string; $client->autoflush; RESPONSE: while (<STDIN>) { last RESPONSE if $_ eq ".\n"; last CONNECTION if $_ eq "..\n"; print $client $_; } print "\nEOF\n"; } print "CLOSE: ", $client->reason, "\n"; $client->close; undef $client; } #----------------------------- #http://somewhere.com/cgi-bin/whatever #----------------------------- #http://somewhere.com:8989/cgi-bin/whatever #----------------------------- #% telnet www.perl.com 80 #GET /bogotic HTTP/1.0 # #<blank line here> # #HTTP/1.1 404 File Not Found # #Date: Tue, 21 Apr 1998 11:25:43 GMT # #Server: Apache/1.2.4 # #Connection: close # #Content-Type: text/html # # #<HTML><HEAD> # #<TITLE>404 File Not Found</TITLE> # #</HEAD><BODY> # #<H1>File Not Found</H1> # #The requested URL /bogotic was not found on this server.<P> # #</BODY></HTML> #----------------------------- % GET -esuSU http://mox.perl.com/perl/bogotic # GET http://language.perl.com/bogotic # # Host: mox.perl.com # # User-Agent: lwp-request/1.32 # # # GET http://mox.perl.com/perl/bogotic --> 302 Moved Temporarily # # GET http://www.perl.com/perl/bogotic --> 302 Moved Temporarily # # GET http://language.perl.com/bogotic --> 404 File Not Found # # Connection: close # # Date: Tue, 21 Apr 1998 11:29:03 GMT # # Server: Apache/1.2.4 # # Content-Type: text/html # # Client-Date: Tue, 21 Apr 1998 12:29:01 GMT # # Client-Peer: 208.201.239.47:80 # # Title: Broken perl.com Links # # # <HTML> # # <HEAD><TITLE>An Error Occurred</TITLE></HEAD> # # <BODY> # # <H1>An Error Occurred</h1> # # 404 File Not Found # # </BODY> # # </HTML> #----------------------------- |
#-----------------------------
$preference_value = cookie("preference name");
#-----------------------------
$packed_cookie = cookie( -NAME => "preference name",
-VALUE => "whatever you'd like",
-EXPIRES => "+2y");
#-----------------------------
print header(-COOKIE => $packed_cookie);
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# ic_cookies - sample CGI script that uses a cookie
use CGI qw(:standard);
use strict;
my $cookname = "favorite ice cream";
my $favorite = param("flavor");
my $tasty = cookie($cookname) || 'mint';
unless ($favorite) {
print header(), start_html("Ice Cookies"), h1("Hello Ice Cream"),
hr(), start_form(),
p("Please select a flavor: ", textfield("flavor",$tasty)),
end_form(), hr();
exit;
}
my $cookie = cookie(
-NAME => $cookname,
-VALUE => $favorite,
-EXPIRES => "+2y",
);
print header(-COOKIE => $cookie),
start_html("Ice Cookies, #2"),
h1("Hello Ice Cream"),
p("You chose as your favorite flavor `$favorite'.");
#-----------------------------
|
#-----------------------------
print textfield("SEARCH"); # previous SEARCH value is the default
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -wT
# who.cgi - run who(1) on a user and format the results nicely
$ENV{IFS}='';
$ENV{PATH}='/bin:/usr/bin';
use CGI qw(:standard);
# print search form
print header(), start_html("Query Users"), h1("Search");
print start_form(), p("Which user?", textfield("WHO")); submit(), end_form();
# print results of the query if we have someone to look for
$name = param("WHO");
if ($name) {
print h1("Results");
$html = '';
# call who and build up text of response
foreach (`who`) {
next unless /^$name\s/o; # only lines matching $name
s/&/&/g; # escape HTML
s/</</g;
s/>/>/g;
$html .= $_;
}
# nice message if we didn't find anyone by that name
$html = $html || "$name is not logged in";
print pre($html);
}
print end_html();
#-----------------------------
|
#-----------------------------
use CGI qw(:standard);
print hidden("bacon");
#-----------------------------
print submit(-NAME => ".State", -VALUE => "Checkout");
#-----------------------------
sub to_page { return submit( -NAME => ".State", -VALUE => shift ) }
#-----------------------------
$page = param(".State") || "Default";
#-----------------------------
if ($page eq "Default") {
front_page();
} elsif ($page eq "Checkout") {
checkout();
} else {
no_such_page(); # when we get a .State that doesn't exist
}
#-----------------------------
%States = (
'Default' => \&front_page,
'Shirt' => \&shirt,
'Sweater' => \&sweater,
'Checkout' => \&checkout,
'Card' => \&credit_card,
'Order' => \&order,
'Cancel' => \&front_page,
);
if ($States{$page}) {
$States{$page}->(); # call the correct subroutine
} else {
no_such_page();
}
#-----------------------------
while (($state, $sub) = each %States) {
$sub->( $page eq $state );
}
#-----------------------------
sub t_shirt {
my $active = shift;
unless ($active) {
print hidden("size"), hidden("color");
return;
}
print p("You want to buy a t-shirt?");
print p("Size: ", popup_menu('size', [ qw(XL L M S XS) ]));
print p("Color:", popup_menu('color', [ qw(Black White) ]));
print p( to_page("Shoes"), to_page("Checkout") );
}
#-----------------------------
print header("Program Title"), start_html();
print standard_header(), begin_form();
while (($state, $sub) = each %States) {
$sub->( $page eq $state );
}
print standard_footer(), end_form(), end_html();
#-----------------------------
|
#-----------------------------
# first open and exclusively lock the file
open(FH, ">>/tmp/formlog") or die "can't append to formlog: $!";
flock(FH, 2) or die "can't flock formlog: $!";
# either using the procedural interface
use CGI qw(:standard);
save_parameters(*FH); # with CGI::save
# or using the object interface
use CGI;
$query = CGI->new();
$query->save(*FH);
close(FH) or die "can't close formlog: $!";
#-----------------------------
use CGI qw(:standard);
open(MAIL, "|/usr/lib/sendmail -oi -t") or die "can't fork sendmail: $!";
print MAIL <<EOF;
From: $0 (your cgi script)
To: hisname\@hishost.com
Subject: mailed form submission
EOF
save_parameters(*MAIL);
close(MAIL) or die "can't close sendmail: $!";
#-----------------------------
param("_timestamp", scalar localtime);
param("_environs", %ENV);
#-----------------------------
use CGI;
open(FORMS, "< /tmp/formlog") or die "can't read formlog: $!";
flock(FORMS, 1) or die "can't lock formlog: $!";
while ($query = CGI->new(*FORMS)) {
last unless $query->param(); # means end of file
%his_env = $query->param('_environs');
$count += $query->param('items requested')
unless $his_env{REMOTE_HOST} =~ /(^|\.)perl\.com$/
}
print "Total orders: $count\n";
#-----------------------------
|
#----------------------------- # download the following standalone program #!/usr/bin/perl -w # chemiserie - simple CGI shopping for shirts and sweaters use strict; use CGI qw(:standard); use CGI::Carp qw(fatalsToBrowser); my %States; # state table mapping pages to functions my $Current_Screen; # the current screen # Hash of pages and functions. %States = ( 'Default' => \&front_page, 'Shirt' => \&shirt, 'Sweater' => \&sweater, 'Checkout' => \&checkout, 'Card' => \&credit_card, 'Order' => \&order, 'Cancel' => \&front_page, ); $Current_Screen = param(".State") || "Default"; die "No screen for $Current_Screen" unless $States{$Current_Screen}; # Generate the current page. standard_header(); while (my($screen_name, $function) = each %States) { $function->($screen_name eq $Current_Screen); } standard_footer(); exit; ################################ # header, footer, menu functions ################################ sub standard_header { print header(), start_html(-Title => "Shirts", -BGCOLOR=>"White"); print start_form(); # start_multipart_form() if file upload } sub standard_footer { print end_form(), end_html() } sub shop_menu { print p(defaults("Empty My Shopping Cart"), to_page("Shirt"), to_page("Sweater"), to_page("Checkout")); } ############################# # subroutines for each screen ############################# # The default page. sub front_page { my $active = shift; return unless $active; print "<H1>Hi!</H1>\n"; print "Welcome to our Shirt Shop! Please make your selection from "; print "the menu below.\n"; shop_menu(); } # Page to order a shirt from. sub shirt { my $active = shift; my @sizes = qw(XL L M S); my @colors = qw(Black White); my ($size, $color, $count) = (param("shirt_size"), param("shirt_color"), param("shirt_count")); # sanity check if ($count) { $color = $colors[0] unless grep { $_ eq $color } @colors; $size = $sizes[0] unless grep { $_ eq $size } @sizes; param("shirt_color", $color); param("shirt_size", $size); } unless ($active) { print hidden("shirt_size") if $size; print hidden("shirt_color") if $color; print hidden("shirt_count") if $count; return; } print h1("T-Shirt"); print p("What a shirt! This baby is decked out with all the options.", "It comes with full luxury interior, cotton trim, and a collar", "to make your eyes water! Unit price: \$33.00"); print h2("Options"); print p("How Many?", textfield("shirt_count")); print p("Size?", popup_menu("shirt_size", \@sizes ), "Color?", popup_menu("shirt_color", \@colors)); shop_menu(); } # Page to order a sweater from. sub sweater { my $active = shift; my @sizes = qw(XL L M); my @colors = qw(Chartreuse Puce Lavender); my ($size, $color, $count) = (param("sweater_size"), param("sweater_color"), param("sweater_count")); # sanity check if ($count) { $color = $colors[0] unless grep { $_ eq $color } @colors; $size = $sizes[0] unless grep { $_ eq $size } @sizes; param("sweater_color", $color); param("sweater_size", $size); } unless ($active) { print hidden("sweater_size") if $size; print hidden("sweater_color") if $color; print hidden("sweater_count") if $count; return; } print h1("Sweater"); print p("Nothing implies preppy elegance more than this fine", "sweater. Made by peasant workers from black market silk,", "it slides onto your lean form and cries out ``Take me,", "for I am a god!''. Unit price: \$49.99."); print h2("Options"); print p("How Many?", textfield("sweater_count")); print p("Size?", popup_menu("sweater_size", \@sizes)); print p("Color?", popup_menu("sweater_color", \@colors)); shop_menu(); } # Page to display current order for confirmation. sub checkout { my $active = shift; return unless $active; print h1("Order Confirmation"); print p("You ordered the following:"); print order_text(); print p("Is this right? Select 'Card' to pay for the items", "or 'Shirt' or 'Sweater' to continue shopping."); print p(to_page("Card"), to_page("Shirt"), to_page("Sweater")); } # Page to gather credit-card information. sub credit_card { my $active = shift; my @widgets = qw(Name Address1 Address2 City Zip State Phone Card Expiry); unless ($active) { print map { hidden($_) } @widgets; return; } print pre(p("Name: ", textfield("Name")), p("Address: ", textfield("Address1")), p(" ", textfield("Address2")), p("City: ", textfield("City")), p("Zip: ", textfield("Zip")), p("State: ", textfield("State")), p("Phone: ", textfield("Phone")), p("Credit Card #: ", textfield("Card")), p("Expiry: ", textfield("Expiry"))); print p("Click on 'Order' to order the items. Click on 'Cancel' to return shopping."); print p(to_page("Order"), to_page("Cancel")); } # Page to complete an order. sub order { my $active = shift; unless ($active) { return; } # you'd check credit card values here print h1("Ordered!"); print p("You have ordered the following toppings:"); print order_text(); print p(defaults("Begin Again")); } # Returns HTML for the current order ("You have ordered ...") sub order_text { my $html = ''; if (param("shirt_count")) { $html .= p("You have ordered ", param("shirt_count"), " shirts of size ", param("shirt_size"), " and color ", param("shirt_color"), "."); } if (param("sweater_count")) { $html .= p("You have ordered ", param("sweater_count"), " sweaters of size ", param("sweater_size"), " and color ", param("sweater_color"), "."); } $html = p("Nothing!") unless $html; $html .= p("For a total cost of ", calculate_price()); return $html; } sub calculate_price { my $shirts = param("shirt_count") || 0; my $sweaters = param("sweater_count") || 0; return sprintf("\$%.2f", $shirts*33 + $sweaters * 49.99); } sub to_page { submit(-NAME => ".State", -VALUE => shift) } #----------------------------- |