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