\n" if $DEBUG;
close($handle);
print "
Closed file $handle\n" if $DEBUG;
$nfiles--;
$inentry = $save_inentry[$nfiles];
$indirect = $save_indirect[$nfiles];
print "--inentry: $inentry--indirect: $indirect--
\n" if $DEBUG;
last if $matches;
}
if (!$matches) {
&error("Couldn't find target: \"$target\" in file \"$file\".");
if ($cachefound) {
&UpdateCache("($file)$target");
}
}
return $matches;
}
#---------------------------------------------------------------------------
sub make_anchor {
local($ref, $label, $icon) = @_;
local($node_file, $node_name, $img, $href);
print "--make_anchor($ref, $label)
\n" if $DEBUG;
# (foo)bar
if ($ref =~ m/\(([^\)]+)\)\s*([^\t,\.]*)/) {
$node_file = $1;
$node_name = $2;
} elsif ($file =~ /^dir$/i) {
print "--(DIR) node - Menu \"@_\" means \"($ref)\"
\n" if $DEBUG;
$node_file = $ref;
$node_name = "";
} else {
$node_file = $h_file;
$node_name = $ref;
}
$node_name =~ s/[ ]*$//;
if ($node_name ne "") {
$href = &Escape("$prefix($node_file)$node_name");
} else {
$href = &Escape("$prefix($node_file)");
}
if ($icon) {
$img = " ";
}
return "$img$label";
}
sub StartMenu {
print "\n
- " if $active;
$menu = 1;
}
sub EndMenu {
if ($menu) {
print "
\n" if $active;
$listing++;
}
sub EndListing {
if ($listing) {
print "\n" if $active;
$listing--;
}
}
sub FindFile {
local($filename) = @_;
local($dir, $fil);
print "", "FindFile: '$filename'\n" if $DEBUG; ($dir, $fil) = &FindFileNoAlias($filename); if ($dir) { return $dir, $fil; } # Try a possible alias... $fil = $filename; $fil =~ s/[-\.]info$//; $fil =~ tr/A-Z/a-z/; $filename = $ALIAS{$fil}; print "
", "\$", "ALIAS{", $fil, "} = ", $filename, "\n" if $DEBUG; if ($filename) { print "
Trying with the alias \"$filename\"...\n" if $DEBUG; return &FindFileNoAlias($filename); } else { # Bummer - no alias return; } } sub FindFileNoAlias { local($filename) = @_; local($altfilename) = $filename; local(@filelist) = (); local($dir, $fil); local($regex, $altregex); if ($filename =~ /\.info$/) { $altfilename =~ s/\.info$//; } elsif ($filename =~ /-info$/) { $altfilename =~ s/-info$/.info/; } else { $altfilename =~ s/$/.info/; } print "
FindFileNoAlias: '$filename', Alt='$altfilename'\n" if $DEBUG; $regex = &ToPattern($filename); $altregex = &ToPattern($altfilename); # Try absolute match for $filename... if ($filename =~ /\//) { ($dir, $fil) = ($filename =~ m,(.*)/([^/]*),); if ($ALLOWPATH || grep($_ eq $dir, @INFOPATH)) { print "
Trying absolute match for \"$filename\"...\n" if $DEBUG; if (-e "$filename") { return $dir, $fil; } print "
Trying absolute match for \"$altfilename\"...\n" if $DEBUG; if (-e "$altfilename") { ($dir, $fil) = ($altfilename =~ m,(.*)/([^/]*),); return $dir, $fil; } $file =~ s,^.*/([^/]*)$,$1,; $filename =~ s,^.*/([^/]*)$,$1,; $altfilename =~ s,^.*/([^/]*)$,$1,; print "
Stripped path from filename: $filename\n" if $DEBUG; } elsif (!$ALLOWPATH) { print "
Warning: Absolute path-names not allowed!\n" if $DEBUG; $file =~ s,^.*/([^/]*)$,$1,; $filename =~ s,^.*/([^/]*)$,$1,; $altfilename =~ s,^.*/([^/]*)$,$1,; print "
Stripped path from filename: $filename\n" if $DEBUG; } } # Try exact match for $filename in all directories... print "
Trying exact match for \"$filename\"...\n" if $DEBUG; foreach (@INFOPATH) { if (-e "$_/$filename") { return $_, $filename; } } # Try exact match for $altfilename in all directories... print "
Trying exact match for \"$altfilename\"...\n" if $DEBUG; foreach (@INFOPATH) { if (-e "$_/$altfilename") { return $_, $altfilename; } } # Try caseless match for $filename in all directories... print "
Trying caseless match for \"$filename\"...\n" if $DEBUG; @filelist = (); foreach (@INFOPATH) { $dir = $_; opendir(DIR, $dir); push (@filelist, sort grep(s/^/$dir\//, grep(/^$regex$/i, readdir(DIR)))); closedir(DIR); } if ($#filelist > 0) { # Multiple matches...present list or just return one item? ($dir, $fil) = ($filelist[0] =~ m,(.*)/([^/]*),); return $dir, $fil; } elsif ($#filelist == 0) { ($dir, $fil) = ($filelist[0] =~ m,(.*)/([^/]*),); return $dir, $fil; } # Try caseless match for $altfilename in all directories... print "
Trying caseless match for \"$altfilename\"...\n" if $DEBUG; @filelist = (); foreach (@INFOPATH) { $dir = $_; opendir(DIR, $dir); push (@filelist, sort grep(s/^/$dir\//, grep(/^$altregex$/i, readdir(DIR)))); closedir(DIR); } if ($#filelist > 0) { # Multiple matches...present list or just return one item? ($dir, $fil) = ($filelist[0] =~ m,(.*)/([^/]*),); return $dir, $fil; } elsif ($#filelist == 0) { ($dir, $fil) = ($filelist[0] =~ m,(.*)/([^/]*),); return $dir, $fil; } # Bummer - no matches at all return; } sub OpenFile { local($filename) = @_; local($alternate, $handle); $nfiles++; $handle = "FH_$nfiles"; if ($filename =~ /\//) { ($directory, $filename) = ($filename =~ m,(.*)/([^/]*),); } $realfile{$handle} = "$directory/$filename"; $success = 0; print "
Trying to open file ", "\"$filename\" in directory \"$directory\" ...\n" if $DEBUG; if (open($handle, "$directory/$filename")) { print "
Opened file \"$directory/$filename\"\n" if $DEBUG; return(1); } else { print "
Could not open file",
"\"$filename\" in directory \"$directory\".\n" if "$DEBUG";
return(0);
}
}
sub TryCache {
local($cachekey) = @_;
local($handle, $line, $h_node);
local($cachevalue, $cachepos, $cachefile, $cachedir, $newkey);
print "
Trying cached entry for \"$cachekey\"...\n" if $DEBUG;
if ($CACHE && &LockCache()) {
if (dbmopen(%cache, $CACHE, 0644)) {
$cachevalue = $cache{$cachekey};
dbmclose(%cache);
&UnLockCache();
} else {
$CACHE = "";
&UnLockCache();
return(0);
}
} else {
$CACHE = "";
return(0);
}
if (!$cachevalue) {
if ($cachekey =~ m,\(.*/.*\).*,) {
$newkey = $cachekey;
$newkey =~ s,^\(.*/([^/\)]*)\),($1),;
return(&TryCache($newkey));
} else {
return(0);
}
}
print "
Cached entry found: " if $DEBUG;
($cachepos, $cachefile) = split("\0", $cachevalue);
print "$cachepos in \"$cachefile\"\n" if $DEBUG;
if ($cachefile =~ /\//) {
$cachedir = $cachefile;
$cachedir =~ s,(.*)/[^/]*$,$1,;
if (!$ALLOWPATH && !grep($_ eq $cachedir, @INFOPATH)) {
print "
Warning: Absolute path-names not allowed!\n" if $DEBUG;
&UpdateCache($cachekey);
return(0);
}
}
if (!&OpenFile($cachefile)) {
&UpdateCache($cachekey);
return(0);
}
$handle = "FH_$nfiles";
print "
--now reading from $handle--\n" if $DEBUG;
if (!seek($handle, $cachepos, 0)) {
close($handle);
&UpdateCache($cachekey);
return(0);
}
print "
Position: $cachepos\n" if $DEBUG;
if ($line = <$handle>) {
chop($line);
$line =~ s/&/&\;/g;
$line =~ s//>\;/g;
print("
line: <", $line, ">\n") if $DEBUG;
if ($line =~ /^[\037\f]/) {
print "
Found node-start\n" if $DEBUG;
if ($line = <$handle>) {
chop($line);
$line =~ s/&/&\;/g;
$line =~ s//>\;/g;
print("
line: <", $line, ">\n") if $DEBUG;
if ($line =~ /\bnode: *([^,\t]*)/i) {
$h_node = $1;
$h_node =~ s/\s+$//; # delete trailing spaces
if ($h_node =~ m/^$target$/i) {
print "
Found the node!\n" if $DEBUG;
seek($handle, $cachepos, 0);
print("
", tell, "\n") if $DEBUG;
return(1);
}
}
}
}
}
&UpdateCache($cachekey);
close($handle);
return(0);
}
sub UpdateCache {
local($key, $pos, $file) = @_;
local($value);
if ($CACHE && &LockCache()) {
if (dbmopen(%cache, $CACHE, 0644)) {
if ($pos && $file) {
$cache{$key} = join("\0", $pos, $file);
print "
cache{$key} set to: $pos in \"$file\"\n" if $DEBUG;
} else {
delete $cache{$key};
print "
cache{$key} deleted\n" if $DEBUG;
}
dbmclose(%cache);
&UnLockCache();
return(1);
} else {
$CACHE = "";
&UnLockCache();
return(0);
}
} else {
$CACHE = "";
return(0);
}
}
sub LockCache {
local($file) = $CACHE . ".lock";
if (!open(LOCKFILE, ">$file")) {
print "
Couldn't open CACHE lockfile \"$file\"\n" if $DEBUG;
print "
Reason: $!\n" if $DEBUG;
return(0);
}
if (!flock(LOCKFILE, $LOCK_EX)) {
print "
Couldn't lock CACHE lockfile \"$file\"\n" if $DEBUG;
print "
Reason: $!\n" if $DEBUG;
close(LOCKFILE);
return(0);
}
print "
Locked CACHE lockfile \"$file\"\n" if $DEBUG;
return(1);
}
sub UnLockCache {
local($file) = $CACHE . ".lock";
if (!flock(LOCKFILE, $LOCK_UN)) {
print "
Couldn't unlock CACHE lockfile \"$file\"\n" if $DEBUG;
print "
Reason: $!\n" if $DEBUG;
close(LOCKFILE);
return(0);
}
close(LOCKFILE);
print "
Unlocked CACHE lockfile \"$file\"\n" if $DEBUG;
return(1);
}
sub error {
local($reason) = @_;
print
"