# $Id: Common.pm,v 1.6 1998/05/14 11:59:22 argggh Exp $
package LXR::Common;
use DB_File;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&warning &fatal &abortall &fflush &urlargs
&fileref &idref &htmlquote &freetextmarkup &markupfile
&init &makeheader &makefooter &expandtemplate);
$wwwdebug = 1;
$SIG{__WARN__} = 'warning';
$SIG{__DIE__} = 'fatal';
@cterm = ('atom', '\\\\.', '',
'comment', '/\*', '\*/',
'comment', '//', "\n",
'string', '"', '"',
'string', "'", "'",
'include', '#include', "\n");
sub warning {
print(STDERR "[",scalar(localtime),"] warning: $_[0]\n");
print("** Warning: $_[0]
\n") if $wwwdebug;
}
sub fatal {
print(STDERR "[",scalar(localtime),"] fatal: $_[0]\n");
print("** Fatal: $_[0]
\n") if $wwwdebug;
exit(1);
}
sub abortall {
print(STDERR "[",scalar(localtime),"] abortall: $_[0]\n");
print("Content-Type: text/html\n\n",
"\n\nAbort\n\n",
"Abort!
\n",
"** Aborting: $_[0]\n",
"\n\n") if $wwwdebug;
exit(1);
}
sub fflush {
$| = 1; print('');
}
sub urlargs {
my @args = @_;
my %args = ();
my $val;
foreach (@args) {
$args{$1} = $2 if /(\S+)=(\S*)/;
}
@args = ();
foreach ($Conf->allvariables) {
$val = $args{$_} || $Conf->variable($_);
push(@args, "$_=$val") unless ($val eq $Conf->vardefault($_));
delete($args{$_});
}
foreach (keys(%args)) {
push(@args, "$_=$args{$_}");
}
return($#args < 0 ? '' : '?'.join(';',@args));
}
sub fileref {
my ($desc, $path, $line, @args) = @_;
return(" 0 ? "#L$line" : "").
"\"\>$desc");
}
sub diffref {
my ($desc, $path, $darg) = @_;
($darg,$dval) = $darg =~ /(.*?)=(.*)/;
return("$desc");
}
sub idref {
my ($desc, $id, @args) = @_;
return("$desc");
}
sub http_wash {
my $t = shift;
$t =~ s/\+/ /g;
$t =~ s/\%([\da-f][\da-f])/pack("C", hex($1))/gie;
# Paranoia check. Regexp-searches in Glimpse won't work.
# if ($t =~ tr/;<>*|\`&$!#()[]{}:\'\"//) {
# Should be sufficient to keep "open" from doing unexpected stuff.
if ($t =~ tr/<>|\"\'\`//) {
&abortall("Illegal characters in HTTP-parameters.");
}
return($t);
}
sub markspecials {
$_[0] =~ s/([\&\<\>])/\0$1/g;
}
sub htmlquote {
$_[0] =~ s/\0&/&/g;
$_[0] =~ s/\0/>/g;
}
sub freetextmarkup {
$_[0] =~ s#((ftp|http)://\S*[^\s.])#$1#g;
$_[0] =~ s/(<(.*@.*)>)/$1<\/a>/g;
}
sub linetag {
#$frag =~ s/\n/"\n".&linetag($virtp.$fname, $line)/ge;
# my $tag = ''.$_[1].' ';
my $tag;
$tag .= ' ' if $_[1] < 10;
$tag .= ' ' if $_[1] < 100;
$tag .= &fileref($_[1], $_[0], $_[1]).' ';
$tag =~ s/dbdir."/xref", O_RDONLY, 0664, $DB_HASH)
|| &warning("Cannot open xref database.");
&$outfun(# "\n".
#"');
&linetag($virtp.$fname, $line++));
($btype, $frag) = &SimpleParse::nextfrag;
while (defined($frag)) {
&markspecials($frag);
if ($btype eq 'comment') {
# Comment
# Convert mail adresses to mailto:
&freetextmarkup($frag);
$frag = "$frag";
$frag =~ s#\n#\n#g;
} elsif ($btype eq 'string') {
# String
$frag = "$frag";
} elsif ($btype eq 'include') {
# Include directive
$frag =~ s#\"(.*)\"#
'"'.&fileref($1, $virtp.$1).'"'#e;
$frag =~ s#<(.*)>#
"<".&fileref
($1,
$Conf->mappath($Conf->incprefix."/$1")).
">"#e;
} else {
# Code
$frag =~ s#(^|[^a-zA-Z_\#0-9])([a-zA-Z_~][a-zA-Z0-9_]*)\b#
"$1".(defined($xref{$2}) ?
&idref($2,$2) :
"$2")#ge;
}
&htmlquote($frag);
$frag =~ s/\n/"\n".&linetag($virtp.$fname, $line++)/ge;
&$outfun($frag);
($btype, $frag) = &SimpleParse::nextfrag;
}
# &$outfun("\n");
untie(%xref);
} elsif ($fname =~ /\.(gif|jpg)$/) {
&$outfun("![\"$fname\"](\"http:source".$virtp.$fname.)
\n");
} elsif ($fname eq 'CREDITS') {
while (<$INFILE>) {
&SimpleParse::untabify($_);
&markspecials($_);
&htmlquote($_);
s/^N:\s+(.*)/
\n/#gi;
}
sub init {
my @a;
$HTTP->{'path_info'} = &http_wash($ENV{'PATH_INFO'});
$HTTP->{'this_url'} = &http_wash(join('', 'http://',
$ENV{'SERVER_NAME'},
':', $ENV{'SERVER_PORT'},
$ENV{'SCRIPT_NAME'},
$ENV{'PATH_INFO'},
'?', $ENV{'QUERY_STRING'}));
foreach ($ENV{'QUERY_STRING'} =~ /([^;&=]+)(?:=([^;&]+)|)/g) {
push(@a, &http_wash($_));
}
$HTTP->{'param'} = {@a};
$HTTP->{'param'}->{'v'} ||= $HTTP->{'param'}->{'version'};
$HTTP->{'param'}->{'a'} ||= $HTTP->{'param'}->{'arch'};
$HTTP->{'param'}->{'i'} ||= $HTTP->{'param'}->{'identifier'};
$identifier = $HTTP->{'param'}->{'i'};
$readraw = $HTTP->{'param'}->{'raw'};
if (defined($readraw)) {
print("\n");
} else {
print("Content-Type: text/html\n\n");
}
$Conf = new LXR::Config;
foreach ($Conf->allvariables) {
$Conf->variable($_, $HTTP->{'param'}->{$_}) if $HTTP->{'param'}->{$_};
}
&fixpaths($HTTP->{'path_info'} || $HTTP->{'param'}->{'file'});
if (defined($readraw)) {
open(RAW, $Path->{'realf'});
while () {
print;
}
close(RAW);
exit;
}
return($Conf, $HTTP, $Path);
}
sub expandtemplate {
my ($templ, %expfunc) = @_;
my ($expfun, $exppar);
while ($templ =~ s/(\{[^\{\}]*)\{([^\{\}]*)\}/$1\01$2\02/s) {}
$templ =~ s/(\$(\w+)(\{([^\}]*)\}|))/{
if (defined($expfun = $expfunc{$2})) {
if ($3 eq '') {
&$expfun;
} else {
$exppar = $4;
$exppar =~ s#\01#\{#gs;
$exppar =~ s#\02#\}#gs;
&$expfun($exppar);
}
} else {
$1;
}
}/ges;
$templ =~ s/\01/\{/gs;
$templ =~ s/\02/\}/gs;
return($templ);
}
# What follows is a pretty hairy way of expanding nested templates.
# State information is passed via localized variables.
# The first one is simple, the "banner" template is empty, so we
# simply return an appropriate value.
sub bannerexpand {
if ($who eq 'source' || $who eq 'diff') {
return($Path->{'xref'});
} else {
return('');
}
}
sub titleexpand {
if ($who eq 'source' || $who eq 'diff') {
return($Conf->sourcerootname.$Path->{'virtf'});
} elsif ($who eq 'ident') {
my $i = $HTTP->{'param'}->{'i'};
return($Conf->sourcerootname.' identfier search'.
($i ? " \"$i\"" : ''));
} elsif ($who eq 'search') {
my $s = $HTTP->{'param'}->{'string'};
return($Conf->sourcerootname.' freetext search'.
($s ? " \"$s\"" : ''));
} elsif ($who eq 'find') {
my $s = $HTTP->{'param'}->{'string'};
return($Conf->sourcerootname.' file search'.
($s ? " \"$s\"" : ''));
}
}
sub thisurl {
my $url = $HTTP->{'this_url'};
$url =~ s/([\?\&\;\=])/sprintf('%%%02x',(unpack('c',$1)))/ge;
return($url);
}
sub baseurl {
return($Conf->baseurl);
}
# This one isn't too bad either. We just expand the "modes" template
# by filling in all the relevant values in the nested "modelink"
# template.
sub modeexpand {
my $templ = shift;
my $modex = '';
my @mlist = ();
local $mode;
if ($who eq 'source') {
push(@mlist, "source navigation");
} else {
push(@mlist, &fileref("source navigation", $Path->{'virtf'}));
}
if ($who eq 'diff') {
push(@mlist, "diff markup");
} elsif ($who eq 'source' && $Path->{'file'}) {
push(@mlist, &diffref("diff markup", $Path->{'virtf'}));
}
if ($who eq 'ident') {
push(@mlist, "identifier search");
} else {
push(@mlist, &idref("identifier search", ""));
}
if ($who eq 'search') {
push(@mlist, "freetext search");
} else {
push(@mlist, "freetext search");
}
if ($who eq 'find') {
push(@mlist, "file search");
} else {
push(@mlist, "file search");
}
foreach $mode (@mlist) {
$modex .= &expandtemplate($templ,
('modelink', sub { return($mode) }));
}
return($modex);
}
# This is where it gets a bit tricky. varexpand expands the
# "variables" template using varname and varlinks, the latter in turn
# expands the nested "varlinks" template using varval.
sub varlinks {
my $templ = shift;
my $vlex = '';
my ($val, $oldval);
local $vallink;
$oldval = $Conf->variable($var);
foreach $val ($Conf->varrange($var)) {
if ($val eq $oldval) {
$vallink = "$val";
} else {
if ($who eq 'source') {
$vallink = &fileref($val,
$Conf->mappath($Path->{'virtf'},
"$var=$val"),
0,
"$var=$val");
} elsif ($who eq 'diff') {
$vallink = &diffref($val, $Path->{'virtf'}, "$var=$val");
} elsif ($who eq 'ident') {
$vallink = &idref($val, $identifier, "$var=$val");
} elsif ($who eq 'search') {
$vallink = "$val";
} elsif ($who eq 'find') {
$vallink = "$val";
}
}
$vlex .= &expandtemplate($templ,
('varvalue', sub { return($vallink) }));
}
return($vlex);
}
sub varexpand {
my $templ = shift;
my $varex = '';
local $var;
foreach $var ($Conf->allvariables) {
$varex .= &expandtemplate($templ,
('varname', sub {
return($Conf->vardescription($var))}),
('varlinks', \&varlinks));
}
return($varex);
}
sub makeheader {
local $who = shift;
if ($Conf->htmlhead && !open(TEMPL, $Conf->htmlhead)) {
&warning("Template ".$Conf->htmlhead." does not exist.");
$template ||= "\n
\n";
} else {
$save = $/; undef($/);
$template = ;
$/ = $save;
close(TEMPL);
}
print(
#"\n",
# "\n",
# "\n",
# "",$Conf->sourcerootname," Cross Reference\n",
# "baseurl,"\">\n",
# "\n",
&expandtemplate($template,
('title', \&titleexpand),
('banner', \&bannerexpand),
('baseurl', \&baseurl),
('thisurl', \&thisurl),
('modes', \&modeexpand),
('variables', \&varexpand)));
}
sub makefooter {
local $who = shift;
if ($Conf->htmltail && !open(TEMPL, $Conf->htmltail)) {
&warning("Template ".$Conf->htmltail." does not exist.");
$template = "
\n\n";
} else {
$save = $/; undef($/);
$template = ;
$/ = $save;
close(TEMPL);
}
print(&expandtemplate($template,
('banner', \&bannerexpand),
('thisurl', \&thisurl),
('modes', \&modeexpand),
('variables', \&varexpand)),
"\n");
}
1;