# CGIplus.pm - released with PerlRTE 1.2 (see end of module for details)
#------------------------------------------------------------------------------

package CGIplus;

use Carp;
use 5.006;
use strict;
use warnings;

require Exporter;
use AutoLoader qw(AUTOLOAD);

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use CGIplus ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.

our %EXPORT_TAGS = ( 'all' => [ qw(
    beginStream
    endStream
    fileStream
    isCGI
    isCGIplus
    process
    stripWWW
    usageCount
    usingWWW
    var
    varPrint
    writeStream
) ] );

our @EXPORT_OK = (
    @{ $EXPORT_TAGS{'all'} },
    qw(
    )
);

our @EXPORT = qw(
	
);

our $VERSION = '1.01' ;

use VMS::Stdio qw( :CONSTANTS :FUNCTIONS );

# add qw() with v5.10.0
use FileHandle qw();

our $CGIPLUSIN ;
our $CGIPLUSIN_BIN ;
our $isCGIplusEnv ;
our $stripWWW = 1;
our $structDone = 0;
our $SYSOUTPUT ;
our $usageCount = 0;
our $usingWWW = 0;

if ($usingWWW) { $stripWWW = 0; }  # insurance

#------------------------------------------------------------------------------
# Takes one parameter, a function by reference (see examples).
# This dereferenced function is then executed once for standard CGI, or
# in a loop with the appropriate infrastructure if CGIplus.

sub process
{
   my $funcref = shift ;
   if (! ref($funcref)) {
      croak("CGIplus::process() was passed no function reference\n");
   }

   if ($stripWWW)
   {
      # remove (any) leading "WWW_" from $ENV variable names
      # (can clobber non-CGI variables beginning with "WWW_" but ...)
      my @sortedKeys = sort (keys %ENV);
      foreach my $name (@sortedKeys)
      {
         if (substr($name,0,4) eq 'WWW_' &&
             $name ne 'WWW_IN' && $name ne 'WWW_OUT')
         {
            my $value = $ENV{$name};
            $ENV{substr($name,4)} = $ENV{$name};
            # if you are looking at this source line because your received
            # a %SYSTEM-F-NOPRIV error you need a system or process logical:
            # DEFINE PERL_ENV_TABLES CLISYM_GLOBAL,LNM$PROCESS
            delete $ENV{$name};
         }
      }
   }

   if (defined($ENV{'CGIPLUSEOF'}))
   {
      # CGIplus environment
      $isCGIplusEnv = 1;
      while (1)
      {
         # read, with implicit wait-for, the next request's variable stream
         # (if used with PerlRTE the first CGIplus stream will have already
         # been read by that.  Only read subsequent variable streams.)
         # Perl5.18.1 suggests removal of the 'defined()'
         if (!%main::CGIplusENV || $usageCount)
         {
            private_ReadCGIplusStream();
         }
         $usageCount++;
         if (defined(CGIplus::var('SCRIPT_RTE')))
         {
            # server will get confused when the CGIplus script goes quiescent
            croak("Cannot use CGIplus.pm via RTE script path!\n");
         }
         # execute the function reference
         &$funcref;
         # tell the server we've finished processing this request
         CGIplus::eof();
      }
   }

   # otherwise standard CGI, execute the function reference once
   $isCGIplusEnv = 0;
   &$funcref;
}

#------------------------------------------------------------------------------
# Set whether or not CGI variable names have any leading "WWW_" retained.
# Takes one parameter, true or false.

sub stripWWW
{
   if ($_[0]) {
      $stripWWW = 1;
   }
   else {
      $stripWWW = 0;
   }
}

#------------------------------------------------------------------------------
# Set whether or not CGI variable names have a "WWW_" added if required before
# lookup by CGIplus::var().  Setting this turns off $stripWWW (if insisting on
# "WWW_" why strip it?), but resetting it makes no change to $stripWWW.
# Takes one parameter, true or false.

sub usingWWW
{
   if ($_[0]) {
      $usingWWW = 1;
      $stripWWW = 0;
   }
   else {
      $usingWWW = 0;
   }
}

#------------------------------------------------------------------------------
# Return true if it is CGIplus environment.
# Takes zero parameters.

sub isCGIplus
{
   return ($isCGIplusEnv);
}

#------------------------------------------------------------------------------
# Return true if it is standard CGI environment.
# Takes zero parameters.

sub isCgi
{
   return (!$isCGIplusEnv);
}

#------------------------------------------------------------------------------
# Return the number of time the script has been used (standard CGI is always 1).
# Takes zero parameters.

sub usageCount
{
   return ($usageCount);
}

