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(
  54                         &fixEthnicity
  55                         &borrowercategories &getborrowercategory
  56                         &ethnicitycategories
  57                         &subfield_is_koha_internal_p
  58                         &getbranches &getbranch &getbranchname
  59                         &getprinters &getprinter
  60                         &getitemtypes &getitemtypeinfo
  61                         &getframeworks &getframeworkinfo
  62                         &getauthtypes &getauthtype
  63                         &getallthemes &getalllanguages
  64                         $DEBUG);
  65
  66 use vars qw();
  67
  68 my $DEBUG = 0;
  69
  70 # removed slashifyDate => useless
  71
  72 =head2 fixEthnicity
  73
  74   $ethn_name = &fixEthnicity($ethn_code);
  75
  76 Takes an ethnicity code (e.g., "european" or "pi") and returns the
  77 corresponding descriptive name from the C<ethnicity> table in the
  78 Koha database ("European" or "Pacific Islander").
  79
  80 =cut
  81 #'
  82
  83 sub fixEthnicity($) {
  84
  85     my $ethnicity = shift;
  86     my $dbh = C4::Context->dbh;
  87     my $sth=$dbh->prepare("Select name from ethnicity where code = ?");
  88     $sth->execute($ethnicity);
  89     my $data=$sth->fetchrow_hashref;
  90     $sth->finish;
  91     return $data->{'name'};
  92 }
  93
  94 =head2 borrowercategories
  95
  96   ($codes_arrayref, $labels_hashref) = &borrowercategories();
  97
  98 Looks up the different types of borrowers in the database. Returns two
  99 elements: a reference-to-array, which lists the borrower category
 100 codes, and a reference-to-hash, which maps the borrower category codes
 101 to category descriptions.
 102
 103 =cut
 104 #'
 105
 106 sub borrowercategories {
 107     my $dbh = C4::Context->dbh;
 108     my $sth=$dbh->prepare("Select categorycode,description from categories order by description");
 109     $sth->execute;
 110     my %labels;
 111     my @codes;
 112     while (my $data=$sth->fetchrow_hashref){
 113       push @codes,$data->{'categorycode'};
 114       $labels{$data->{'categorycode'}}=$data->{'description'};
 115     }
 116     $sth->finish;
 117     return(\@codes,\%labels);
 118 }
 119
 120 =item getborrowercategory
 121
 122   $description = &getborrowercategory($categorycode);
 123
 124 Given the borrower's category code, the function returns the corresponding
 125 description for a comprehensive information display.
 126
 127 =cut
 128
 129 sub getborrowercategory
 130 {
 131         my ($catcode) = @_;
 132         my $dbh = C4::Context->dbh;
 133         my $sth = $dbh->prepare("SELECT description FROM categories WHERE categorycode = ?");
 134         $sth->execute($catcode);
 135         my $description = $sth->fetchrow();
 136         $sth->finish();
 137         return $description;
 138 } # sub getborrowercategory
 139
 140
 141 =head2 ethnicitycategories
 142
 143   ($codes_arrayref, $labels_hashref) = &ethnicitycategories();
 144
 145 Looks up the different ethnic types in the database. Returns two
 146 elements: a reference-to-array, which lists the ethnicity codes, and a
 147 reference-to-hash, which maps the ethnicity codes to ethnicity
 148 descriptions.
 149
 150 =cut
 151 #'
 152
 153 sub ethnicitycategories {
 154     my $dbh = C4::Context->dbh;
 155     my $sth=$dbh->prepare("Select code,name from ethnicity order by name");
 156     $sth->execute;
 157     my %labels;
 158     my @codes;
 159     while (my $data=$sth->fetchrow_hashref){
 160       push @codes,$data->{'code'};
 161       $labels{$data->{'code'}}=$data->{'name'};
 162     }
 163     $sth->finish;
 164     return(\@codes,\%labels);
 165 }
 166
 167 # FIXME.. this should be moved to a MARC-specific module
 168 sub subfield_is_koha_internal_p ($) {
 169     my($subfield) = @_;
 170
 171     # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
 172     # But real MARC subfields are always single-character
 173     # so it really is safer just to check the length
 174
 175     return length $subfield != 1;
 176 }
 177
 178 =head2 getbranches
 179
 180   $branches = &getbranches();
 181   returns informations about branches.
 182   Create a branch selector with the following code
 183
 184 =head3 in PERL SCRIPT
 185
 186 my $branches = getbranches;
 187 my @branchloop;
 188 foreach my $thisbranch (sort keys %$branches) {
 189         my $selected = 1 if $thisbranch eq $branch;
 190         my %row =(value => $thisbranch,
 191                                 selected => $selected,
 192                                 branchname => $branches->{$thisbranch}->{'branchname'},
 193                         );
 194         push @branchloop, \%row;
 195 }
 196
 197
 198 =head3 in TEMPLATE
 199                         <select name="branch">
 200                                 <option value="">Default</option>
 201                         <!-- TMPL_LOOP name="branchloop" -->
 202                                 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="branchname" --></option>
 203                         <!-- /TMPL_LOOP -->
 204                         </select>
 205
 206 =cut
 207
 208 sub getbranches {
 209 # returns a reference to a hash of references to branches...
 210         my %branches;
 211         my $dbh = C4::Context->dbh;
 212         my $sth;
 213         if (C4::Context->preference("IndependantBranches") && (C4::Context->userenv->{flags}!=1)){
 214                 my $strsth ="Select * from branches ";
 215                 $strsth.= " WHERE branchcode = ".$dbh->quote(C4::Context->userenv->{branch});
 216                 $strsth.= " order by branchname";
 217                 $sth=$dbh->prepare($strsth);
 218         } else {
 219         $sth = $dbh->prepare("Select * from branches order by branchname");
 220         }
 221         $sth->execute;
 222         while (my $branch=$sth->fetchrow_hashref) {
 223                 my $nsth = $dbh->prepare("select categorycode from branchrelations where branchcode = ?");
 224                 $nsth->execute($branch->{'branchcode'});
 225                 while (my ($cat) = $nsth->fetchrow_array) {
 226                         # FIXME - This seems wrong. It ought to be
 227                         # $branch->{categorycodes}{$cat} = 1;
 228                         # otherwise, there's a namespace collision if there's a
 229                         # category with the same name as a field in the 'branches'
 230                         # table (i.e., don't create a category called "issuing").
 231                         # In addition, the current structure doesn't really allow
 232                         # you to list the categories that a branch belongs to:
 233                         # you'd have to list keys %$branch, and remove those keys
 234                         # that aren't fields in the "branches" table.
 235                         $branch->{$cat} = 1;
 236                         }
 237                         $branches{$branch->{'branchcode'}}=$branch;
 238         }
 239         return (\%branches);
 240 }
 241
 242 =head2 getitemtypes
 243
 244   $itemtypes = &getitemtypes();
 245
 246 Returns information about existing itemtypes.
 247
 248 build a HTML select with the following code :
 249
 250 =head3 in PERL SCRIPT
 251
 252 my $itemtypes = getitemtypes;
 253 my @itemtypesloop;
 254 foreach my $thisitemtype (sort keys %$itemtypes) {
 255         my $selected = 1 if $thisitemtype eq $itemtype;
 256         my %row =(value => $thisitemtype,
 257                                 selected => $selected,
 258                                 description => $itemtypes->{$thisitemtype}->{'description'},
 259                         );
 260         push @itemtypesloop, \%row;
 261 }
 262 $template->param(itemtypeloop => \@itemtypesloop);
 263
 264 =head3 in TEMPLATE
 265
 266 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 267         <select name="itemtype">
 268                 <option value="">Default</option>
 269         <!-- TMPL_LOOP name="itemtypeloop" -->
 270                 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
 271         <!-- /TMPL_LOOP -->
 272         </select>
 273         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 274         <input type="submit" value="OK" class="button">
 275 </form>
 276
 277
 278 =cut
 279
 280 sub getitemtypes {
 281 # returns a reference to a hash of references to branches...
 282         my %itemtypes;
 283         my $dbh = C4::Context->dbh;
 284         my $sth=$dbh->prepare("select * from itemtypes");
 285         $sth->execute;
 286         while (my $IT=$sth->fetchrow_hashref) {
 287                         $itemtypes{$IT->{'itemtype'}}=$IT;
 288         }
 289         return (\%itemtypes);
 290 }
 291
 292 =head2 getauthtypes
 293
 294   $authtypes = &getauthtypes();
 295
 296 Returns information about existing authtypes.
 297
 298 build a HTML select with the following code :
 299
 300 =head3 in PERL SCRIPT
 301
 302 my $authtypes = getauthtypes;
 303 my @authtypesloop;
 304 foreach my $thisauthtype (keys %$authtypes) {
 305         my $selected = 1 if $thisauthtype eq $authtype;
 306         my %row =(value => $thisauthtype,
 307                                 selected => $selected,
 308                                 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
 309                         );
 310         push @authtypesloop, \%row;
 311 }
 312 $template->param(itemtypeloop => \@itemtypesloop);
 313
 314 =head3 in TEMPLATE
 315
 316 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 317         <select name="authtype">
 318         <!-- TMPL_LOOP name="authtypeloop" -->
 319                 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
 320         <!-- /TMPL_LOOP -->
 321         </select>
 322         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 323         <input type="submit" value="OK" class="button">
 324 </form>
 325
 326
 327 =cut
 328
 329 sub getauthtypes {
 330 # returns a reference to a hash of references to authtypes...
 331         my %authtypes;
 332         my $dbh = C4::Context->dbh;
 333         my $sth=$dbh->prepare("select * from auth_types order by authtypetext");
 334         $sth->execute;
 335         while (my $IT=$sth->fetchrow_hashref) {
 336                         $authtypes{$IT->{'authtypecode'}}=$IT;
 337         }
 338         return (\%authtypes);
 339 }
 340
 341 sub getauthtype {
 342         my ($authtypecode) = @_;
 343 # returns a reference to a hash of references to authtypes...
 344         my %authtypes;
 345         my $dbh = C4::Context->dbh;
 346         my $sth=$dbh->prepare("select * from auth_types where authtypecode=?");
 347         $sth->execute($authtypecode);
 348         my $res=$sth->fetchrow_hashref;
 349         return $res;
 350 }
 351
 352 =head2 getframework
 353
 354   $frameworks = &getframework();
 355
 356 Returns information about existing frameworks
 357
 358 build a HTML select with the following code :
 359
 360 =head3 in PERL SCRIPT
 361
 362 my $frameworks = frameworks();
 363 my @frameworkloop;
 364 foreach my $thisframework (keys %$frameworks) {
 365         my $selected = 1 if $thisframework eq $frameworkcode;
 366         my %row =(value => $thisframework,
 367                                 selected => $selected,
 368                                 description => $frameworks->{$thisframework}->{'frameworktext'},
 369                         );
 370         push @frameworksloop, \%row;
 371 }
 372 $template->param(frameworkloop => \@frameworksloop);
 373
 374 =head3 in TEMPLATE
 375
 376 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 377         <select name="frameworkcode">
 378                 <option value="">Default</option>
 379         <!-- TMPL_LOOP name="frameworkloop" -->
 380                 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
 381         <!-- /TMPL_LOOP -->
 382         </select>
 383         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 384         <input type="submit" value="OK" class="button">
 385 </form>
 386
 387
 388 =cut
 389
 390 sub getframeworks {
 391 # returns a reference to a hash of references to branches...
 392         my %itemtypes;
 393         my $dbh = C4::Context->dbh;
 394         my $sth=$dbh->prepare("select * from biblio_framework");
 395         $sth->execute;
 396         while (my $IT=$sth->fetchrow_hashref) {
 397                         $itemtypes{$IT->{'frameworkcode'}}=$IT;
 398         }
 399         return (\%itemtypes);
 400 }
 401 =head2 getframeworkinfo
 402
 403   $frameworkinfo = &getframeworkinfo($frameworkcode);
 404
 405 Returns information about an frameworkcode.
 406
 407 =cut
 408
 409 sub getframeworkinfo {
 410         my ($frameworkcode) = @_;
 411         my $dbh = C4::Context->dbh;
 412         my $sth=$dbh->prepare("select * from biblio_framework where frameworkcode=?");
 413         $sth->execute($frameworkcode);
 414         my $res = $sth->fetchrow_hashref;
 415         return $res;
 416 }
 417
 418
 419 =head2 getitemtypeinfo
 420
 421   $itemtype = &getitemtype($itemtype);
 422
 423 Returns information about an itemtype.
 424
 425 =cut
 426
 427 sub getitemtypeinfo {
 428         my ($itemtype) = @_;
 429         my $dbh = C4::Context->dbh;
 430         my $sth=$dbh->prepare("select * from itemtypes where itemtype=?");
 431         $sth->execute($itemtype);
 432         my $res = $sth->fetchrow_hashref;
 433         return $res;
 434 }
 435
 436 =head2 getprinters
 437
 438   $printers = &getprinters($env);
 439   @queues = keys %$printers;
 440
 441 Returns information about existing printer queues.
 442
 443 C<$env> is ignored.
 444
 445 C<$printers> is a reference-to-hash whose keys are the print queues
 446 defined in the printers table of the Koha database. The values are
 447 references-to-hash, whose keys are the fields in the printers table.
 448
 449 =cut
 450
 451 sub getprinters {
 452     my ($env) = @_;
 453     my %printers;
 454     my $dbh = C4::Context->dbh;
 455     my $sth=$dbh->prepare("select * from printers");
 456     $sth->execute;
 457     while (my $printer=$sth->fetchrow_hashref) {
 458         $printers{$printer->{'printqueue'}}=$printer;
 459     }
 460     return (\%printers);
 461 }
 462
 463 sub getbranch ($$) {
 464     my($query, $branches) = @_; # get branch for this query from branches
 465     my $branch = $query->param('branch');
 466     ($branch) || ($branch = $query->cookie('branch'));
 467     ($branches->{$branch}) || ($branch=(keys %$branches)[0]);
 468     return $branch;
 469 }
 470
 471 =item getbranchname
 472
 473   $branchname = &getbranchname($branchcode);
 474
 475 Given the branch code, the function returns the corresponding
 476 branch name for a comprehensive information display
 477
 478 =cut
 479
 480 sub getbranchname
 481 {
 482         my ($branchcode) = @_;
 483         my $dbh = C4::Context->dbh;
 484         my $sth = $dbh->prepare("SELECT branchname FROM branches WHERE branchcode = ?");
 485         $sth->execute($branchcode);
 486         my $branchname = $sth->fetchrow();
 487         $sth->finish();
 488         return $branchname;
 489 } # sub getbranchname
 490
 491 sub getprinter ($$) {
 492     my($query, $printers) = @_; # get printer for this query from printers
 493     my $printer = $query->param('printer');
 494     ($printer) || ($printer = $query->cookie('printer')) || ($printer='');
 495     ($printers->{$printer}) || ($printer = (keys %$printers)[0]);
 496     return $printer;
 497 }
 498
 499 =item getalllanguages
 500
 501   (@languages) = &getalllanguages($type);
 502   (@languages) = &getalllanguages($type,$theme);
 503
 504 Returns an array of all available languages.
 505
 506 =cut
 507
 508 sub getalllanguages {
 509     my $type=shift;
 510     my $theme=shift;
 511     my $htdocs;
 512     my @languages;
 513     if ($type eq 'opac') {
 514         $htdocs=C4::Context->config('opachtdocs');
 515         if ($theme and -d "$htdocs/$theme") {
 516             opendir D, "$htdocs/$theme";
 517             foreach my $language (readdir D) {
 518                 next if $language=~/^\./;
 519                 next if $language eq 'all';
 520                 push @languages, $language;
 521             }
 522             return sort @languages;
 523         } else {
 524             my $lang;
 525             foreach my $theme (getallthemes('opac')) {
 526                 opendir D, "$htdocs/$theme";
 527                 foreach my $language (readdir D) {
 528                     next if $language=~/^\./;
 529                     next if $language eq 'all';
 530                     $lang->{$language}=1;
 531                 }
 532             }
 533             @languages=keys %$lang;
 534             return sort @languages;
 535         }
 536     } elsif ($type eq 'intranet') {
 537         $htdocs=C4::Context->config('intrahtdocs');
 538         if ($theme and -d "$htdocs/$theme") {
 539             opendir D, "$htdocs/$theme";
 540             foreach my $language (readdir D) {
 541                 next if $language=~/^\./;
 542                 next if $language eq 'all';
 543                 push @languages, $language;
 544             }
 545             return sort @languages;
 546         } else {
 547             my $lang;
 548             foreach my $theme (getallthemes('opac')) {
 549                 opendir D, "$htdocs/$theme";
 550                 foreach my $language (readdir D) {
 551                     next if $language=~/^\./;
 552                     next if $language eq 'all';
 553                     $lang->{$language}=1;
 554                 }
 555             }
 556             @languages=keys %$lang;
 557             return sort @languages;
 558         }
 559     } else {
 560         my $lang;
 561         my $htdocs=C4::Context->config('intrahtdocs');
 562         foreach my $theme (getallthemes('intranet')) {
 563             opendir D, "$htdocs/$theme";
 564             foreach my $language (readdir D) {
 565                 next if $language=~/^\./;
 566                 next if $language eq 'all';
 567                 $lang->{$language}=1;
 568             }
 569         }
 570         $htdocs=C4::Context->config('opachtdocs');
 571         foreach my $theme (getallthemes('opac')) {
 572             opendir D, "$htdocs/$theme";
 573             foreach my $language (readdir D) {
 574                 next if $language=~/^\./;
 575                 next if $language eq 'all';
 576                 $lang->{$language}=1;
 577             }
 578         }
 579         @languages=keys %$lang;
 580         return sort @languages;
 581     }
 582 }
 583
 584 =item getallthemes
 585
 586   (@themes) = &getallthemes('opac');
 587   (@themes) = &getallthemes('intranet');
 588
 589 Returns an array of all available themes.
 590
 591 =cut
 592
 593 sub getallthemes {
 594     my $type=shift;
 595     my $htdocs;
 596     my @themes;
 597     if ($type eq 'intranet') {
 598         $htdocs=C4::Context->config('intrahtdocs');
 599     } else {
 600         $htdocs=C4::Context->config('opachtdocs');
 601     }
 602     opendir D, "$htdocs";
 603     my @dirlist=readdir D;
 604     foreach my $directory (@dirlist) {
 605         -d "$htdocs/$directory/en" and push @themes, $directory;
 606     }
 607     return @themes;
 608 }
 609
 610
 611 1;
 612 __END__
 613
 614 =back
 615
 616 =head1 AUTHOR
 617
 618 Koha Team
 619
 620 =cut