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 sub pathtotemplate {
 171   my %params = @_;
 172   my $template = $params{'template'};
 173   my $themeor = $params{'theme'};
 174   my $languageor = lc($params{'language'});
 175   my $ptype = lc($params{'type'} or 'intranet');
 176
 177   my $type;
 178   if ($ptype eq 'opac') {$type = 'opac-tmpl/'; }
 179   elsif ($ptype eq 'none') {$type = ''; }
 180   elsif ($ptype eq 'intranet') {$type = 'intranet-tmpl/'; }
 181   else {$type = $ptype . '/'; }
 182
 183   my %returns;
 184   my %prefs= systemprefs();
 185   my $theme= $prefs{'theme'} || 'default';
 186   if ($themeor and ($prefs{'allowthemeoverride'} =~ qr/$themeor/i )) {$theme = $themeor;}
 187   my @languageorder = getlanguageorder();
 188   my $language = $languageor || shift(@languageorder);
 189
 190   #where to search for templates
 191   my @tmpldirs = ("$path/templates", $path);
 192   unshift (@tmpldirs, $configfile{'templatedirectory'}) if $configfile{'templatedirectory'};
 193   unshift (@tmpldirs, $params{'path'}) if $params{'path'};
 194
 195   my ($edir, $etheme, $elanguage, $epath);
 196
 197   CHECK: foreach (@tmpldirs) {
 198     $edir= $_;
 199     foreach ($theme, 'all', 'default') {
 200       $etheme=$_;
 201       foreach ($language, @languageorder, 'all','en') {  # 'en' is the fallback-language
 202         $elanguage = $_;
 203         if (-e "$edir/$type$etheme/$elanguage/$template") {
 204           $epath = "$edir/$type$etheme/$elanguage/$template";
 205           last CHECK;
 206         }
 207       }
 208     }
 209   }
 210
 211   unless ($epath) {
 212     warn "Could not find $template in @tmpldirs";
 213     return 0;
 214   }
 215
 216   if ($language eq $elanguage) {
 217     $returns{'foundlanguage'} = 1;
 218   } else {
 219     $returns{'foundlanguage'} = 0;
 220     warn "The language $language could not be found for $template of $theme.\nServing $elanguage instead.\n";
 221   }
 222   if ($theme eq $etheme) {
 223     $returns{'foundtheme'} = 1;
 224   } else {
 225     $returns{'foundtheme'} = 0;
 226     warn "The template $template could not be found for theme $theme.\nServing $template of $etheme instead.\n";
 227   }
 228
 229   $returns{'path'} = $epath;
 230
 231   return (%returns);
 232 }
 233
 234 sub getlanguageorder () {
 235   my @languageorder;
 236   my %prefs = systemprefs();
 237
 238   if ($ENV{'HTTP_ACCEPT_LANGUAGE'}) {
 239     @languageorder = split (/,/ ,lc($ENV{'HTTP_ACCEPT_LANGUAGE'}));
 240   } elsif ($prefs{'languageorder'}) {
 241     @languageorder = split (/,/ ,lc($prefs{'languageorder'}));
 242   } else { # here should be another elsif checking for apache's languageorder
 243     @languageorder = ('en');
 244   }
 245
 246   return (@languageorder);
 247 }
 248
 249
 250 sub startpage() {
 251   return("<html>\n");
 252 }
 253
 254 sub gotopage($) {
 255   my ($target) = shift;
 256   #print "<br>goto target = $target<br>";
 257   my $string = "<META HTTP-EQUIV=Refresh CONTENT=\"0;URL=http:$target\">";
 258   return $string;
 259 }
 260
 261
 262 sub startmenu($) {
 263   # edit the paths in here
 264   my ($type)=shift;
 265   if ($type eq 'issue') {
 266     open (FILE,"$path/issues-top.inc") || die;
 267   } elsif ($type eq 'opac') {
 268     open (FILE,"$path/opac-top.inc") || die;
 269   } elsif ($type eq 'member') {
 270     open (FILE,"$path/members-top.inc") || die;
 271   } elsif ($type eq 'acquisitions'){
 272     open (FILE,"$path/acquisitions-top.inc") || die;
 273   } elsif ($type eq 'report'){
 274     open (FILE,"$path/reports-top.inc") || die;
 275   } elsif ($type eq 'circulation') {
 276     open (FILE,"$path/circulation-top.inc") || die;
 277   } else {
 278     open (FILE,"$path/cat-top.inc") || die;
 279   }
 280   my @string=<FILE>;
 281   close FILE;
 282   # my $count=@string;
 283   # $string[$count]="<BLOCKQUOTE>";
 284   return @string;
 285 }
 286
 287 =item endmenu
 288
 289   @lines = &endmenu($type);
 290   print join("", @lines);
 291
 292 Given a page type, or category, returns a set of lines of HTML which,
 293 when concatenated, generate the menu at the bottom of the web page.
 294
 295 C<$type> may be one of C<issue>, C<opac>, C<member>, C<acquisitions>,
 296 C<report>, C<circulation>, or something else, in which case the menu
 297 will be for the catalog pages.
 298
 299 =cut
 300 #'
 301 sub endmenu {
 302   my ($type) = @_;
 303   if ( ! defined $type ) { $type=''; }
 304   # FIXME - It's bad form to die in a CGI script. It's even worse form
 305   # to die without issuing an error message.
 306   if ($type eq 'issue') {
 307     open (FILE,"$path/issues-bottom.inc") || die;
 308   } elsif ($type eq 'opac') {
 309     open (FILE,"$path/opac-bottom.inc") || die;
 310   } elsif ($type eq 'member') {
 311     open (FILE,"$path/members-bottom.inc") || die;
 312   } elsif ($type eq 'acquisitions') {
 313     open (FILE,"$path/acquisitions-bottom.inc") || die;
 314   } elsif ($type eq 'report') {
 315     open (FILE,"$path/reports-bottom.inc") || die;
 316   } elsif ($type eq 'circulation') {
 317     open (FILE,"$path/circulation-bottom.inc") || die;
 318   } else {
 319     open (FILE,"$path/cat-bottom.inc") || die;
 320   }
 321   my @string=<FILE>;
 322   close FILE;
 323   return @string;
 324 }
 325
 326 sub mktablehdr() {
 327     return("<table border=0 cellspacing=0 cellpadding=5>\n");
 328 }
 329
 330
 331 sub mktablerow {
 332     #the last item in data may be a backgroundimage
 333
 334     # FIXME
 335     # should this be a foreach (1..$cols) loop?
 336
 337   my ($cols,$colour,@data)=@_;
 338   my $i=0;
 339   my $string="<tr valign=top bgcolor=$colour>";
 340   while ($i <$cols){
 341       if (defined $data[$cols]) { # if there is a background image
 342           $string.="<td background=\"$data[$cols]\">";
 343       } else { # if there's no background image
 344           $string.="<td>";
 345       }
 346       if (! defined $data[$i]) {$data[$i]="";}
 347       if ($data[$i] eq "") {
 348           $string.=" &nbsp; </td>";
 349       } else {
 350           $string.="$data[$i]</td>";
 351       }
 352       $i++;
 353   }
 354   $string=$string."</tr>\n";
 355   return($string);
 356 }
 357
 358 sub mktableft() {
 359   return("</table>\n");
 360 }
 361
 362 sub mkform{
 363   my ($action,%inputs)=@_;
 364   my $string="<form action=$action method=post>\n";
 365   $string=$string.mktablehdr();
 366   my $key;
 367   my @keys=sort keys %inputs;
 368
 369   my $count=@keys;
 370   my $i2=0;
 371   while ( $i2<$count) {
 372     my $value=$inputs{$keys[$i2]};
 373     my @data=split('\t',$value);
 374     #my $posn = shift(@data);
 375     if ($data[0] eq 'hidden'){
 376       $string=$string."<input type=hidden name=$keys[$i2] value=\"$data[1]\">\n";
 377     } else {
 378       my $text;
 379       if ($data[0] eq 'radio') {
 380         $text="<input type=radio name=$keys[$i2] value=$data[1]>$data[1]
 381         <input type=radio name=$keys[$i2] value=$data[2]>$data[2]";
 382       }
 383       if ($data[0] eq 'text') {
 384         $text="<input type=$data[0] name=$keys[$i2] value=\"$data[1]\">";
 385       }
 386       if ($data[0] eq 'textarea') {
 387         $text="<textarea name=$keys[$i2] wrap=physical cols=40 rows=4>$data[1]</textarea>";
 388       }
 389       if ($data[0] eq 'select') {
 390         $text="<select name=$keys[$i2]>";
 391         my $i=1;
 392         while ($data[$i] ne "") {
 393           my $val = $data[$i+1];
 394           $text = $text."<option value=$data[$i]>$val";
 395           $i = $i+2;
 396         }
 397         $text=$text."</select>";
 398       }
 399       $string=$string.mktablerow(2,'white',$keys[$i2],$text);
 400       #@order[$posn] =mktablerow(2,'white',$keys[$i2],$text);
 401     }
 402     $i2++;
 403   }
 404   #$string=$string.join("\n",@order);
 405   $string=$string.mktablerow(2,'white','<input type=submit>','<input type=reset>');
 406   $string=$string.mktableft;
 407   $string=$string."</form>";
 408 }
 409
 410 sub mkform3 {
 411   my ($action, %inputs) = @_;
 412   my $string = "<form action=\"$action\" method=\"post\">\n";
 413   $string   .= mktablehdr();
 414   my $key;
 415   my @keys = sort(keys(%inputs));
 416   my @order;
 417   my $count = @keys;
 418   my $i2 = 0;
 419   while ($i2 < $count) {
 420     my $value=$inputs{$keys[$i2]};
 421     my @data=split('\t',$value);
 422     my $posn = $data[2];
 423     if ($data[0] eq 'hidden'){
 424       $order[$posn]="<input type=hidden name=$keys[$i2] value=\"$data[1]\">\n";
 425     } else {
 426       my $text;
 427       if ($data[0] eq 'radio') {
 428         $text="<input type=radio name=$keys[$i2] value=$data[1]>$data[1]
 429         <input type=radio name=$keys[$i2] value=$data[2]>$data[2]";
 430       }
 431       # FIXME - Is 40 the right size in all cases?
 432       if ($data[0] eq 'text') {
 433         $text="<input type=$data[0] name=$keys[$i2] value=\"$data[1]\" size=40>";
 434       }
 435       # FIXME - Is 40x4 the right size in all cases?
 436       if ($data[0] eq 'textarea') {
 437         $text="<textarea name=$keys[$i2] cols=40 rows=4>$data[1]</textarea>";
 438       }
 439       if ($data[0] eq 'select') {
 440         $text="<select name=$keys[$i2]>";
 441         my $i=1;
 442         while ($data[$i] ne "") {
 443           my $val = $data[$i+1];
 444           $text = $text."<option value=$data[$i]>$val";
 445           $i = $i+2;            # FIXME - Use $i += 2.
 446         }
 447         $text=$text."</select>";
 448       }
 449 #      $string=$string.mktablerow(2,'white',$keys[$i2],$text);
 450       $order[$posn]=mktablerow(2,'white',$keys[$i2],$text);
 451     }
 452     $i2++;
 453   }
 454   my $temp=join("\n",@order);
 455   # FIXME - Use ".=". That's what it's for.
 456   $string=$string.$temp;
 457   $string=$string.mktablerow(1,'white','<input type=submit>');
 458   $string=$string.mktableft;
 459   $string=$string."</form>";
 460   # FIXME - A return statement, while not strictly necessary, would be nice.
 461 }
 462
 463 # XXX - POD
 464 sub mkformnotable{
 465   my ($action,@inputs)=@_;
 466   my $string="<form action=$action method=post>\n";
 467   my $count=@inputs;
 468   for (my $i=0; $i<$count; $i++){
 469     if ($inputs[$i][0] eq 'hidden'){
 470       $string=$string."<input type=hidden name=$inputs[$i][1] value=\"$inputs[$i][2]\">\n";
 471     }
 472     if ($inputs[$i][0] eq 'radio') {
 473       $string.="<input type=radio name=$inputs[1] value=$inputs[$i][2]>$inputs[$i][2]";
 474     }
 475     if ($inputs[$i][0] eq 'text') {
 476       $string.="<input type=$inputs[$i][0] name=$inputs[$i][1] value=\"$inputs[$i][2]\">";
 477     }
 478     if ($inputs[$i][0] eq 'textarea') {
 479         $string.="<textarea name=$inputs[$i][1] wrap=physical cols=40 rows=4>$inputs[$i][2]</textarea>";
 480     }
 481     if ($inputs[$i][0] eq 'reset'){
 482       $string.="<input type=reset name=$inputs[$i][1] value=\"$inputs[$i][2]\">";
 483     }
 484     if ($inputs[$i][0] eq 'submit'){
 485       $string.="<input type=submit name=$inputs[$i][1] value=\"$inputs[$i][2]\">";
 486     }
 487   }
 488   $string=$string."</form>";
 489 }
 490
 491 =item mkform2
 492
 493   $str = &mkform2($action,
 494         $fieldname => "$fieldpos\t$required\t$label\t$fieldtype\t$value0\t$value1\t...",
 495         ...
 496         );
 497   print $str;
 498
 499 Takes a set of arguments that define an input form, generates an HTML
 500 string for the form, and returns the string.
 501
 502 C<$action> is the action for the form, usually the URL of the script
 503 that will process it.
 504
 505 The remaining arguments define the fields in the form. C<$fieldname>
 506 is the field's name. This is for the script's benefit, and will not be
 507 shown to the user.
 508
 509 C<$fieldpos> is an integer; fields will be output in order of
 510 increasing C<$fieldpos>. This number must be unique: if two fields
 511 have the same C<$fieldpos>, one will be picked at random, and the
 512 other will be ignored. See below for special considerations, however.
 513
 514 If C<$required> is the string C<R>, then the field is required, and
 515 the label will have C< (Req.)> appended.
 516
 517 C<$label> is a string that will appear next to the input field.
 518
 519 C<$fieldtype> specifies the type of the input field. It may be one of
 520 the following:
 521
 522 =over 4
 523
 524 =item C<hidden>
 525
 526 Generates a hidden field, used to pass data to the script without
 527 showing it to the user. C<$value0> is its value.
 528
 529 =item C<radio>
 530
 531 Generates a pair of radio buttons, with values C<$value0> and
 532 C<$value1>. In both cases, C<$value0> and C<$value1> will be shown to
 533 the user, next to the radio button.
 534
 535 =item C<text>
 536
 537 Generates a one-line text input field. Its size may be specified by
 538 C<$value0>. The default is 40. The initial text of the field may be
 539 specified by C<$value1>.
 540
 541 =item C<textarea>
 542
 543 Generates a text input area. C<$value0> may be a string of the form
 544 "WWWxHHH", in which case the text input area will be WWW columns wide
 545 and HHH rows tall. The size defaults to 40x4.
 546
 547 The initial text (which, of course, may not contain any tabs) may be
 548 specified by C<$value1>.
 549
 550 =item C<select>
 551
 552 Generates a list of items, from which the user may choose one. Here,
 553 C<$value1>, C<$value2>, etc. are a list of key-value pairs. In each
 554 pair, the key specifies an internal label for a choice, and the value
 555 specifies the description of the choice that will be shown the user.
 556
 557 If C<$value0> is the same as one of the keys that follows, then the
 558 corresponding choice will initially be selected.
 559
 560 =back
 561
 562 =cut
 563 #'
 564 sub mkform2{
 565     # FIXME
 566     # no POD and no tests yet.  Once tests are written,
 567     # this function can be cleaned up with the following steps:
 568     #  turn the while loop into a foreach loop
 569     #  pull the nested if,elsif structure back up to the main level
 570     #  pull the code for the different kinds of inputs into separate
 571     #   functions
 572   my ($action,%inputs)=@_;
 573   my $string="<form action=$action method=post>\n";
 574   $string=$string.mktablehdr();
 575   my $key;
 576   my @order;
 577   while ( my ($key, $value) = each %inputs) {
 578     my @data=split('\t',$value);
 579     my $posn = shift(@data);
 580     my $reqd = shift(@data);
 581     my $ltext = shift(@data);
 582     if ($data[0] eq 'hidden'){
 583       $string=$string."<input type=hidden name=$key value=\"$data[1]\">\n";
 584     } else {
 585       my $text;
 586       if ($data[0] eq 'radio') {
 587         $text="<input type=radio name=$key value=$data[1]>$data[1]
 588         <input type=radio name=$key value=$data[2]>$data[2]";
 589       } elsif ($data[0] eq 'text') {
 590         my $size = $data[1];
 591         if ($size eq "") {
 592           $size=40;
 593         }
 594         $text="<input type=$data[0] name=$key size=$size value=\"$data[2]\">";
 595       } elsif ($data[0] eq 'textarea') {
 596         my @size=split("x",$data[1]);
 597         if ($data[1] eq "") {
 598           $size[0] = 40;
 599           $size[1] = 4;
 600         }
 601         $text="<textarea name=$key wrap=physical cols=$size[0] rows=$size[1]>$data[2]</textarea>";
 602       } elsif ($data[0] eq 'select') {
 603         $text="<select name=$key>";
 604         my $sel=$data[1];
 605         my $i=2;
 606         while ($data[$i] ne "") {
 607           my $val = $data[$i+1];
 608           $text = $text."<option value=\"$data[$i]\"";
 609           if ($data[$i] eq $sel) {
 610              $text = $text." selected";
 611           }
 612           $text = $text.">$val";
 613           $i = $i+2;
 614         }
 615         $text=$text."</select>";
 616       }
 617       if ($reqd eq "R") {
 618         $ltext = $ltext." (Req)";
 619         }
 620       $order[$posn] =mktablerow(2,'white',$ltext,$text);
 621     }
 622   }
 623   $string=$string.join("\n",@order);
 624   $string=$string.mktablerow(2,'white','<input type=submit>','<input type=reset>');
 625   $string=$string.mktableft;
 626   $string=$string."</form>";
 627 }
 628
 629 =pod
 630
 631 =head2 &endpage
 632
 633  &endpage does not expect any arguments, it returns the string:
 634    </body></html>\n
 635
 636 =cut
 637
 638 sub endpage() {
 639   return("</body></html>\n");
 640 }
 641
 642 =pod
 643
 644 =head2 &mklink
 645
 646  &mklink expects two arguments, the url to link to and the text of the link.
 647  It returns this string:
 648    <a href="$url">$text</a>
 649  where $url is the first argument and $text is the second.
 650
 651 =cut
 652
 653 sub mklink($$) {
 654   my ($url,$text)=@_;
 655   my $string="<a href=\"$url\">$text</a>";
 656   return ($string);
 657 }
 658
 659 =pod
 660
 661 =head2 &mkheadr
 662
 663  &mkeadr expects two strings, a type and the text to use in the header.
 664  types are:
 665
 666 =over
 667
 668 =item 1  ends with <br>
 669
 670 =item 2  no special ending tag
 671
 672 =item 3  ends with <p>
 673
 674 =back
 675
 676  Other than this, the return value is the same:
 677    <FONT SIZE=6><em>$text</em></FONT>$string
 678  Where $test is the text passed in and $string is the tag generated from
 679  the type value.
 680
 681 =cut
 682
 683 sub mkheadr {
 684     # FIXME
 685     # would it be better to make this more generic by accepting an optional
 686     # argument with a closing tag instead of a numeric type?
 687
 688   my ($type,$text)=@_;
 689   my $string;
 690   if ($type eq '1'){
 691     $string="<FONT SIZE=6><em>$text</em></FONT><br>";
 692   }
 693   if ($type eq '2'){
 694     $string="<FONT SIZE=6><em>$text</em></FONT><br>";
 695   }
 696   if ($type eq '3'){
 697     $string="<FONT SIZE=6><em>$text</em></FONT><p>";
 698   }
 699   return ($string);
 700 }
 701
 702 =pod
 703
 704 =head2 &center and &endcenter
 705
 706  &center and &endcenter take no arguments and return html tags <CENTER> and
 707  </CENTER> respectivley.
 708
 709 =cut
 710
 711 sub center() {
 712   return ("<CENTER>\n");
 713 }
 714
 715 sub endcenter() {
 716   return ("</CENTER>\n");
 717 }
 718
 719 =pod
 720
 721 =head2 &bold
 722
 723  &bold requires that a single string be passed in by the caller.  &bold
 724  will return "<b>$text</b>" where $text is the string passed in.
 725
 726 =cut
 727
 728 sub bold($) {
 729   my ($text)=shift;
 730   return("<b>$text</b>");
 731 }
 732
 733 #---------------------------------------------
 734 # Create an HTML option list for a <SELECT> form tag by using
 735 #    values from a DB file
 736 sub getkeytableselectoptions {
 737         use strict;
 738         # inputs
 739         my (
 740                 $dbh,           # DBI handle
 741                 $tablename,     # name of table containing list of choices
 742                 $keyfieldname,  # column name of code to use in option list
 743                 $descfieldname, # column name of descriptive field
 744                 $showkey,       # flag to show key in description
 745                 $default,       # optional default key
 746         )=@_;
 747         my $selectclause;       # return value
 748
 749         my (
 750                 $sth, $query,
 751                 $key, $desc, $orderfieldname,
 752         );
 753         my $debug=0;
 754
 755         requireDBI($dbh,"getkeytableselectoptions");
 756
 757         if ( $showkey ) {
 758                 $orderfieldname=$keyfieldname;
 759         } else {
 760                 $orderfieldname=$descfieldname;
 761         }
 762         $query= "select $keyfieldname,$descfieldname
 763                 from $tablename
 764                 order by $orderfieldname ";
 765         print "<PRE>Query=$query </PRE>\n" if $debug;
 766         $sth=$dbh->prepare($query);
 767         $sth->execute;
 768         while ( ($key, $desc) = $sth->fetchrow) {
 769             if ($showkey || ! $desc ) { $desc="$key - $desc"; }
 770             $selectclause.="<option";
 771             if (defined $default && $default eq $key) {
 772                 $selectclause.=" selected";
 773             }
 774             $selectclause.=" value='$key'>$desc\n";
 775             print "<PRE>Sel=$selectclause </PRE>\n" if $debug;
 776         }
 777         return $selectclause;
 778 } # sub getkeytableselectoptions
 779
 780 #---------------------------------
 781
 782 END { }       # module clean-up code here (global destructor)
 783
 784 1;
 785 __END__
 786 =back
 787
 788 =head1 SEE ALSO
 789
 790 L<DBI(3)|DBI>
 791
 792 =cut