diff options
Diffstat (limited to 'cgi-bin/lxr')
| -rwxr-xr-x | cgi-bin/lxr | 659 |
1 files changed, 659 insertions, 0 deletions
diff --git a/cgi-bin/lxr b/cgi-bin/lxr new file mode 100755 index 0000000..cda9179 --- /dev/null +++ b/cgi-bin/lxr @@ -0,0 +1,659 @@ +#!/usr/bin/perl + +use strict; + +use FindBin; +use lib "$FindBin::Bin/../lib"; +use lib '/home/argggh/www/lxrng/_deps/share/perl/5.8.4'; + +use CGI::Carp qw(fatalsToBrowser); +use IO::Handle; + +use LXRng ROOT => "$FindBin::Bin/.."; +use LXRng::Context; +use LXRng::Lang qw(C); +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; + + 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'; + print("<pre id=\"file_contents\" class=\"$class\">"); + while (<$cache>) { + next if $focus and $. < $focus - 5; + print($_); + last if $focus and $. > $focus + 70; + } + print("</pre>"); + close($cache); + } + else { + my $cache; + open($cache, '>', $cfile) if $cfile; + my $handle = $node->handle(); + 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\">"); + while (1) { + my @frags = $markup->markupfile($subst, $parse); + last unless @frags; + print(@frags); + print($cache @frags) if $cache; + } + print("</pre>\n"); + } + } +} + +sub print_release_list { + my ($context, $template) = @_; + + $template->process('release_select.tt2', + {'context' => $context}) + or die $template->error(); +} + +sub source { + my ($context, $template, $query) = @_; + + my $pjx = CGI::Ajax->new('pjx_search' => 'lxr', + 'pjx_load_file' => 'lxr', + 'pjx_releases' => 'lxr'); + $pjx->js_encode_function('escape'); + + if ($context->prefs and $context->prefs->{'navmethod'} eq 'ajax') { + my $path = $query->path_info; + $path =~ s,^/[+ ],,; + if ($path ne '') { + $path =~ s,^/+,,; + print($query->redirect($query->url(-full => 1). + '#'.$path)); + } + else { + print($query->header(-type => 'text/html', + -charset => 'utf-8')); + + my $base = $query->url(-full => 1); + $template->process('main.tt2', + {'context' => $context, + 'base_url' => $base.'/+ajax/', + 'javascript' => $pjx->show_javascript(), + 'is_ajax' => 1}) + or die $template->error(); + } + return; + } + + my $gzip = do_compress_response($query); + + # history cookie + + print($query->header(-type => 'text/html', + -charset => 'utf-8', + $gzip ? (-content_encoding => 'gzip') : ())); + + binmode(\*STDOUT, ":gzip") if $gzip; + + my $ver = $context->release; + my $rep = $context->config->{'repository'}; + my $node = $rep->node($context->path, $ver); + + die "Node not found: ".$context->path." ($ver)" unless $node; + + my %template_args = ('context' => $context, + 'tree' => $context->tree, + 'node' => $node, + '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 ($type eq 'file' or $type eq 'search') { + # $template_args{'file_res'} = {'query' => $find, + # 'files' => \@args,} + } + 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->symbols_by_name($context->tree, $ver, $find); + my @cooked = (map { $$_[1] = $LXRng::Lang::deftypes{$$_[1]}; + $$_[5] &&= $LXRng::Lang::deftypes{$$_[5]}; + $_ } + sort { $LXRng::Lang::defweight{$$a[1]} cmp + $LXRng::Lang::defweight{$$b[1]} } + @$result); + $template_args{'code_res'} = {'query' => $find, + 'idents' => \@cooked}; + } + if ($type eq 'ident') { + my ($symname, $symid, $ident, $refs) = + $index->get_identifier_info($find, $rel_id); + + $$ident[1] = $LXRng::Lang::deftypes{$$ident[1]}; + $$ident[5] &&= $LXRng::Lang::deftypes{$$ident[5]}; + + use Data::Dumper; + warn Dumper($symname, $symid, $ident, $refs); + $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->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); + + my $gzip = do_compress_response($query); + + print($query->header(-type => 'text/html', + -charset => 'utf-8', + $gzip ? (-content_encoding => 'gzip') : ())); + + binmode(\*STDOUT, ":gzip") if $gzip; + + if ($context->prefs and $context->prefs->{'navmethod'} eq 'popup') { + $template->process('popup_main.tt2', + {%template_args, + 'is_popup' => 1}) + or die $template->error(); + } + else { + $template->process('main.tt2', + {%template_args, + 'file_content' => '', + 'is_dir' => 0}) + or die $template->error(); + } +} + + +# Callback to perform the ajax-available functions. + +sub handle_ajax_request { + my ($query, $context, $template) = @_; + my $gzip = do_compress_response($query); + + print($query->header(-type => 'text/html', + -charset => 'utf-8', + $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')); + + $template->process('prefs.tt2', + {'return' => $query->param('return')}) + 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{}', + "\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(); + 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])/$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; |