C4/Koha.pm

   1 package C4::Koha;
   2
   3 # Copyright 2000-2002 Katipo Communications
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 2 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along with
  17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  18 # Suite 330, Boston, MA  02111-1307 USA
  19
  20 use strict;
  21 require Exporter;
  22 use C4::Context;
  23
  24 use vars qw($VERSION @ISA @EXPORT);
  25
  26 $VERSION = 0.01;
  27
  28 =head1 NAME
  29
  30 C4::Koha - Perl Module containing convenience functions for Koha scripts
  31
  32 =head1 SYNOPSIS
  33
  34   use C4::Koha;
  35
  36
  37   $date = slashifyDate("01-01-2002")
  38   $ethnicity = fixEthnicity('asian');
  39   ($categories, $labels) = borrowercategories();
  40   ($categories, $labels) = ethnicitycategories();
  41
  42 =head1 DESCRIPTION
  43
  44 Koha.pm provides many functions for Koha scripts.
  45
  46 =head1 FUNCTIONS
  47
  48 =over 2
  49
  50 =cut
  51
  52 @ISA = qw(Exporter);
  53 @EXPORT = qw(&slashifyDate
  54                         &fixEthnicity
  55                         &borrowercategories
  56                         &ethnicitycategories
  57                         &subfield_is_koha_internal_p
  58                         &getbranches &getbranch
  59                         &getprinters &getprinter
  60                         &getitemtypes &getitemtypeinfo
  61                         &getframeworks &getframeworkinfo
  62                         &getauthtypes &getauthtype
  63                         $DEBUG);
  64
  65 use vars qw();
  66
  67 my $DEBUG = 0;
  68
  69 =head2 slashifyDate
  70
  71   $slash_date = &slashifyDate($dash_date);
  72
  73 Takes a string of the form "DD-MM-YYYY" (or anything separated by
  74 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
  75
  76 =cut
  77
  78 sub slashifyDate {
  79     # accepts a date of the form xx-xx-xx[xx] and returns it in the
  80     # form xx/xx/xx[xx]
  81     my @dateOut = split('-', shift);
  82     return("$dateOut[2]/$dateOut[1]/$dateOut[0]")
  83 }
  84
  85 =head2 fixEthnicity
  86
  87   $ethn_name = &fixEthnicity($ethn_code);
  88
  89 Takes an ethnicity code (e.g., "european" or "pi") and returns the
  90 corresponding descriptive name from the C<ethnicity> table in the
  91 Koha database ("European" or "Pacific Islander").
  92
  93 =cut
  94 #'
  95
  96 sub fixEthnicity($) {
  97
  98     my $ethnicity = shift;
  99     my $dbh = C4::Context->dbh;
 100     my $sth=$dbh->prepare("Select name from ethnicity where code = ?");
 101     $sth->execute($ethnicity);
 102     my $data=$sth->fetchrow_hashref;
 103     $sth->finish;
 104     return $data->{'name'};
 105 }
 106
 107 =head2 borrowercategories
 108
 109   ($codes_arrayref, $labels_hashref) = &borrowercategories();
 110
 111 Looks up the different types of borrowers in the database. Returns two
 112 elements: a reference-to-array, which lists the borrower category
 113 codes, and a reference-to-hash, which maps the borrower category codes
 114 to category descriptions.
 115
 116 =cut
 117 #'
 118
 119 sub borrowercategories {
 120     my $dbh = C4::Context->dbh;
 121     my $sth=$dbh->prepare("Select categorycode,description from categories order by description");
 122     $sth->execute;
 123     my %labels;
 124     my @codes;
 125     while (my $data=$sth->fetchrow_hashref){
 126       push @codes,$data->{'categorycode'};
 127       $labels{$data->{'categorycode'}}=$data->{'description'};
 128     }
 129     $sth->finish;
 130     return(\@codes,\%labels);
 131 }
 132
 133 =head2 ethnicitycategories
 134
 135   ($codes_arrayref, $labels_hashref) = &ethnicitycategories();
 136
 137 Looks up the different ethnic types in the database. Returns two
 138 elements: a reference-to-array, which lists the ethnicity codes, and a
 139 reference-to-hash, which maps the ethnicity codes to ethnicity
 140 descriptions.
 141
 142 =cut
 143 #'
 144
 145 sub ethnicitycategories {
 146     my $dbh = C4::Context->dbh;
 147     my $sth=$dbh->prepare("Select code,name from ethnicity order by name");
 148     $sth->execute;
 149     my %labels;
 150     my @codes;
 151     while (my $data=$sth->fetchrow_hashref){
 152       push @codes,$data->{'code'};
 153       $labels{$data->{'code'}}=$data->{'name'};
 154     }
 155     $sth->finish;
 156     return(\@codes,\%labels);
 157 }
 158
 159 # FIXME.. this should be moved to a MARC-specific module
 160 sub subfield_is_koha_internal_p ($) {
 161     my($subfield) = @_;
 162
 163     # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
 164     # But real MARC subfields are always single-character
 165     # so it really is safer just to check the length
 166
 167     return length $subfield != 1;
 168 }
 169
 170 =head2 getbranches
 171
 172   $branches = &getbranches();
 173   returns informations about branches.
 174   Create a branch selector with the following code
 175
 176 =head3 in PERL SCRIPT
 177
 178 my $branches = getbranches;
 179 my @branchloop;
 180 foreach my $thisbranch (keys %$branches) {
 181         my $selected = 1 if $thisbranch eq $branch;
 182         my %row =(value => $thisbranch,
 183                                 selected => $selected,
 184                                 branchname => $branches->{$thisbranch}->{'branchname'},
 185                         );
 186         push @branchloop, \%row;
 187 }
 188
 189
 190 =head3 in TEMPLATE
 191                         <select name="branch">
 192                                 <option value="">Default</option>
 193                         <!-- TMPL_LOOP name="branchloop" -->
 194                                 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="branchname" --></option>
 195                         <!-- /TMPL_LOOP -->
 196                         </select>
 197
 198 =cut
 199
 200 sub getbranches {
 201 # returns a reference to a hash of references to branches...
 202         my %branches;
 203         my $dbh = C4::Context->dbh;
 204         my $sth=$dbh->prepare("select * from branches order by branchname");
 205         $sth->execute;
 206         while (my $branch=$sth->fetchrow_hashref) {
 207                 my $nsth = $dbh->prepare("select categorycode from branchrelations where branchcode = ?");
 208                 $nsth->execute($branch->{'branchcode'});
 209                 while (my ($cat) = $nsth->fetchrow_array) {
 210                         # FIXME - This seems wrong. It ought to be
 211                         # $branch->{categorycodes}{$cat} = 1;
 212                         # otherwise, there's a namespace collision if there's a
 213                         # category with the same name as a field in the 'branches'
 214                         # table (i.e., don't create a category called "issuing").
 215                         # In addition, the current structure doesn't really allow
 216                         # you to list the categories that a branch belongs to:
 217                         # you'd have to list keys %$branch, and remove those keys
 218                         # that aren't fields in the "branches" table.
 219                         $branch->{$cat} = 1;
 220                         }
 221                         $branches{$branch->{'branchcode'}}=$branch;
 222         }
 223         return (\%branches);
 224 }
 225
 226 =head2 getitemtypes
 227
 228   $itemtypes = &getitemtypes();
 229
 230 Returns information about existing itemtypes.
 231
 232 build a HTML select with the following code :
 233
 234 =head3 in PERL SCRIPT
 235
 236 my $itemtypes = getitemtypes;
 237 my @itemtypesloop;
 238 foreach my $thisitemtype (keys %$itemtypes) {
 239         my $selected = 1 if $thisitemtype eq $itemtype;
 240         my %row =(value => $thisitemtype,
 241                                 selected => $selected,
 242                                 description => $itemtypes->{$thisitemtype}->{'description'},
 243                         );
 244         push @itemtypesloop, \%row;
 245 }
 246 $template->param(itemtypeloop => \@itemtypesloop);
 247
 248 =head3 in TEMPLATE
 249
 250 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 251         <select name="itemtype">
 252                 <option value="">Default</option>
 253         <!-- TMPL_LOOP name="itemtypeloop" -->
 254                 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
 255         <!-- /TMPL_LOOP -->
 256         </select>
 257         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 258         <input type="submit" value="OK" class="button">
 259 </form>
 260
 261
 262 =cut
 263
 264 sub getitemtypes {
 265 # returns a reference to a hash of references to branches...
 266         my %itemtypes;
 267         my $dbh = C4::Context->dbh;
 268         my $sth=$dbh->prepare("select * from itemtypes order by description");
 269         $sth->execute;
 270         while (my $IT=$sth->fetchrow_hashref) {
 271                         $itemtypes{$IT->{'itemtype'}}=$IT;
 272         }
 273         return (\%itemtypes);
 274 }
 275
 276 =head2 getauthtypes
 277
 278   $authtypes = &getauthtypes();
 279
 280 Returns information about existing authtypes.
 281
 282 build a HTML select with the following code :
 283
 284 =head3 in PERL SCRIPT
 285
 286 my $authtypes = getauthtypes;
 287 my @authtypesloop;
 288 foreach my $thisauthtype (keys %$authtypes) {
 289         my $selected = 1 if $thisauthtype eq $authtype;
 290         my %row =(value => $thisauthtype,
 291                                 selected => $selected,
 292                                 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
 293                         );
 294         push @authtypesloop, \%row;
 295 }
 296 $template->param(itemtypeloop => \@itemtypesloop);
 297
 298 =head3 in TEMPLATE
 299
 300 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 301         <select name="authtype">
 302         <!-- TMPL_LOOP name="authtypeloop" -->
 303                 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
 304         <!-- /TMPL_LOOP -->
 305         </select>
 306         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 307         <input type="submit" value="OK" class="button">
 308 </form>
 309
 310
 311 =cut
 312
 313 sub getauthtypes {
 314 # returns a reference to a hash of references to authtypes...
 315         my %authtypes;
 316         my $dbh = C4::Context->dbh;
 317         my $sth=$dbh->prepare("select * from auth_types order by authtypetext");
 318         $sth->execute;
 319         while (my $IT=$sth->fetchrow_hashref) {
 320                         $authtypes{$IT->{'authtypecode'}}=$IT;
 321         }
 322         return (\%authtypes);
 323 }
 324
 325 sub getauthtype {
 326         my ($authtypecode) = @_;
 327 # returns a reference to a hash of references to authtypes...
 328         my %authtypes;
 329         my $dbh = C4::Context->dbh;
 330         my $sth=$dbh->prepare("select * from auth_types where authtypecode=?");
 331         $sth->execute($authtypecode);
 332         my $res=$sth->fetchrow_hashref;
 333         return $res;
 334 }
 335
 336 =head2 getframework
 337
 338   $frameworks = &getframework();
 339
 340 Returns information about existing frameworks
 341
 342 build a HTML select with the following code :
 343
 344 =head3 in PERL SCRIPT
 345
 346 my $frameworks = frameworks();
 347 my @frameworkloop;
 348 foreach my $thisframework (keys %$frameworks) {
 349         my $selected = 1 if $thisframework eq $frameworkcode;
 350         my %row =(value => $thisframework,
 351                                 selected => $selected,
 352                                 description => $frameworks->{$thisframework}->{'frameworktext'},
 353                         );
 354         push @frameworksloop, \%row;
 355 }
 356 $template->param(frameworkloop => \@frameworksloop);
 357
 358 =head3 in TEMPLATE
 359
 360 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 361         <select name="frameworkcode">
 362                 <option value="">Default</option>
 363         <!-- TMPL_LOOP name="frameworkloop" -->
 364                 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
 365         <!-- /TMPL_LOOP -->
 366         </select>
 367         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 368         <input type="submit" value="OK" class="button">
 369 </form>
 370
 371
 372 =cut
 373
 374 sub getframeworks {
 375 # returns a reference to a hash of references to branches...
 376         my %itemtypes;
 377         my $dbh = C4::Context->dbh;
 378         my $sth=$dbh->prepare("select * from biblio_framework");
 379         $sth->execute;
 380         while (my $IT=$sth->fetchrow_hashref) {
 381                         $itemtypes{$IT->{'frameworkcode'}}=$IT;
 382         }
 383         return (\%itemtypes);
 384 }
 385 =head2 getframeworkinfo
 386
 387   $frameworkinfo = &getframeworkinfo($frameworkcode);
 388
 389 Returns information about an frameworkcode.
 390
 391 =cut
 392
 393 sub getframeworkinfo {
 394         my ($frameworkcode) = @_;
 395         my $dbh = C4::Context->dbh;
 396         my $sth=$dbh->prepare("select * from biblio_framework where frameworkcode=?");
 397         $sth->execute($frameworkcode);
 398         my $res = $sth->fetchrow_hashref;
 399         return $res;
 400 }
 401
 402
 403 =head2 getitemtypeinfo
 404
 405   $itemtype = &getitemtype($itemtype);
 406
 407 Returns information about an itemtype.
 408
 409 =cut
 410
 411 sub getitemtypeinfo {
 412         my ($itemtype) = @_;
 413         my $dbh = C4::Context->dbh;
 414         my $sth=$dbh->prepare("select * from itemtypes where itemtype=?");
 415         $sth->execute($itemtype);
 416         my $res = $sth->fetchrow_hashref;
 417         return $res;
 418 }
 419
 420 =head2 getprinters
 421
 422   $printers = &getprinters($env);
 423   @queues = keys %$printers;
 424
 425 Returns information about existing printer queues.
 426
 427 C<$env> is ignored.
 428
 429 C<$printers> is a reference-to-hash whose keys are the print queues
 430 defined in the printers table of the Koha database. The values are
 431 references-to-hash, whose keys are the fields in the printers table.
 432
 433 =cut
 434
 435 sub getprinters {
 436     my ($env) = @_;
 437     my %printers;
 438     my $dbh = C4::Context->dbh;
 439     my $sth=$dbh->prepare("select * from printers");
 440     $sth->execute;
 441     while (my $printer=$sth->fetchrow_hashref) {
 442         $printers{$printer->{'printqueue'}}=$printer;
 443     }
 444     return (\%printers);
 445 }
 446 sub getbranch ($$) {
 447     my($query, $branches) = @_; # get branch for this query from branches
 448     my $branch = $query->param('branch');
 449     ($branch) || ($branch = $query->cookie('branch'));
 450     ($branches->{$branch}) || ($branch=(keys %$branches)[0]);
 451     return $branch;
 452 }
 453
 454 sub getprinter ($$) {
 455     my($query, $printers) = @_; # get printer for this query from printers
 456     my $printer = $query->param('printer');
 457     ($printer) || ($printer = $query->cookie('printer'));
 458     ($printers->{$printer}) || ($printer = (keys %$printers)[0]);
 459     return $printer;
 460 }
 461
 462
 463 1;
 464 __END__
 465
 466 =back
 467
 468 =head1 AUTHOR
 469
 470 Koha Team
 471
 472 =cut