#------------------------------------------------------------------------------
# Write an end-of-CGIplus-request record.
# Takes zero parameters.

sub eof
{
   STDOUT->autoflush(1);
   printf ("%s\n",$ENV{'CGIPLUSEOF'});
   STDOUT->autoflush(0);
}

#------------------------------------------------------------------------------
# Write a begin-callout record.
# Takes zero parameters.

sub esc
{
   STDOUT->autoflush(1);
   printf ("%s\n",$ENV{'CGIPLUSESC'});
   STDOUT->autoflush(0);
}

#------------------------------------------------------------------------------
# Write an end-callout record.
# Takes zero parameters.

sub eot
{
   STDOUT->autoflush(1);
   printf ("%s\n",$ENV{'CGIPLUSEOT'});
   STDOUT->autoflush(0);
}

#------------------------------------------------------------------------------
# Return the CGI variable value corresponding the supplied variable name.
# Takes one parameter, the name of the variable to be returned.
# If the module is stripping leading "WWW_" from variable names and this call
# uses a name with a leading "WWW_" it is automatically removed before lookup.
# If $usingWWW is true any variable name lacking a leading "WWW_" has one
# added before lookup.

sub var
{
   my $name = $_[0];
   if ($stripWWW && substr($name,0,4) eq 'WWW_') {
      $name = substr($name,4);
   }
   if ($usingWWW && substr($name,0,4) ne 'WWW_') {
      $name = 'WWW_' + $name;
   }
   if ($isCGIplusEnv)
   {
      # CGIplus environment
      return ($main::CGIplusENV{$name});
   }
   # standard CGI environment
   return ($ENV{$name});
}

#------------------------------------------------------------------------------
# Reads the CGIplus variable stream.
# Adds them also to the $ENV associative array.
# *** internal module use only ***

sub private_ReadCGIplusStream
{
   if (!defined($CGIPLUSIN)) {
      open (CGIPLUSIN, $ENV{'CGIPLUSIN'}) or croak"Could not open CGIPLUSIN\n";
   }
   # ensure no variables are carried-over
   foreach my $name (keys %main::CGIplusENV)
   {
      delete $main::CGIplusENV{$name};
      delete $ENV{$name};
   }

   # read CGIplus variable stream
   while (<CGIPLUSIN>)
   {
      chop;  # remove trailing newline
      if ($main::perlRTEdebug)
         { printf ("Content-Type: text/plain\n\nCGIplus.pm |%s|\n", $_); }
      if ($_ eq '') { last; }  # end of request's CGIplus stream
      if (substr($_,0,2) eq '!!')
      {
         # CGIplus stream is in 'struct' mode
         private_ReadCGIplusStruct();
         # ensure that (any) CGI.pm understands this is persistent
         # (CGI.pm only checks for the non-"WWW_" variable name!)
         $main::CGIplusENV{'GATEWAY_INTERFACE'} = 'CGI-PerlEx';
         $ENV{'GATEWAY_INTERFACE'} = 'CGI-PerlEx';
         return;
      }
      if ($_ eq '!') { next; }  # start of new request's CGIplus stream
      if ($main::perlRTEdebug) { printf ("|%s|\n", $_); }
      my $slen = index($_,'=');  # find end of name, start of value
      my $name = substr($_,0,$slen);
      my $value = substr($_,$slen+1); 
      if ($stripWWW && substr($name,0,4) eq 'WWW_')
         { $name = substr($name,4); }
      $main::CGIplusENV{$name} = $value;
      $ENV{$name} = $value;
   }

   # ensure that (any) CGI.pm understands this is persistent
   # (CGI.pm only checks for the non-"WWW_" variable name!)
   $main::CGIplusENV{'GATEWAY_INTERFACE'} = 'CGI-PerlEx';
   $ENV{'GATEWAY_INTERFACE'} = 'CGI-PerlEx';

   if ($structDone) { return };

   # (attempt to) turn on variable 'struct' mode
   $structDone = 1;
   STDOUT->autoflush(1);
   printf ("%s\n!CGIPLUS: struct\n%s\n",$ENV{'CGIPLUSESC'},$ENV{'CGIPLUSEOT'});
   STDOUT->autoflush(0);
}

#------------------------------------------------------------------------------
# Process a CGIplus variable stream provided in 'struct' mode.
# *** internal module use only ***

