view release on metacpan or  search on metacpan

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

    while( <$f> ) {
        if ( /$search_re/ )  {
            $found = 1;
        } elsif (/^=item/) {
            if ($found > 1 and !$inlist) {
                close $f;
                return "=over 4\n\n$prefix$document\n\n=back\n\n";
            } elsif (!$found and !$inlist) {
                $prefix.=$_."\n";
            }
        } elsif ($found > 1 and !$inlist and /^=back/) {
            close $f;
            return "=over 4\n\n$prefix$document\n\n=back\n\n";
        } elsif (!$found and /\S/) {
            $prefix='';
        }
        next unless $found;
        if (/^=over/) {
            ++$inlist;
        } elsif (/^=back/) {
            --$inlist;
        }
        $document .= "$_";
        ++$found if /^\w/;        # found descriptive text
    }

    die \Apache2::Const::NOT_FOUND;
}

sub _getpodfuncdoc {
    my ($r, $fun) = @_;

    foreach my $name (qw/perlfunc perlvar/) {
        my $doc=eval {_scanit $r, $fun, $name};
        return $doc unless $@;
    }

    die \Apache2::Const::NOT_FOUND;
}

sub _body {
    my ($r, $file, $function, $uplink)=@_;

    my $body;
    my $parser=$r->dir_config('PARSER');
    $parser='Apache2::PodBrowser::Formatter' unless length $parser;
    eval "require $parser";
    if( $@ ) {
        chomp $@;
        $r->log_reason($@);
        die \Apache2::Const::NOT_FOUND;
    }
    $parser=$parser->new;
    $parser->r($r) if ($parser->can('r'));
    $parser->html_css(_stylesheet($r)) if ($parser->can('html_css'));
    $parser->html_header_after_title($parser->html_header_after_title.
                                     _indexlink(INDEX_NORMAL)."\n")
        if ($uplink and $parser->can('html_header_after_title'));
    $parser->no_errata_section(1);
    $parser->complain_stderr(1);
    $parser->output_string( \$body );
    $parser->index( $r->dir_config('INDEX') ) if ($parser->can('index'));
    if ($parser->can('perldoc_url_prefix')) {
        my $prefix=$r->dir_config('LINKBASE');
        if (defined $prefix) {
            $parser->perldoc_url_prefix($prefix);
        } else {
            $parser->perldoc_url_prefix('');
        }
    }
    if ( $function ) {
        $parser->parse_string_document( _getpodfuncdoc($r, $function) );
        $body=~s!<a href="(?:\./perl(?:func|var))?#([^"]+)"!<a href="./?$1"!g;
    } else {
        $parser->parse_file( $file );
    }
    # TODO: Send the timestamp of the file in the header here
    return $body;
}

sub _compress {
    my $r=$_[1];                # do not copy $_[0] here

    if ($r->dir_config('GZIP') and eval {require Compress::Zlib}) {
        $r->headers_out->add(Vary=>'accept-encoding');
        if ($r->subprocess_env->{'no-gzip'} ne '1') { # behave as mod_deflate
            if ($r->headers_in->{'Accept-Encoding'} =~ /\bdeflate\b/) {
                $r->headers_out->{'Content-Encoding'} = 'deflate';
                $r->content_encoding('deflate');
                return Compress::Zlib::compress
                    ($_[0], &Compress::Zlib::Z_BEST_COMPRESSION);
            } elsif ($r->headers_in->{'Accept-Encoding'} =~ /\bgzip\b/) {
                $r->headers_out->{'Content-Encoding'} = 'gzip';
                $r->content_encoding('gzip');
                return Compress::Zlib::memGzip($_[0]);
            }
        }
    }
    return $_[0];
}

sub handler {
    my ($r)=@_;

    my $ct=$r->dir_config('CONTENTTYPE');
    $r->content_type($ct||'text/html');

    my $body;
    eval {
        if( $r->finfo->filetype==APR::Const::FILETYPE_DIR or
            $r->finfo->filetype==APR::Const::FILETYPE_NOFILE ) { # perldoc mode
            # compute sane path_info
            # path_info as it is set by the default map_to_storage
            # handler depends on the directory layout on the disk.
            # In perldoc mode we cannot rely on that. So, we compute
            # saner path_info as the part of the uri that is not covered
            # by $r->location.
            my $loc=$r->location;
            $loc=~s!/+$!!;          # cut off trailing slash;
            $r->path_info(substr($r->uri, length($loc)));