C4/Output.pm

   1 package C4::Output;
   2
   3 #package to deal with marking up output
   4 #You will need to edit parts of this pm
   5 #set the value of path to be where your html lives
   6
   7
   8 # Copyright 2000-2002 Katipo Communications
   9 #
  10 # This file is part of Koha.
  11 #
  12 # Koha is free software; you can redistribute it and/or modify it under the
  13 # terms of the GNU General Public License as published by the Free Software
  14 # Foundation; either version 2 of the License, or (at your option) any later
  15 # version.
  16 #
  17 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  18 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  19 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  20 #
  21 # You should have received a copy of the GNU General Public License along with
  22 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  23 # Suite 330, Boston, MA  02111-1307 USA
  24
  25 use strict;
  26 require Exporter;
  27
  28 use C4::Context;
  29 use C4::Database;
  30 use C4::Search; #for getting the systempreferences
  31
  32 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  33
  34 # set the version for version checking
  35 $VERSION = 0.01;
  36
  37 =head1 NAME
  38
  39 C4::Output - Functions for generating HTML for the Koha web interface
  40
  41 =head1 SYNOPSIS
  42
  43   use C4::Output;
  44
  45   $str = &mklink("http://www.koha.org/", "Koha web page");
  46   print $str;
  47
  48 =head1 DESCRIPTION
  49
  50 The functions in this module generate HTML, and return the result as a
  51 printable string.
  52
  53 =head1 FUNCTIONS
  54
  55 =over 2
  56
  57 =cut
  58
  59 @ISA = qw(Exporter);
  60 @EXPORT = qw(&startpage &endpage
  61              &mktablehdr &mktableft &mktablerow &mklink
  62              &startmenu &endmenu &mkheadr
  63              &center &endcenter
  64              &mkform &mkform2 &bold
  65              &gotopage &mkformnotable &mkform3
  66              &getkeytableselectoptions
  67              &pathtotemplate
  68                 &themelanguage &gettemplate
  69              );
  70 %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
  71
  72 # your exported package globals go here,
  73 # as well as any optionally exported functions
  74
  75 @EXPORT_OK   = qw($Var1 %Hashit);       # FIXME - These are never used
  76
  77
  78 # non-exported package globals go here
  79 use vars qw(@more $stuff);              # FIXME - These are never used
  80
  81 # initalize package globals, first exported ones
  82
  83 # FIXME - These are never used
  84 my $Var1   = '';
  85 my %Hashit = ();
  86
  87
  88 # then the others (which are still accessible as $Some::Module::stuff)
  89 # FIXME - These are never used
  90 my $stuff  = '';
  91 my @more   = ();
  92
  93 # all file-scoped lexicals must be created before
  94 # the functions below that use them.
  95
  96 my $path = C4::Context->config('includes') ||
  97         "/usr/local/www/hdl/htdocs/includes";
  98
  99 #---------------------------------------------------------------------------------------------------------
 100 # FIXME - POD
 101 sub gettemplate {
 102     my ($tmplbase, $opac) = @_;
 103
 104     my $htdocs;
 105     if ($opac) {
 106         $htdocs = C4::Context->config('opachtdocs');
 107     } else {
 108         $htdocs = C4::Context->config('intrahtdocs');
 109     }
 110
 111     my ($theme, $lang) = themelanguage($htdocs, $tmplbase);
 112
 113     my $template = HTML::Template->new(filename      => "$htdocs/$theme/$lang/$tmplbase",
 114                                    die_on_bad_params => 0,
 115                                    global_vars       => 1,
 116                                    path              => ["$htdocs/$theme/$lang/includes"]);
 117
 118     $template->param(themelang => "/$theme/$lang");
 119     return $template;
 120 }
 121
 122 #---------------------------------------------------------------------------------------------------------
 123 # FIXME - POD
 124 sub themelanguage {
 125   my ($htdocs, $tmpl) = @_;
 126
 127 # language preferences....
 128   my $dbh = C4::Context->dbh;
 129   my $sth=$dbh->prepare("SELECT value FROM systempreferences WHERE variable='opaclanguages'");
 130   $sth->execute;
 131   my ($lang) = $sth->fetchrow;
 132   $sth->finish;
 133   my @languages = split " ", $lang;
 134
 135 # theme preferences....
 136   my $sth=$dbh->prepare("SELECT value FROM systempreferences WHERE variable='opacthemes'");
 137   $sth->execute;
 138   my ($theme) = $sth->fetchrow;
 139   $sth->finish;
 140   my @themes = split " ", $theme;
 141
 142   my ($theme, $lang);
 143 # searches through the themes and languages. First template it find it returns.
 144 # Priority is for getting the theme right.
 145   THEME:
 146   foreach my $th (@themes) {
 147     foreach my $la (@languages) {
 148         warn "File = $htdocs/$th/$la/$tmpl\n";
 149         if (-e "$htdocs/$th/$la/$tmpl") {
 150             $theme = $th;
 151             $lang = $la;
 152             last THEME;
 153         }
 154     }
 155   }
 156   if ($theme and $lang) {
 157     return ($theme, $lang);
 158   } else {
 159     return ('default', 'en');
 160   }
 161 }
 162
 163
 164 =item pathtotemplate
 165
 166   %values = &pathtotemplate(template => $template,
 167         theme => $themename,
 168         language => $language,
 169         type => $ptype,
 170         path => $includedir);
 171
 172 Finds a directory containing the desired template. The C<template>
 173 argument specifies the template you're looking for (this should be the
 174 name of the script you're using to generate an HTML page, without the
 175 C<.pl> extension). Only the C<template> argument is required; the
 176 others are optional.
 177
 178 C<theme> specifies the name of the theme to use. This will be used
 179 only if it is allowed by the C<allowthemeoverride> system preference
 180 option (in the C<systempreferences> table of the Koha database).
 181
 182 C<language> specifies the desired language. If not specified,
 183 C<&pathtotemplate> will use the list of acceptable languages specified
 184 by the browser, then C<all>, and finally C<en> as fallback options.
 185
 186 C<type> may be C<intranet>, C<opac>, C<none>, or some other value.
 187 C<intranet> and C<opac> specify that you want a template for the
 188 internal web site or the public OPAC, respectively. C<none> specifies
 189 that the template you're looking for is at the top level of one of the
 190 include directories. Any other value is taken as-is, as a subdirectory
 191 of one of the include directories.
 192
 193 C<path> specifies an include directory.
 194
 195 C<&pathtotemplate> searches first in the directory given by the
 196 C<path> argument, if any, then in the directories given by the
 197 C<templatedirectory> and C<includes> directives in F</etc/koha.conf>,
 198 in that order.
 199
 200 C<&pathtotemplate> returns a hash with the following keys:
 201
 202 =over 4
 203
 204 =item C<path>
 205
 206 The full pathname to the desired template.
 207
 208 =item C<foundlanguage>
 209
 210 The value is set to 1 if a template in the desired language was found,
 211 or 0 otherwise.
 212
 213 =item C<foundtheme>
 214
 215 The value is set to 1 if a template of the desired theme was found, or
 216 0 otherwise.
 217
 218 =back
 219
 220 If C<&pathtotemplate> cannot find an acceptable template, it returns 0.
 221
 222 Note that if a template of the desired language or theme cannot be
 223 found, C<&pathtotemplate> will print a warning message. Unless you've
 224 set C<$SIG{__WARN__}>, though, this won't show up in the output HTML
 225 document.
 226
 227 =cut
 228 #'
 229 sub pathtotemplate {
 230   my %params = @_;
 231   my $template = $params{'template'};
 232   my $themeor = $params{'theme'};
 233   my $languageor = lc($params{'language'});
 234   my $ptype = lc($params{'type'} or 'intranet');
 235
 236   # FIXME - Make sure $params{'template'} was given. Or else assume
 237   # "default".
 238   my $type;
 239   if ($ptype eq 'opac') {$type = 'opac-tmpl/'; }
 240   elsif ($ptype eq 'none') {$type = ''; }
 241   elsif ($ptype eq 'intranet') {$type = 'intranet-tmpl/'; }
 242   else {$type = $ptype . '/'; }
 243
 244   my %returns;
 245   my %prefs= systemprefs();
 246   my $theme= $prefs{'theme'} || 'default';
 247   if ($themeor and ($prefs{'allowthemeoverride'} =~ qr/$themeor/i )) {$theme = $themeor;}
 248   my @languageorder = getlanguageorder();
 249   my $language = $languageor || shift(@languageorder);
 250
 251   #where to search for templates
 252   my @tmpldirs = ("$path/templates", $path);
 253   unshift (@tmpldirs, C4::Context->config('templatedirectory')) if C4::Context->config('templatedirectory');
 254   unshift (@tmpldirs, $params{'path'}) if $params{'path'};
 255
 256   my ($edir, $etheme, $elanguage, $epath);
 257
 258   # FIXME - Use 'foreach my $var (...)'
 259   CHECK: foreach (@tmpldirs) {
 260     $edir= $_;
 261     foreach ($theme, 'all', 'default') {
 262       $etheme=$_;
 263       foreach ($language, @languageorder, 'all','en') {  # 'en' is the fallback-language
 264         $elanguage = $_;
 265         if (-e "$edir/$type$etheme/$elanguage/$template") {
 266           $epath = "$edir/$type$etheme/$elanguage/$template";
 267           last CHECK;
 268         }
 269       }
 270     }
 271   }
 272
 273   unless ($epath) {
 274     warn "Could not find $template in @tmpldirs";
 275     return 0;
 276   }
 277
 278   if ($language eq $elanguage) {
 279     $returns{'foundlanguage'} = 1;
 280   } else {
 281     $returns{'foundlanguage'} = 0;
 282     warn "The language $language could not be found for $template of $theme.\nServing $elanguage instead.\n";
 283   }
 284   if ($theme eq $etheme) {
 285     $returns{'foundtheme'} = 1;
 286   } else {
 287     $returns{'foundtheme'} = 0;
 288     warn "The template $template could not be found for theme $theme.\nServing $template of $etheme instead.\n";
 289   }
 290
 291   $returns{'path'} = $epath;
 292
 293   return (%returns);
 294 }
 295
 296 =item getlanguageorder
 297
 298   @languages = &getlanguageorder();
 299
 300 Returns the list of languages that the user will accept, and returns
 301 them in order of decreasing preference. This is retrieved from the
 302 browser's headers, if possible; otherwise, C<&getlanguageorder> uses
 303 the C<languageorder> setting from the C<systempreferences> table in
 304 the Koha database. If neither is set, it defaults to C<en> (English).
 305
 306 =cut
 307 #'
 308 sub getlanguageorder () {
 309   my @languageorder;
 310   my %prefs = systemprefs();
 311
 312   if ($ENV{'HTTP_ACCEPT_LANGUAGE'}) {
 313     @languageorder = split (/,/ ,lc($ENV{'HTTP_ACCEPT_LANGUAGE'}));
 314   } elsif ($prefs{'languageorder'}) {
 315     @languageorder = split (/,/ ,lc($prefs{'languageorder'}));
 316   } else { # here should be another elsif checking for apache's languageorder
 317     @languageorder = ('en');
 318   }
 319
 320   return (@languageorder);
 321 }
 322
 323 =item startpage
 324
 325   $str = &startpage();
 326   print $str;
 327
 328 Returns a string of HTML, the beginning of a new HTML document.
 329
 330 =cut
 331 #'
 332 sub startpage() {
 333   return("<html>\n");
 334 }
 335
 336 =item gotopage
 337
 338   $str = &gotopage("//opac.koha.org/index.html");
 339   print $str;
 340
 341 Generates a snippet of HTML code that will redirect to the given URL
 342 (which should not include the initial C<http:>), and returns it.
 343
 344 =cut
 345 #'
 346 sub gotopage($) {
 347   my ($target) = shift;
 348   #print "<br>goto target = $target<br>";
 349   my $string = "<META HTTP-EQUIV=Refresh CONTENT=\"0;URL=http:$target\">";
 350   return $string;
 351 }
 352
 353 =item startmenu
 354
 355   @lines = &startmenu($type);
 356   print join("", @lines);
 357
 358 Given a page type, or category, returns a set of lines of HTML which,
 359 when concatenated, generate the menu at the top of the web page.
 360
 361 C<$type> may be one of C<issue>, C<opac>, C<member>, C<acquisitions>,
 362 C<report>, C<circulation>, or something else, in which case the menu
 363 will be for the catalog pages.
 364
 365 =cut
 366 #'
 367 sub startmenu($) {
 368   # edit the paths in here
 369   my ($type)=shift;
 370   if ($type eq 'issue') {
 371     open (FILE,"$path/issues-top.inc") || die;
 372   } elsif ($type eq 'opac') {
 373     open (FILE,"$path/opac-top.inc") || die;
 374   } elsif ($type eq 'member') {
 375     open (FILE,"$path/members-top.inc") || die;
 376   } elsif ($type eq 'acquisitions'){
 377     open (FILE,"$path/acquisitions-top.inc") || die;
 378   } elsif ($type eq 'report'){
 379     open (FILE,"$path/reports-top.inc") || die;
 380   } elsif ($type eq 'circulation') {
 381     open (FILE,"$path/circulation-top.inc") || die;
 382   } else {
 383     open (FILE,"$path/cat-top.inc") || die;
 384   }
 385   my @string=<FILE>;
 386   close FILE;
 387   # my $count=@string;
 388   # $string[$count]="<BLOCKQUOTE>";
 389   return @string;
 390 }
 391
 392 =item endmenu
 393
 394   @lines = &endmenu($type);
 395   print join("", @lines);
 396
 397 Given a page type, or category, returns a set of lines of HTML which,
 398 when concatenated, generate the menu at the bottom of the web page.
 399
 400 C<$type> may be one of C<issue>, C<opac>, C<member>, C<acquisitions>,
 401 C<report>, C<circulation>, or something else, in which case the menu
 402 will be for the catalog pages.
 403
 404 =cut
 405 #'
 406 sub endmenu {
 407   my ($type) = @_;
 408   if ( ! defined $type ) { $type=''; }
 409   # FIXME - It's bad form to die in a CGI script. It's even worse form
 410   # to die without issuing an error message.
 411   if ($type eq 'issue') {
 412     open (FILE,"$path/issues-bottom.inc") || die;
 413   } elsif ($type eq 'opac') {
 414     open (FILE,"$path/opac-bottom.inc") || die;
 415   } elsif ($type eq 'member') {
 416     open (FILE,"$path/members-bottom.inc") || die;
 417   } elsif ($type eq 'acquisitions') {
 418     open (FILE,"$path/acquisitions-bottom.inc") || die;
 419   } elsif ($type eq 'report') {
 420     open (FILE,"$path/reports-bottom.inc") || die;
 421   } elsif ($type eq 'circulation') {
 422     open (FILE,"$path/circulation-bottom.inc") || die;
 423   } else {
 424     open (FILE,"$path/cat-bottom.inc") || die;
 425   }
 426   my @string=<FILE>;
 427   close FILE;
 428   return @string;
 429 }
 430
 431 =item mktablehdr
 432
 433   $str = &mktablehdr();
 434   print $str;
 435
 436 Returns a string of HTML, which generates the beginning of a table
 437 declaration.
 438
 439 =cut
 440 #'
 441 sub mktablehdr() {
 442     return("<table border=0 cellspacing=0 cellpadding=5>\n");
 443 }
 444
 445 =item mktablerow
 446
 447   $str = &mktablerow($columns, $color, @column_data, $bgimage);
 448   print $str;
 449
 450 Returns a string of HTML, which generates a row of data inside a table
 451 (see also C<&mktablehdr>, C<&mktableft>).
 452
 453 C<$columns> specifies the number of columns in this row of data.
 454
 455 C<$color> specifies the background color for the row, e.g., C<"white">
 456 or C<"#ffacac">.
 457
 458 C<@column_data> is an array of C<$columns> elements, each one a string
 459 of HTML. These are the contents of the row.
 460
 461 The optional C<$bgimage> argument specifies the pathname to an image
 462 to use as the background for each cell in the row. This pathname will
 463 used as is in the output, so it should be relative to the HTTP
 464 document root.
 465
 466 =cut
 467 #'
 468 sub mktablerow {
 469     #the last item in data may be a backgroundimage
 470
 471     # FIXME
 472     # should this be a foreach (1..$cols) loop?
 473
 474   my ($cols,$colour,@data)=@_;
 475   my $i=0;
 476   my $string="<tr valign=top bgcolor=$colour>";
 477   while ($i <$cols){
 478       if (defined $data[$cols]) { # if there is a background image
 479           $string.="<td background=\"$data[$cols]\">";
 480       } else { # if there's no background image
 481           $string.="<td>";
 482       }
 483       if (! defined $data[$i]) {$data[$i]="";}
 484       if ($data[$i] eq "") {
 485           $string.=" &nbsp; </td>";
 486       } else {
 487           $string.="$data[$i]</td>";
 488       }
 489       $i++;
 490   }
 491   $string=$string."</tr>\n";
 492   return($string);
 493 }
 494
 495 =item mktableft
 496
 497   $str = &mktableft();
 498   print $str;
 499
 500 Returns a string of HTML, which generates the end of a table
 501 declaration.
 502
 503 =cut
 504 #'
 505 sub mktableft() {
 506   return("</table>\n");
 507 }
 508
 509 # FIXME - This is never used.
 510 sub mkform{
 511   my ($action,%inputs)=@_;
 512   my $string="<form action=$action method=post>\n";
 513   $string=$string.mktablehdr();
 514   my $key;
 515   my @keys=sort keys %inputs;
 516
 517   my $count=@keys;
 518   my $i2=0;
 519   while ( $i2<$count) {
 520     my $value=$inputs{$keys[$i2]};
 521     my @data=split('\t',$value);
 522     #my $posn = shift(@data);
 523     if ($data[0] eq 'hidden'){
 524       $string=$string."<input type=hidden name=$keys[$i2] value=\"$data[1]\">\n";
 525     } else {
 526       my $text;
 527       if ($data[0] eq 'radio') {
 528         $text="<input type=radio name=$keys[$i2] value=$data[1]>$data[1]
 529         <input type=radio name=$keys[$i2] value=$data[2]>$data[2]";
 530       }
 531       if ($data[0] eq 'text') {
 532         $text="<input type=$data[0] name=$keys[$i2] value=\"$data[1]\">";
 533       }
 534       if ($data[0] eq 'textarea') {
 535         $text="<textarea name=$keys[$i2] wrap=physical cols=40 rows=4>$data[1]</textarea>";
 536       }
 537       if ($data[0] eq 'select') {
 538         $text="<select name=$keys[$i2]>";
 539         my $i=1;
 540         while ($data[$i] ne "") {
 541           my $val = $data[$i+1];
 542           $text = $text."<option value=$data[$i]>$val";
 543           $i = $i+2;
 544         }
 545         $text=$text."</select>";
 546       }
 547       $string=$string.mktablerow(2,'white',$keys[$i2],$text);
 548       #@order[$posn] =mktablerow(2,'white',$keys[$i2],$text);
 549     }
 550     $i2++;
 551   }
 552   #$string=$string.join("\n",@order);
 553   $string=$string.mktablerow(2,'white','<input type=submit>','<input type=reset>');
 554   $string=$string.mktableft;
 555   $string=$string."</form>";
 556 }
 557
 558 =item mkform3
 559
 560   $str = &mkform3($action,
 561         $fieldname => "$fieldtype\t$fieldvalue\t$fieldpos",
 562         ...
 563         );
 564   print $str;
 565
 566 Takes a set of arguments that define an input form, generates an HTML
 567 string for the form, and returns the string.
 568
 569 C<$action> is the action for the form, usually the URL of the script
 570 that will process it.
 571
 572 The remaining arguments define the fields in the form. C<$fieldname>
 573 is the field's name. This is for the script's benefit, and will not be
 574 shown to the user.
 575
 576 C<$fieldpos> is an integer; fields will be output in order of
 577 increasing C<$fieldpos>. This number must be unique: if two fields
 578 have the same C<$fieldpos>, one will be picked at random, and the
 579 other will be ignored. See below for special considerations, however.
 580
 581 C<$fieldtype> specifies the type of the input field. It may be one of
 582 the following:
 583
 584 =over 4
 585
 586 =item C<hidden>
 587
 588 Generates a hidden field, used to pass data to the script without
 589 showing it to the user. C<$fieldvalue> is the value.
 590
 591 =item C<radio>
 592
 593 Generates a pair of radio buttons, with values C<$fieldvalue> and
 594 C<$fieldpos>. In both cases, C<$fieldvalue> and C<$fieldpos> will be
 595 shown to the user.
 596
 597 =item C<text>
 598
 599 Generates a one-line text input field. It initially contains
 600 C<$fieldvalue>.
 601
 602 =item C<textarea>
 603
 604 Generates a four-line text input area. The initial text (which, of
 605 course, may not contain any tabs) is C<$fieldvalue>.
 606
 607 =item C<select>
 608
 609 Generates a list of items, from which the user may choose one. This is
 610 somewhat different from other input field types, and should be
 611 specified as:
 612   "myselectfield" => "select\t<label0>\t<text0>\t<label1>\t<text1>...",
 613 where the C<text>N strings are the choices that will be presented to
 614 the user, and C<label>N are the labels that will be passed to the
 615 script.
 616
 617 However, C<text0> should be an integer, since it will be used to
 618 determine the order in which this field appears in the form. If any of
 619 the C<label>Ns are empty, the rest of the list will be ignored.
 620
 621 =back
 622
 623 =cut
 624 #'
 625 sub mkform3 {
 626   my ($action, %inputs) = @_;
 627   my $string = "<form action=\"$action\" method=\"post\">\n";
 628   $string   .= mktablehdr();
 629   my $key;
 630   my @keys = sort(keys(%inputs));       # FIXME - Why do these need to be
 631                                         # sorted?
 632   my @order;
 633   my $count = @keys;
 634   my $i2 = 0;
 635   while ($i2 < $count) {
 636     my $value=$inputs{$keys[$i2]};
 637     # FIXME - Why use a tab-separated string? Why not just use an
 638     # anonymous array?
 639     my @data=split('\t',$value);
 640     my $posn = $data[2];
 641     if ($data[0] eq 'hidden'){
 642       $order[$posn]="<input type=hidden name=$keys[$i2] value=\"$data[1]\">\n";
 643     } else {
 644       my $text;
 645       if ($data[0] eq 'radio') {
 646         $text="<input type=radio name=$keys[$i2] value=$data[1]>$data[1]
 647         <input type=radio name=$keys[$i2] value=$data[2]>$data[2]";
 648       }
 649       # FIXME - Is 40 the right size in all cases?
 650       if ($data[0] eq 'text') {
 651         $text="<input type=$data[0] name=$keys[$i2] value=\"$data[1]\" size=40>";
 652       }
 653       # FIXME - Is 40x4 the right size in all cases?
 654       if ($data[0] eq 'textarea') {
 655         $text="<textarea name=$keys[$i2] cols=40 rows=4>$data[1]</textarea>";
 656       }
 657       if ($data[0] eq 'select') {
 658         $text="<select name=$keys[$i2]>";
 659         my $i=1;
 660         while ($data[$i] ne "") {
 661           my $val = $data[$i+1];
 662           $text = $text."<option value=$data[$i]>$val";
 663           $i = $i+2;            # FIXME - Use $i += 2.
 664         }
 665         $text=$text."</select>";
 666       }
 667 #      $string=$string.mktablerow(2,'white',$keys[$i2],$text);
 668       $order[$posn]=mktablerow(2,'white',$keys[$i2],$text);
 669     }
 670     $i2++;
 671   }
 672   my $temp=join("\n",@order);
 673   # FIXME - Use ".=". That's what it's for.
 674   $string=$string.$temp;
 675   $string=$string.mktablerow(1,'white','<input type=submit>');
 676   $string=$string.mktableft;
 677   $string=$string."</form>";
 678   # FIXME - A return statement, while not strictly necessary, would be nice.
 679 }
 680
 681 =item mkformnotable
 682
 683   $str = &mkformnotable($action, @inputs);
 684   print $str;
 685
 686 Takes a set of arguments that define an input form, generates an HTML
 687 string for the form, and returns the string. Unlike C<&mkform2> and
 688 C<&mkform3>, it does not put the form inside a table.
 689
 690 C<$action> is the action for the form, usually the URL of the script
 691 that will process it.
 692
 693 The remaining arguments define the fields in the form. Each is an
 694 anonymous array, e.g.:
 695
 696   &mkformnotable("/cgi-bin/foo",
 697         [ "hidden", "hiddenvar", "value" ],
 698         [ "text", "username", "" ]);
 699
 700 The first element of each argument defines its type. The remaining
 701 ones are type-dependent. The supported types are:
 702
 703 =over 4
 704
 705 =item C<[ "hidden", $name, $value]>
 706
 707 Generates a hidden field, for passing information to a script without
 708 showing it to the user. C<$name> is the name of the field, and
 709 C<$value> is the value to pass.
 710
 711 =item C<[ "radio", $groupname, $value ]>
 712
 713 Generates a radio button. Its name (or button group name) is C<$name>.
 714 C<$value> is the value associated with the button; this is both the
 715 value that will be shown to the user, and that which will be passed on
 716 to the C<$action> script.
 717
 718 =item C<[ "text", $name, $inittext ]>
 719
 720 Generates a text input field. C<$name> specifies its name, and
 721 C<$inittext> specifies the text that the field should initially
 722 contain.
 723
 724 =item C<[ "textarea", $name ]>
 725
 726 Creates a 40x4 text area, named C<$name>.
 727
 728 =item C<[ "reset", $name, $label ]>
 729
 730 Generates a reset button, with name C<$name>. C<$label> specifies the
 731 text for the button.
 732
 733 =item C<[ "submit", $name, $label ]>
 734
 735 Generates a submit button, with name C<$name>. C<$label> specifies the
 736 text for the button.
 737
 738 =back
 739
 740 =cut
 741 #'
 742 sub mkformnotable{
 743   my ($action,@inputs)=@_;
 744   my $string="<form action=$action method=post>\n";
 745   my $count=@inputs;
 746   for (my $i=0; $i<$count; $i++){
 747     if ($inputs[$i][0] eq 'hidden'){
 748       $string=$string."<input type=hidden name=$inputs[$i][1] value=\"$inputs[$i][2]\">\n";
 749     }
 750     if ($inputs[$i][0] eq 'radio') {
 751       $string.="<input type=radio name=$inputs[1] value=$inputs[$i][2]>$inputs[$i][2]";
 752     }
 753     if ($inputs[$i][0] eq 'text') {
 754       $string.="<input type=$inputs[$i][0] name=$inputs[$i][1] value=\"$inputs[$i][2]\">";
 755     }
 756     if ($inputs[$i][0] eq 'textarea') {
 757         $string.="<textarea name=$inputs[$i][1] wrap=physical cols=40 rows=4>$inputs[$i][2]</textarea>";
 758     }
 759     if ($inputs[$i][0] eq 'reset'){
 760       $string.="<input type=reset name=$inputs[$i][1] value=\"$inputs[$i][2]\">";
 761     }
 762     if ($inputs[$i][0] eq 'submit'){
 763       $string.="<input type=submit name=$inputs[$i][1] value=\"$inputs[$i][2]\">";
 764     }
 765   }
 766   $string=$string."</form>";
 767 }
 768
 769 =item mkform2
 770
 771   $str = &mkform2($action,
 772         $fieldname => "$fieldpos\t$required\t$label\t$fieldtype\t$value0\t$value1\t...",
 773         ...
 774         );
 775   print $str;
 776
 777 Takes a set of arguments that define an input form, generates an HTML
 778 string for the form, and returns the string.
 779
 780 C<$action> is the action for the form, usually the URL of the script
 781 that will process it.
 782
 783 The remaining arguments define the fields in the form. C<$fieldname>
 784 is the field's name. This is for the script's benefit, and will not be
 785 shown to the user.
 786
 787 C<$fieldpos> is an integer; fields will be output in order of
 788 increasing C<$fieldpos>. This number must be unique: if two fields
 789 have the same C<$fieldpos>, one will be picked at random, and the
 790 other will be ignored. See below for special considerations, however.
 791
 792 If C<$required> is the string C<R>, then the field is required, and
 793 the label will have C< (Req.)> appended.
 794
 795 C<$label> is a string that will appear next to the input field.
 796
 797 C<$fieldtype> specifies the type of the input field. It may be one of
 798 the following:
 799
 800 =over 4
 801
 802 =item C<hidden>
 803
 804 Generates a hidden field, used to pass data to the script without
 805 showing it to the user. C<$value0> is its value.
 806
 807 =item C<radio>
 808
 809 Generates a pair of radio buttons, with values C<$value0> and
 810 C<$value1>. In both cases, C<$value0> and C<$value1> will be shown to
 811 the user, next to the radio button.
 812
 813 =item C<text>
 814
 815 Generates a one-line text input field. Its size may be specified by
 816 C<$value0>. The default is 40. The initial text of the field may be
 817 specified by C<$value1>.
 818
 819 =item C<textarea>
 820
 821 Generates a text input area. C<$value0> may be a string of the form
 822 "WWWxHHH", in which case the text input area will be WWW columns wide
 823 and HHH rows tall. The size defaults to 40x4.
 824
 825 The initial text (which, of course, may not contain any tabs) may be
 826 specified by C<$value1>.
 827
 828 =item C<select>
 829
 830 Generates a list of items, from which the user may choose one. Here,
 831 C<$value1>, C<$value2>, etc. are a list of key-value pairs. In each
 832 pair, the key specifies an internal label for a choice, and the value
 833 specifies the description of the choice that will be shown the user.
 834
 835 If C<$value0> is the same as one of the keys that follows, then the
 836 corresponding choice will initially be selected.
 837
 838 =back
 839
 840 =cut
 841 #'
 842 sub mkform2{
 843     # FIXME
 844     # no POD and no tests yet.  Once tests are written,
 845     # this function can be cleaned up with the following steps:
 846     #  turn the while loop into a foreach loop
 847     #  pull the nested if,elsif structure back up to the main level
 848     #  pull the code for the different kinds of inputs into separate
 849     #   functions
 850   my ($action,%inputs)=@_;
 851   my $string="<form action=$action method=post>\n";
 852   $string=$string.mktablehdr();
 853   my $key;
 854   my @order;
 855   while ( my ($key, $value) = each %inputs) {
 856     my @data=split('\t',$value);
 857     my $posn = shift(@data);
 858     my $reqd = shift(@data);
 859     my $ltext = shift(@data);
 860     if ($data[0] eq 'hidden'){
 861       $string=$string."<input type=hidden name=$key value=\"$data[1]\">\n";
 862     } else {
 863       my $text;
 864       if ($data[0] eq 'radio') {
 865         $text="<input type=radio name=$key value=$data[1]>$data[1]
 866         <input type=radio name=$key value=$data[2]>$data[2]";
 867       } elsif ($data[0] eq 'text') {
 868         my $size = $data[1];
 869         if ($size eq "") {
 870           $size=40;
 871         }
 872         $text="<input type=$data[0] name=$key size=$size value=\"$data[2]\">";
 873       } elsif ($data[0] eq 'textarea') {
 874         my @size=split("x",$data[1]);
 875         if ($data[1] eq "") {
 876           $size[0] = 40;
 877           $size[1] = 4;
 878         }
 879         $text="<textarea name=$key wrap=physical cols=$size[0] rows=$size[1]>$data[2]</textarea>";
 880       } elsif ($data[0] eq 'select') {
 881         $text="<select name=$key>";
 882         my $sel=$data[1];
 883         my $i=2;
 884         while ($data[$i] ne "") {
 885           my $val = $data[$i+1];
 886           $text = $text."<option value=\"$data[$i]\"";
 887           if ($data[$i] eq $sel) {
 888              $text = $text." selected";
 889           }
 890           $text = $text.">$val";
 891           $i = $i+2;
 892         }
 893         $text=$text."</select>";
 894       }
 895       if ($reqd eq "R") {
 896         $ltext = $ltext." (Req)";
 897         }
 898       $order[$posn] =mktablerow(2,'white',$ltext,$text);
 899     }
 900   }
 901   $string=$string.join("\n",@order);
 902   $string=$string.mktablerow(2,'white','<input type=submit>','<input type=reset>');
 903   $string=$string.mktableft;
 904   $string=$string."</form>";
 905 }
 906
 907 =item endpage
 908
 909   $str = &endpage();
 910   print $str;
 911
 912 Returns a string of HTML, the end of an HTML document.
 913
 914 =cut
 915 #'
 916 sub endpage() {
 917   return("</body></html>\n");
 918 }
 919
 920 =item mklink
 921
 922   $str = &mklink($url, $text);
 923   print $str;
 924
 925 Returns an HTML string, where C<$text> is a link to C<$url>.
 926
 927 =cut
 928 #'
 929 sub mklink($$) {
 930   my ($url,$text)=@_;
 931   my $string="<a href=\"$url\">$text</a>";
 932   return ($string);
 933 }
 934
 935 =item mkheadr
 936
 937   $str = &mkheadr($type, $text);
 938   print $str;
 939
 940 Takes a header type and header text, and returns a string of HTML,
 941 where C<$text> is rendered with emphasis in a large font size (not an
 942 actual HTML header).
 943
 944 C<$type> may be 1, 2, or 3. A type 1 "header" ends with a line break;
 945 Type 2 has no special tag at the end; Type 3 ends with a paragraph
 946 break.
 947
 948 =cut
 949 #'
 950 sub mkheadr {
 951     # FIXME
 952     # would it be better to make this more generic by accepting an optional
 953     # argument with a closing tag instead of a numeric type?
 954
 955   my ($type,$text)=@_;
 956   my $string;
 957   if ($type eq '1'){
 958     $string="<FONT SIZE=6><em>$text</em></FONT><br>";
 959   }
 960   if ($type eq '2'){
 961     $string="<FONT SIZE=6><em>$text</em></FONT>";
 962   }
 963   if ($type eq '3'){
 964     $string="<FONT SIZE=6><em>$text</em></FONT><p>";
 965   }
 966   return ($string);
 967 }
 968
 969 =item center and endcenter
 970
 971   print &center(), "This is a line of centered text.", &endcenter();
 972
 973 C<&center> and C<&endcenter> take no arguments and return HTML tags
 974 <CENTER> and </CENTER> respectively.
 975
 976 =cut
 977 #'
 978 sub center() {
 979   return ("<CENTER>\n");
 980 }
 981
 982 sub endcenter() {
 983   return ("</CENTER>\n");
 984 }
 985
 986 =item bold
 987
 988   $str = &bold($text);
 989   print $str;
 990
 991 Returns a string of HTML that renders C<$text> in bold.
 992
 993 =cut
 994 #'
 995 sub bold($) {
 996   my ($text)=shift;
 997   return("<b>$text</b>");
 998 }
 999
