view release on metacpan or  search on metacpan

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

        my $prefix='';
        my $firstchar=substr($name, 0, 1);
        unless( $firstchar eq $current ) {
            push @index, $firstchar;
            $prefix="<h2><a name=\"$firstchar\">$firstchar</a></h2>\n";
            $current=$firstchar;
        }

        my $display;
        if( length $name>35 ) {
            $display='...'.substr($name, -32);
        } else {
            $display=$name;
        }
        my $title=$name;
        $name=~s{([^A-Za-z0-9\-_.!~*'()/:\$@&=+,;?\\\]\[^`|<>{}])}
                {sprintf("%%%02X",ord($1))}eg;
        for my $x ($title, $display) {
            $x=~s/(["<>&])/$html{$1}/ge;
        }
        $prefix."<a href=\"./$linkprefix$name\" title=\"$title\">$display</a>";
    }

    sub _gen_index {
        "<div class=\"indexgroup\"><div>\n    ".join("\n    ", map {
            "<a href=\"#$_\">$_</a>";
        } @index)."\n</div></div>\n";
    }
}

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

    my $stylesheet=$r->dir_config('STYLESHEET') || '';
    if ($stylesheet=~/^auto$/i) {
        $stylesheet='./auto.css';
    } elsif ($stylesheet=~/^fancy$/i) {
        $stylesheet='./fancy.css';
    }

    return $stylesheet;
}

sub _findpod {
    my ($r, $name, $ignore_NOINC)=@_;
    $name=~s!^/!!;
    $name=Pod::Find::pod_where
        ( {
           -inc=>$ignore_NOINC || !$r->dir_config->get('NOINC'),
           -dirs=>[$r->dir_config->get('PODDIR')],
          },
          $name );
    die \Apache2::Const::NOT_FOUND unless( length $name );

    return $name;
}

sub update_finfo {
    my ($r, $name)=@_;

    $r->finfo(APR::Finfo::stat($name, APR::Const::FINFO_NORM,
                               $r->pool)) if defined $name;

    $r->set_last_modified($r->finfo->mtime);
    $r->set_etag;
    my $rc=$r->meets_conditions;
    die \$rc unless $rc==Apache2::Const::OK;
}

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

    my @links=do {
        local $_;
        my %unique;

        open my $f, '<', _findpod($r, 'perlfunc', 1) or
            die \Apache2::Const::NOT_FOUND;

        while ( <$f> ) {
            /^=head2 Alphabetical Listing of Perl Functions/ and last;
        }

        my $level=0;
        while ( <$f> ) {
            if( ($level==0 && /^=over/)..($level==1 && /^=back/) ) {
                /^=over/ and $level++;
                /^=back/ and $level--;
                $level==1 && /^=item ([-\w]+)/ and undef $unique{$1};
            }
        }

        open my $f, '<', _findpod($r, 'perlvar', 1) or
            die \Apache2::Const::NOT_FOUND;

        my $level=0;
        while ( <$f> ) {
            if( ($level==0 && /^=over 8/)..($level==1 && /^=back/) ) {
                /^=over/ and $level++;
                /^=back/ and $level--;
                $level==1 && /^=item (?!IO::|HANDLE|\$\w+\{expr\})(.+)/
                    and do {
                        my $name=$1;
                        $name='$1..$N' if $name=~/digit/i;
                        undef $unique{$name};
                    };
            }
        }

        _reset_link_generator;
        map {_link($_, '?')} sort keys %unique;
    };

    return (_header(INDEX_FUNCINDEX, _stylesheet($r)).
            _gen_index.
            join("\n", @links)."\n".
            _footer);
}

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

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

                }
            } else {
                my $fn=_findpod($r, $pi);
                update_finfo $r, $fn;
                $body=_compress(_body($r, $fn, undef, 1), $r);
            }
        } else {                    # simple handler
            # here we expect $r->filename to point to a file containing POD
            # and path_info to be empty.
            die \Apache2::Const::NOT_FOUND
                if (length $r->path_info or
                    ($r->finfo->filetype!=APR::Const::FILETYPE_REG));

            update_finfo $r;

            $body=_compress(_body($r, $r->filename, undef, 0), $r);
        }
    };
    # In case of an error we expect $@ to be a reference
    # the points to a scalar containing the HTTP error code
    # If that is not the case the next line will lead to an internal
    # server error which is ok then.
    return Apache2::Const::NOT_FOUND
        if ref $@ eq 'APR::Error' and $@==APR::Const::ENOENT;

    return ${$@} if ref $@ eq 'SCALAR';

    if( $@ ) {
        chomp $@;
        $r->log_reason($@);
        return Apache2::Const::NOT_FOUND;
    }

    $r->set_content_length(length($body));
    $r->print( $body );

    return Apache2::Const::OK;
}

