view release on metacpan or  search on metacpan

lib/PAB3/CGI.pm  view on Meta::CPAN

sub cleanup {
	return if $FIRSTRUN;
	if( %_FILES ) {
		foreach( keys %_FILES ) {
			unless( $_FILES{$_}->{'tmp_name'} ) {
				next;
			}
			unlink( split( "\0", $_FILES{$_}->{'tmp_name'} ) );
		}
	}
	undef %_GET;
	undef %_POST;
	undef %_REQUEST;
	undef %_FILES;
	undef %_COOKIE;
	undef $HeaderDone;
	undef %HEAD;
	print ''; # untie stdout
	$FIRSTRUN = 1;
	my( $handler, $h, $ref );
	foreach $h( @CleanupHandler ) {
		if( ref( $h ) eq 'ARRAY' ) {
			$handler = shift @$h;
		}
		else {
			$handler = $h;
			$h = [];
		}
		if( ( $ref = ref( $handler ) ) ) {
			if( $ref eq 'CODE' ) {
				eval{
					local( $SIG{'__DIE__'}, $SIG{'__WARN__'} );
					$handler->( @$h );
				};
			}
		}
		else {
			eval{
				local( $SIG{'__DIE__'}, $SIG{'__WARN__'} );
				&{$handler}( @$h );
			};
		}
	}
	undef @CleanupHandler;
	if( $PAB3::Statistic::VERSION ) {
		&PAB3::Statistic::send(
			'CSN|' . ( $GLOBAL::MPREQ || $$ )
				. '|' . time
				. '|' . &microtime()
				. '|' . ( $GLOBAL::STATUS || ( $GLOBAL::MPREQ ? $GLOBAL::MPREQ->status : 200 ) )
		);
	}
	undef $GLOBAL::MPREQ;
}

sub cleanup_register {
	push @CleanupHandler, [ @_ ];
}

sub setenv {
	if( $ENV{'SCRIPT_FILENAME'}
		&& $ENV{'SCRIPT_FILENAME'} =~ /^(.+[\\\/])(.+?)$/
	) {
		$ENV{'SCRIPT_PATH'} = $1;
		$ENV{'SCRIPT'} = $2;
	}
	elsif( $0 =~ /^(.+[\\\/])(.+?)$/ ) {
		$ENV{'SCRIPT_PATH'} = $1;
		$ENV{'SCRIPT'} = $2;
	}
	else {
		$ENV{'SCRIPT_PATH'} = '';
		$ENV{'SCRIPT'} = $0;
	}
	my $hua = lc( $ENV{'HTTP_USER_AGENT'} );
	if( index( $hua, 'win' ) >= 0 ) {
		$ENV{'REMOTE_OS'} = 'windows'
	}
	elsif( index( $hua, 'linux' ) >= 0 ) {
		$ENV{'REMOTE_OS'} = 'linux';
	}
	elsif( index( $hua, 'ppc' ) >= 0 ) {
		$ENV{'REMOTE_OS'} = 'macos';
	}
	elsif( index( $hua, 'freebsd' ) >= 0 ) {
		$ENV{'REMOTE_OS'} = 'freebsd';
	}
	else {
		$ENV{'REMOTE_OS'} = 'unknown';
	}
}

sub set {
	my( $index, $len );
	$len = $#_ + 1;
	for( $index = 0; $index < $len; $index += 2 ) {
		if( $_[ $index ] eq 'request_max_size' ) {
			$RequestMaxData = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'mpart_buffer_size' ) {
			$MPartBufferSize = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'max_boundary' ) {
			$MaxBoundary = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'temp_dir' ) {
			$UploadFileDir = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'save_to_file' ) {
			$SaveToFile = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'logger' ) {
			$Logger = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'request' ) {
			$GLOBAL::MPREQ = $_[ $index + 1 ];
		}
		else {
#			&Carp::carp( 'Unknown parameter ' . $_[ $index ] );
		}

lib/PAB3/CGI.pm  view on Meta::CPAN

		;
		$step ++;
	}
	print "</ul>\n";
	print "</code><br />\n";
	my $s = $str;
	$s =~ s!\n+$!!;
	if( $Logger ) {
		$Logger->error( $s );
	}
	if( $GLOBAL::MPREQ ) {
		$GLOBAL::MPREQ->log()->error( $s );
		#$GLOBAL::MPREQ->status( 500 );
		$GLOBAL::STATUS = 500;
		Apache::exit() if $GLOBAL::MODPERL == 1;
	}
	else {
		print STDERR '[error] Perl: ' . $str;
	}
#	return 500;
	exit( 0 );
}

