"Fossies" - the Fresh Open Source Software Archive

Member "whois-5.5.2/bwInclude.pm" (8 Aug 2012, 7169 Bytes) of package /linux/privat/old/whois-5.5.2.tgz:


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.

    1 #
    2 # bwInclude.pm
    3 #
    4 # version 0.5a
    5 #  includes fixes for perl 5.8
    6 #
    7 # Copyright (c) 1995-2002 William E. Weinman
    8 # http://whois.bw.org/    
    9 #
   10 # This program is free software. You may modify and distribute it under
   11 # the same terms as perl itself.
   12 #
   13 
   14 package bwInclude;
   15 $VERSION = "0.5a";
   16 
   17 use IO::File;
   18 use IO::Pipe;
   19 
   20 sub new
   21 {
   22 my $proto = shift;
   23 my $class = ref($proto) || $proto;
   24 my $self = {};
   25 bless ($self, $class);
   26 $self->init(@_);
   27 return $self;
   28 }
   29 
   30 sub init
   31 {
   32 my $self = shift;
   33 my $arg = $_[0];
   34 
   35 ### handle different sorts of arguments ###
   36 
   37 # hash ref?
   38 if(ref($arg) eq 'HASH') {
   39   my %h = %$arg;
   40   foreach my $i (keys %h) { $self->{$i} = $h{$i}; }
   41   }
   42 
   43 # array? (hash but not ref)
   44 elsif ($_[1]) {
   45   while (@_) {
   46     my $k = shift;
   47     my $v = shift;
   48     $self->{$k} = $v;
   49     }
   50   }
   51 
   52 # scalar? (or nothing)
   53 else { $self->{FILENAME} = $arg || '' }
   54 
   55 return $self;
   56 }
   57 
   58 # set and get vars
   59 sub var
   60 {
   61 my $self = shift;
   62 my $name = shift or return '';
   63 my $value = shift;
   64 
   65 if(defined($value)) {
   66   $self->{VARS}{$name} = $value;
   67   }
   68 
   69 return $self->{VARS}{$name};
   70 }
   71 
   72 # wrapper for print self->spf
   73 sub pf
   74 {
   75 my $self = shift;
   76 my $filename = shift || $self->{FILENAME};
   77 return "No Filename! ($self, $filename)\n" unless $filename;
   78 
   79 STDOUT->autoflush(1);
   80 print $self->spf($filename);
   81 }
   82 
   83 # main routine -- recursively builds a string from file with includes
   84 sub spf
   85 {
   86 my $self = shift;
   87 
   88 my $filename = shift || $self->{FILENAME};
   89 return "No Filename! ($self, $filename)\n" unless $filename;
   90 
   91 # create the filename
   92 if(substr($filename, 1, 1) eq '/' and $ENV{DOCUMENT_ROOT}) {
   93   $filename = $ENV{DOCUMENT_ROOT} . $filename;
   94   }
   95 elsif($self->{DIR}) {
   96   $filename = "$self->{DIR}/$filename";
   97   }
   98 
   99 my $s = '';
  100 
  101 # this alows arbitrary perl code in the included file
  102 sub expand { 
  103   my $self = shift;
  104   my $v = shift;
  105   my $x;
  106   if (   $x = $self->var($v)     or defined $x) { $x }
  107   elsif ($x = eval("\$main::$v") or defined $x) { $x }
  108   elsif ($x = eval("\$$v")       or defined $x) { $x }
  109   elsif ($x = eval("\$ENV{$v}")  or defined $x) { $x }
  110   else { "Undefined Variable ($v)" }
  111   }
  112 
  113 # include virtual for running CGI ... 
  114 sub runprog { 
  115   my $self = shift;
  116   my $_qs = '';
  117   my $x = '';
  118   my $pn = shift || '';
  119 
  120   # $pn =~ m|^/| or $pn = '/' . $pn;  # imply the leading / if missing
  121   my $progpath = '';
  122   if($pn =~ m|^/|) {
  123     $progpath = "$ENV{DOCUMENT_ROOT}$pn";
  124     }
  125   else { 
  126     if($ENV{SCRIPT_FILENAME}) {   # derive the current directory if possible
  127       $ENV{SCRIPT_FILENAME} =~ m|(.*[\\/])|;
  128       $progpath = $1 || '';
  129       }
  130     else {
  131       $progpath = "./";    # a unixish guess
  132       }
  133     $progpath .= $pn;
  134     }
  135 
  136   ($progpath, $_qs) = split(/\?/, $progpath, 2);
  137   if ( -f $progpath ) {
  138     if ( -x $progpath ) {  # run it as CGI
  139       # save the environment
  140       my $sn = $ENV{SCRIPT_NAME}; 
  141       my $qs = $ENV{QUERY_STRING};
  142       my $cl = $ENV{CONTENT_LENGTH} if $ENV{CONTENT_LENGTH};
  143       my $ct = $ENV{CONTENT_TYPE} if $ENV{CONTENT_TYPE};
  144       my $rm = $ENV{REQUEST_METHOD} || 'GET';
  145 
  146       # set up the CGI environment
  147       $pn =~ /(.*)\?/ and $pn = $1; # SCRIPT_NAME has no query
  148       $ENV{SCRIPT_NAME} = $pn;
  149       $ENV{QUERY_STRING} = $_qs || '';
  150 
  151       # post method is always invalid for included CGI . . . 
  152       delete $ENV{CONTENT_LENGTH} if $ENV{CONTENT_LENGTH};
  153       delete $ENV{CONTENT_TYPE} if $ENV{CONTENT_TYPE};
  154       $ENV{REQUEST_METHOD} = 'GET';
  155 
  156       # make the path safe for the -T switch
  157       my $env_path = $ENV{PATH} || '';
  158       $ENV{PATH} = '';
  159 
  160       # makesure the progpath string is safe
  161       if ($progpath =~ /^([-\/\\\@\w.]+)$/) {
  162         $progpath = $1;
  163 
  164         # run it
  165         my $p = new IO::Pipe;
  166         $p->reader($progpath);
  167         while(<$p>) { $x .= $_ }
  168         $p->close;
  169 
  170         # can't use the mime header
  171         $x =~ s/^content-type:.*//i if $x;
  172         }
  173 
  174       else {
  175         $x = 'unsafe characters in exec';
  176         }
  177 
  178       # restore the environment
  179       $ENV{PATH} = $env_path;
  180       $ENV{SCRIPT_NAME} = $sn;
  181       $ENV{QUERY_STRING} = $qs;
  182       $ENV{CONTENT_LENGTH} = $cl if $cl;
  183       $ENV{CONTENT_TYPE} = $ct if $ct;
  184       $ENV{REQUEST_METHOD} = $rm;
  185       return $x;
  186       }
  187     else {  # display it
  188       return $self->spf($progpath);
  189       }
  190     } else { return "$progpath: $!" }
  191   }
  192 
  193 my $fh = IO::File->new("<$filename") or return $s = "cannot open $filename ($!)<br>\n";
  194 
  195 while (<$fh>)
  196   {
  197   $_ =~ s|\$([a-z0-9_:]+)\$|expand($self, $1)|gei;
  198   $_ =~ s|<!--#echo var="([^"]+)" -->|expand($self, $1)|ge;
  199   $_ =~ s|<!--#include virtual="([^"]+)" -->|runprog($self, $1)|ge;
  200   $s .= $_;
  201   }
  202 close $fh;
  203 
  204 return $s;
  205 }
  206 
  207 return 1;
  208 
  209 
  210 __END__
  211 
  212 =head1 NAME
  213 
  214 bwInclude - Included File Processing
  215 
  216 =head1 SYNOPSIS
  217 
  218   use bwInclude;
  219 
  220   $pf = new bwInclude;
  221 
  222   $pf = new bwInclude($filename);
  223 
  224   $pf = new bwInclude(DIR => $absolutepath)
  225 
  226   $pf = new bwInclude({
  227                    DIR => $absolutepath, 
  228                    FILENAME => $filename
  229                  })
  230 
  231 =head1 ABSTRACT
  232 
  233 Include perl objects in external files for processing the output of 
  234 CGI and other perl programs. 
  235 
  236 =head1 METHODS
  237 
  238 =over 4
  239 
  240 =item B<spf>
  241 
  242    $pf->spf;
  243    $pf->spf($filename);
  244 
  245 The B<spf> method reads a file, performs the appropriate replacements, 
  246 and returns the result. The file named in I<$filename> is used, if provided. 
  247 
  248 =item B<pf>
  249 
  250    $pf->pf;
  251    $pf->pf($filename);
  252 
  253 The B<pf> method calls B<spf> and sends the result to B<STDOUT>. 
  254 The file named in I<$filename> is used, if provided. 
  255 
  256 =item B<var>
  257 
  258    $pf->var($name);
  259    $pf->var($name, $value);
  260 
  261 The B<var> method sets or gets the value of a named variable. The variables 
  262 are stored in a hash associated with the bwInclude object. If there is a 
  263 value passed, the method sets the variable. The method always returns the 
  264 value, if any. 
  265 
  266 =back
  267 
  268 =head1 OBJECT DATA VARIABLES
  269 
  270 Object values can be specified in the initiation of the bwInclude object in 
  271 several ways: 
  272 
  273    $pf = new bwInclude($filename);
  274 
  275 If the new constructor is called with a single scalar argument, it is used for 
  276 the default filename. 
  277 
  278    $pf = new bwInclude(DIR => $path, FILENAME => $filename);
  279 
  280 If the new constructor is called with several arguments, they are taken to be 
  281 hash name/value pairs. These are used as object data variables (see below).
  282 
  283    $pf = new bwInclude( { DIR => $path, FILENAME => $filename } );
  284 
  285 Alternately the new constructor may be called with a hash reverence, 
  286 which will be used for object data variables (see below). 
  287 
  288 =over 4
  289 
  290 =head2 
  291 
  292 The object data variables are used as follows:
  293 
  294 =item B<FILENAME>
  295 
  296 The filesystem name of the file to be included. 
  297 
  298 =item B<DIRECTORY>
  299 
  300 An optional directory where the filename will be read from. This is useful 
  301 for putting all of your HTML files in one place. You can specify relative 
  302 directories from this base in your filenames. For example: 
  303 
  304    $pf = new bwInclude ( DIRECTORY => "/home/you/htmlfiles" );
  305 
  306    $pf->pf( "subdirectory/admin.html" );
  307 
  308 That will use /home/you/htmlfiles/subdirectory/admin.html as the file to 
  309 be included. 
  310 
  311 =out
  312 
  313 =head1 FILE PROCESSING
  314 
  315 =over 4
  316 
  317 =head2 Variable Replacement
  318 
  319 =head2 Including External CGI Programs
  320 
  321 =head2 mod_inclue Emulation
  322 
  323 =head2 File Location
  324 
  325 =cut
  326