sub Fixup {                     # use a fixup instead of a transhandler here
    my $r = shift;              # so it can be used in a <Location>

    return Apache2::Const::DECLINED unless ($r->uri =~ m!/(\w+).css$!);

    my $name=$1;
    my $css=$INC{"Apache2/PodBrowser.pm"};
    $css=~s!\.pm$!/$name.css!;

    if ($r->dir_config('GZIP')) {
        $r->headers_out->add(Vary=>'accept-encoding');
        if ($r->headers_in->{'Accept-Encoding'}=~/\bgzip\b/ and
            $r->subprocess_env->{'no-gzip'} ne '1' and # behave as mod_deflate
            $r->subprocess_env->{'gzip-only-text/html'} ne '1' and
            -f $css.'.gz') {
            $r->headers_out->{'Content-Encoding'} = 'gzip';
            $r->content_encoding('gzip');
            $r->filename($css.'.gz');
            $r->path_info('');
            $r->handler('default');
            $r->content_type('text/css');
            $r->finfo(APR::Finfo::stat($r->filename, APR::Const::FINFO_NORM,
                                       $r->pool));
            return Apache2::Const::OK;
        }
    }

    if (-f $css) {
        $r->filename($css);
        $r->path_info('');
        $r->handler('default');
        $r->content_type('text/css');
        $r->finfo(APR::Finfo::stat($r->filename, APR::Const::FINFO_NORM,
                                   $r->pool));

        return Apache2::Const::OK;
    }

    return Apache2::Const::DECLINED;
}

{
    package Apache2::PodBrowser::Formatter;

    use strict;
    use base qw/Pod::Simple::HTML/;

    our $VERSION=Apache2::PodBrowser->VERSION;

    @INC{'Apache2/PodBrowser/Formatter.pm'}=1;

    sub new {
        local $Pod::Simple::HTML::Doctype_decl=
            (qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"}.
             qq{ "http://www.w3.org/TR/html4/loose.dtd">\n});

        return shift->SUPER::new(@_);
    }

    sub resolve_pod_page_link {
        my ($I, $to, $sec)=@_;

        $to=~s/::$//s;
        $to=~s/([^A-Za-z0-9\-_.!~*'():])/sprintf("%%%02X", ord $1)/ge;

        return './'.$to.$I->perldoc_url_postfix
            unless length($I->perldoc_url_prefix);

        return $I->perldoc_url_prefix.$to.$I->perldoc_url_postfix;
    }
}

{
    package Apache2::PodBrowser::DirectMode;

    use strict;
    use base qw/Apache2::PodBrowser::Formatter/;

    our $VERSION=Apache2::PodBrowser->VERSION;

    @INC{'Apache2/PodBrowser/DirectMode.pm'}=1;

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

        if( @_>=2 ) {
            $I->{__PACKAGE__.'::r'}=$_[1];
        }
        $I->{__PACKAGE__.'::r'};
    }

    sub resolve_pod_page_link {
        my ($I, $to, $sec)=@_;