sub _warn_handler {
	my $str = shift;
	if( $str =~ /(.+) at (.+) line (.+)$/s ) {
		print "<br />\n<code>Warning: <b>$1</b>\n"
			. 'at <b>' . $2 . '</b> line <b>' . $3 . '</b>'
			. "</code>\n<br />\n"
		;
	}
	else {
		print "<br />\n<code>Warning: <b>$str</p></code>\n<br />\n";
	}
	my $s = $str;
	$s =~ s!\n+$!!;
	if( $Logger ) {
		$Logger->warn( $s );
	}
	if( $GLOBAL::MPREQ ) {
		$GLOBAL::MPREQ->log()->warn( $s );
	}
	else {
		print STDERR '[warn] Perl: ' . $str;
	}
}


__END__

=head1 NAME

PAB3::CGI - CGI module for the PAB3 environment or as standalone

=head1 SYNOPSIS

  # load module and export default functions and variables
  use PAB3::CGI qw(:default);
  
  # set some useful variables to the environment
  PAB3::CGI::setenv();
  
  # parse request and cookies and start the cgi output handler
  PAB3::CGI::init();
  
  if( $_REQUEST{'cmd'} eq 'showenv' ) {
      print_var( \%ENV );
  }
  elsif( $_REQUEST{'cmd'} eq 'redirect' ) {
      return redirect( 'http://myserver.com/' );
  }


=head1 DESCRIPTION

PAB3::CGI handles CGI requests.
Some syntax is taken from PHP.
Multipart content is based on the cgi-lib. Thank you for the great work.

=head1 EXAMPLES

=head2 Standard CGI output

  # load module and export default functions and variables
  use PAB3::CGI qw(:default);
  
  # parse request and cookies and start the cgi output handler
  PAB3::CGI::init();
  
  # start data output
  print "<h1>Environment</h1>\n";
  
  # print a human readable version of %ENV
  print_var( \%ENV );


=head2 CGI output with HTTP headers

  # load module and export default functions and variables
  use PAB3::CGI qw(:default);
  
  # parse request and cookies and start the cgi output handler
  PAB3::CGI::init();
  
  # set userdefined header
  header( "Content-Type: text/plain" );
  
  # start data output
  print "plain text comes here\n";


=head1 METHODS

=over 4

=item init ( [%ARG] )

Initializes the CGI environment, parses request and cookies.

Available arguments are:

  request_max_size   => maximum allowed data to be sent to the server,
                        default value is 131072 (128kb)
  mpart_buffer_size  => size of buffer for reading files sent to
                        the server, default is 8192 (8kb)
  max_boundary       => maximum length of boundary in multipart
                        content, default is 10
  temp_dir           => directory to upload temporary files,
                        default value is '/tmp' on unix and %WINDOWS%\\Temp on
                        Win32
  save_to_file       => if TRUE, save uploaded files to disk
                        if FALSE, hold uploaded files in memory
                        default is TRUE

Example:

  PAB3::CGI::init();


=item setenv ()

Set some useful variables to the interpreters environment 

these variables are:

  $ENV{'SCRIPT_PATH'}   : path to the main script
  $ENV{'SCRIPT'}        : name of the main script
  $ENV{'REMOTE_OS'}     : name of the remote operating system


=item setcookie ( $name )

=item setcookie ( $name, $value )

=item setcookie ( $name, $value, $expire )

=item setcookie ( $name, $value, $expire, $path )

=item setcookie ( $name, $value, $expire, $path, $domain )

=item setcookie ( $name, $value, $expire, $path, $domain, $secure )


setcookie() defines a cookie to be sent along with the rest of the
HTTP headers. Like other headers, cookies must be sent before any
other output. If output exists prior to calling this function,
setcookie() will fail and return 0. If setcookie() successfully runs,
it will return a true value. This does not indicate whether the remote
user accepted the cookie.
The first parameter I<$name> defines the name of the cookie. The
second parameter I<$value> is stored on the clients computer. The
third parameter defines the time the cookie expires. This is a Unix
timestamp as number of seconds since the epoch. If I<$expire> is
undefined, the cookie will expire at the end of the session.
The fourth parameter I<$path> defines the path on the server in which
the cookie will be available on. If path set to '/', the cookie will be
available within the entire domain. If set to '/foo/', the cookie
will only be available within the /foo/ directory and all sub-
directories such as /foo/bar/ of domain. The default value is '/'.
The fifth parameter I<$domain> defines the domain that the cookie
is available. To make the cookie available on all subdomains of
example.com then you would set it to '.example.com'. The . is not
required but makes it compatible with more browsers. Setting it to
www.example.com will make the cookie only available in the www
subdomain. The sixth parameter indicates that the cookie should
only be transmitted over a secure HTTPS connection. When set to
TRUE, the cookie will only be set if a secure connection exists.
The default is FALSE.


=item header ( $header )

=item header ( $header, $overwrite )

header() is used to send raw HTTP headers. See the
http://www.faqs.org/rfcs/rfc2616 specification for more
information on HTTP headers.

Example: