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