sub private_ReadCGIplusStruct
{
   if (!defined($CGIPLUSIN_BIN)) {
      $CGIPLUSIN_BIN =
         vmssysopen ($ENV{'CGIPLUSIN'}, &O_RDONLY, 0, "ctx=bin")
            or croak("Could not open \"\$CGIPLUSIN_BIN\"");
   }
   my $sbuf ;
   my $bcnt = int(substr($_,2));
   my $rcnt = sysread($CGIPLUSIN_BIN,$sbuf,$bcnt);
   if ($rcnt ne $bcnt) {
      croak("Inconsistent read from \"\$CGIPLUSIN_BIN\"");
   }
   my $bpos = 0;
   for (;;)
   {
      # get the leading 16 bit integer variable length
      my $vlen = ord(substr($sbuf,$bpos,1)) +
                 ord(substr($sbuf,$bpos+1,1)) * 256;
      if ($vlen eq 0) { return };
      # extract that length string (minus the terminating null)
      my $cgivar = substr($sbuf,$bpos+2,$vlen-1);
      if ($main::perlRTEdebug) { printf ("|%s|\n", $cgivar); }
      my $slen = index($cgivar,'=');  # find end of name, start of value
      my $name = substr($cgivar,0,$slen);
      my $value = substr($cgivar,$slen+1); 
      if ($stripWWW && substr($name,0,4) eq 'WWW_')
         { $name = substr($name,4); }
      $main::CGIplusENV{$name} = $value;
      $ENV{$name} = $value;
      $bpos += $vlen + 2;
   }
}  

#------------------------------------------------------------------------------
# Print out the CGI variable values (for debug purposes).
# Takes zero parameters.

sub varPrint
{
   if ($isCGIplusEnv)
   {
      my $name;
      printf ("CGIplus Variables (usage count %d)\n", $usageCount);
      printf ("-----------------\n");
      my @sortedKeys = sort (keys %main::CGIplusENV);
      foreach $name (@sortedKeys) {
         printf ("$name=\"%s\"\n",$main::CGIplusENV{$name});
      }
      printf ("-----------------\n");
   }
   else
   {
      printf ("Standard CGI Variables (DCL symbols)\n");
      printf ("----------------------\n");
      system ("show symbol /global *");
      printf ("----------------------\n");
   }
}

#------------------------------------------------------------------------------
# Open a binary stream to SYS$OUTPUT.
# Takes zero parameters.

sub beginStream
{
   $SYSOUTPUT = vmssysopen ("SYS\$OUTPUT", &O_WRONLY, 0, "ctx=bin")
      or croak("Could not open \"SYS\$OUTPUT\"");
   # make standard output flush-every-record mode
   STDOUT->autoflush(1);
}

#------------------------------------------------------------------------------
# Close the binary stream to SYS$OUTPUT.
# Takes zero parameters.

sub endStream
{
   close($SYSOUTPUT);
   # return standard output to buffered mode
   STDOUT->autoflush(0);
}

#------------------------------------------------------------------------------
# Write to the binary SYS$OUTPUT stream.
# The first parameter is the data to written.
# The second parameter is the number of bytes in the data.
# (if the second parameter is -1 the length of the data is determined)

sub writeStream
{
   my $data = $_[0];
   my $length = $_[1];
   if ($length < 0) {
      $length = length($data);
   }
   syswrite ($SYSOUTPUT, $data, $length);
}

#------------------------------------------------------------------------------
# Open the file specified in the parameter and return it as a binary stream.
# The first parameter is the file name.
# The second parameter is the file MIME content-type (default octet-stream).

sub fileStream
{
   $SYSOUTPUT = vmssysopen ("SYS\$OUTPUT", &O_WRONLY, 0, "ctx=bin")
      or croak("Could not open \"SYS\$OUTPUT\"");

   my $INFILE = vmssysopen ($_[0], &O_RDONLY, 0, "ctx=bin")
      or croak("Could not open \"$_[0]\"");

   my $contentType ;

   if ($_[1] eq "") {
      $contentType = "Content-Type: application/octet-stream\n\n";
   }
   else {
      $contentType = "Content-Type: " . $_[1] . "\n\n";
   }

   syswrite ($SYSOUTPUT, $contentType, length($contentType));

   my $bytes ;
   my $bytesRead ;

   while ($bytesRead = sysread ($INFILE, $bytes, 4096)) {
      syswrite ($SYSOUTPUT, $bytes, $bytesRead);
   }

   close($INFILE);
   close($SYSOUTPUT);
}

#------------------------------------------------------------------------------

# end of module initialization, return TRUE
1;

__END__

=head1 NAME

CGIplus - Perl extension for WASD CGIplus protocol.

=head1 COPYRIGHT

