• Your recent searches
CGI-Application-Dispatch
1 match

 view release on metacpan or  search on metacpan

lib/CGI/Application/Dispatch.pm  view on Meta::CPAN 

            #    409 => 'Conflict',
            #    410 => 'Gone',
            #    411 => 'Length Required',
            #    412 => 'Precondition Failed',
            #    413 => 'Request Entity Too Large',
            #    414 => 'Request-URI Too Large',
            #    415 => 'Unsupported Media Type',
            #    416 => 'Requested Range Not Satisfiable',
            #    417 => 'Expectation Failed',
            #    422 => 'Unprocessable Entity',
            #    423 => 'Locked',
            #    424 => 'Failed Dependency',
            500 => 'Internal Server Error',

            #    501 => 'Method Not Implemented',
            #    502 => 'Bad Gateway',
            #    503 => 'Service Temporarily Unavailable',
            #    504 => 'Gateway Time-out',
            #    505 => 'HTTP Version Not Supported',
            #    506 => 'Variant Also Negotiates',
            #    507 => 'Insufficient Storage',
            #    510 => 'Not Extended',
        );

        $errno = 500 if(!exists $status_lines{$errno});

        if($url) {

            # somewhat mailformed header, no errors in access.log, but browsers
            # display contents of $url document and old URI in address bar.
            $output = "HTTP/1.0 $errno $status_lines{$errno}\n";
            $output .= "Location: $url\n\n";
        } else {

            unless($output) {

                # TODO: possibly provide more feedback in a way that
                # is XSS safe.  (I'm not sure that passing through the
                # raw ENV variable directly is safe.)
                # <P>We tried: $ENV{REQUEST_URI}</P></BODY></HTML>";
                $output = qq(
                <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
                <HTML><HEAD>
                <TITLE>$errno $status_lines{$errno}</TITLE>
                </HEAD><BODY>)
                  . (
                    $DEBUG
                    ? '<h1>' . __PACKAGE__ . ' error!</h1>'
                    : ''
                  )
                  . qq(<H1>$status_lines{$errno}</H1>
                <P><ADDRESS>)
                  . ($ENV{SERVER_ADMIN} ? "($ENV{SERVER_ADMIN})" : '') . qq(</ADDRESS></P>
                <HR>)
                  . ($ENV{SERVER_SIGNATURE} || '') . qq(</BODY></HTML>);
            }

            # Apache will report $errno in access.log
            my $header .= "Status: $errno $status_lines{$errno}\n";

            # try to guess, what a crap we get here
            $header .=
              $output =~ /<html/i
              ? "Content-type: text/html\n\n"
              : "Content-type: text/plain\n\n";

            # Workaround for IE error document 512 byte size "feature"
            $output .= ' ' x (520 - length($output))
              if(length($output) < 520);

            $output = $header . $output;
        }

        # Send output to browser (unless we're in serious debug mode!)
        print $output unless $ENV{CGI_APP_RETURN_ONLY};

        return $output;
    }
}

# protected method - designed to be used by sub classes, not by end users
sub _parse_path {
    my ($self, $path, $table) = @_;

    # get the module name from the table
    return unless defined($path);

    unless(ref($table) eq 'ARRAY') {
        warn "[Dispatch] Invalid or no dispatch table!\n";
        return;
    }

    # look at each rule and stop when we get a match
    for(my $i = 0 ; $i < scalar(@$table) ; $i += 2) {

        my $rule = $table->[$i];

        # are we trying to dispatch based on HTTP_METHOD?
        my $http_method_regex = qr/\[([^\]]+)\]$/;
        if($rule =~ /$http_method_regex/) {
            my $http_method = $1;

            # go ahead to the next rule
            next unless lc($1) eq lc($self->_http_method);

            # remove the method portion from the rule
            $rule =~ s/$http_method_regex//;
        }

        # make sure they start and end with a '/' to match how
        # PATH_INFO is formatted
        $rule = "/$rule" unless(index($rule, '/') == 0);
        $rule = "$rule/" if(substr($rule, -1) ne '/');

        my @names = ();

        # translate the rule into a regular expression, but remember
        # where the named args are
        # '/:foo' will become '/([^\/]*)'
        # and
        # '/:bar?' will become '/?([^\/]*)?'



( run in 1.019 second using v1.01-cache-2.11-cpan-39bf76dae61 )