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

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