view release on metacpan or  search on metacpan

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

    sub _link {
        my ($name, $linkprefix)=@_;

        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);
}