view release on metacpan or  search on metacpan

lib/Apache2/SSI.pm  view on Meta::CPAN

sub find_file
{
    my( $self, $args ) = @_;
    my $r = $self->apache_request;
    my $req = '';
    if( exists( $args->{file} ) )
    {
        $self->_interp_vars( $args->{file} );
        $req = $self->lookup_file( $args->{file} );
    }
    elsif( exists( $args->{virtual} ) )
    {
        $self->_interp_vars( $args->{virtual} );
        $req = $self->lookup_uri( $args->{virtual} );
    }
    elsif( $r )
    {
        $req = Apache2::SSI::File->new( $r->filename, apache_request => $r );
    }
    return( $req );
}

sub finfo
{
    my $self = shift( @_ );
    my $r = $self->apache_request;
    my $newfile;
    if( @_ )
    {
        $newfile = shift( @_ );
        return( $self->error( "New file path specified but is an empty string." ) ) if( !defined( $newfile ) || !length( $newfile ) );
    }
    elsif( !$self->{finfo} )
    {
        $newfile = $self->filename;
        return( $self->error( "No file path set. This should not happen." ) ) if( !$newfile );
    }
    
    if( defined( $newfile ) )
    {
        $self->{finfo} = Apache2::SSI::Finfo->new( $newfile, ( $r ? ( apache_request => $r ) : () ) );
    }
    return( $self->{finfo} );
}

sub html { return( shift->_set_get_scalar( 'html', @_ ) ); }

sub legacy { return( shift->_set_get_boolean( 'legacy', @_ ) ); }

sub lookup_file
{
    my $self = shift( @_ );
    my $file = shift( @_ ) || return( $self->error( "No file provided to look up." ) );
    my $r = $self->apache_request;
    my $f = Apache2::SSI::File->new(
        $file,
        ( $r ? ( apache_request => $r ) : () ),
        base_file => $self->uri->filename,
        debug => $self->debug
    ) || return( $self->error( "Unable to instantiate an Apache2::SSI::File object: ", Apache2::SSI::File->error ) );
    if( $f->code == 404 )
    {
        # Mimic the Apache error when the file does not exist
        $self->error( "unable to lookup information about \"$file\" in parsed file \"", $self->uri, "\"." );
    }
    return( $f );
}

sub lookup_uri
{
    my $self = shift( @_ );
    my $uri  = shift( @_ );
    my $r = $self->apache_request;
    my $u = Apache2::SSI::URI->new(
        ( $r ? ( apache_request => $r ) : () ),
        base_uri => $self->uri,
        document_uri => $uri,
        document_root => ( $r ? $r->document_root : $self->document_root ),
        debug => $self->debug
    ) || return( $self->error( "Unable to instantiate an Apache2::SSI::URI object: ", Apache2::SSI::URI->error ) );
    if( $u->code == 404 )
    {
        # Mimic the Apache error when the file does not exist
        $self->error( "unable to get information about uri \"$uri\" in parsed file ", $self->uri );
    }
    return( $u );
}

sub mod_perl { return( shift->_set_get_boolean( 'mod_perl', @_ ) ); }

sub new_uri
{
    my $self = shift( @_ );
    my $uri  = shift( @_ );
    return( $self->error( "No uri provided to create an Apache2::SSI::URI object." ) ) if( !defined( $uri ) || !length( $uri ) );
    my $p =
    {
        document_uri => $uri,
        document_root => $self->document_root,
        base_uri => $self->uri,
        debug => $self->debug,
    };
    $p->{apache_request} = $self->apache_request if( $self->apache_request );
    my $o = Apache2::SSI::URI->new( $p ) ||
        return( $self->error( "Unable to create an Apache2::SSI::URI: ", Apache2::SSI::URI->error ) );
    return( $o );
}

