밤새 lxr을 설치했는데.... 펄스크립트 문제..특정 파일을 보여
글쓴이: shamlock / 작성시간: 수, 2005/06/22 - 11:38오전
삽질끝에 lxr의 설치를 다했습니다.
lxr-0.9.4를 sf.net에서 다운받아 설치하고
glimpse 도 같이 설치하고
겨우 겨우 설치를 다 했는데............
대부분의 파일이 다 보입니다.
근데.. 몇몇 파일만 내용이 안보이데요 ㅠㅠ 울면서 이것 저것 막 열어봤더니
파일 경로에 마이너스 기호가 있는 파일만 열리지가 않습니다.
예를 들어
/aaa/bbb/ddd.c 는 잘 열리지만
/aaa/bbb/ddd-1.c 는 안열립니다.
웹상에서 lxr에 파일명이 ddd를 포함하고 있는
모든 파일을 검색했더니 아래와 같이 검색이 되는데
/aaa/bbb/ddd.c
/aaa/bbb/ddd-1.c
상세내용을 보려고 하면
ddd-1.c 파일을 볼수가 없습니다.
디렉토리도 마찬가지로 마이너스 기호가 있으면
서브디렉토리 목록이 안나오네요
스크립트를 보니깐..
디렉토리나 파일 오픈이 실패하면 파일이 없다는 오류를 뿌리는데
웹 페이지 상에 파일이 없다는 오류를 뿌리지 않는거 보면 오픈은 성공하는 것 같은데..
( 제가 5번 정도 설치했는데..환경설정이 잘못되서
실제로 파일경로를 잘못 적은 적도 있엇거든요..
그때는 파일이 없다는 에러를 뿌려주었었습니다
근데 이번엔 파일이 없다는 에러를 뿌리지는 않는군요
)
아래는 혹시나 하는 마음으로
펄스크립트 파일 두개를 첨부해드립니다.
경로를 파싱하는 펄 스크립트 하나와
그 펄스크립트가 참조하는(라이브러리인가) 스크립트도 첨부해봅니다.
아래의 파일이
/source/aaa/bbb/ddd-1.c 의 경로명을 파싱해서
실제로 html 형태로 뿌려주는 펄스크립트인데..
문법이 너무 어려워서리..
#!/usr/bin/perl -T
# $Id: source,v 1.44 2004/09/02 15:26:42 brondsem Exp $
# source -- Present sourcecode as html, complete with references
# the '/icons' images are available in any standard Apache installation
#
# Arne Georg Gleditsch <argggh@ifi.uio.no>
# Per Kristian Gjermshus <pergj@ifi.uio.no>
#
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
######################################################################
$CVSID = '$Id: source,v 1.44 2004/09/02 15:26:42 brondsem Exp $ ';
use strict;
use lib '.'; # for Local.pm
use lib do { $0 =~ m{(.*)/} ? "$1/lib" : "lib" }; # if LXR modules are in ./lib
use LXR::Common qw(:html);
use Local;
sub diricon {
my ($templ, $node, $dir) = @_;
my $img;
if ($node eq '../') {
$img = "/icons/back.gif";
} else {
$img = "/icons/folder.gif";
}
return fileref("<img align=\"bottom\" border=\"0\" src=\"$img\" alt=\"folder\">", "",
$dir . $node);
}
sub dirname {
my ($templ, $node, $dir) = @_;
if ($node eq '../') {
return fileref("Parent directory", "dirfolder", $dir . $node);
} else {
return fileref($node, "dirfolder", $dir . $node);
}
}
sub fileicon {
my ($templ, $node, $dir) = @_;
my $img;
if ($node =~ /^.*\.[ch]$/) {
$img = "/icons/c.gif";
} elsif ($node =~ /^.*\.(cpp|cc|java)$/) {
# TODO: Find a nice icon for c++ files (KDE?)
$img = "/icons/c.gif";
} elsif ($node =~ /^.*\.(txt)$/) {
$img = "/icons/text.gif";
} elsif ($node =~ /^.*\.(jar|war|ear|zip|tar|gz|tgz|cab)$/) {
$img = "/icons/compressed.gif";
} elsif ($node =~ /^.*\.(jpg|jpeg|gif|bmp|png)$/) {
$img = "/icons/image2.gif";
} else {
$img = "/icons/generic.gif";
}
return fileref("<img align=\"bottom\" border=\"0\" src=\"$img\" alt=\"\">", "", $dir . $node);
}
sub filename {
my ($templ, $node, $dir) = @_;
return fileref($node, "dirfile", $dir . $node);
}
sub filesize {
my ($templ, $node, $dir) = @_;
my $s = $files->getfilesize($dir . $node, $release);
my $str;
if ($s < 1 << 10) {
$str = "$s";
} else {
# if ($s < 1<<20) {
$str = ($s >> 10) . "k";
# } else {
# $str = ($s>>20) . "M";
# }
}
return expandtemplate(
$templ,
(
'bytes' => sub { return $str },
'kbytes' => sub { return $str },
'mbytes' => sub { return $str }
)
);
}
sub modtime {
my ($templ, $node, $dir) = @_;
my $current_time = time;
my $file_time = $files->getfiletime($dir . $node, $release);
return '-' unless defined($file_time);
my @t = gmtime($file_time);
my ($sec, $min, $hour, $mday, $mon, $year) = @t;
return
sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec);
}
sub bgcolor {
my ($templ, $line) = @_;
return ((($line - 1) / 3) % 2) ? "#FFFFFF" : "#EEEEEE";
}
sub rowclass {
my ($templ, $line) = @_;
return ((($line - 1) / 3) % 2) ? "dirrow2" : "dirrow1";
}
sub direxpand {
my ($templ, $dir) = @_;
my $direx = '';
my $line = 1;
my %index;
my @nodes;
my $node;
@nodes = $files->getdir($dir, $release);
unless (@nodes) {
print( "<p align=\"center\">\n<i>The directory "
. $files->toreal($dir, $release)
. " does not exist.</i>\n");
print(
"\<p align=\"center\">\n<i>This directory might exist in other versions, try 'Show attic files' or select a different Version.</i>\n"
)
if $files->isa("LXR::Files::CVS")
and !$HTTP->{'param'}->{'showattic'};
#FIXME what does this do?
if ($files->toreal($dir, $release) =~ m#(.+[^/])[/]*$#) {
if (-e $1) {
warning("Unable to open " . $files->toreal($dir, $release));
}
}
return;
}
unshift(@nodes, '../') unless $dir eq '/';
#CSS checked _PH_
foreach $node (@nodes) {
if ($node =~ /\/$/) {
$direx .= expandtemplate(
$templ,
(
'iconlink' => sub { diricon(@_, $node, $dir) },
'namelink' => sub { dirname(@_, $node, $dir) },
'filesize' => sub { '-' },
'modtime' => sub { modtime(@_, $node, $dir) },
'bgcolor' => sub { bgcolor(@_, $line++) },
'css' => sub { rowclass(@_, $line++) },
'description' => sub { descexpand(@_, $node, $dir, $release) }
)
);
} else {
next if $node =~ /^.*\.[oa]$|^core$|^00-INDEX$/;
$direx .= expandtemplate(
$templ,
(
'iconlink' => sub { fileicon(@_, $node, $dir) },
'namelink' => sub { filename(@_, $node, $dir) },
'filesize' => sub { filesize(@_, $node, $dir) },
'modtime' => sub { modtime(@_, $node, $dir) },
'bgcolor' => sub { bgcolor(@_, $line++) },
'css' => sub { rowclass(@_, $line++) },
'description' => sub {
(
$files->toreal($dir . $node, $release) =~ m|/Attic/|
? "<i>In Attic</i> "
: ""
)
. descexpand(@_, $node, $dir, $release);
}
)
);
}
}
return ($direx);
}
sub printdir {
my $dir = shift;
my $templ;
$templ = "<ul>\n\$files{\n<li>\$iconlink \$namelink\n}</ul>\n";
if ($config->htmldir) {
unless (open(TEMPL, $config->htmldir)) {
warning("Template " . $config->htmldir . " does not exist.");
} else {
local ($/) = undef;
$templ = <TEMPL>;
close(TEMPL);
}
}
# print the description of the current directory
print dirdesc($dir, $release);
# print the listing itself
print(expandtemplate($templ, ('files' => sub { direxpand(@_, $dir) })));
}
sub printfile {
my $raw = shift;
if ($pathname =~ m|/$|) {
printdir($pathname);
} else {
my $fileh = $files->getfilehandle($pathname, $release);
if ($fileh) {
if ($raw) {
print($fileh->getlines );
}
else {
if ($config->cvswebprefix) {
my $revtarget = "";
$revtarget = "#rev$release" if lc($release) ne "head";
print "<a href='"
. $config->cvswebprefix
. $pathname
. $config->cvswebpostfix
. $revtarget
. "'>View CVS Log</a>";
}
my @ann = $files->getannotations($pathname, $release);
if (@ann) {
my ($a, $b);
foreach $a (@ann) {
if ($a eq $b) {
$a = ' ' x 16;
next;
}
$b = $a;
$a .= ' ' x (6 - length($a)) . $files->getauthor($pathname, $a);
$a .= ' ' x (16 - length($a));
}
}
my $l;
my $outfun = sub {
$l = shift;
$l =~ s/(\n)/$1.shift(@ann)/ge;
print $l;
};
&$outfun("<pre class=\"file\">\n");
markupfile($fileh, $outfun);
&$outfun("</pre>\n");
}
} else {
print("\<p align=\"center\">\n<i>The file $pathname does not exist.</i>\n");
print(
"\<p align=\"center\">\n<i>This file might exist in other versions, try 'Show attic files' or select a different Version.</i>\n"
)
if $files->isa("LXR::Files::CVS")
and !$HTTP->{'param'}->{'showattic'};
if (-f $files->toreal($pathname, $release)) {
warning("Unable to open " . $files->toreal($pathname, $release));
}
}
}
}
httpinit;
if ($config->filter && $pathname !~ $config->filter) {
makeheader('source');
print("\<p align=\"center\">\n<i>The file $pathname does not exist.</i>\n");
makefooter('source');
exit;
}
# If the file is html then simply pump it out.
if ($pathname =~ /\.(html)$/ || $HTTP->{'param'}->{'raw'}) {
printfile(1);
} else {
my $type = ($pathname !~ m|/$| ? 'source' : 'sourcedir');
makeheader($type);
printfile(0);
makefooter($type);
}
httpclean;
이 파일은 Common.pm 파일입니다.
아마도 위의 펄스크립트에서 참조하는 것 같습니다
# -*- tab-width: 4 -*- ###############################################
#
# $Id: Common.pm,v 1.51 2005/05/04 23:19:33 mbox Exp $
#
# FIXME: java doesn't support super() or super.x
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
package LXR::Common;
$CVSID = '$Id: Common.pm,v 1.51 2005/05/04 23:19:33 mbox Exp $ ';
use strict;
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS
$files $index $config $pathname $identifier $release
$HTTP $wwwdebug $tmpcounter);
@ISA = qw(Exporter);
@EXPORT = qw($files $index $config &fatal);
@EXPORT_OK = qw($files $index $config $pathname $identifier $release
$HTTP
&warning &fatal &abortall &fflush &urlargs &fileref
&idref &incref &htmlquote &freetextmarkup &markupfile
&markupstring &httpinit &makeheader &makefooter
&expandtemplate &httpclean);
%EXPORT_TAGS = ('html' => [@EXPORT_OK]);
require Local;
require LXR::SimpleParse;
require LXR::Config;
require LXR::Files;
require LXR::Index;
require LXR::Lang;
$wwwdebug = 0;
$tmpcounter = 23;
sub warning {
my $c = join(", line ", (caller)[ 0, 2 ]);
print(STDERR "[", scalar(localtime), "] warning: $c: $_[0]\n");
print("<h4 align=\"center\"><i>** Warning: $_[0]</i></h4>\n") if $wwwdebug;
}
sub fatal {
my $c = join(", line ", (caller)[ 0, 2 ]);
print(STDERR "[", scalar(localtime), "] fatal: $c: $_[0]\n");
print(STDERR '[@INC ', join(" ", @INC), ' $0 ', $0, "\n");
print(STDERR '$config', join(" ", %$config), "\n") if ref($config) eq "HASH";
print("<h4 align=\"center\"><i>** Fatal: $_[0]</i></h4>\n") if $wwwdebug;
exit(1);
}
sub abortall {
my $c = join(", line ", (caller)[ 0, 2 ]);
print(STDERR "[", scalar(localtime), "] abortall: $c: $_[0]\n");
print(
"Content-Type: text/html; charset=iso-8859-1\n\n",
"<html>\n<head>\n<title>Abort</title>\n</head>\n",
"<body><h1>Abort!</h1>\n",
"<b><i>** Aborting: $_[0]</i></b>\n",
"</body>\n</html>\n"
)
if $wwwdebug;
exit(1);
}
sub fflush {
$| = 1;
print('');
}
sub tmpcounter {
return $tmpcounter++;
}
sub urlargs {
my @args = @_;
my %args = ();
my $val;
foreach (@args) {
$args{$1} = $2 if /(\S+)=(\S*)/;
}
@args = ();
foreach ($config->allvariables) {
$val = $args{$_} || $config->variable($_);
push(@args, "$_=$val") unless ($val eq $config->vardefault($_));
delete($args{$_});
}
foreach (keys(%args)) {
push(@args, "$_=$args{$_}");
}
return ($#args < 0 ? '' : '?' . join(';', @args));
}
sub fileref {
my ($desc, $css, $path, $line, @args) = @_;
# jwz: URL-quote any special characters.
$path =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge;
if ($line > 0 && length($line) < 3) {
$line = ('0' x (3 - length($line))) . $line;
}
return ("<a class='$css' href=\"$config->{virtroot}/source$path"
. &urlargs(@args)
. ($line > 0 ? "#$line" : "")
. "\"\>$desc</a>");
}
sub diffref {
my ($desc, $css, $path, $darg) = @_;
my $dval;
($darg, $dval) = $darg =~ /(.*?)=(.*)/;
return ("<a class='$css' href=\"$config->{virtroot}/diff$path"
. &urlargs(($darg ? "diffvar=$darg" : ""), ($dval ? "diffval=$dval" : ""))
. "\"\>$desc</a>");
}
sub idref {
my ($desc, $css, $id, @args) = @_;
return ("<a class='$css' href=\"$config->{virtroot}/ident"
. &urlargs(($id ? "i=$id" : ""), @args)
. "\"\>$desc</a>");
}
sub incref {
my ($name, $css, $file, @paths) = @_;
my ($dir, $path);
push(@paths, $config->incprefix);
foreach $dir (@paths) {
$dir =~ s/\/+$//;
$path = $config->mappath($dir . "/" . $file);
return &fileref($name, $css, $path) if $files->isfile($path, $release);
}
return $name;
}
sub http_wash {
my $t = shift;
if (!defined($t)) {
return (undef);
}
$t =~ s/\+/ /g;
$t =~ s/\%([\da-f][\da-f])/pack("C", hex($1))/gie;
return ($t);
}
# dme: Smaller version of the markupfile function meant for marking up
# the descriptions in source directory listings.
sub markupstring {
my ($string, $virtp) = @_;
# Mark special characters so they don't get processed just yet.
$string =~ s/([\&\<\>])/\0$1/g;
# Look for identifiers and create links with identifier search query.
# TODO: Is there a performance problem with this?
$string =~ s#(^|\s)([a-zA-Z_~][a-zA-Z0-9_]*)\b#
$1.(is_linkworthy($2) ? &idref($2, "", $2) : $2)#ge;
# HTMLify the special characters we marked earlier,
# but not the ones in the recently added xref html links.
$string =~ s/\0&/&/g;
$string =~ s/\0</</g;
$string =~ s/\0>/>/g;
# HTMLify email addresses and urls.
$string =~
s#((ftp|http|nntp|snews|news)://(\w|\w\.\w|\~|\-|\/|\#)+(?!\.\b))#<a href=\"$1\">$1</a>#g;
# htmlify certain addresses which aren't surrounded by <>
$string =~ s/([\w\-\_]*\@netscape.com)(?!>)/<a href=\"mailto:$1\">$1<\/a>/g;
$string =~ s/([\w\-\_]*\@mozilla.org)(?!>)/<a href=\"mailto:$1\">$1<\/a>/g;
$string =~ s/([\w\-\_]*\@gnome.org)(?!>)/<a href=\"mailto:$1\">$1<\/a>/g;
$string =~ s/([\w\-\_]*\@linux.no)(?!>)/<a href=\"mailto:$1\">$1<\/a>/g;
$string =~ s/([\w\-\_]*\@sourceforge.net)(?!>)/<a href=\"mailto:$1\">$1<\/a>/g;
$string =~ s/([\w\-\_]*\@sf.net)(?!>)/<a href=\"mailto:$1\">$1<\/a>/g;
$string =~ s/(<)(.*@.*)(>)/$1<a href=\"mailto:$2\">$2<\/a>$3/g;
# HTMLify file names, assuming file is in the current directory.
$string =~
s#\b(([\w\-_\/]+\.(c|h|cc|cp|hpp|cpp|java))|README)\b#<a href=\"$config->{virtroot}/source$virtp$1\">$1</a>#g;
return ($string);
}
# dme: Return true if string is in the identifier db and it seems like its
# use in the sentence is as an identifier and its not just some word that
# happens to have been used as a variable name somewhere. We don't want
# words like "of", "to" and "a" to get links. The string must be long
# enough, and either contain "_" or if some letter besides the first
# is capitalized
sub is_linkworthy {
my ($string) = @_;
if (
$string =~ /....../
&& ($string =~ /_/ || $string =~ /.[A-Z]/)
# && defined($xref{$string}) FIXME
)
{
return (1);
} else {
return (0);
}
}
sub markspecials {
$_[0] =~ s/([\&\<\>])/\0$1/g;
}
sub htmlquote {
$_[0] =~ s/\0&/&/g;
$_[0] =~ s/\0</</g;
$_[0] =~ s/\0>/>/g;
}
sub freetextmarkup {
$_[0] =~ s{((f|ht)tp://[^\s<>\0]*[^\s<>\0.])}
{<a class='offshore' href="$1">$1</a>}g;
$_[0] =~ s{(\0<([^\s<>\0]+@[^\s<>\0]+)\0>)}
{<a class='offshore' href="mailto:$2">$1</a>}g;
}
sub markupfile {
#_PH_ supress block is here to avoid the <pre> tag output
#while called from diff
my ($fileh, $outfun) = @_;
my ($dir) = $pathname =~ m|^(.*/)|;
my $line = '001';
my @ltag = &fileref(1, "fline", $pathname, 1) =~ /^(<a)(.*\#)001(\">)1(<\/a>)$/;
$ltag[0] .= ' name=';
$ltag[3] .= " ";
my @itag = &idref(1, "fid", 1) =~ /^(.*=)1(\">)1(<\/a>)$/;
my $lang = new LXR::Lang($pathname, $release, @itag);
# A source code file
if ($lang) {
my $language = $lang->language; # To get back to the key to lookup the tabwidth.
&LXR::SimpleParse::init($fileh, $config->filetype->{$language}[3], $lang->parsespec);
my ($btype, $frag) = &LXR::SimpleParse::nextfrag;
#&$outfun("<pre class=\"file\">\n");
&$outfun(join($line++, @ltag)) if defined($frag);
while (defined($frag)) {
&markspecials($frag);
if ($btype eq 'comment') {
# Comment
# Convert mail adresses to mailto:
&freetextmarkup($frag);
$lang->processcomment(\$frag);
} elsif ($btype eq 'string') {
# String
$frag = "<span class='string'>$frag</span>";
} elsif ($btype eq 'include') {
# Include directive
$lang->processinclude(\$frag, $dir);
} else {
# Code
$lang->processcode(\$frag);
}
&htmlquote($frag);
my $ofrag = $frag;
($btype, $frag) = &LXR::SimpleParse::nextfrag;
$ofrag =~ s/\n$// unless defined($frag);
$ofrag =~ s/\n/"\n".join($line++, @ltag)/ge;
&$outfun($ofrag);
}
#&$outfun("</pre>");
} elsif ($pathname =~ /$config->graphicfile/) {
&$outfun("<ul><table><tr><th valign=\"center\"><b>Image: </b></th>");
&$outfun("<img src=\"$config->{virtroot}/source"
. $pathname
. &urlargs("raw=1")
. "\" border=\"0\" alt=\"$pathname\">\n");
&$outfun("</tr></td></table></ul>");
} elsif ($pathname =~ m|/CREDITS$|) {
while (defined($_ = $fileh->getline)) {
&LXR::SimpleParse::untabify($_);
&markspecials($_);
&htmlquote($_);
s/^N:\s+(.*)/<strong>$1<\/strong>/gm;
s/^(E:\s+)(\S+@\S+)/$1<a href=\"mailto:$2\">$2<\/a>/gm;
s/^(W:\s+)(.*)/$1<a href=\"$2\">$2<\/a>/gm;
# &$outfun("<a name=\"L$.\"><\/a>".$_);
&$outfun(join($line++, @ltag) . $_);
}
} else {
return unless defined($_ = $fileh->getline);
# If it's not a script or something with an Emacs spec header and
# the first line is very long or containts control characters...
if ( !/^\#!/
&& !/-\*-.*-\*-/i
&& (length($_) > 132 || /[\000-\010\013\014\016-\037\200-?/))
{
# We postulate that it's a binary file.
&$outfun("<ul><b>Binary File: ");
# jwz: URL-quote any special characters.
my $uname = $pathname;
$uname =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge;
&$outfun("<a href=\"$config->{virtroot}/source" . $uname . &urlargs("raw=1") . "\">");
&$outfun("$pathname</a></b>");
&$outfun("</ul>");
} else {
#&$outfun("<pre class=\"file\">\n");
do {
&LXR::SimpleParse::untabify($_);
&markspecials($_);
&freetextmarkup($_);
&htmlquote($_);
# &$outfun("<a name=\"L$.\"><\/a>".$_);
&$outfun(join($line++, @ltag) . $_);
} while (defined($_ = $fileh->getline));
#&$outfun("</pre>");
}
}
}
sub fixpaths {
my $node = '/' . shift;
while ($node =~ s|/[^/]+/\.\./|/|g) { }
$node =~ s|/\.\./|/|g;
$node .= '/' if $files->isdir($node);
$node =~ s|//+|/|g;
return $node;
}
sub printhttp {
# Print out a Last-Modified date that is the larger of: the
# underlying file that we are presenting; and the "source" script
# itself (passed in as an argument to this function.) If we can't
# stat either of them, don't print out a L-M header. (Note that this
# stats lxr/source but not lxr/lib/LXR/Common.pm. Oh well, I can
# live with that I guess...) -- jwz, 16-Jun-98
# Made it stat all currently loaded modules. -- agg.
# Todo: check lxr.conf.
my $time = $files->getfiletime($pathname, $release);
my $time2 = (stat($config->confpath))[9];
$time = $time2 if $time2 > $time;
# Remove this to see if we get a speed increase by not stating all
# the modules. Since for most sites the modules change rarely,
# this is a big hit for each access.
# my %mods = ('main' => $0, %INC);
# my ($mod, $path);
# while (($mod, $path) = each %mods) {
# $mod =~ s/.pm$//;
# $mod =~ s|/|::|g;
# $path =~ s|/+|/|g;
# no strict 'refs';
# next unless $ {$mod.'::CVSID'};
# $time2 = (stat($path))[9];
# $time = $time2 if $time2 > $time;
# }
if ($time > 0) {
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
my @days = ("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun");
my @months =
("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
$year += 1900;
$wday = $days[$wday];
$mon = $months[$mon];
# Last-Modified: Wed, 10 Dec 1997 00:55:32 GMT
printf("Last-Modified: %s, %2d %s %d %02d:%02d:%02d GMT\n",
$wday, $mday, $mon, $year, $hour, $min, $sec);
}
if ($HTTP->{'param'}->{'raw'}) {
#FIXME - need more types here
my %type = (
'gif' => 'image/gif',
'html' => 'text/html'
);
if ($pathname =~ /\.([^.]+)$/ && $type{$1}) {
print("Content-type: ", $type{$1}, "\n");
} else {
print("Content-Type: text/plain\n");
}
} else {
print("Content-Type: text/html; charset=iso-8859-1\n");
# print("Content-Type: text/html\n");
}
# Close the HTTP header block.
print("\n");
}
# httpinit - parses and cleans up the URL parameters and sets up the various variables
# Also prints the HTTP header & sets up the signal handlers
# This is also where we protect from malicious input
#
# HTTP:
# path_info -
# param - Array of parameters
# this_url - The current url
#
sub httpinit {
$SIG{__WARN__} = \&warning;
$SIG{__DIE__} = \&fatal;
$HTTP->{'path_info'} = http_wash($ENV{'PATH_INFO'});
$HTTP->{'path_info'} = clean_path($HTTP->{'path_info'});
$HTTP->{'this_url'} = 'http://' . $ENV{'SERVER_NAME'};
$HTTP->{'this_url'} .= ':' . $ENV{'SERVER_PORT'}
if $ENV{'SERVER_PORT'} != 80;
$HTTP->{'this_url'} .= $ENV{'SCRIPT_NAME'} . $ENV{'PATH_INFO'};
$HTTP->{'this_url'} .= '?' . $ENV{'QUERY_STRING'}
if $ENV{'QUERY_STRING'};
# We don't clean all the parameters here, as some scripts need extended characters
# e.g. regexp searching
$HTTP->{'param'} = { map { http_wash($_) } $ENV{'QUERY_STRING'} =~ /([^;&=]+)(?:=([^;&]+)|)/g };
# But do clean up these
$HTTP->{'param'}->{'v'} ||= $HTTP->{'param'}->{'version'};
$HTTP->{'param'}->{'a'} ||= $HTTP->{'param'}->{'arch'};
$HTTP->{'param'}->{'i'} ||= $HTTP->{'param'}->{'identifier'};
$identifier = clean_identifier($HTTP->{'param'}->{'i'});
# remove the param versions to prevent unclean versions being used
delete $HTTP->{'param'}->{'i'};
delete $HTTP->{'param'}->{'identifier'};
$config = new LXR::Config($HTTP->{'this_url'});
die "Can't find config for " . $HTTP->{'this_url'} if !defined($config);
$files = new LXR::Files($config->sourceroot);
die "Can't create Files for " . $config->sourceroot if !defined($files);
$index = new LXR::Index($config->dbname);
die "Can't create Index for " . $config->dbname if !defined($index);
foreach ($config->allvariables) {
$config->variable($_, $HTTP->{'param'}->{$_}) if $HTTP->{'param'}->{$_};
delete $HTTP->{'param'}->{$_};
}
$release = clean_release($config->variable('v'));
$config->variable('v', $release); # put back into config obj
$HTTP->{'param'}->{'file'} = clean_path($HTTP->{'param'}->{'file'});
$pathname = fixpaths($HTTP->{'path_info'} || $HTTP->{'param'}->{'file'});
printhttp;
}
sub clean_release {
my $release = shift;
my @rels= $config->varrange('v');
my %test;
@test{@rels} = undef;
if(!exists $test{$release}) {
$release = $config->vardefault('v');
}
return $release;
}
sub clean_identifier {
my $id = shift;
$id =~ s/(^[\w`:.,]+).*/$1/ if defined $id;
return $id;
}
sub clean_path {
# Cleans up a string to path
my $path = shift;
if(defined $path) {
# First suppress anything after a dodgy character
$path =~ s!(^[\w_+-,.%^/]+).*!$1!;
# Clean out /../
while ($path =~ m!/../!) {
$path = s!/\.\./!/!g;
}
}
return $path;
}
sub httpclean {
$config = undef;
$files = undef;
$index = undef;
}
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(undef);
}
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 somewhat less hairy way of expanding nested
# templates than it used to be. State information is passed via
# function arguments, as God intended.
sub bannerexpand {
my ($templ, $who) = @_;
if ($who eq 'source' || $who eq 'sourcedir' || $who eq 'diff') {
my $fpath = '';
my $furl = fileref($config->sourcerootname . '/', "banner", '/');
foreach ($pathname =~ m|([^/]+/?)|g) {
$fpath .= $_;
# jwz: put a space after each / in the banner so that it's
# possible for the pathnames to wrap. The <wbr> tag ought
# to do this, but it is ignored when sizing table cells,
# so we have to use a real space. It's somewhat ugly to
# have these spaces be visible, but not as ugly as getting
# a horizontal scrollbar...
$furl .= ' ' . fileref($_, "banner", "/$fpath");
}
$furl =~ s|/</a>|</a>/|gi;
return "<span class=\"banner\">$furl</span>";
} else {
return '';
}
}
sub pathname {
return $pathname;
}
sub titleexpand {
my ($templ, $who) = @_;
if ($who eq 'source' || $who eq 'diff' || $who eq 'sourcedir') {
return $config->sourcerootname . $pathname;
} elsif ($who eq 'ident') {
my $i = $HTTP->{'param'}->{'i'};
return $config->sourcerootname . ' identifier search' . ($i ? ": $i" : '');
} elsif ($who eq 'search') {
my $s = $HTTP->{'param'}->{'string'};
return $config->sourcerootname . ' general search' . ($s ? ": $s" : '');
}
}
sub thisurl {
my $url = $HTTP->{'this_url'};
$url =~ s/([\?\&\;\=])/sprintf('%%%02x',(unpack('c',$1)))/ge;
return ($url);
}
sub baseurl {
(my $url = $config->baseurl) =~ s|/*$|/|;
return $url;
}
sub stylesheet {
return $config->stylesheet;
}
sub dotdoturl {
my $url = $config->baseurl;
$url =~ s@/$@@;
$url =~ s@/[^/]*$@@;
return ($url);
}
# 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, $who) = @_;
my $modex = '';
my @mlist = ();
my $mode;
if ($who eq 'source' || $who eq 'sourcedir') {
push(@mlist, "<span class='modes-sel'>source navigation</span>");
} else {
push(@mlist, fileref("source navigation", "modes", $pathname));
}
if ($who eq 'diff') {
push(@mlist, "<span class='modes-sel'>diff markup</span>");
} elsif ($who eq 'source' && $pathname !~ m|/$|) {
push(@mlist, diffref("diff markup", "modes", $pathname));
}
if ($who eq 'ident') {
push(@mlist, "<span class='modes-sel'>identifier search</span>");
} else {
push(@mlist, idref("identifier search", "modes", ""));
}
if ($who eq 'search') {
push(@mlist, "<span class='modes-sel'>general search</span>");
} else {
push(@mlist,
"<a class=\"modes\" "
. "href=\"$config->{virtroot}/search"
. urlargs
. "\">general search</a>");
}
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, $who, $var) = @_;
my $vlex = '';
my ($val, $oldval);
my $vallink;
$oldval = $config->variable($var);
foreach $val ($config->varrange($var)) {
if ($val eq $oldval) {
$vallink = "<span class=\"var-sel\">$val</span>";
} else {
if ($who eq 'source' || $who eq 'sourcedir') {
$vallink = &fileref($val, "varlink", $config->mappath($pathname, "$var=$val"),
0, "$var=$val");
} elsif ($who eq 'diff') {
$vallink = &diffref($val, "varlink", $pathname, "$var=$val");
} elsif ($who eq 'ident') {
$vallink = &idref($val, "varlink", $identifier, "$var=$val");
} elsif ($who eq 'search') {
$vallink =
"<a class=\"varlink\" href=\"$config->{virtroot}/search"
. &urlargs("$var=$val", "string=" . $HTTP->{'param'}->{'string'})
. "\">$val</a>";
}
}
$vlex .= expandtemplate($templ, ('varvalue' => sub { return $vallink }));
}
return ($vlex);
}
sub varexpand {
my ($templ, $who) = @_;
my $varex = '';
my $var;
foreach $var ($config->allvariables) {
$varex .= expandtemplate(
$templ,
(
'varname' => sub { $config->vardescription($var) },
'varlinks' => sub { varlinks(@_, $who, $var) }
)
);
}
return ($varex);
}
sub devinfo {
my ($templ) = @_;
my (@mods, $mod, $path);
my %mods = ('main' => $0, %INC);
while (($mod, $path) = each %mods) {
$mod =~ s/.pm$//;
$mod =~ s|/|::|g;
$path =~ s|/+|/|g;
no strict 'refs';
next unless ${ $mod . '::CVSID' };
push(@mods, [ ${ $mod . '::CVSID' }, $path, (stat($path))[9] ]);
}
return join(
'',
map {
expandtemplate(
$templ,
(
'moduleid' => sub { $$_[0] },
'modpath' => sub { $$_[1] },
'modtime' => sub { scalar(localtime($$_[2])) }
)
);
}
sort {
$$b[2] <=> $$a[2]
} @mods
);
}
sub atticlink {
return " " if !$files->isa("LXR::Files::CVS");
return " " if $ENV{'SCRIPT_NAME'} !~ m|/source$|;
if ($HTTP->{'param'}->{'showattic'}) {
return ("<a class='modes' href=\"$config->{virtroot}/source"
. $HTTP->{'path_info'}
. &urlargs("showattic=0")
. "\">Hide attic files</a>");
} else {
return ("<a class='modes' href=\"$config->{virtroot}/source"
. $HTTP->{'path_info'}
. &urlargs("showattic=1")
. "\">Show attic files</a>");
}
}
sub makeheader {
my $who = shift;
my $tmplname;
my $template = "<html><body>\n<hr>\n";
$tmplname = $who . "head";
unless ($who ne "sourcedir" || $config->sourcedirhead) {
$tmplname = "sourcehead";
}
unless ($config->value($tmplname)) {
$tmplname = "htmlhead";
}
if ($config->value($tmplname)) {
if (open(TEMPL, $config->value($tmplname))) {
local ($/) = undef;
$template = <TEMPL>;
close(TEMPL);
} else {
warning("Template " . $config->value($tmplname) . " does not exist.");
}
}
#CSS checked _PH_
print(
expandtemplate(
$template,
(
'title' => sub { titleexpand(@_, $who) },
'banner' => sub { bannerexpand(@_, $who) },
'baseurl' => sub { baseurl(@_) },
'stylesheet' => sub { stylesheet(@_) },
'dotdoturl' => sub { dotdoturl(@_) },
'thisurl' => sub { thisurl(@_) },
'pathname' => sub { pathname(@_) },
'modes' => sub { modeexpand(@_, $who) },
'variables' => sub { varexpand(@_, $who) },
'devinfo' => sub { devinfo(@_) },
'atticlink' => sub { atticlink(@_) },
)
)
);
}
sub makefooter {
my $who = shift;
my $tmplname;
my $template = "<hr>\n</body>\n";
$tmplname = $who . "tail";
unless ($who ne "sourcedir" || $config->sourcedirhead) {
$tmplname = "sourcetail";
}
unless ($config->value($tmplname)) {
$tmplname = "htmltail";
}
if ($config->value($tmplname)) {
if (open(TEMPL, $config->value($tmplname))) {
local ($/) = undef;
$template = <TEMPL>;
close(TEMPL);
} else {
warning("Template " . $config->value($tmplname) . " does not exist.");
}
}
print(
expandtemplate(
$template,
(
'banner' => sub { bannerexpand(@_, $who) },
'thisurl' => sub { thisurl(@_) },
'modes' => sub { modeexpand(@_, $who) },
'variables' => sub { varexpand(@_, $who) },
'devinfo' => sub { devinfo(@_) }
)
),
"</html>\n"
);
}
1;
펄스크립트로 되어 있던데.. 문법 공부할 시간도 없고
에휴..
다른 분들은 어떻게 해결하셨는지요..
Forums:
댓글 달기