home *** CD-ROM | disk | FTP | other *** search
/ Internet 1996 World Exposition / park.org.s3.amazonaws.com.7z / park.org.s3.amazonaws.com / Pavilions / BrainOpera / cgi-bin / cgi-hacks.pl < prev    next >
Perl Script  |  2017-09-21  |  6KB  |  185 lines
  1. #!/usr/local/bin/perl
  2.  
  3. # STOLE THE FOLLOWING FROM ai cluster /com/doc/web-support/cgi-hacks 
  4.  
  5. # Useful routines for writing CGI scripts (and general puttering about)
  6.  
  7. # '&find_form_args' takes as (first) argument the expected field names
  8. # separated by '|', as in:
  9.  
  10. #        &find_form_args("name|address|phone|wants_pepperoni");
  11.  
  12. # On return, the variables whose names are those of the form fields are
  13. # set to the appropriate values (unescaped, if necessary, so that for
  14. # type-in fields what you get is what the user typed).  These would be
  15. # $name, $address, $phone, and $wants_pepperoni in the above example.
  16.  
  17. # Second argument, if any, is the name of an associative array, indexed
  18. # by field-name, which gets the values supplied for unexpected fields (i.e.,
  19. # those with names not listed in the first argument).  If no second
  20. # argument is supplied, and an unexpected field is found, we &cgidie;
  21. # this is to help catch misspellings, and also may help with security
  22. # (so that a malicious client can't cause arbitrary variables to be set,
  23. # with potentially disruptive effects).  
  24.  
  25. # Return value is true if we clearly got arguments, false if the
  26. # caller looked as if he was looking for a coversheet.  This is to
  27. # facilitate such stuff as:
  28.  
  29. #   do { print <<EOF; exit(0); } unless (&find_form_args (...));
  30. #   Content-type: text/html
  31. #
  32. #   ... contents of cover sheet
  33. #   EOF
  34.  
  35. sub find_form_args
  36. {
  37.   local($var_ptrn, $catch_array) = @_;
  38.   local($var_rx) = '^(' . $var_ptrn . ')=';
  39.  
  40.   local($is_get) = ($ENV{'REQUEST_METHOD'} eq 'GET');
  41.   local($qry);
  42.   local($nvars) = 0;
  43.  
  44.   if ($is_get) { $qry = $ENV{'QUERY_STRING'}; }
  45.   else { read (STDIN, $qry, $ENV{'CONTENT_LENGTH'}); } 
  46.  
  47.   $qry =~ s/\+/ /g;
  48.  
  49.   foreach (split (/\&/, $qry))
  50.   {
  51.     if (s/$var_rx//)
  52.       { eval "\$$1 = &unescape(\$_);"; }
  53.     elsif ($catch_array ne '' && s/^([^=]*)=//)
  54.       { eval "\$$catch_array{&unescape(\$1)} = &unescape(\$_);"; }
  55.     else
  56.       { &cgidie ("Unexpected field received for this form: $_"); }
  57.  
  58.     ++$nvars;
  59.   }
  60.  
  61.   # Return...
  62.   ($nvars > 0) || (! $is_get);
  63. }
  64.  
  65. # Error handling ... the well-tempered CGI script doesn't croak without
  66. # making sure that someone has a chance to see its dying gasp; that means
  67. # giving it a proper Content-type line (and hoping it doesn't get too
  68. # screwed up).
  69.  
  70. # The first argument is an error message, which gets potential HTML syntax
  71. # ('<', '>', '&') escaped out so that it is seen by the user verbatim.  The
  72. # second argument is optional; if present, it is treated as HTML (i.e.,
  73. # left as is), for scripts which want to die a particularly elaborate
  74. # death.
  75.  
  76. # Note that if the script has already produced output before calling this,
  77. # things will be a little garbled all around, but still somewhat better than
  78. # nothing.
  79.  
  80. sub cgidie
  81. {
  82.   local ($header, $body) = @_;
  83.   $header = &HTMLize ($header);
  84.  
  85.   if ($body eq '') { $body = $header; $header = '' }
  86.   if ($header eq '') { $header = "Error in processing your request"; }
  87.  
  88.   print <<EOF;
  89. Content-type: text/html
  90.  
  91. <title> $header </title>
  92. <h1> $header </h1>
  93. $body
  94. EOF
  95.   exit(1);
  96. }
  97.  
  98. # Self-referencing URL generation... the value of this function is, loosely
  99. # speaking, the URL of the directory which the script resides in ... more
  100. # precisely, it is the script's own URL (sans any PATH_INFO), with the name
  101. # of the script itself, and the preceding '/', stripped off.
  102.  
  103. sub my_dir_url
  104. {
  105.   local ($sname) = $ENV{"SERVER_NAME"};
  106.   local ($sport) = $ENV{"SERVER_PORT"};
  107.   local ($hroot) = &dirstring($ENV{"SCRIPT_NAME"});
  108.  
  109.   "http://$sname:$sport$hroot"
  110. }
  111.  
  112. # Useful string conversions...
  113.  
  114. # '&unescape' translates the %.. escapes used in URLs back into what the user
  115. # originally typed.
  116.  
  117. # '&HTMLize' translates a random ASCII string into HTML by HTML-escaping
  118. # stuff that might be mistaken for HTML syntax.
  119.  
  120. # '&capitalize' does the obvious.
  121.  
  122. sub unescape { local ($_) = @_; s/%(..)/pack ('H2', $1)/eg; $_ }
  123. sub HTMLize { local ($_) = @_; s/\&/&/g; s/\>/>/g; s/\</</g; $_; }
  124. sub capitalize { local($_) = @_; local ($l);
  125.                  y/A-Z/a-z/; s+[a-z]+$l = $&; $l =~ y/a-z/A-Z/; $l+e; $_ }
  126.  
  127. # Wrestling with filenames 
  128. # '&nodirs' strips the directories off of a pathname.
  129. # '&dirstring' returns what &nodirs strips off (less the final '/');
  130.  
  131. sub dirstring { local ($_) = @_; s+/[^/]*$++; $_ }
  132. sub nodirs { local ($_) = @_; s+^.*/++; $_ }
  133.  
  134. # Routines to deal with the filesystem.
  135. # Note that most of these die if they can't do their jobs.
  136.  
  137. # Exceptions ... 'read_file and 'print_file' return distinctive comments
  138. # if they can't get at the file, which (I expect to) show up in the final
  139. # output...
  140.  
  141. sub create_file {
  142.   local ($file, $contents) = @_; local (*dummy);
  143.   open (dummy, ">$file") || &cgidie ("Couldn't create $file");
  144.   ( (print dummy $contents) || &cgidie ("Couldn't write to $file"))
  145.        unless ($contents eq '');
  146.   close dummy;
  147. }
  148.  
  149. sub copy_file {
  150.   local ($dest, $source) = @_;
  151.   local (*dst, *src);
  152.  
  153.   open (dst, ">$dest") || &cgidie("Couldn't write to $dest");
  154.   open (src, "$source") || &cgidie("Couldn't read from $source");
  155.   
  156.   while (<src>) { (print dst) || &cgidie ("Couldn't write to $dest"); }
  157.   close (dst); close (src);
  158. }
  159.  
  160. sub print_file {
  161.   local ($name) = @_; local (*file); local ($hname) = &HTMLize($name);
  162.   if (! open (file, $name)) { print "<b>Couldn't open $hname!!!</b>"; return }
  163.   while (<file>) { print }
  164.   close (file)
  165. }
  166.  
  167. sub read_file {
  168.   local ($name) = @_; local (*file, $it); local ($hname) = &HTMLize($name);
  169.   if (! open (file, $name)) { return "<b>Couldn't open $hname!!!</b>"; }
  170.   $it = '';
  171.   while (<file>) { $it .= $_ }
  172.   close (file);
  173.   $it
  174. }
  175.  
  176. 1;
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.