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 # $args{"ListItem"}=\%...;
  58 sub init_project ($%)
  59 {
  60 my($class,%args)=@_;
  61
  62         my $ListItem=$args{"ListItem"};
  63         my $name=$ListItem->{"name"};
  64         $name=~s#<a\s[^>]*>([^<]*)</a>#$1#g;
  65         init($class,
  66                         "title"=>$name,
  67                         %args);
  68         heading();
  69         print "<h1>".$ListItem->{"name"}."</h1>\n";
  70         print $ListItem->{"description"};
  71         print "<hr />\n";
  72         my @table=(
  73                 {"key"=>qr(^download\b.*),"text"=>sub ($) {
  74                                                 $_[0]=~s/^download//;
  75                                                 $_[0]=~s/^-/ /;
  76                                                 return "Download".$_[0];
  77                                                 },
  78                                 "format"=>sub ($) {
  79                                                 my $r;
  80                                                 if ($_[0]=~m#^[a-z]+://#) {
  81                                                         $r="<a href=\"".$_[0]."\">".CGI::escapeHTML($_[0])."</a>";
  82                                                         }
  83                                                 else {
  84                                                         $r="<a href=\"".$_[0]."\">".CGI::escapeHTML(basename($_[0]))."</a>";
  85                                                         my $size=(stat $_[0])[7];
  86                                                         die "Cannot stat \"".$_[0]."\": $!" if !defined $size;
  87                                                                  if ($size>=1024*1024) { $size=int($size/(1024*1024))." MB"; }
  88                                                         elsif ($size>=1024     ) { $size=int($size/(1024     ))." KB"; }
  89                                                         else                     { $size=int($size            )." B"; }
  90                                                         $r.=" ($size)";
  91                                                         }
  92                                                 return $r;
  93                                                 }},
  94                 {"key"=>qr(^link\b.*),"text"=>sub ($) {
  95                                                 $_[0]=~s/^link-//;
  96                                                 return $_[0];
  97                                                 },
  98                                 "format"=>sub ($) {
  99                                                 return "<a href=\"".$_[0]."\">".CGI::escapeHTML($_[0])."</a>";
 100                                                 }},
 101                 {"key"=>"summary","text"=>"Summary"},
 102                 {"key"=>"ownership","text"=>"Ownership"},
 103                 {"key"=>"license","text"=>"License","format"=>sub ($) {
 104                                 my %known=(
 105                                                 "PD"=>"Public Domain",
 106                                                 "GPL"=>"<a href=\"http://www.gnu.org/licenses/gpl.html\">GNU General Public License</a>",
 107                                                 "LGPL"=>"<a href=\"http://www.gnu.org/licenses/lgpl.html\">GNU Lesser General Public License</a>",
 108                                                 );
 109                                 return $known{$_[0]};
 110                                 }},
 111                 {"key"=>"maintenance","text"=>"Currently maintained?","format"=>sub ($) {
 112                                 my %known=(
 113                                                 "finished"=>"Project is finished. No serious bugs known. No new features planned.",
 114                                                 "dead"=>"Project became dead code. Some updates may be needed. It is no longer used.",
 115                                                 );
 116                                 return $known{$_[0]};
 117                                 }},
 118                 {"key"=>"language","text"=>"Programming language","format"=>sub ($) {
 119                                 return "<a href=\"http://java.sun.com/\">".CGI::escapeHTML($_[0])."</a>"
 120                                                 if $_[0]=~/^Java\b/;
 121                                 return "<a href=\"http://www.php.net/\">".CGI::escapeHTML($_[0])."</a>"
 122                                                 if $_[0]=~/^PHP\b/;
 123                                 return undef();
 124                                 }},
 125                 );
 126         print '<table border="0">'."\n";
 127
 128 sub tableit_func
 129 {
 130 my($tableit,$val,$key)=@_;
 131
 132         print "<tr><td>";
 133         if (!ref $tableit->{"text"}) {
 134                 print $tableit->{"text"};
 135                 }
 136         else {
 137                 my $textfunc=$tableit->{"text"};
 138                 print &$textfunc($key);
 139                 }
 140         print ":</td>";
 141         if ($tableit->{"format"}) {
 142                 my $format=$tableit->{"format"};
 143                 my $valn=&$format($val);
 144                 $val=$valn if defined $valn;
 145                 }
 146         print "<td>$val</td></tr>\n";
 147 }
 148
 149         for my $tableit (@table) {
 150                 if (!ref $tableit->{"key"}) {
 151                         tableit_func($tableit,$ListItem->{$tableit->{"key"}},$tableit->{"key"}) 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);
 158                                 }
 159                         }
 160                 }
 161         print "</table>\n";
 162 }
 163
 164 sub fatal (;$)
 165 {
 166 my($msg)=@_;
 167
 168         $msg="UNKNOWN" if !$msg;
 169
 170 #       heading(false/*title*/,false/*indexme*/); // notitle is always safe, don't index the error message
 171         print("\n<p>&nbsp;<br />&nbsp;</p><hr /><h1 class=\"error\">FATAL ERROR: $msg!</h1>\n"
 172                         ."<p>You can report this problem's details to"
 173                         ." <a href=\"mailto:".$WebConfig{"admin_mail"}."\">admin of this website</a>.</p>\n");
 174 #       footer();
 175 }
 176
 177 my $footer_passed;
 178 sub footer (;$)
 179 {
 180 my($delimit)=@_;
 181
 182         $delimit=1 if !defined $delimit;
 183
 184         exit(1) if $footer_passed++;    # deadlock prevention:
 185
 186         print "<p>&nbsp;</p>\n" if $delimit;
 187         print "<hr />\n<p class=\"cvs-id\">$cvs_id_html</p>\n";
 188         print "</body></html>\n";
 189         exit(0);
 190 }
 191
 192 my $heading_done;
 193
 194 my %headers;
 195 my %headers_lc; # maps lc($headers_key)=>$headers_key
 196 sub header (%)
 197 {
 198 my(%pairs)=@_;
 199
 200         while (my($key,$val)=each(%pairs)) {
 201                 do { warn "Headers already sent"; next; } if $heading_done;
 202                 for ($headers_lc{lc $key} || ()) {
 203                         delete $headers{$_};
 204                         }
 205                 $headers_lc{lc $key}=$key;
 206                 $headers{$key}=$val;
 207                 }
 208 }
 209
 210 sub img_size ($$)
 211 {
 212 my($width,$height)=@_;
 213
 214         return((1 #$have_style TODO:dyn
 215                         ? "style=\"border:0;width:${width}px;height:${height}px\"" : "border=\"0\"")
 216                         ." width=\"$width\" height=\"$height\"");
 217 }
 218
 219 sub img ($$;$)
 220 {
 221 my($file,$alt,$attrs)=@_;
 222
 223         (my $file_det=$file)=~s/[.]mng$/.gif/;
 224         my($width,$height)=Image::Size::imgsize($file_det);
 225         $alt=CGI::escapeHTML($alt);
 226         return("<img src=\"$file\" alt=\"$alt\" title=\"$alt\" ".img_size($width,$height)
 227                         .(!defined($attrs) ? "" : " ".$attrs)." />");
 228 }
 229
 230
 231 sub heading (;$$)
 232 {
 233 my($class,$showtitle,$indexme)=@_;
 234
 235         $showtitle=1 if !defined $showtitle;
 236         $indexme=1 if !defined $indexme;
 237
 238         # $ENV{"CLIENT_CHARSET"} ignored (mod_czech support dropped!)
 239         my $client_charset=$Args{"force_charset"} || "us-ascii";
 240         header("Content-type"=>"text/html; charset=$client_charset");
 241         header("Content-Style-Type"=>"text/css");
 242
 243         if ($ENV{"SERVER_SOFTWARE"}) {
 244                 while (my($key,$val)=each(%headers)) {
 245                         print "$key: $val\n";
 246                         }
 247                 print "\n";
 248                 }
 249
 250         return if $heading_done++;
 251
 252         if (1) { # || !$msie_major || $msie_major>=4) # TODO:dyn
 253                 print '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n";
 254                 }
 255         print '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">'."\n";
 256         print '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="cs">'."\n";
 257         print '<head><title>'.CGI::escapeHTML($WebConfig{"title_prefix"})
 258                         .join("",map({ ': '.CGI::escapeHTML($_); } ($WebConfig{"title"} || ())))
 259                         .'</title>'."\n";
 260
 261         if (1) { # || $have_css)        # TODO:dyn
 262                 print <<'HERE';
 263 <style type="text/css"><!--
 264 .cvs-id   { font-family: monospace; }
 265 .error    { color: red;   background-color: transparent; }
 266 .quote    { font-family: monospace; }
 267 .nowrap   { white-space: nowrap; }
 268 .centered { text-align: center; }
 269 .tab-bold { font-weight: bold; }
 270 .tab-head { font-weight: bold; color: yellow; background-color: transparent; }
 271 body {
 272                 background-color: black;
 273                 color: white;
 274                 }
 275 :link    { color: aqua;   background-color: transparent; }
 276 :visited { color: teal;   background-color: transparent; }
 277 h1,h2    { color: yellow; background-color: transparent; }
 278 .footer img { vertical-align: middle; }
 279 HERE
 280
 281 # TODO:dyn
 282 #               if (isset($head_css))
 283 #                       print(trim($head_css)."\n");
 284                 print "--></style>\n";
 285                 }
 286
 287         print '<meta name="robots" content="'.($indexme ? "" : "no" ).'index,follow" />'."\n";
 288         print $_ for ($WebConfig{"head"} || ());
 289         print "</head><body";
 290 # TODO:dyn
 291 #       if (isset($mozilla_major) && $mozilla_major==4)
 292 #               print(" bgcolor=\"black\" text=\"white\" link=\"aqua\" vlink=\"teal\"");
 293         print ">\n";
 294 #       if ($showtitle)
 295 #               print("<h1 class=\"centered\"><a href=\"/\">"
 296 #                               ."Energie & Peníze")
 297 #                               ."</a></h1>\n");
 298 }
 299
 300 1;