Copyright (C) 2000-2008 Mark G.Daniel
This program, comes with ABSOLUTELY NO WARRANTY.
This is free software, and you are welcome to redistribute it under the
conditions of the GNU GENERAL PUBLIC LICENSE, version 3, or any later version.
http://www.gnu.org/licenses/gpl.txt

=head1 Revision History

=over 4

=item 1 20-Jan-2008  MGD

Perl v5.10.0 required "qw()" in "use FileHandle qw()";

=item 2 12-May-2003  DM

Miscellaneous changes to get use strict to work.

=item 3 04-JAN-2002  MGD

refinements (including for variable detection),
CGI variables are now available via $ENV{'name'}
as well as the via the function CGIplus::var()

=item 4 31-MAY-2000  MGD

initial

=head1 SYNOPSIS

    # CGIplusPM_example1.pl
    #
    # Simple example that just prints the CGI variables, then demonstrates how
    # to retrive variable values using the CGIplus module 'var' subroutine.
    # May be invoked using either /cgi-bin/cpipluspm_example1 for standard CGI
    # environment or using /CGIplus-bin/cpipluspm_example1 for CGIplus environment.
    #

    use CGIplus qw(:all) ;

    # change this to false to retain (any) "WWW_" on CGI variable names
    #stripWWW(1);

    # change this to true to coerce all CGIplus::var() to have a leading "WWW_"
    #usingWWW(0);

    # pass the reference of the example function to the CGIplus processor
    process(\&exampleScript);

    #------------------------------------------------------------------------------
    # all the work is done in this function

    sub exampleScript
    {
       printf ("Content-Type: text/plain\
    Expires: Fri, 13 Jan 1978 14:00:00 GMT\
    ");

       if (isCGIplus())
       {
	  if ($ENV{'QUERY_STRING'} eq "eoj")
	  {
	     printf ("Bye! (after %d requests)\n", CGIplus::usageCount());
	     exit;
	  }
       }

       varPrint();

       # show that the $ENV associative array and var() are identical
       printf ("\nDemonstrate that the var() function and \$ENV associative array contents are identical ...\n");
       printf ("\n\$ENV{'SCRIPT_NAME'}  |%s|\n", $ENV{'SCRIPT_NAME'});
       printf ("var('SCRIPT_NAME')  |%s|\n", var('SCRIPT_NAME'));
       printf ("\n\$ENV{'PATH_INFO'}    |%s|\n", $ENV{'PATH_INFO'});
       printf ("var('PATH_INFO'}    |%s|\n", var('PATH_INFO'));
       printf ("\n\$ENV{'QUERY_STRING'} |%s|\n", $ENV{'QUERY_STRING'});
       printf ("var('QUERY_STRING') |%s|\n\n", var('QUERY_STRING'));

       if (!defined($ENV{'SERVER_SOFT'})) {
	  printf ("SERVER_SOFT does not exist and looks like an empty string ...\n");
       }
       printf ("SERVER_SOFT |%s|\n\n", $ENV{'SERVER_SOFT'});

       if (defined($ENV{'SERVER_SOFTWARE'})) {
	  printf ("SERVER_SOFTWARE should exist ...\n");
       }
       printf ("SERVER_SOFTWARE |%s|\n", $ENV{'SERVER_SOFTWARE'});
    }

    #------------------------------------------------------------------------------

=head1 DESCRIPTION

CGIplus provides a persistent CGI environment for a specific CGI
running under the WASD web server.  CGIplus dedicates a process
running a Perl interpreter (for CGIs written in Perl) to the
execution of the CGI.

