view release on metacpan or  search on metacpan

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

	}
	if($self->is_search_engine()) {
		return 'search';
	}
	if($self->is_robot()) {
		return 'robot';
	}
	return 'web';
}

=head2 get_cookie

Returns a cookie's value, or undef if no name is given, or the requested
cookie isn't in the jar.

Deprecated - use cookie() instead.

    use CGI::Info;

    my $i = CGI::Info->new();
    my $name = $i->get_cookie(cookie_name => 'name');
    print "Your name is $name\n";
    my $address = $i->get_cookie('address');
    print "Your address is $address\n";

=cut

sub get_cookie {
	my $self = shift;

	return $self->cookie(\@_);
}

=head2 cookie

Returns a cookie's value, or undef if no name is given, or the requested
cookie isn't in the jar.
API is the same as "param",
it will replace the "get_cookie" method in the future.

    use CGI::Info;

    my $name = CGI::Info->new()->cookie('name');
    print "Your name is $name\n";


=head3 API SPECIFICATION

=head4 INPUT

  {
    cookie_name => {
      'type' => 'string',
      'min' => 1,
      'matches' => qr/^[!#-'*+\-.\^_`|~0-9A-Za-z]+$/	# RFC6265
    }
  }

=head4 OUTPUT

Cookie not set: C<undef>

Cookie set:

  {
    type => 'string',
    optional => 1,
    matches => qr/	# RFC6265
      ^
      (?:
        "[\x21\x23-\x2B\x2D-\x3A\x3C-\x5B\x5D-\x7E]*"   # quoted
      | [\x21\x23-\x2B\x2D-\x3A\x3C-\x5B\x5D-\x7E]*     # unquoted
      )
      $
    /x
  }

=cut

sub cookie
{
	my $self = shift;
	my $params = Params::Validate::Strict::validate_strict({
		args => Params::Get::get_params('cookie_name', @_),
		schema => {
			cookie_name => {
				'type' => 'string',
				'min' => 1,
				'matches' => qr/^[!#-'*+\-.\^_`|~0-9A-Za-z]+$/	# RFC6265
			}
		}
	});

	my $field = $params->{'cookie_name'};

	# Validate field argument
	if(!defined($field)) {
		$self->_error('what cookie do you want?');
		Carp::croak('what cookie do you want?');
		return;
	}
	if(ref($field)) {
		$self->_error('Cookie name should be a string');
		Carp::croak('Cookie name should be a string');
		return;
	}

	# Load cookies if not already loaded
	unless($self->{jar}) {
		if(defined $ENV{'HTTP_COOKIE'}) {
			# grep { /=/ } filters out malformed tokens (empty strings, bare
			# semicolons, entries with no name=value separator) that would
			# otherwise cause split(/=/, $_, 2) to return a single-element list
			# and make the flattened list odd-length, corrupting the hash.
			$self->{jar} = {
				map  { split(/=/, $_, 2) }
				grep { /=/ }
				split(/; /, $ENV{'HTTP_COOKIE'})
			};
		}
	}

	# Return the cookie value if it exists, otherwise return undef
	return $self->{jar}{$field};
}

=head2 status($status)

Sets or returns the status of the object,
200 for OK,
otherwise an HTTP error code

=over 4

=item $status

Optional integer value to be set or retrieved.
If omitted, the value is retrieved.

=back

=cut

sub status
{
	my $self = shift;
	my $status = shift;

	# Set status if provided
	return $self->{status} = $status if(defined($status));

	# Determine status based on request method if status is not set
	unless (defined $self->{status}) {
		my $method = $ENV{'REQUEST_METHOD'};

		return 405 if $method && ($method eq 'OPTIONS' || $method eq 'DELETE');
		return 411 if $method && ($method eq 'POST' && !defined $ENV{'CONTENT_LENGTH'});

		return 200;
	}

	# Return current status or 200 by default
	return $self->{status} || 200;
}