# This makes use of Apache2::SSI::Notes which guarantees that notes are shared in and out of Apache framework
# Notes are cleaned up at server shutdown with an handler set in startup.pl
# See scripts/startup.pl and conf/extra.conf.in as an example
sub notes
{
    my $self = shift( @_ );
    my $notes = $self->{notes};
    my $r = $self->apache_request;
    unless( scalar( @_ ) )
    {
        if( $r )
        {
            return( $r->pnotes );
        }
        elsif( $notes )
        {
            return( $notes->get );
        }
        # We just return an empty hash to avoid error
        else
        {
            return( {} );
        }
    }
    my $var  = shift( @_ );
    my $new;
    my $new_value_set = 0;
    if( @_ )
    {
        $new = shift( @_ );
        $new_value_set++;
        if( $notes )
        {

lib/Apache2/SSI.pm  view on Meta::CPAN

    {
        $filename = $r->filename;

        if( $r->allow_options & &Apache2::Const::OPT_INCNOEXEC )
        {
            $self->error( "httpd: exec used but not allowed in $filename" );
            return( $self->errmsg );
        }
    }
    # TODO Need to improve on this
    if( exists( $args->{cmd} ) )
    {
        # https://metacpan.org/pod/Apache2::SubProcess
        # Fails to work: <https://rt.cpan.org/Public/Bug/Display.html?id=54153>
        # <https://rt.cpan.org/Public/Dist/Display.html?Status=Active;Name=mod_perl>
        if( $r && MOD_PERL_SPAWN_PROC_PROG_WORKING )
        {
            my $data;
            my $fh = $r->spawn_proc_prog( $args->{cmd} );
            if( PERLIO_IS_ENABLED || IO::Select->new( $fh )->can_read(10) )
            {
                $data = <$fh>;
            }
            return( defined( $data ) ? $data : '' );
        }
        else
        {
            my $env = $self->env;
            local %ENV = %$env;
            # What a shame to fork exec. Too bad spawn_proc_prog() does not work.
            return( scalar( qx( $args->{cmd} ) ) );
        }
    }
    
    unless( exists( $args->{cgi} ) )
    {
        $self->error( "No 'cmd' or 'cgi' argument given to #exec" );
        return( $self->errmsg );
    }
    
    # Get a new Apache2::SSI::URI object
    my $cgi = $self->new_uri( $args->{cgi} ) || do
    {
        return( $self->errmsg );
    };
    my $doc_root = $self->document_root || do
    {
        $self->error( "No document root set." );
        return( $self->errmsg );
    };
    
    if( $cgi->code != 200 )
    {
        $self->error( "Error including cgi: subrequest returned status '" . $cgi->code . "', not 200" );
        return( $self->errmsg );
    }
    
    my $finfo = $cgi->finfo;
    if( !$finfo->exists )
    {
        $cgi->code( 404 );
        $self->error( "Error including cgi \"$args->{cgi}\". File not found. CGI resolved to \"", $cgi->filename, "\"" );
        return( $self->errmsg );
    }
    elsif( !$finfo->can_exec )
    {
        unless( $^O =~ /^(dos|mswin32|NetWare|symbian|win32)$/i && -T( "$finfo" ) )
        {
            # return( $self->error( "Error including cgi \"$args->{cgi}\". File is not executable by Apache user." ) );
            $self->error( "Error including cgi \"$args->{cgi}\". File is not executable by Apache user." );
            $cgi->code( 401 );
            return( $self->errmsg );
        }
    }
        
    
    if( $r )
    {
        my $rr = $cgi->apache_request;
#         my $u = URI->new( $rr->uri . ( length( $cgi->path_info ) ? $cgi->path_info : length( $uri->path_info ) ? $uri->path_info : '' ) );
#         $u->query( $uri->query_string ) if( !length( $cgi->query_string ) && length( $uri->query_string ) );
        $cgi->path_info( $uri->path_info ) if( !length( $cgi->path_info ) && length( $uri->path_info ) );
        $cgi->query_string( $uri->query_string ) if( !length( $cgi->query_string ) && length( $uri->query_string ) );
        $rr->content_type( 'application/x-httpd-cgi' );
        $cgi->env( GATEWAY_INTERFACE => 'CGI/1.1' );
        $cgi->env( DOCUMENT_URI => "$cgi" );
        my( $content, $headers ) = $rr->fetch_uri( "$cgi" );
        return( $content );
    }
    else
    {
        my $buf;
        {
            local $ENV{DOCUMENT_URI} = $cgi->document_uri;
            local $ENV{PATH_INFO} = $uri->path_info;
            local $ENV{PATH_INFO} = $cgi->path_info if( length( $cgi->path_info ) );
            local $ENV{QUERY_STRING} = $uri->query_string;
            local $ENV{QUERY_STRING} = $cgi->query_string if( length( $cgi->query_string ) );
            local $ENV{REMOTE_ADDR} = $self->remote_ip;
            local $ENV{REQUEST_METHOD} = 'GET';
            local $ENV{REQUEST_URI} = $cgi->document_uri;
            my $file = $cgi->filename;
            my $mime = $finfo->mime_type;
            if( $^O =~ /^(dos|mswin32|NetWare|symbian|win32)$/i && $mime eq 'text/x-perl' )
            {
                $buf = `$^X $file`;
            }
            else
            {
                $buf = qx( "$file" );
            }
        };
        # Failed to execute
        if( $? == -1 )
        {
            $cgi->code( 500 );
            return( $self->errmsg );
        }
        my( $key, $val );
        my $headers = {};
        while( $buf =~ s/([^\012]*)\012// )