view release on metacpan or  search on metacpan

lib/CGI.pm  view on Meta::CPAN

    $MOD_PERL = 1;
    require Apache;
  }
}

# Define the CRLF sequence.  I can't use a simple "\r\n" because the meaning
# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
# and sometimes CR).  The most popular VMS web server
# doesn't accept CRLF -- instead it wants a LR.  EBCDIC machines don't
# use ASCII, so \015\012 means something different.  I find this all 
# really annoying.
$EBCDIC = "\t" ne "\011";
if ($OS eq 'VMS') {
  $CRLF = "\n";
} elsif ($EBCDIC) {
  $CRLF= "\r\n";
} else {
  $CRLF = "\015\012";
}

_set_binmode() if ($needs_binmode);

sub _set_binmode {

	# rt #57524 - don't set binmode on filehandles if there are
	# already none default layers set on them
	my %default_layers = (
		unix   => 1,
		perlio => 1,
		stdio  => 1,
		crlf   => 1,
	);

	foreach my $fh (
		\*main::STDOUT,
		\*main::STDIN,
		\*main::STDERR,
	) {
		my @modes = grep { ! $default_layers{$_} }
			PerlIO::get_layers( $fh );

		if ( ! @modes ) {
			$CGI::DefaultClass->binmode( $fh );
		}
	}
}

%EXPORT_TAGS = (
	':html2' => [ 'h1' .. 'h6', qw/
		p br hr ol ul li dl dt dd menu code var strong em
		tt u i b blockquote pre img a address cite samp dfn html head
		base body Link nextid title meta kbd start_html end_html
		input Select option comment charset escapeHTML
	/ ],
	':html3' => [ qw/
		div table caption th td TR Tr sup Sub strike applet Param nobr
		embed basefont style span layer ilayer font frameset frame script small big Area Map
	/ ],
	':html4' => [ qw/
		abbr acronym bdo col colgroup del fieldset iframe
		ins label legend noframes noscript object optgroup Q
		thead tbody tfoot
	/ ],
	':form'     => [ qw/
		textfield textarea filefield password_field hidden checkbox checkbox_group
		submit reset defaults radio_group popup_menu button autoEscape
		scrolling_list image_button start_form end_form
		start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART
	/ ],
	':cgi' => [ qw/
		param multi_param upload path_info path_translated request_uri url self_url script_name
		cookie Dump raw_cookie request_method query_string Accept user_agent remote_host content_type
		remote_addr referer server_name server_software server_port server_protocol virtual_port
		virtual_host remote_ident auth_type http append save_parameters restore_parameters param_fetch
		remote_user user_name header redirect import_names put Delete Delete_all url_param cgi_error env_query_string
	/ ],
	':netscape' => [qw/blink fontsize center/],
	':ssl'      => [qw/https/],
	':cgi-lib'  => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
	':push'     => [qw/multipart_init multipart_start multipart_end multipart_final/],

	# bulk export/import
	':html'     => [qw/:html2 :html3 :html4 :netscape/],
	':standard' => [qw/:html2 :html3 :html4 :form :cgi :ssl/],
	':all'      => [qw/:html2 :html3 :html4 :netscape :form :cgi :ssl :push/]
);

