C4/Output.pm

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