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