view release on metacpan or  search on metacpan

lib/CGI/Simple/Standard.pm  view on Meta::CPAN

use strict;
#use warnings;
use CGI::Simple;
use Carp;
use vars qw( $VERSION $USE_CGI_PM_DEFAULTS $DISABLE_UPLOADS $POST_MAX
 $NO_UNDEF_PARAMS $USE_PARAM_SEMICOLONS $HEADERS_ONCE
 $NPH $DEBUG $NO_NULL $FATAL *in %EXPORT_TAGS $AUTOLOAD );

$VERSION = "1.282";

%EXPORT_TAGS = (
  ':html'     => [qw(:misc)],
  ':standard' => [qw(:core :access)],
  ':cgi'      => [qw(:core :access)],
  ':all'      => [
    qw(:core :misc :cookie :header :push :debug :cgi-lib
     :access :internal)
  ],
  ':core' => [
    qw(param add_param param_fetch url_param keywords
     append Delete delete_all Delete_all upload
     query_string parse_query_string  parse_keywordlist
     Vars save_parameters restore_parameters)
  ],
  ':misc'   => [qw(url_decode url_encode escapeHTML unescapeHTML put)],
  ':cookie' => [qw(cookie raw_cookie)],
  ':header' => [qw(header cache no_cache redirect)],
  ':push'   => [
    qw(multipart_init multipart_start multipart_end
     multipart_final)
  ],
  ':debug'   => [qw(Dump as_string cgi_error _cgi_object)],
  ':cgi-lib' => [
    qw(ReadParse SplitParam MethGet MethPost MyBaseUrl MyURL
     MyFullUrl PrintHeader HtmlTop HtmlBot PrintVariables
     PrintEnv CgiDie CgiError Vars)
  ],
  ':ssl'    => [qw(https)],
  ':access' => [
    qw(version nph all_parameters charset crlf globals
     auth_type content_length content_type document_root
     gateway_interface path_translated referer remote_addr
     remote_host remote_ident remote_user request_method
     script_name server_name server_port server_protocol
     server_software user_name user_agent virtual_host
     path_info Accept http https protocol url self_url
     state)
  ],
  ':internal' => [
    qw(_initialize_globals _use_cgi_pm_global_settings
     _store_globals _reset_globals)
  ]
);

# BEGIN {
#     $SIG{__DIE__} = sub { croak "Undefined Method : @_\n" }
# }

sub import {
  my ( $self, @args ) = @_;
  my $package = caller();
  my ( %exports, %pragmas );
  for my $arg ( @args ) {
    $exports{$arg}++, next if $arg =~ m/^\w+$/;
    $pragmas{$arg}++, next if $arg =~ m/^-\w+$/;
    if ( $arg =~ m/^:[-\w]+$/ ) {
      if ( exists $EXPORT_TAGS{$arg} ) {
        my @tags = @{ $EXPORT_TAGS{$arg} };
        for my $tag ( @tags ) {
          my @expanded
           = exists $EXPORT_TAGS{$tag}
           ? @{ $EXPORT_TAGS{$tag} }
           : ( $tag );
          $exports{$_}++ for @expanded;
        }
      }
      else {
        croak
         "No '$arg' tag set available for export from CGI::Simple::Standard!\n";
      }
    }
  }
  my @exports = keys %exports;
  my %valid_exports;
  for my $tag ( @{ $EXPORT_TAGS{':all'} } ) {
    $valid_exports{$_}++ for @{ $EXPORT_TAGS{$tag} };
  }
  for ( @exports ) {
    croak
     "'$_' is not an available export method from CGI::Simple::Standard!\n"
     unless exists $valid_exports{$_};
  }
  no strict 'refs';
  if ( exists $pragmas{'-autoload'} ) {

    # hack symbol table to export our AUTOLOAD sub
    *{"${package}::AUTOLOAD"} = sub {
      my ( $caller, $sub ) = $AUTOLOAD =~ m/(.*)::(\w+)$/;
      &CGI::Simple::Standard::loader( $caller, $sub, @_ );
    };
    delete $pragmas{'-autoload'};
  }
  my @pragmas = keys %pragmas;
  CGI::Simple->import( @pragmas ) if @pragmas;

  # export subroutine stubs for all the desired export functions
  # we will replace them in the symbol table with the real thing
  # if and when they are first called
  for my $i ( 0 .. $#exports ) {
    *{"${package}::$exports[$i]"} = sub {
      my $caller = caller;
      &CGI::Simple::Standard::loader( $caller, $exports[$i], @_ );
     }
  }
}

# loader() may be called either via our exported AUTOLOAD sub or by the
# subroutine stubs we exported on request. It has three functions:
# 1) to initialize and store (via a closure) our CGI::Simple object
# 2) to overwrite the exported subroutine stubs with calls to the real ones
# 3) to provide two 'virtual' methods - _cgi_object() and restore_parameters()