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

   1 # -*-perl-*-
   2 #
   3 # $Id: SWDoc.pm,v 1.2 1999/08/18 17:10:07 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.2  1999/08/18 17:10:07  mdw
  32 # Slight improvements to URL and email address parsing.
  33 #
  34 # Revision 1.1  1999/07/30 18:46:37  mdw
  35 # New CGI script for browsing installed software and documentation.
  36 #
  37
  38 #----- Package preamble -----------------------------------------------------
  39
  40 package SWDoc;
  41
  42 use IO;
  43 use POSIX;
  44 use SWConfig;
  45 use SWCGI qw(:DEFAULT :layout);
  46 use SWMan;
  47
  48 #----- Actions provided -----------------------------------------------------
  49
  50 sub doc {
  51   my $file = "$C{doc}/$Q{pkg}";
  52   barf("illegal filename `$file'") if $file =~ m:\./:;
  53   my $fh = IO::File->new($file, O_RDONLY) or
  54     barf("couldn't open `$file': $!");
  55   header("Local documentation for package $Q{pkg}");
  56   print("<h3>Local documentation for package $Q{pkg}</h3>\n");
  57   print("<pre>\n");
  58
  59   while (my $line = $fh->getline()) {
  60     last if $line =~ /\f/;
  61     $line =~ s/\&/&amp;/g;
  62     $line =~ s/\</&lt;/g;
  63     $line =~ s/\>/&gt;/g;
  64     $line =~ s!\b(https?|ftp|file|news):[^]&)\s]*[^]&).,\s\']!<a href="$&">$&</a>!g;
  65     $line =~ s!info:([^]&)\s]*[^]&).,\s\'\"])!<a href="$ref?act=info&file=$1&node=Top">$&</a>!g;
  66     $line =~ s!(?:\bmailto:)?([^\s()&;:{}.,\`\"][^\s()&;:{}\`\"]*\@[^\s()&;:{}\'\"]*[^\s()&;:{}.,\'\"])!<a href="mailto:$1">$&</a>!g;
  67     $line =~ s!([-_.\w]+)\((\d+\w*)\)!SWMan::subst("$1($2)", $1, $2)!eg;
  68     print $line;
  69   }
  70   print "</pre>\n";
  71   footer();
  72 }
  73
  74 #----- Register actions -----------------------------------------------------
  75
  76 $main::ACT{"doc"} = \&doc;
  77
  78 #----- That's all, folks ----------------------------------------------------
  79
  80 1;