CGIplus.pm makes WASD and general DCL CGI and WASD CGIplus environments transparent to CGI
Perl scripts.  To make the standard CGI and CGIplus as compatible as possible
the CGIplus::process() function takes a reference to a function which contains
all of the essential activities of the script.  This mechanism should *always*
be used to execute the script.  Nothing of the environment is then needed to be
known by the script itself! Of course, for persistent scripting some care needs
to be taken to ensure all storage, etc., is correctly initialized each time the
script is started and nothing is left to script exit and rundown to clean up
(which of course doesn't happen with persistant scripts).

This version of CGIplus.pm (January 2003) makes CGI environment variables,
formally available only via CGIplus::var(), accessable using ENV associative
array.  The CGIplus.pm variable array has been renamed and relocated to
main::CGIplusENV.  This allows PERLRTE.C to support CGIplus (in addition to
RTE) with CGIplus.pm.  The complication arose because both would be attempting
to read the CGIPLUSIN stream and synchronise the request processing.  Obviously
both cannot do this!  The compromise has been to allow PERLRTE.C to sync and
read the first request's variables, which it places into the main::CGIplusENV
associative array used by this module (as well as into main::ENV).  After that
initial request CGIplus.pm takes over the request syncchronising and variable
reading (As far as PERLRTE.C is concerned the first request it initiates never,
or seldom, completes ;^)

A script using CGIplus.pm should never be activated using an RTE path (one
using the mapping syntax "exec+ (rte_executable)/path/* /path/*").  When an RTE
becomes quiescent the server will give it another script.  With the CGIplus.pm
CGIplus loop is active an unintended and probably incorrect script will become
active.  Always activate CGIplus.pm enabled scripts via a CGIplus path. 
CGIplus.pm will detect this mapping mistake and die!

It also, by default, strips the leading "WWW_" from variable names (for greater
compatibility with most CGI environments that do not use such).  This should
not be a problem with scripts designed for the previous version module and
using CGIplus::var() with leading "WWW_" on variable names as this will be
removed automatically by CGIplus::var() before lookup.  It may be an issue with
non-CGI variables stored in $ENV as the algorithm is fairly heavy handed and
will also clobber the names of any non-CGI environment variables in $ENV.  It
can be turned off before starting any script using CGIplus::stripWWW(0) or on a
per-module basis by modifying CGIplus.pm itself to initialize "$stripWWW = 0;"; 
A complementary switch that can be set using CGIplys::usingWWW(1) (or modify to
"$usingWWW = 1;") to retain any leading "WWW_" on variable names and to add
them to names (if necessary) before lookup using CGIplus::var().

VMS' RMS complicates output streams under Perl.  This is a particular issue
with CGIplus end-of-file sentinals, which must be output as a single record. 
CGIplus.pm attempts to provide a simple mechanism for providing binary streams
if necessary, while still ensuring it's own records are not interfered with. 
This uses Charles Bailey's VMS::Stdio extension module built into most versions
of VMS Perl.

This module should be suitable for VMS Perl 5.6 and 5.8.

It requires that the following system or process level logical be defined for
correct resolution of the standard CGI variables supplied by WASD using DCL
symbols (CGIplus variables are not affected by this).
	
    $ DEFINE /SYSTEM PERL_ENV_TABLES CLISYM_GLOBAL,LNM$PROCESS

=head2 Functions

All functions are exported and may be included into the using
packages name space at will.

=over 4

=item beginStream

    beginStream()

Open SYS$OUTPUT as a binary stream.

=item endStream

Close SYS$OUTPUT when in use as a binary stream.

=item fileStream

    fileStream(fileName,
	      [content type])

Write the contents of the specified file to SYS$OUTPUT in binary
mode.  A content-type HTTP header is generated.  If the content
type is omitted, it defaults to application/octed-stream.

=item isCGI

    isCGI()

Return true if the CGIplus environment is not active, false
otherwise.

=item isCGIplus

    isCGIplus()

Returns true if the CGIplus environment is active, false
otherwise.

=item process

    process(function reference)

The specified function is called whenever CGIplus has more work
for the function to do.

=item stripWWW

    stripWWW(boolean)

If true, the leading "WWW_" will be stripped from all CGI symbols
before calling the CGI function passed to process.  If false, the
CGI symbols are left intact.  This can be important for CGIs
developed under U*x and ported to OpenVMS/WASD.  U*x CGIs do not
expect the CGI variables to begin with WWW_ (or any other prefix
for that matter).

=item usageCount

    usageCount()

The number of times this CGI has been executed by CGIplus.

=item usingWWW

    usingWWW(boolean)

If true, environment variables are expected to begin with WWW_.
It turns off stripWWW if enabled, but doesn't touch stripWWW if
disabled.

=item var

    $theValue = var(variable name)

Look up the specified variable name in the CGIplus environment
(if CGIplus is active) or the CGI environment (if CGIplus is NOT
active). If stripWWW is true and the variable name begins with WWW_ then
the prefix is stripped before lookup occurs.  If usingWWW is true
and the variable name does not begin with WWW_ then WWW_ is
added.

=item varPrint

    varPrint()

Print the CGIplus environment variables or the CGI environment
variables depending on which environment is active.

=item writeStream

    writeStream(string, length)

Write the data specified to the SYS$OUTPUT when in binary mode.

=back 4

=head2 EXPORT

None by default.


=head1 AUTHOR

Mark Daniel, E<lt>Mark.Daniel@wasd.vsm.com.auE<gt>

Perl language refinements and notes courtesy Richard Munroe
E<lt>munroe@csworks.comE<gt>

=head1 SEE ALSO

L<perl>.

=cut