#----------------------------- # 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) } #----------------------------- |