1000 =item getkeytableselectoptions
1001
1002   $str = &getkeytableselectoptions($dbh, $tablename,
1003         $keyfieldname, $descfieldname,
1004         $showkey, $default);
1005   print $str;
1006
1007 Builds an HTML selection box from a database table. Returns a string
1008 of HTML that implements this.
1009
1010 C<$dbh> is a DBI::db database handle.
1011
1012 C<$tablename> is the database table in which to look up the possible
1013 values for the selection box.
1014
1015 C<$keyfieldname> is field in C<$tablename>. It will be used as the
1016 internal label for the selection.
1017
1018 C<$descfieldname> is a field in C<$tablename>. It will be used as the
1019 option shown to the user.
1020
1021 If C<$showkey> is true, then both the key and value will be shown to
1022 the user.
1023
1024 If the C<$default> argument is given, then if a value (from
1025 C<$keyfieldname>) matches C<$default>, it will be selected by default.
1026
1027 =cut
1028 #'
1029 #---------------------------------------------
1030 # Create an HTML option list for a <SELECT> form tag by using
1031 #    values from a DB file
1032 sub getkeytableselectoptions {
1033         use strict;
1034         # inputs
1035         my (
1036                 $dbh,           # DBI handle
1037                 $tablename,     # name of table containing list of choices
1038                 $keyfieldname,  # column name of code to use in option list
1039                 $descfieldname, # column name of descriptive field
1040                 $showkey,       # flag to show key in description
1041                 $default,       # optional default key
1042         )=@_;
1043         my $selectclause;       # return value
1044
1045         my (
1046                 $sth, $query,
1047                 $key, $desc, $orderfieldname,
1048         );
1049         my $debug=0;
1050
1051         requireDBI($dbh,"getkeytableselectoptions");
1052
1053         if ( $showkey ) {
1054                 $orderfieldname=$keyfieldname;
1055         } else {
1056                 $orderfieldname=$descfieldname;
1057         }
1058         $query= "select $keyfieldname,$descfieldname
1059                 from $tablename
1060                 order by $orderfieldname ";
1061         print "<PRE>Query=$query </PRE>\n" if $debug;
1062         $sth=$dbh->prepare($query);
1063         $sth->execute;
1064         while ( ($key, $desc) = $sth->fetchrow) {
1065             if ($showkey || ! $desc ) { $desc="$key - $desc"; }
1066             $selectclause.="<option";
1067             if (defined $default && $default eq $key) {
1068                 $selectclause.=" selected";
1069             }
1070             $selectclause.=" value='$key'>$desc\n";
1071             print "<PRE>Sel=$selectclause </PRE>\n" if $debug;
1072         }
1073         return $selectclause;
1074 } # sub getkeytableselectoptions
1075
1076 #---------------------------------
1077
1078 END { }       # module clean-up code here (global destructor)
1079
1080 1;
1081 __END__
1082 =back
1083
1084 =head1 SEE ALSO
1085
1086 L<DBI(3)|DBI>
1087
1088 =cut