aboutsummaryrefslogtreecommitdiffstats
path: root/cgi-bin/lxr
diff options
context:
space:
mode:
Diffstat (limited to 'cgi-bin/lxr')
-rwxr-xr-xcgi-bin/lxr735
1 files changed, 0 insertions, 735 deletions
diff --git a/cgi-bin/lxr b/cgi-bin/lxr
deleted file mode 100755
index b134738..0000000
--- a/cgi-bin/lxr
+++ /dev/null
@@ -1,735 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-
-use FindBin;
-use lib "$FindBin::Bin/../lib";
-
-use CGI::Carp qw(fatalsToBrowser);
-use IO::Handle;
-
-use LXRng ROOT => "$FindBin::Bin/..";
-use LXRng::Context;
-use LXRng::Lang;
-use LXRng::Parse::Simple;
-use LXRng::Markup::File;
-use LXRng::Markup::Dir;
-use Subst::Complex;
-
-use Template;
-use Digest::SHA1 qw(sha1_hex);
-use CGI::Ajax;
-use CGI::Simple qw(-newstyle_urls);
-use File::Temp qw(tempdir tempfile);
-use POSIX qw(waitpid);
-
-use constant PDF_LINELEN => 95;
-use constant PDF_CHARPTS => 6.6;
-
-use vars qw($has_gzip_io);
-eval { require PerlIO::gzip; $has_gzip_io = 1; };
-
-
-# Return 1 if gzip compression of html is desired.
-
-sub do_compress_response {
- my ($query) = @_;
-
- my @enc = split(",", $query->http('Accept-Encoding'));
- return $has_gzip_io && grep { $_ eq 'gzip' } @enc;
-}
-
-
-# Progressive output of marked-up file. If the file in question
-# exists in cache, and this is the initial load of an ajax-requested
-# file, return only the lines the user wants to see (with a minimum of
-# context) as a first approximation.
-
-sub print_markedup_file {
- my ($context, $template, $node) = @_;
-
- autoflush STDOUT 1;
-
- unless ($node) {
- print('<div class="error">File not found.</div>');
- return;
- }
-
- if ($node->isa('LXRng::Repo::Directory')) {
- my $markup = LXRng::Markup::Dir->new('context' => $context,
- 'node' => $node);
- $template->process('content_dir.tt2',
- {'context' => $context,
- 'dir_listing' => $markup->listing})
- or die $template->error();
- }
- else {
- # Grmble. We assume the identifiers to markup are identical
- # from one version to another, but if the same revision of a
- # file exists both in an indexed and un-indexed release, one
- # of them will have its identifiers highlighted and the other
- # not. So we can't share a cache slot across releases without
- # adding some extra logic here. Bummer.
- # TODO: Resolve by caching only accesses to releases that are
- # is_indexed.
- my $shaid = sha1_hex(join("\0", $node->name, $node->revision,
- $context->release));
- my $cfile;
- $cfile = $context->config->{'cache'}.'/'.$shaid
- if exists $context->config->{'cache'};
-
- if ($cfile and -e $cfile) {
- open(my $cache, '<', $cfile);
-
- my $focus = $context->param('line') || 0;
- $focus = 0 if $context->param('full');
- my $class = $focus ? 'partial' : 'full';
- my $start = $focus > 5 ? " start=".($focus - 5) : "";
- print("<pre id=\"file_contents\" class=\"$class\"><ol$start><span>");
- while (<$cache>) {
- next if $focus and $. < $focus - 5;
- print($_);
- last if $focus and $. > $focus + 70;
- }
- print("</span></ol></pre>");
- close($cache);
- }
- else {
- my $cache;
- open($cache, '>', $cfile) if $cfile;
- my $handle = $node->handle();
- LXRng::Lang->init($context);
- my $lang = LXRng::Lang->new($node);
- my $parse = LXRng::Parse::Simple->new($handle, 8,
- @{$lang->parsespec});
- my $markup = LXRng::Markup::File->new('context' => $context);
- my $subst = $lang->markuphandlers($context, $node, $markup);
-
- # Possible optimization: store cached file also as .gz,
- # and pass that on if the client accepts gzip-encoded
- # data. Saves us from compressing the cached file each
- # time it's needed, but requires a bit of fiddling with
- # perlio and the streams to get right. Also messes up
- # partial transfers.
- print("<pre id=\"file_contents\" class=\"full\"><ol><span>");
- while (1) {
- my @frags = $markup->markupfile($subst, $parse);
- last unless @frags;
- print(@frags);
- print($cache @frags) if $cache;
- }
- print("</span></ol></pre>\n");
- }
- }
-}
-
-sub print_tree_list {
- my ($context, $template) = @_;
-
- $template->process('tree_list.tt2',
- {'context' => $context})
- or die $template->error();
-}
-
-sub print_release_list {
- my ($context, $template) = @_;
-
- $template->process('release_select.tt2',
- {'context' => $context})
- or die $template->error();
-}
-
-sub source {
- my ($context, $template, $query, $template_extra_args) = @_;
-
- my $pjx = CGI::Ajax->new('pjx_search' => '',
- 'pjx_load_file' => '',
- 'pjx_releases' => '');
- $pjx->js_encode_function('escape');
-
- if ($context->prefs and $context->prefs->{'navmethod'} eq 'ajax') {
- if ($context->tree ne '') {
- my $base = $context->base_url(1);
- my $path = $context->vtree.'/'.$context->path;
- print($query->redirect($base.'#'.$path));
- }
- else {
- print($query->header(-type => 'text/html',
- -charset => 'utf-8'));
-
- if ($context->release eq 'trees') {
- print_tree_list($context, $template);
- }
- else {
- my $base = $context->base_url(1);
- $base =~ s,/*$,/ajax+*/,;
-
- $template->process('main.tt2',
- {'context' => $context,
- 'base_url' => $base,
- 'javascript' => $pjx->show_javascript(),
- 'is_ajax' => 1})
- or die $template->error();
- }
- }
- return;
- }
-
- if ($context->tree eq '') {
- print($query->header(-type => 'text/html',
- -charset => 'utf-8'));
- print_tree_list($context, $template);
- return;
- }
-
-
- my $ver = $context->release;
- my $rep = $context->config->{'repository'};
- die "No tree given" unless $rep;
-
- my $node = $rep->node($context->path, $ver);
- die "Node not found: ".$context->path." ($ver)" unless $node;
-
- my $gzip = do_compress_response($query);
-
- my @history = $query->cookie('lxr_history_'.$context->tree);
- if ($node->isa('LXRng::Repo::File')) {
- my $h = $context->path.'+'.$ver;
- @history = ($h, grep { $_ ne $h } @history);
- splice(@history, 15) if @history > 15;
- }
-
- my $lxr_hist = $query->cookie(-name => 'lxr_history_'.$context->tree,
- -values => \@history,
- -expires => '+1y');
-
- print($query->header(-type => 'text/html',
- -charset => 'utf-8',
- -cookie => $lxr_hist,
- $gzip ? (-content_encoding => 'gzip') : ()));
-
- binmode(\*STDOUT, ":gzip") if $gzip;
-
- my @rels = @{$context->all_releases()};
- unshift(@rels, $rels[0]);
- while (@rels > 2 and $rels[1] ne $context->release) {
- shift(@rels);
- }
-
- my $ver_next = @rels > 1 ? $rels[0] : $context->release;
- my $ver_prev = @rels > 2 ? $rels[2] : $context->release;
-
- my %template_args = (%{$template_extra_args || {}},
- 'context' => $context,
- 'tree' => $context->tree,
- 'node' => $node,
- 'ver_prev' => $ver_prev,
- 'ver_next' => $ver_next,
- 'base_url' => $context->base_url,
- 'javascript' => $pjx->show_javascript());
-
-
- if ($context->prefs and $context->prefs->{'navmethod'} eq 'popup') {
- $template_args{'is_popup'} = 1;
- $template_args{'popup_serial'} = int(rand(1000000));
- }
-
- if ($node->isa('LXRng::Repo::Directory')) {
- my $markup = LXRng::Markup::Dir->new('context' => $context,
- 'node' => $node);
- $template->process('main.tt2',
- {%template_args,
- 'dir_listing' => $markup->listing,
- 'is_dir' => 1})
- or die $template->error();
- }
- else {
- my $html = '';
- $template->process('main.tt2',
- {%template_args,
- 'file_content' => '<!--FILE_CONTENT-->',
- 'is_dir' => 0},
- \$html)
- or die $template->error();
-
- # Template directives in processed template. Sigh. TT2 sadly
- # can't do progressive rendering of its templates, so we cheat...
- my ($pre, $post) = split('<!--FILE_CONTENT-->', $html);
- print($pre);
- print_markedup_file($context, $template, $node);
- print($post);
- }
-
- # TODO: This is potentially useful, in that it resets the stream
- # to uncompressed mode. However, under Perl 5.8.8+PerlIO::gzip
- # 0.18, this seems to truncate the stream. Not strictly needed
- # for CGI, reexamine when adapting to mod_perl.
- ## binmode(\*STDOUT, ":pop") if $gzip;
-}
-
-#sub ident {
-# my ($self) = @_;
-
-# my $index = $self->context->config->{'index'};
-# my $view = LXRng::View->new('context' => $self->context);;
-
-# my $ident = $self->context->value('ident');
-# my $target = $self->context->value('navtarget');
-# $target ||= 'source';
-
-# my $rel_id = $index->release_id($self->tree, $self->context->value('v'));
-# my ($symname, $symid, $ident, $refs) =
-# $index->get_identifier_info($ident, $rel_id);
-
-# $$ident[1] = $LXRng::Lang::deftypes{$$ident[1]};
-# $$ident[5] &&= $LXRng::Lang::deftypes{$$ident[5]};
-
-# return $view->identifier_info($symname, $symid, $ident, $refs, $target);
-#}
-
-
-# Perform various search operations. Return results as html suitable
-# both as a response to an ajax request and inclusion in a more
-# general html document.
-
-sub search {
- my ($context, $template, $type, $find) = @_;
-
- my $ver = $context->release;
- $find ||= $context->param('search');
-
- my $index = $context->config->{'index'};
- my $rel_id = $index->release_id($context->tree, $ver);
- my %template_args = ('context' => $context);
-
- $template_args{'navtarget'} = 'target='.$context->param('navtarget')
- if $context->param('navtarget');
-
-
- if ($find =~ /\S/) {
- if ($find =~ /^(ident|code):(.*)/) {
- $type = 'code';
- $find = $2;
- }
- elsif ($find =~ /^(file|path):(.*)/) {
- $type = 'file';
- $find = $2;
- }
- elsif ($find =~ /^(text):(.*)/) {
- $type = 'text';
- $find = $2;
- }
-
- if ($type eq 'file' or $type eq 'search') {
- my $files = $index->files_by_wildcard($context->tree,
- $ver, $find);
- $template_args{'file_res'} = {'query' => $find,
- 'files' => $files,}
- }
- if ($type eq 'text' or $type eq 'search') {
- my $hash = $context->config->{'search'};
- my ($total, $res) = $hash->search($rel_id, $find);
-
- $template_args{'text_res'} = {'query' => $find,
- 'total' => $total,
- 'files' => $res};
- }
- if ($type eq 'code' or $type eq 'search') {
- my $result = $index->identifiers_by_name($context->tree,
- $ver, $find);
- my @cooked = (map { $$_[1] = ucfirst($LXRng::Lang::deftypes{$$_[1]});
- $_ }
- sort { $LXRng::Lang::defweight{$$b[1]} cmp
- $LXRng::Lang::defweight{$$a[1]} ||
- $$a[2] cmp $$b[2] ||
- $$a[3] <=> $$b[3] }
- @$result);
- $template_args{'code_res'} = {'query' => $find,
- 'idents' => \@cooked};
- }
- if ($type eq 'ident') {
- my $usage = $context->config->{'usage'};
- my ($symname, $symid, $ident, $refs) =
- $index->get_identifier_info($usage, $find, $rel_id);
-
- $$ident[1] = ucfirst($LXRng::Lang::deftypes{$$ident[1]});
- $$ident[5] &&= $LXRng::Lang::deftypes{$$ident[5]};
-
- $template_args{'ident_res'} = {'query' => $symname,
- 'ident' => $ident,
- 'refs' => $refs};
- }
- if ($type eq 'ambig') {
- my $rep = $context->config->{'repository'};
- my @args = grep {
- $rep->node($_, $context->release)
- } split(/\|/, $find);
- $template_args{'ambig_res'} = {'query' => $find,
- 'files' => \@args,}
- }
- }
- else {
- die "No query string given";
- }
- my $html = '';
- $template_args{'tree'} = $context->tree;
- $template_args{'search_type'} = $type if
- $type =~ /^(search|file|text|code|ident|ambig)$/;
- $template->process('search_result.tt2',
- \%template_args,
- \$html)
- or die $template->error();
- return $html;
-}
-
-
-# Display search results for plain and popup navigation methods.
-# (Ajax methods call "search" directly.)
-
-sub search_result {
- my ($context, $template, $query, $result) = @_;
-
- my %template_args = ('context' => $context,
- 'tree' => $context->tree,
- 'search_res' => $result,
- 'base_url' => $context->base_url);
-
- if ($context->prefs and $context->prefs->{'navmethod'} eq 'popup') {
- my $gzip = do_compress_response($query);
-
- print($query->header(-type => 'text/html',
- -charset => 'utf-8',
- $gzip ? (-content_encoding => 'gzip') : ()));
-
- binmode(\*STDOUT, ":gzip") if $gzip;
-
- $template->process('popup_main.tt2',
- {%template_args,
- 'is_popup' => 1})
- or die $template->error();
- }
- else {
- $context->path('');
- source($context, $template, $query, \%template_args);
- }
-}
-
-
-# Callback to perform the ajax-available functions.
-
-sub handle_ajax_request {
- my ($query, $context, $template) = @_;
- my $gzip = do_compress_response($query);
-
- $query->no_cache(1);
- print($query->header(-type => 'text/html',
- -charset => 'utf-8',
- -cache-control => 'no-store, no-cache, must-revalidate',
- $gzip ? (-content_encoding => 'gzip') : ()));
-
- binmode(\*STDOUT, ":gzip") if $gzip;
-
- if ($context->param('fname') eq 'pjx_load_file') {
- my $rep = $context->config->{'repository'};
- my $node = $rep->node($context->param('file'), $context->release);
- print_markedup_file($context, $template, $node);
-
- }
- elsif ($context->param('fname') eq 'pjx_search') {
- if ($context->param('ajax_lookup') =~
- /^[+ ](code|ident|file|text|ambig)=(.*)/)
- {
- print(search($context, $template, $1, $2));
- }
- else {
- print(search($context, $template, 'search',
- $context->param('search')));
- }
- }
- elsif ($context->param('fname') eq 'pjx_releases') {
- print_release_list($context, $template);
- }
-
- # binmode(\*STDOUT, ":pop") if $gzip;
-}
-
-
-# Stuff user preferences in cookie.
-
-sub handle_preferences {
- my ($query, $context, $template) = @_;
-
- if ($context->param('resultloc')) {
- my @prefs;
- if ($context->param('resultloc') =~ /^(replace|popup|ajax)$/) {
- push(@prefs, 'navmethod='.$1);
- }
- my $lxr_prefs = $query->cookie(-name => 'lxr_prefs',
- -values => \@prefs,
- -expires => '+1y');
- print($query->header(-type => 'text/html',
- -charset => 'utf-8',
- -cookie => $lxr_prefs));
-
- my %template_args;
- if (defined($context->param('return')) and $context->config) {
- $template_args{'return'} =
- $context->base_url.$query->param('return');
- }
- else {
- my $url = $query->url(-full => 1, -path => 1);
- $url =~ s,/[+ ]prefs\b.*,/,;
- $template_args{'return'} = $url;
- }
-
- $template->process('prefs_set.tt2',
- \%template_args)
- or die $template->error();
- }
- else {
- print($query->header(-type => 'text/html',
- -charset => 'utf-8'));
-
- my $nav = 'is_replace';
- $nav = 'is_'.$context->prefs->{'navmethod'} if
- $context->prefs and $context->prefs->{'navmethod'} ne '';
-
- $template->process('prefs.tt2',
- {'return' => $query->param('return'),
- $nav => 1})
- or die $template->error();
- }
-}
-
-
-# Generate pdf listing of given file. Much if the following lifted
-# from the script "texify". Proof of concept, code quality could be
-# better.
-
-sub generate_pdf {
- my ($query, $context, $template, $path) = @_;
-
- my $tempdir = tempdir(CLEANUP => 1);
-
- my %tspecials = (
- '$' => '\$', '*' => "\$\\ast\$",
- '&' => '\&', '%' => '\%',
- '#' => '\#', '_' => '\_',
- '^' => '\^{}', '{' => '\{',
- '}' => '\}', '|' => "\$|\$",
- '[' => '{[}', ']' => '{]}',
- "'" => "{'}", "\"" => "\\string\"",
- '~' => '\~{}', '<' => "\$<\$",
- '>' => "\$>\$", "\\" => "\$\\backslash\$",
- '-' => '\dash{}',
-# These are latin1-replacements, and interact badly with utf8...
- "\242" => '?', "\244" => '?',
- "\245" => '?', "\246" => '?',
- "\252" => "\$\252\$", "\254" => "\$\254\$",
- "\255" => "\\dash{}", "\260" => "\$\260\$",
- "\261" => "\$\261\$", "\262" => "\$\262\$",
- "\263" => "\$\263\$", "\265" => "\$\265\$",
- "\271" => "\$\271\$", "\272" => "\$\272\$",
- "\327" => "\$\327\$", "\367" => "\$\367\$",
- );
-
- my $tspecials = join('', map { quotemeta($_) } keys(%tspecials));
-
- my $ver = $context->release;
- my $rep = $context->config->{'repository'};
- my $node = $rep->node($path, $ver);
-
- die "No such file" unless $node;
-
- my $handle = $node->handle();
- LXRng::Lang->init($context);
- my $lang = LXRng::Lang->new($node);
- my $parse = LXRng::Parse::Simple->new($handle, 8,
- @{$lang->parsespec});
- my $res = $lang->reserved();
- my $resre;
- if (%$res) {
- $resre = '(?:(?<=[\s\W])|^)('.
- join('|', map { my $c = $_; $c =~ s/\#/\\\#/g; quotemeta($c) }
- sort { length($b) <=> length($a) }
- keys %$res).')(?=$|[\s\W])';
- }
-
- my @lines;
- my $row = 1;
- my $col = 0;
- my $line = '\\lxrln{1}';
-
- while (1) {
- my ($btype, $frag) = $parse->nextfrag;
-
- last unless defined $frag;
-
- $btype ||= 'code';
- my @parts = split(/(\n)/, $frag);
-
- while (@parts) {
- my $part = shift(@parts);
- my $align = 0;
- my $cont = 0;
-
- if ($part eq "\n") {
- push(@lines, $line);
-
- $col = 0;
- $row++;
- if ($row % 5 == 0) {
- $line = "\\lxrln{$row}";
- }
- else {
- $line = '';
- }
- next;
- }
-
- if ($part =~ /^(.*? +)(.*)/) {
- unshift(@parts, $2);
- $part = $1;
- $align = 1;
- }
-
- $col += length($part);
-
- if ($col > PDF_LINELEN) {
- unshift(@parts,
- substr($part, PDF_LINELEN - $col, length($part), ''));
- if ($part =~ s/([^\s_,\(\)\{\}\/\=\-\+\*\<\>\[\]\.]+)$//) {
- if (length($1) < 20) {
- unshift(@parts, $1);
- }
- else {
- $part .= $1;
- }
- }
- $align = 0;
- $cont = 1;
- }
-
- $part =~ s(([$tspecials\0-\010\013\014\016-\037\200-\240]))
- (exists $tspecials{$1} ? $tspecials{$1} : '?')ge;
-
- if ($btype eq 'code') {
- $part =~ s/$resre/\\textbf{$1}/g if $resre;
- }
- elsif ($btype eq 'include') {
- $part =~ s/$resre/\\textbf{$1}/ if $resre;
- }
- elsif ($btype eq 'comment') {
- $part = '\textit{'.$part.'}';
- }
- elsif ($btype eq 'string') {
- $part = '\texttt{'.$part.'}';
- }
-
- # Common fixed-width "ascii-art" characters.
- $part =~ s/(\$\\ast\$|=)/'\\makebox['.PDF_CHARPTS."pt][c]{$1}"/ge;
- $line .= $part;
- if ($align) {
- $line = '\\makebox['.int($col * PDF_CHARPTS).
- 'pt][l]{'.$line.'}';
- }
- if ($cont) {
- push(@lines, "$line\\raisebox{-2pt}{\\ArrowBoldRightStrobe}");
- $line = '\\raisebox{-2pt}{\\ArrowBoldDownRight} ';
- $col = 3;
- }
- }
- }
-
- if ($line ne '') {
- push(@lines, $line);
- }
- else {
- $row--;
- }
-
- if (@lines and $row % 5 != 0) {
- $lines[$#lines] =~ s/^/\\lxrln{$row}/;
- }
-
- my $pathdesc = $context->tree."/$path ($ver)";
- $pathdesc =~ s/([$tspecials])/$tspecials{$1}/ge;
-
- my ($texh, $texname) = tempfile(DIR => $tempdir, SUFFIX => '.tex');
-
- $template->process('print_pdf.tt2',
- {'pathdesc' => $pathdesc,
- 'lines' => \@lines},
- $texh)
- or die $template->error();
- my $pid = fork();
- die $! unless defined($pid);
- if ($pid == 0) {
- close(STDOUT);
- open(STDOUT, "> $texname.output");
- close(STDERR);
- open(STDERR, ">&STDOUT");
- chdir($tempdir);
- exec("pdflatex", "$texname");
- kill(9, $$);
- }
- waitpid($pid, 0);
- my $pdfname = $texname;
- $pdfname =~ s/[.]tex$/.pdf/;
- if (-e $pdfname) {
- open(my $pdfh, "< $pdfname") or die $!;
-
- print($query->header(-type => 'application/pdf',
- -content_disposition =>
- "inline; filename=$path.pdf"));
- my $buf = '';
- while (sysread($pdfh, $buf, 65536) > 0) {
- print($buf);
- }
- close($pdfh);
- }
- elsif (-e "$texname.output") {
- open(my $errh, "< $texname.output") or die $!;
- my @err = <$errh>;
- close($errh);
- @err = splice(@err, -15) if @err > 15;
- die "PDF generation failed: ".join("\n", @err);
- }
- else {
- die "PDF generation failed";
- }
-}
-
-
-# Initial request dispatch.
-
-my $query = CGI::Simple->new();
-my $context = LXRng::Context->new('query' => $query);
-my $template = Template->new({'INCLUDE_PATH' => $LXRng::ROOT.'/tmpl/'});
-
-
-if ($context->param('fname')) {
- handle_ajax_request($query, $context, $template);
-}
-else {
- if ($context->path =~ /^[+ ]prefs$/) {
- handle_preferences($query, $context, $template);
- }
- elsif ($context->path =~ /^[+ ]print=(.*)/) {
- generate_pdf($query, $context, $template, $1);
- }
- else {
- if ($context->path =~
- /^[+ ](search|code|ident|file|text|ambig)(?:=(.*)|)/)
- {
- search_result($context, $template, $query,
- search($context, $template, $1, $2));
- $context->path('');
- }
- else {
- source($context, $template, $query);
- }
- }
-}
-
-1;
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-10 03:56:07 +0000