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

   1 # -*-perl-*-
   2 #
   3 # $Id: SWDoc.pm,v 1.3 1999/08/19 12:11:09 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.3  1999/08/19 12:11:09  mdw
  32 # More improvements to URL recognizer.
  33 #
  34 # Revision 1.2  1999/08/18 17:10:07  mdw
  35 # Slight improvements to URL and email address parsing.
  36 #
  37 # Revision 1.1  1999/07/30 18:46:37  mdw
  38 # New CGI script for browsing installed software and documentation.
  39 #
  40
  41 #----- Package preamble -----------------------------------------------------
  42
  43 package SWDoc;
  44
  45 use IO;
  46 use POSIX;
  47 use SWConfig;
  48 use SWCGI qw(:DEFAULT :layout);
  49 use SWMan;
  50
  51 #----- Actions provided -----------------------------------------------------
  52
  53 sub doc {
  54   my $file = "$C{doc}/$Q{pkg}";
  55   barf("illegal filename `$file'") if $file =~ m:\./:;
  56   my $fh = IO::File->new($file, O_RDONLY) or
  57     barf("couldn't open `$file': $!");
  58   header("Local documentation for package $Q{pkg}");
  59   print("<h3>Local documentation for package $Q{pkg}</h3>\n");
  60   print("<pre>\n");
  61
  62   while (my $line = $fh->getline()) {
  63     last if $line =~ /\f/;
  64     $line =~ s/\&/&amp;/g;
  65     $line =~ s/\</&lt;</g;
  66     $line =~ s/\>/>&gt;/g;
  67
  68     # --- Spot URLs (except `mailto') ---
  69
  70     $line =~ s! \b (http s? | ftp | file | news) :
  71                 [^])\s<>]* [^]<>&).,\s\']
  72               !SWMan::urlsubst($&, $&)!egx;
  73
  74     # --- Spot email addresses (including `mailto' URLs) ---
  75
  76     $line =~ s! (?:\bmailto:)?
  77                 ([^\s()&;:<>&{}.,\`\'\"] [^\s()&;:<>&{}\`\'\"]*
  78                  \@
  79                  [^\s()&;:{}<>&\'\"]* [^\s()&;:{}<>&.,\'\"])
  80               !<a href="mailto:$1">$&</a>!gx;
  81
  82     # --- Spot info references ---
  83
  84     $line =~ s! \b info: ([^]&)\s<>]* [^]&).,\s<>\'\"])
  85               !<a href="$ref?act=info&file=$1&node=Top">$&</a>!gx;
  86
  87     # --- Spot manpage references ---
  88
  89     $line =~ s! ([-_.\w]+) \( (\d+\w*) \)
  90               !SWMan::subst("$1($2)", $1, $2)!egx;
  91
  92     # --- Finally fix up the HTML properly ---
  93
  94     $line =~ s/\&lt\;\</&lt;/g;
  95     $line =~ s/\>\&gt\;/&gt;/g;
  96
  97     print $line;
  98   }
  99   print "</pre>\n";
 100   footer();
 101 }
 102
 103 #----- Register actions -----------------------------------------------------
 104
 105 $main::ACT{"doc"} = \&doc;
 106
 107 #----- That's all, folks ----------------------------------------------------
 108
 109 1;