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