chiark - git - mdw - sw-tools/blob - perl/SWDoc.pm

   1 # -*-perl-*-
   2 #
   3 # $Id: SWDoc.pm,v 1.1 1999/07/30 18:46:37 mdw Exp $
   4 #
   5 # Display documentation files
   6 #
   7 # (c) 1999 EBI
   8 #
   9
  10 #----- Licensing notice -----------------------------------------------------
  11 #
  12 # This file is part of sw-tools.
  13 #
  14 # sw-tools is free software; you can redistribute it and/or modify
  15 # it under the terms of the GNU General Public License as published by
  16 # the Free Software Foundation; either version 2 of the License, or
  17 # (at your option) any later version.
  18 #
  19 # sw-tools is distributed in the hope that it will be useful,
  20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 # GNU General Public License for more details.
  23 #
  24 # You should have received a copy of the GNU General Public License
  25 # along with sw-tools; if not, write to the Free Software Foundation,
  26 # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  27
  28 #----- Revision history -----------------------------------------------------
  29 #
  30 # $Log: SWDoc.pm,v $
  31 # Revision 1.1  1999/07/30 18:46:37  mdw
  32 # New CGI script for browsing installed software and documentation.
  33 #
  34
  35 #----- Package preamble -----------------------------------------------------
  36
  37 package SWDoc;
  38
  39 use IO;
  40 use POSIX;
  41 use SWConfig;
  42 use SWCGI qw(:DEFAULT :layout);
  43 use SWMan;
  44
  45 #----- Actions provided -----------------------------------------------------
  46
  47 sub doc {
  48   my $file = "$C{doc}/$Q{pkg}";
  49   barf("illegal filename `$file'") if $file =~ m:\./:;
  50   my $fh = IO::File->new($file, O_RDONLY) or
  51     barf("couldn't open `$file': $!");
  52   header("Local documentation for package $Q{pkg}");
  53   print("<h3>Local documentation for package $Q{pkg}</h3>\n");
  54   print("<pre>\n");
  55
  56   while (my $line = $fh->getline()) {
  57     last if $line =~ /\f/;
  58     $line =~ s/\&/&amp;/g;
  59     $line =~ s/\</&lt;/g;
  60     $line =~ s/\>/&gt;/g;
  61     $line =~ s!(http|ftp)://[^]&)\s]*[^]&).,\s\']!<a href="$&">$&</a>!g;
  62     $line =~ s!info:([^]&)\s]*[^]&).,\s\'\"])!<a href="$ref?act=info&file=$1&node=Top">$&</a>!g;
  63     $line =~ s![^\s()&;{}.,\`\"][^\s()&;{}\`\"]*\@[^\s()&;{}\'\"]*[^\s()&;{}.,\'\"]!<a href="mailto:$&">$&</a>!g;
  64     $line =~ s!([-_.\w]+)\((\d+\w*)\)!SWMan::subst("$1($2)", $1, $2)!eg;
  65     print $line;
  66   }
  67   print "</pre>\n";
  68   footer();
  69 }
  70
  71 #----- Register actions -----------------------------------------------------
  72
  73 $main::ACT{"doc"} = \&doc;
  74
  75 #----- That's all, folks ----------------------------------------------------
  76
  77 1;