view release on metacpan or  search on metacpan

lib/Pod/Webserver/Source.pm  view on Meta::CPAN

package Pod::Webserver::Source;
# $Id: Source.pm,v 1.1 2005/01/05 12:26:39 cwest Exp $
use strict;
use vars qw[$LINK_PATH $PERLTIDY_ARGV $VERSION];
$PERLTIDY_ARGV = [qw[-html -npod -nnn]];
$VERSION = sprintf "%d.%02d", split m/\./, (qw$Revision: 1.1 $)[1];

sub _serve_thing {
    my ($self, $conn, $req) = @_;
    return $conn->send_error(405) unless $req->method eq 'GET';  # sanity

    my $path = $req->url;
    $path .= substr( ($ENV{PATH} ||''), 0, 0);  # to force-taint it.
  
    my $fs   = $self->{'__daemon_fs'};
    my $pods = $self->{'__modname2path'};
    my $resp = HTTP::Response->new(200);
    $resp->content_type( $fs->{"\e$path"} || 'text/html' );

    my $path = $req->url;
    $path .= substr( ($ENV{PATH} ||''), 0, 0);  # to force-taint it.
    $path =~ s{:+}{/}g;
    my $modname = $path;
       $modname =~ s{/+}{::}g;   $modname =~ s{^:+}{};
       $modname =~ s{:+$}{};     $modname =~ s{:+$}{::}g;

    $Pod::Webserver::Source::LINK_PATH = $req->url;
    return shift->_real_serve_thing(@_) unless $modname =~ /\.source$/;

    $modname =~ s/\.source$//;
    if ( $modname =~ m{^([a-zA-Z0-9_]+(?:::[a-zA-Z0-9_]+)*)$}s ) {
        $modname = $1;  # thus untainting
    } else {
        $modname = '';
    }
    Pod::Webserver::DEBUG() > 1 and print "Modname $modname source ($path)\n";

    if ( $pods->{$modname} ) {   # Is it known pod?
        $self->muse("I know $modname source as ", $pods->{$modname});
        __PACKAGE__->_serve_source($pods->{$modname}, $resp);
    } else {
        # If it's not known, look for it.
        #  This is necessary for indexless mode, and also useful just incase
        #  the user has just installed a new module (after the index was generated)
        my $fspath = $Pod::Simple::HTMLBatch::SEARCH_CLASS->new->find($modname);
    
        if( defined($fspath) ) {
            $self->muse("Found $modname source as $fspath");
            __PACKAGE__->_serve_source($fspath, $resp);
        } else {
            $resp = '';
            $self->muse("Can't find $modname in \@INC");
            unless( $self->{'httpd_has_noted_inc_already'} ++ ) {
                $self->muse("  \@INC = [ @INC ]");
            }
        }
    }
  
    $resp ? $conn->send_response( $resp ) : $conn->send_error(404);
    return;
}

sub _serve_source {
    my ($self, $fspath, $resp) = @_;
    
    my $output = '';