view release on metacpan or  search on metacpan

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

sub auth_type         { $ENV{'AUTH_TYPE'} }
sub content_length    { $ENV{'CONTENT_LENGTH'} }
sub content_type      { $ENV{'CONTENT_TYPE'} }
sub document_root     { $ENV{'DOCUMENT_ROOT'} }
sub gateway_interface { $ENV{'GATEWAY_INTERFACE'} }
sub path_translated   { $ENV{'PATH_TRANSLATED'} }
sub referer           { $ENV{'HTTP_REFERER'} }
sub remote_addr       { $ENV{'REMOTE_ADDR'} || '127.0.0.1' }

sub remote_host {
  $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} || 'localhost';
}

sub remote_ident   { $ENV{'REMOTE_IDENT'} }
sub remote_user    { $ENV{'REMOTE_USER'} }
sub request_method { $ENV{'REQUEST_METHOD'} }
sub script_name    { $ENV{'SCRIPT_NAME'} || $0 || '' }
sub server_name     { $ENV{'SERVER_NAME'}     || 'localhost' }
sub server_port     { $ENV{'SERVER_PORT'}     || 80 }
sub server_protocol { $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0' }
sub server_software { $ENV{'SERVER_SOFTWARE'} || 'cmdline' }

sub user_name {
  $ENV{'HTTP_FROM'} || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
}

sub user_agent {
  my ( $self, $match ) = @_;
  return $match
   ? $ENV{'HTTP_USER_AGENT'} =~ /\Q$match\E/i
   : $ENV{'HTTP_USER_AGENT'};
}

sub virtual_host {
  my $vh = $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'};
  $vh =~ s/:\d+$//;    # get rid of port number
  return $vh;
}

sub path_info {
  my ( $self, $info ) = @_;
  if ( defined $info ) {
    $info = "/$info" if $info !~ m|^/|;
    $self->{'.path_info'} = $info;
  }
  elsif ( !defined( $self->{'.path_info'} ) ) {
    $self->{'.path_info'}
     = defined( $ENV{'PATH_INFO'} ) ? $ENV{'PATH_INFO'} : '';

    # hack to fix broken path info in IIS source CGI.pm
    $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E//
     if defined( $ENV{'SERVER_SOFTWARE'} )
       && $ENV{'SERVER_SOFTWARE'} =~ /IIS/;
  }
  return $self->{'.path_info'};
}

sub accept {
  my ( $self, $search ) = @_;
  my %prefs;
  for my $accept ( split ',', $ENV{'HTTP_ACCEPT'} ) {
    ( my $pref ) = $accept =~ m|q=([\d\.]+)|;
    ( my $type ) = $accept =~ m|(\S+/[^;]+)|;
    next unless $type;
    $prefs{$type} = $pref || 1;
  }
  return keys %prefs unless $search;
  return $prefs{$search} if $prefs{$search};

  # Didn't get it, so try pattern matching.
  for my $pref ( keys %prefs ) {
    next unless $pref =~ m/\*/;    # not a pattern match
    ( my $pat = $pref ) =~ s/([^\w*])/\\$1/g;   # escape meta characters
    $pat =~ s/\*/.*/g;                          # turn it into a pattern
    return $prefs{$pref} if $search =~ /$pat/;
  }
}

sub Accept { my $self = shift; $self->accept( @_ ) }

sub http {
  my ( $self, $parameter ) = @_;
  if ( defined $parameter ) {
    ( $parameter = uc $parameter ) =~ tr/-/_/;
    return $ENV{$parameter} if $parameter =~ m/^HTTP/;
    return $ENV{"HTTP_$parameter"} if $parameter;
  }
  return grep { /^HTTP/ } keys %ENV;
}

sub https {
  my ( $self, $parameter ) = @_;
  return $ENV{'HTTPS'} unless $parameter;
  ( $parameter = uc $parameter ) =~ tr/-/_/;
  return $ENV{$parameter} if $parameter =~ /^HTTPS/;
  return $ENV{"HTTPS_$parameter"};
}

sub protocol {
  local ( $^W ) = 0;
  my $self = shift;
  return 'https' if uc $ENV{'HTTPS'} eq 'ON';
  return 'https' if $self->server_port == 443;
  my ( $protocol, $version ) = split '/', $self->server_protocol;
  return lc $protocol;
}

sub url {
  my ( $self, @p ) = @_;
  use CGI::Simple::Util 'rearrange';
  my ( $relative, $absolute, $full, $path_info, $query, $base )
   = rearrange(
    [
      'RELATIVE', 'ABSOLUTE', 'FULL',
      [ 'PATH',  'PATH_INFO' ],
      [ 'QUERY', 'QUERY_STRING' ], 'BASE'
    ],
    @p
   );
  my $url;
  $full++ if $base || !( $relative || $absolute );
  my $path        = $self->path_info;
  my $script_name = $self->script_name;
  if ( $full ) {
    my $protocol = $self->protocol();
    $url = "$protocol://";
    my $vh = $self->http( 'host' );
    if ( $vh ) {
      $url .= $vh;
    }
    else {
      $url .= server_name();
      my $port = $self->server_port;
      $url .= ":" . $port
       unless ( lc( $protocol ) eq 'http' && $port == 80 )