"Fossies" - the Fresh Open Source Software Archive

Member "formmail_modules-3.14m1/lib/CGI/NMS/Script.pm" (11 Aug 2004, 10173 Bytes) of package /linux/www/old/formmail_modules-3.14m1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Script.pm" see the Fossies "Dox" file reference documentation.

    1 package CGI::NMS::Script;
    2 use strict;
    3 
    4 use CGI;
    5 use POSIX qw(locale_h strftime);
    6 use CGI::NMS::Charset;
    7 
    8 =head1 NAME
    9 
   10 CGI::NMS::Script - base class for NMS script modules
   11 
   12 =head1 SYNOPSYS
   13 
   14   use base qw(CGI::NMS::Script);
   15 
   16   ...
   17  
   18 =head1 DESCRIPTION
   19 
   20 This module is a base class for the C<CGI::NMS::Script::*> modules,
   21 which implement plugin replacements for Matt Wright's Perl CGI
   22 scripts.
   23 
   24 =head1 CONSTRUCTORS
   25 
   26 =over
   27 
   28 =item new ( CONFIG )
   29 
   30 Creates a new C<CGI::NMS::Script> object and performs compile time
   31 initialisation.
   32 
   33 CONFIG is a key,value,key,value list, which will be stored as a hash
   34 within the object, under the name C<CFG>.
   35 
   36 =cut
   37 
   38 sub new {
   39   my ($pkg, @cfg) = @_;
   40 
   41   my $self = bless {}, $pkg;
   42 
   43   $self->{CFG} = {
   44     DEBUGGING           => 0,
   45     emulate_matts_code  => 0,
   46     secure              => 1,
   47     locale              => '',
   48     charset             => 'iso-8859-1',
   49     style               => '',
   50     cgi_post_max        => 1000000,
   51     cgi_disable_uploads => 1,
   52 
   53     $self->default_configuration,
   54 
   55     @cfg
   56   };
   57 
   58   $self->{Charset} = CGI::NMS::Charset->new( $self->{CFG}{charset} );
   59 
   60   $self->init;
   61 
   62   return $self;
   63 }
   64 
   65 =back
   66 
   67 =item CONFIGURATION SETTINGS
   68 
   69 Values for the following configuration settings can be passed to new().
   70 
   71 Subclasses for different NMS scripts will define their own set of
   72 configuration settings, but they all inherit these as well.
   73 
   74 =over
   75 
   76 =item C<DEBUGGING>
   77 
   78 If this is set to a true value, then the error message will be displayed
   79 in the browser if the script suffers a fatal error.  This should be set
   80 to 0 once the script is in service, since error messages may contain
   81 sensitive information such as file paths which could be useful to
   82 attackers.
   83 
   84 Default: 0
   85 
   86 =item C<name_and_version>
   87 
   88 The name and version of the NMS script, as a single string.
   89 
   90 =item C<emulate_matts_code>
   91 
   92 When this variable is set to a true value (e.g. 1) the script will work
   93 in exactly the same way as its counterpart at Matt's Script Archive. If
   94 it is set to a false value (e.g. 0) then more advanced features and
   95 security checks are switched on. We do not recommend changing this 
   96 variable to 1, as the resulting drop in security may leave your script
   97 open to abuse.
   98 
   99 Default: 0
  100 
  101 =item C<secure>
  102 
  103 When this variable is set to a true value (e.g. 1) many additional
  104 security features are turned on.  We do not recommend changing this
  105 variable to 0, as the resulting drop in security may leave your script
  106 open to abuse.
  107 
  108 Default: 1
  109 
  110 =item C<locale>
  111 
  112 This determines the language that is used in the format_date() method -
  113 by default this is blank and the language will probably be English.
  114 
  115 Default: ''
  116 
  117 =item C<charset>
  118 
  119 The character set to use for output documents.
  120 
  121 Default: 'iso-8859-1'
  122 
  123 =item C<style>
  124 
  125 This is the URL of a CSS stylesheet which will be used for script
  126 generated messages.  This should probably be the same as the one that
  127 you use for all the other pages.  This should be a local absolute URI
  128 fragment.  Set C<style> to 0 or the empty string if you don't want to
  129 use style sheets.
  130 
  131 Default: '';
  132 
  133 =item C<cgi_post_max>
  134 
  135 The variable C<$CGI::POST_MAX> is gets set to this value before the
  136 request is handled.
  137 
  138 Default: 1000000
  139 
  140 =item C<cgi_disable_uploads>
  141 
  142 The variable C<CGI::DISABLE_UPLOADS> gets set to this value before
  143 the request is handled.
  144 
  145 Default: 1
  146 
  147 =item C<no_xml_doc_header>
  148 
  149 If this is set to a true value then the output_cgi_html_header() method
  150 will omit the XML document header that it would normally output.  This
  151 means that the output document will not be strictly valid XHTML, but it
  152 may work better in some older browsers.
  153 
  154 Default: not set
  155 
  156 =item C<no_doctype_doc_header>
  157 
  158 If this is set to a true value then the output_cgi_html_header() method
  159 will omit the DOCTYPE document header that it would normally output.
  160 This means that the output document will not be strictly valid XHTML, but
  161 it may work better in some older browsers.
  162 
  163 Default: not set
  164 
  165 =item C<no_xmlns_doc_header>
  166 
  167 If this is set to a true value then the output_cgi_html_header() method
  168 will omit the C<xmlns> attribute from the opening C<html> tag that it
  169 outputs.
  170 
  171 =back
  172 
  173 =head1 METHODS
  174 
  175 =over
  176 
  177 =item request ()
  178 
  179 This is the method that the CGI script invokes once for each run of the
  180 CGI.  This implementation sets up some things that are common to all NMS
  181 scripts and then invokes the virtual method handle_request() to do the
  182 script specific processing.
  183 
  184 =cut
  185 
  186 sub request {
  187   my ($self) = @_;
  188 
  189   local ($CGI::POST_MAX, $CGI::DISABLE_UPLOADS);
  190   $CGI::POST_MAX        = $self->{CFG}{cgi_post_max};
  191   $CGI::DISABLE_UPLOADS = $self->{CFG}{cgi_disable_uploads};
  192 
  193   $ENV{PATH} =~ /(.*)/m or die;
  194   local $ENV{PATH} = $1;
  195   local $ENV{ENV}  = '';
  196 
  197   $self->{CGI} = CGI->new;
  198   $self->{Done_Header} = 0;
  199 
  200   my $old_locale;
  201   if ($self->{CFG}{locale}) {
  202     $old_locale = POSIX::setlocale( LC_TIME );
  203     POSIX::setlocale( LC_TIME, $self->{CFG}{locale} );
  204   }
  205 
  206   eval { local $SIG{__DIE__} ; $self->handle_request };
  207   my $err = $@;
  208 
  209   if ($self->{CFG}{locale}) {
  210     POSIX::setlocale( LC_TIME, $old_locale );
  211   }
  212 
  213   if ($err) {
  214     my $message;
  215     if ($self->{CFG}{DEBUGGING}) {
  216       $message = $self->escape_html($err);
  217     }
  218     else {
  219       $message = "See the web server's error log for details";
  220     }
  221 
  222     $self->output_cgi_html_header;
  223     print <<END;
  224  <head>
  225   <title>Error</title>
  226  </head>
  227  <body>
  228   <h1>Application Error</h1>
  229   <p>
  230    An error has occurred in the program
  231   </p>
  232   <p>
  233    $message
  234   </p>
  235  </body>
  236 </html>
  237 END
  238 
  239     $self->warn($err);
  240   }
  241 }
  242 
  243 =item output_cgi_html_header ()
  244 
  245 Prints the CGI content-type header and the standard header lines for
  246 an XHTML document, unless the header has already been output.
  247 
  248 =cut
  249 
  250 sub output_cgi_html_header {
  251   my ($self) = @_;
  252 
  253   return if $self->{Done_Header};
  254 
  255   $self->output_cgi_header;
  256 
  257   unless ($self->{CFG}{no_xml_doc_header}) {
  258     print qq|<?xml version="1.0" encoding="$self->{CFG}{charset}"?>\n|;
  259   }
  260 
  261   unless ($self->{CFG}{no_doctype_doc_header}) {
  262     print <<END;
  263 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
  264     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
  265 END
  266   }
  267 
  268   if ($self->{CFG}{no_xmlns_doc_header}) {
  269     print "<html>\n";
  270   }
  271   else {
  272     print qq|<html xmlns="http://www.w3.org/1999/xhtml">\n|;
  273   }
  274 
  275   $self->{Done_Header} = 1;
  276 }
  277 
  278 =item output_cgi_header ()
  279 
  280 Outputs the CGI header for an HTML document.
  281 
  282 =cut
  283 
  284 sub output_cgi_header {
  285   my ($self) = @_;
  286 
  287   my $charset = $self->{CFG}{charset};
  288   my $cgi = $self->cgi_object;
  289 
  290   if ($CGI::VERSION >= 2.57) {
  291     # This is the correct way to set the charset
  292     print $cgi->header('-type'=>'text/html', '-charset'=>$charset);
  293   }
  294   else {
  295     # However CGI.pm older than version 2.57 doesn't have the
  296     # -charset option so we cheat:
  297     print $cgi->header('-type' => "text/html; charset=$charset");
  298   }
  299 }
  300 
  301 =item output_style_element ()
  302 
  303 Outputs the C<link rel=stylesheet> header line, if a style sheet URL is
  304 configured.
  305 
  306 =cut
  307 
  308 sub output_style_element {
  309   my ($self) = @_;
  310 
  311   if ($self->{CFG}{style}) {
  312     print qq|<link rel="stylesheet" type="text/css" href="$self->{CFG}{style}" />\n|;
  313   }
  314 }
  315 
  316 =item cgi_object ()
  317 
  318 Returns a reference to the C<CGI.pm> object for this request.
  319 
  320 =cut
  321 
  322 sub cgi_object {
  323   my ($self) = @_;
  324 
  325    return $self->{CGI};
  326 }
  327 
  328 =item param ( ARGS )
  329 
  330 Invokes the param() method of the C<CGI.pm> object for this request.
  331 
  332 =cut
  333 
  334 sub param {
  335     my $self = shift;
  336 
  337     $self->cgi_object->param(@_);
  338 }
  339 
  340 =item escape_html ( INPUT )
  341 
  342 Returns a copy of the string INPUT with all HTML metacharacters escaped.
  343 
  344 =cut
  345 
  346 sub escape_html {
  347   my ($self, $input) = @_;
  348 
  349   return $self->{Charset}->escape($input);
  350 }
  351 
  352 =item strip_nonprint ( INPUT )
  353 
  354 Returns a copy of the string INPUT with runs of nonprintable characters
  355 replaced by spaces.
  356 
  357 =cut
  358 
  359 sub strip_nonprint {
  360   my ($self, $input) = @_;
  361 
  362   &{ $self->{Charset}->strip_nonprint_coderef }($input);
  363 }
  364 
  365 =item format_date ( FORMAT_STRING [,GMT_OFFSET] )
  366 
  367 Returns the current time and date formated by C<strftime> according
  368 to the format string FORMAT_STRING.
  369 
  370 If GMT_OFFSET is undefined or the empty string then local time is
  371 used.  Otherwise GMT is used, with an offset of GMT_OFFSET hours.
  372 
  373 =cut
  374 
  375 sub format_date {
  376   my ($self, $format_string, $gmt_offset) = @_;
  377 
  378   if (defined $gmt_offset and length $gmt_offset) {
  379     return strftime $format_string, gmtime(time + 60*60*$gmt_offset);
  380   }
  381   else {
  382     return strftime $format_string, localtime;
  383   }
  384 }
  385 
  386 =item name_and_version ()
  387 
  388 Returns the NMS script version string that was passed to the constructor.
  389 
  390 =cut
  391 
  392 sub name_and_version {
  393     my ($self) = @_;
  394 
  395     return $self->{CFG}{name_and_version};
  396 }
  397 
  398 =item warn ( MESSAGE )
  399 
  400 Appends a message to the web server's error log.
  401 
  402 =cut
  403 
  404 sub warn {
  405     my ($self, $msg) = @_;
  406 
  407     if ($ENV{SCRIPT_NAME} =~ m#^([\w\-\/\.\:]{1,100})$#) {
  408         $msg = "$1: $msg";
  409     }
  410 
  411     if ($ENV{REMOTE_ADDR} =~ /^\[?([\d\.\:a-f]{7,100})\]?$/i) {
  412         $msg = "[$1] $msg";
  413     }
  414 
  415     warn "$msg\n";
  416 }
  417 
  418 =back
  419 
  420 =head1 VIRTUAL METHODS
  421 
  422 Subclasses for individual NMS scripts must provide the following
  423 methods:
  424 
  425 =over
  426 
  427 =item default_configuration ()
  428 
  429 Invoked from new(), this method must return the default script
  430 configuration as a key,value,key,value list.  Configuration options
  431 passed to new() will override those set by this method.
  432 
  433 =item init ()
  434 
  435 Invoked from new(), this method can be used to do any script specific
  436 object initialisation.  There is a default implementation, which does
  437 nothing.
  438 
  439 =cut
  440 
  441 sub init {}
  442 
  443 =item handle_request ()
  444 
  445 Invoked from request(), this method is responsible for performing the
  446 bulk of the CGI processing.  Any fatal errors raised here will be
  447 trapped and treated according to the C<DEBUGGING> configuration setting.
  448 
  449 =back
  450 
  451 =head1 SEE ALSO
  452 
  453 L<CGI::NMS::Charset>, L<CGI::NMS::Script::FormMail>
  454 
  455 =head1 MAINTAINERS
  456 
  457 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
  458 
  459 To request support or report bugs, please email
  460 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
  461 
  462 =head1 COPYRIGHT
  463 
  464 Copyright 2003 London Perl Mongers, All rights reserved
  465 
  466 =head1 LICENSE
  467 
  468 This module is free software; you are free to redistribute it
  469 and/or modify it under the same terms as Perl itself.
  470 
  471 =cut
  472 
  473 1;
  474