Web.pm

   1 #! /usr/bin/perl
   2 #
   3 # $Id$
   4 # Common functions for HTML/XHTML output generation
   5 # Copyright (C) 2003 Jan Kratochvil <project-www.jankratochvil.net@jankratochvil.net>
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; exactly version 2 of June 1991 is required
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program; if not, write to the Free Software
  18 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  19
  20
  21 package My::Web;
  22 require 5.6.0;  # at least 'use warnings;' but we need some 5.6.0+ modules anyway
  23 use vars qw($VERSION);
  24 $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; };
  25 use strict;
  26 use warnings;
  27
  28 use WebConfig;  # for %WebConfig
  29 require CGI;    # for &escapeHTML
  30 require Image::Size;    # for &imgsize
  31 use File::Basename;     # &basename
  32
  33
  34 my %Args;
  35                 # $Args{"title"}
  36                 # $Args{"force_charset"}
  37
  38 my $cvs_id_html;
  39 sub init ($%)
  40 {
  41 my($class,%args)=@_;
  42
  43         %WebConfig=(%WebConfig,%args);  # override %WebConfig settings
  44
  45         undef $WebConfig{"viewcvs"} if $ENV{"SCRIPT_NAME"} && $WebConfig{"viewcvs"} eq $ENV{"SCRIPT_NAME"};
  46         my @cvs_id_split=split / +/,$::CVS_ID;
  47         if (@cvs_id_split==8) {
  48                 $cvs_id_split[2]=""
  49                                 ."<a href=\"".map({ s#/viewcvs/#&~checkout~/#; } $WebConfig{"viewcvs"})."?rev=".$cvs_id_split[2]."\">"
  50                                 .$cvs_id_split[2]."</a>";
  51                 $cvs_id_split[1]="<a href=\"".$WebConfig{"viewcvs"}."\">".$cvs_id_split[1]."</a>";
  52                 $cvs_id_split[5]="<a href=\"mailto:".$WebConfig{"admin_mail"}."\">".$cvs_id_split[5]."</a>";
  53                 }
  54         $cvs_id_html=join " ",@cvs_id_split;
  55 }
  56
  57 sub print_project ($)
  58 {
  59 my($class,$ListItem)=@_;
  60
  61         print "<h1>".$ListItem->{"name"}."</h1>\n";
  62         print $ListItem->{"description"};
  63         print "<hr />\n";
  64         my @table=(
  65                 {"key"=>qr(^download\b.*),"text"=>sub ($) {
  66                                                 $_[0]=~s/^download//;
  67                                                 $_[0]=~s/^-/ /;
  68                                                 return "Download".$_[0];
  69                                                 },
  70                                 "format"=>sub ($) {
  71                                                 my $r;
  72                                                 if ($_[0]=~m#^[a-z]+://#) {
  73                                                         $r="<a href=\"".$_[0]."\">".CGI::escapeHTML($_[0])."</a>";
  74                                                         }
  75                                                 else {
  76                                                         $r="<a href=\"".$_[0]."\">".CGI::escapeHTML(basename($_[0]))."</a>";
  77                                                         my $size=(stat $_[0])[7];
  78                                                         die "Cannot stat \"".$_[0]."\": $!" if !defined $size;
  79                                                                  if ($size>=1024*1024) { $size=int($size/(1024*1024))." MB"; }
  80                                                         elsif ($size>=1024     ) { $size=int($size/(1024     ))." KB"; }
  81                                                         else                     { $size=int($size            )." B"; }
  82                                                         $r.=" ($size)";
  83                                                         }
  84                                                 return $r;
  85                                                 }},
  86                 {"key"=>qr(^link\b.*),"text"=>sub ($) {
  87                                                 $_[0]=~s/^link-//;
  88                                                 return $_[0];
  89                                                 },
  90                                 "format"=>sub ($) {
  91                                                 return "<a href=\"".$_[0]."\">".CGI::escapeHTML($_[0])."</a>";
  92                                                 }},
  93                 {"key"=>"summary","text"=>"Summary"},
  94                 {"key"=>"ownership","text"=>"Ownership"},
  95                 {"key"=>"license","text"=>"License","format"=>sub ($) {
  96                                 my %known=(
  97                                                 "PD"=>"Public Domain",
  98                                                 "GPL"=>"<a href=\"http://www.gnu.org/licenses/gpl.html\">GNU General Public License</a>",
  99                                                 "LGPL"=>"<a href=\"http://www.gnu.org/licenses/lgpl.html\">GNU Lesser General Public License</a>",
 100                                                 );
 101                                 return $known{$_[0]};
 102                                 }},
 103                 {"key"=>"maintenance","text"=>"Currently maintained?","format"=>sub ($) {
 104                                 my %known=(
 105                                                 "finished"=>"Project is finished. Possible bug reports welcome although project not actively developed.",
 106                                                 "dead"=>"Project became dead code, some updates would be required. It is no longer used, project is not supported.",
 107                                                 "obsolete"=>"Obsolete as some other existing package superseded this one.",
 108                                                 "merge"=>"Functions of this package should be merged to some other one.",
 109                                                 "update"=>"Package needs updating to be fully usable, patches welcome.",
 110                                                 "accepted"=>"This patch was accepted by the original package author. It has no longer any separate meaning.",
 111                                                 );
 112                                 return $known{$_[0]};
 113                                 }},
 114                 {"key"=>"reason","text"=>"Reason"},
 115                 {"key"=>"sponsorship","text"=>"Sponsoring Company"},
 116                 {"key"=>"language","text"=>"Programming language","format"=>sub ($) {
 117                                 return "<a href=\"http://java.sun.com/\">".CGI::escapeHTML($_[0])."</a>"
 118                                                 if $_[0]=~/^Java\b/;
 119                                 return "<a href=\"http://www.php.net/\">".CGI::escapeHTML($_[0])."</a>"
 120                                                 if $_[0]=~/^PHP\b/;
 121                                 return undef();
 122                                 }},
 123                 );
 124         print '<table border="0">'."\n";
 125
 126 sub tableit_func
 127 {
 128 my($tableit,$val,$key,$ListItem)=@_;
 129
 130         print "<tr><td>";
 131         if (!ref $tableit->{"text"}) {
 132                 print $tableit->{"text"};
 133                 }
 134         else {
 135                 my $textfunc=$tableit->{"text"};
 136                 my $key=$key;
 137                 print &$textfunc($key);
 138                 }
 139         print ":</td>";
 140         if ($tableit->{"format"}) {
 141                 my $format=$tableit->{"format"};
 142                 my $valn=&$format($val);
 143                 $val=$valn if defined $valn;
 144                 }
 145         print "<td>$val</td></tr>\n";
 146         delete $ListItem->{$key};
 147 }
 148
 149         for my $tableit (@table) {
 150                 if (!ref $tableit->{"key"}) {
 151                         tableit_func($tableit,$ListItem->{$tableit->{"key"}},$tableit->{"key"},$ListItem) if $ListItem->{$tableit->{"key"}};
 152                         }
 153                 else {
 154                         for my $key (keys(%$ListItem)) {
 155                                 my $keyregex=$tableit->{"key"};
 156                                 next if $key!~/$keyregex/;
 157                                 tableit_func($tableit,$ListItem->{$key},$key,$ListItem);
 158                                 }
 159                         }
 160                 }
 161         print "</table>\n";
 162         print "<p>&nbsp;</p>\n";
 163 }
 164
 165 # $args{"ListItem"}=\%...;
 166 sub init_project ($%)
 167 {
 168 my($class,%args)=@_;
 169
 170         my $ListItem=$args{"ListItem"};
 171         my $name=$ListItem->{"name"};
 172         $name=~s#<a\s[^>]*>([^<]*)</a>#$1#g;
 173         init($class,
 174                         "title"=>$name,
 175                         %args);
 176         heading();
 177         $class->print_project($ListItem);
 178 }
 179
 180 sub fatal (;$)
 181 {
 182 my($msg)=@_;
 183
 184         $msg="UNKNOWN" if !$msg;
 185
 186 #       heading(false/*title*/,false/*indexme*/); // notitle is always safe, don't index the error message
 187         print("\n<p>&nbsp;<br />&nbsp;</p><hr /><h1 class=\"error\">FATAL ERROR: $msg!</h1>\n"
 188                         ."<p>You can report this problem's details to"
 189                         ." <a href=\"mailto:".$WebConfig{"admin_mail"}."\">admin of this website</a>.</p>\n");
 190 #       footer();
 191 }
 192
 193 my $footer_passed;
 194 sub footer (;$)
 195 {
 196 my($delimit)=@_;
 197
 198         $delimit=1 if !defined $delimit;
 199
 200         exit(1) if $footer_passed++;    # deadlock prevention:
 201
 202         if (0) {
 203                 print "<p>&nbsp;</p>\n" if $delimit;
 204                 print "<hr />\n<p class=\"cvs-id\">$cvs_id_html</p>\n";
 205                 }
 206         print "</body></html>\n";
 207         exit(0);
 208 }
 209
 210 my $heading_done;
 211
 212 my %headers;
 213 my %headers_lc; # maps lc($headers_key)=>$headers_key
 214 sub header (%)
 215 {
 216 my(%pairs)=@_;
 217
 218         while (my($key,$val)=each(%pairs)) {
 219                 do { warn "Headers already sent"; next; } if $heading_done;
 220                 for ($headers_lc{lc $key} || ()) {
 221                         delete $headers{$_};
 222                         }
 223                 $headers_lc{lc $key}=$key;
 224                 $headers{$key}=$val;
 225                 }
 226 }
 227
 228 sub img_size ($$)
 229 {
 230 my($width,$height)=@_;
 231
 232         return((1 #$have_style TODO:dyn
 233                         ? "style=\"border:0;width:${width}px;height:${height}px\"" : "border=\"0\"")
 234                         ." width=\"$width\" height=\"$height\"");
 235 }
 236
 237 sub img ($$;$)
 238 {
 239 my($file,$alt,$attrs)=@_;
 240
 241         (my $file_det=$file)=~s/[.]mng$/.gif/;
 242         my($width,$height)=Image::Size::imgsize($file_det);
 243         $alt=CGI::escapeHTML($alt);
 244         return("<img src=\"$file\" alt=\"$alt\" title=\"$alt\" ".img_size($width,$height)
 245                         .(!defined($attrs) ? "" : " ".$attrs)." />");
 246 }
 247
 248 sub readfile ($$)
 249 {
 250 my($class,$filename)=@_;
 251
 252         local *F;
 253         open F,$filename or die "Cannot open \"$filename\": $!";
 254         local $/=undef();
 255         my $data=<F>;
 256         close F;
 257         return $data;
 258 }
 259
 260 sub heading (;$$)
 261 {
 262 my($class,$showtitle,$indexme)=@_;
 263
 264         $showtitle=1 if !defined $showtitle;
 265         $indexme=1 if !defined $indexme;
 266
 267         # $ENV{"CLIENT_CHARSET"} ignored (mod_czech support dropped!)
 268         my $client_charset=$Args{"force_charset"} || "us-ascii";
 269         header("Content-type"=>"text/html; charset=$client_charset");
 270         header("Content-Style-Type"=>"text/css");
 271
 272         if ($ENV{"SERVER_SOFTWARE"}) {
 273                 while (my($key,$val)=each(%headers)) {
 274                         print "$key: $val\n";
 275                         }
 276                 print "\n";
 277                 }
 278
 279         return if $heading_done++;
 280
 281         if (1) { # || !$msie_major || $msie_major>=4) # TODO:dyn
 282                 print '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n";
 283                 }
 284         print '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">'."\n";
 285         print '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en-US">'."\n";
 286         print '<head><title>'.CGI::escapeHTML($WebConfig{"title_prefix"})
 287                         .join("",map({ ': '.CGI::escapeHTML($_); } ($WebConfig{"title"} || ())))
 288                         .'</title>'."\n";
 289
 290         if (1) { # || $have_css)        # TODO:dyn
 291                 print <<'HERE';
 292 <style type="text/css"><!--
 293 .cvs-id   { font-family: monospace; }
 294 .error    { color: red;   background-color: transparent; }
 295 .quote    { font-family: monospace; }
 296 .nowrap   { white-space: nowrap; }
 297 .centered { text-align: center; }
 298 .tab-bold { font-weight: bold; }
 299 .tab-head { font-weight: bold; color: yellow; background-color: transparent; }
 300 body {
 301                 background-color: black;
 302                 color: white;
 303                 }
 304 :link    { color: aqua;   background-color: transparent; }
 305 :visited { color: teal;   background-color: transparent; }
 306 h1,h2    { color: yellow; background-color: transparent; }
 307 .footer img { vertical-align: middle; }
 308 HERE
 309
 310 # TODO:dyn
 311 #               if (isset($head_css))
 312 #                       print(trim($head_css)."\n");
 313                 print "--></style>\n";
 314                 }
 315
 316         print '<meta name="robots" content="'.($indexme ? "" : "no" ).'index,follow" />'."\n";
 317         print $_ for ($WebConfig{"head"} || ());
 318         print "</head><body";
 319 # TODO:dyn
 320 #       if (isset($mozilla_major) && $mozilla_major==4)
 321 #               print(" bgcolor=\"black\" text=\"white\" link=\"aqua\" vlink=\"teal\"");
 322         print ">\n";
 323 #       if ($showtitle)
 324 #               print("<h1 class=\"centered\"><a href=\"/\">"
 325 #                               ."Energie & Peníze")
 326 #                               ."</a></h1>\n");
 327 }
 328
 329 1;