# to import symbols into caller
sub import {
    my $self = shift;

    # This causes modules to clash.
    undef %EXPORT_OK;
    undef %EXPORT;

    $self->_setup_symbols(@_);
    my ($callpack, $callfile, $callline) = caller;

	if ( $callpack eq 'CGI::Fast' ) {
		# fixes GH #11 (and GH #12 in CGI::Fast since
		# sub import was added to CGI::Fast in 9537f90
		# so we need to move up a level to export the
		# routines to the namespace of whatever is using
		# CGI::Fast
		($callpack, $callfile, $callline) = caller(1);
	}

    # To allow overriding, search through the packages
    # Till we find one in which the correct subroutine is defined.
    my @packages = ($self,@{"$self\:\:ISA"});
    for $sym (sort keys %EXPORT) {
	my $pck;
	my $def = $DefaultClass;
	for $pck (@packages) {
	    if (defined(&{"$pck\:\:$sym"})) {
		$def = $pck;
		last;
	    }
	}
	*{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
    }

lib/CGI.pm  view on Meta::CPAN

    for (@QUERY_PARAM) {
      next unless defined $_;
      $QUERY_PARAM{$_}=$self->{param}{$_};
    }
    $QUERY_CHARSET = $self->charset;
    %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
    %QUERY_TMPFILES   = %{ $self->{'.tmpfiles'} || {} };
}

sub parse_params {
    my($self,$tosplit) = @_;
    my(@pairs) = split(/[&;]/,$tosplit);
    my($param,$value);
    for (@pairs) {
	($param,$value) = split('=',$_,2);
	next unless defined $param;
	next if $NO_UNDEF_PARAMS and not defined $value;
	$value = '' unless defined $value;
	$param = unescape($param);
	$value = unescape($value);
	$self->add_parameter($param);
	push (@{$self->{param}{$param}},$value);
    }
}

sub add_parameter {
    my($self,$param)=@_;
    return unless defined $param;
    push (@{$self->{'.parameters'}},$param) 
	unless defined($self->{param}{$param});
}

sub all_parameters {
    my $self = shift;
    return () unless defined($self) && $self->{'.parameters'};
    return () unless @{$self->{'.parameters'}};
    return @{$self->{'.parameters'}};
}

# put a filehandle into binary mode (DOS)
sub binmode {
    return unless defined($_[1]) && ref ($_[1]) && defined fileno($_[1]);
    CORE::binmode($_[1]);
}

# back compatibility html tag generation functions - noop
# since this is now the default having removed AUTOLOAD
sub compile { 1; }

sub _all_html_tags {
	return qw/
		a abbr acronym address applet Area
		b base basefont bdo big blink blockquote body br
		caption center cite code col colgroup
		dd del dfn div dl dt
		em embed
		fieldset font fontsize frame frameset
		h1 h2 h3 h4 h5 h6 head hr html
		i iframe ilayer img input ins
		kbd
		label layer legend li Link
		Map menu meta
		nextid nobr noframes noscript
		object ol option
		p Param pre
		Q
		samp script Select small span
		strike strong style Sub sup
		table tbody td tfoot th thead title Tr TR tt
		u ul
		var
	/
}

foreach my $tag ( _all_html_tags() ) {
	*$tag = sub { return _tag_func($tag,@_); };

	# start_html and end_html already exist as custom functions
	next if ($tag eq 'html');

	foreach my $start_end ( qw/ start end / ) {
		my $start_end_function = "${start_end}_${tag}";
		*$start_end_function = sub { return _tag_func($start_end_function,@_); };
	}
}

sub _tag_func {
    my $tagname = shift;
	my ($q,$a,@rest) = self_or_default(@_);

	my($attr) = '';

	if (ref($a) && ref($a) eq 'HASH') {
		my(@attr) = make_attributes($a,$q->{'escape'});
		$attr = " @attr" if @attr;
	} else {
		unshift @rest,$a if defined $a;
	}

	$tagname = lc( $tagname );

    if ($tagname=~/start_(\w+)/i) {
		return "<$1$attr>";
    } elsif ($tagname=~/end_(\w+)/i) {
		return "</$1>";
    } else {
	    return $XHTML ? "<$tagname$attr />" : "<$tagname$attr>" unless @rest;
	    my($tag,$untag) = ("<$tagname$attr>","</$tagname>");
	    my @result = map { "$tag$_$untag" } 
                              (ref($rest[0]) eq 'ARRAY') ? @{$rest[0]} : "@rest";
	    return "@result";
    }
}

sub _selected {
  my $self = shift;
  my $value = shift;
  return '' unless $value;
  return $XHTML ? qq(selected="selected" ) : qq(selected );
}