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
  17 # with Koha; if not, write to the Free Software Foundation, Inc.,
  18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20
  21 use strict;
  22 #use warnings; FIXME - Bug 2505
  23 use C4::Context;
  24 use C4::Output;
  25 use URI::Split qw(uri_split);
  26 use Memoize;
  27 use Business::ISBN;
  28
  29 use vars qw($VERSION @ISA @EXPORT $DEBUG);
  30
  31 BEGIN {
  32         $VERSION = 3.01;
  33         require Exporter;
  34         @ISA    = qw(Exporter);
  35         @EXPORT = qw(
  36                 &slashifyDate
  37                 &DisplayISBN
  38                 &subfield_is_koha_internal_p
  39                 &GetPrinters &GetPrinter
  40                 &GetItemTypes &getitemtypeinfo
  41                 &GetCcodes
  42                 &GetSupportName &GetSupportList
  43                 &get_itemtypeinfos_of
  44                 &getframeworks &getframeworkinfo
  45                 &getauthtypes &getauthtype
  46                 &getallthemes
  47                 &getFacets
  48                 &displayServers
  49                 &getnbpages
  50                 &get_infos_of
  51                 &get_notforloan_label_of
  52                 &getitemtypeimagedir
  53                 &getitemtypeimagesrc
  54                 &getitemtypeimagelocation
  55                 &GetAuthorisedValues
  56                 &GetAuthorisedValueCategories
  57                 &GetKohaAuthorisedValues
  58                 &GetKohaAuthorisedValuesFromField
  59                 &GetAuthValCode
  60                 &GetNormalizedUPC
  61                 &GetNormalizedISBN
  62                 &GetNormalizedEAN
  63                 &GetNormalizedOCLCNumber
  64         &xml_escape
  65
  66                 $DEBUG
  67         );
  68         $DEBUG = 0;
  69 }
  70
  71 # expensive functions
  72 memoize('GetAuthorisedValues');
  73
  74 =head1 NAME
  75
  76 C4::Koha - Perl Module containing convenience functions for Koha scripts
  77
  78 =head1 SYNOPSIS
  79
  80 use C4::Koha;
  81
  82 =head1 DESCRIPTION
  83
  84 Koha.pm provides many functions for Koha scripts.
  85
  86 =head1 FUNCTIONS
  87
  88 =cut
  89
  90 =head2 slashifyDate
  91
  92   $slash_date = &slashifyDate($dash_date);
  93
  94 Takes a string of the form "DD-MM-YYYY" (or anything separated by
  95 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
  96
  97 =cut
  98
  99 sub slashifyDate {
 100
 101     # accepts a date of the form xx-xx-xx[xx] and returns it in the
 102     # form xx/xx/xx[xx]
 103     my @dateOut = split( '-', shift );
 104     return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
 105 }
 106
 107
 108 =head2 DisplayISBN
 109
 110   my $string = DisplayISBN( $isbn );
 111
 112 =cut
 113
 114 sub DisplayISBN {
 115     my ($isbn) = @_;
 116     if (length ($isbn)<13){
 117     my $seg1;
 118     if ( substr( $isbn, 0, 1 ) <= 7 ) {
 119         $seg1 = substr( $isbn, 0, 1 );
 120     }
 121     elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
 122         $seg1 = substr( $isbn, 0, 2 );
 123     }
 124     elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
 125         $seg1 = substr( $isbn, 0, 3 );
 126     }
 127     elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
 128         $seg1 = substr( $isbn, 0, 4 );
 129     }
 130     else {
 131         $seg1 = substr( $isbn, 0, 5 );
 132     }
 133     my $x = substr( $isbn, length($seg1) );
 134     my $seg2;
 135     if ( substr( $x, 0, 2 ) <= 19 ) {
 136
 137         # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
 138         $seg2 = substr( $x, 0, 2 );
 139     }
 140     elsif ( substr( $x, 0, 3 ) <= 699 ) {
 141         $seg2 = substr( $x, 0, 3 );
 142     }
 143     elsif ( substr( $x, 0, 4 ) <= 8399 ) {
 144         $seg2 = substr( $x, 0, 4 );
 145     }
 146     elsif ( substr( $x, 0, 5 ) <= 89999 ) {
 147         $seg2 = substr( $x, 0, 5 );
 148     }
 149     elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
 150         $seg2 = substr( $x, 0, 6 );
 151     }
 152     else {
 153         $seg2 = substr( $x, 0, 7 );
 154     }
 155     my $seg3 = substr( $x, length($seg2) );
 156     $seg3 = substr( $seg3, 0, length($seg3) - 1 );
 157     my $seg4 = substr( $x, -1, 1 );
 158     return "$seg1-$seg2-$seg3-$seg4";
 159     } else {
 160       my $seg1;
 161       $seg1 = substr( $isbn, 0, 3 );
 162       my $seg2;
 163       if ( substr( $isbn, 3, 1 ) <= 7 ) {
 164           $seg2 = substr( $isbn, 3, 1 );
 165       }
 166       elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
 167           $seg2 = substr( $isbn, 3, 2 );
 168       }
 169       elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
 170           $seg2 = substr( $isbn, 3, 3 );
 171       }
 172       elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
 173           $seg2 = substr( $isbn, 3, 4 );
 174       }
 175       else {
 176           $seg2 = substr( $isbn, 3, 5 );
 177       }
 178       my $x = substr( $isbn, length($seg2) +3);
 179       my $seg3;
 180       if ( substr( $x, 0, 2 ) <= 19 ) {
 181
 182           # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
 183           $seg3 = substr( $x, 0, 2 );
 184       }
 185       elsif ( substr( $x, 0, 3 ) <= 699 ) {
 186           $seg3 = substr( $x, 0, 3 );
 187       }
 188       elsif ( substr( $x, 0, 4 ) <= 8399 ) {
 189           $seg3 = substr( $x, 0, 4 );
 190       }
 191       elsif ( substr( $x, 0, 5 ) <= 89999 ) {
 192           $seg3 = substr( $x, 0, 5 );
 193       }
 194       elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
 195           $seg3 = substr( $x, 0, 6 );
 196       }
 197       else {
 198           $seg3 = substr( $x, 0, 7 );
 199       }
 200       my $seg4 = substr( $x, length($seg3) );
 201       $seg4 = substr( $seg4, 0, length($seg4) - 1 );
 202       my $seg5 = substr( $x, -1, 1 );
 203       return "$seg1-$seg2-$seg3-$seg4-$seg5";
 204     }
 205 }
 206
 207 # FIXME.. this should be moved to a MARC-specific module
 208 sub subfield_is_koha_internal_p ($) {
 209     my ($subfield) = @_;
 210
 211     # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
 212     # But real MARC subfields are always single-character
 213     # so it really is safer just to check the length
 214
 215     return length $subfield != 1;
 216 }
 217
 218 =head2 GetSupportName
 219
 220   $itemtypename = &GetSupportName($codestring);
 221
 222 Returns a string with the name of the itemtype.
 223
 224 =cut
 225
 226 sub GetSupportName{
 227         my ($codestring)=@_;
 228         return if (! $codestring);
 229         my $resultstring;
 230         my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
 231         if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
 232                 my $query = qq|
 233                         SELECT description
 234                         FROM   itemtypes
 235                         WHERE itemtype=?
 236                         order by description
 237                 |;
 238                 my $sth = C4::Context->dbh->prepare($query);
 239                 $sth->execute($codestring);
 240                 ($resultstring)=$sth->fetchrow;
 241                 return $resultstring;
 242         } else {
 243         my $sth =
 244             C4::Context->dbh->prepare(
 245                     "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
 246                     );
 247         $sth->execute( $advanced_search_types, $codestring );
 248         my $data = $sth->fetchrow_hashref;
 249         return $$data{'lib'};
 250         }
 251
 252 }
 253 =head2 GetSupportList
 254
 255   $itemtypes = &GetSupportList();
 256
 257 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
 258
 259 build a HTML select with the following code :
 260
 261 =head3 in PERL SCRIPT
 262
 263     my $itemtypes = GetSupportList();
 264     $template->param(itemtypeloop => $itemtypes);
 265
 266 =head3 in TEMPLATE
 267
 268     <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 269         <select name="itemtype">
 270             <option value="">Default</option>
 271         <!-- TMPL_LOOP name="itemtypeloop" -->
 272             <option value="<!-- TMPL_VAR name="itemtype" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->> <!--TMPL_IF Name="imageurl"--><img alt="<!-- TMPL_VAR name="description" -->" src="<!--TMPL_VAR Name="imageurl"-->><!--TMPL_ELSE-->"<!-- TMPL_VAR name="description" --><!--/TMPL_IF--></option>
 273         <!-- /TMPL_LOOP -->
 274         </select>
 275         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 276         <input type="submit" value="OK" class="button">
 277     </form>
 278
 279 =cut
 280
 281 sub GetSupportList{
 282         my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
 283         if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
 284                 my $query = qq|
 285                         SELECT *
 286                         FROM   itemtypes
 287                         order by description
 288                 |;
 289                 my $sth = C4::Context->dbh->prepare($query);
 290                 $sth->execute;
 291                 return $sth->fetchall_arrayref({});
 292         } else {
 293                 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
 294                 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
 295                 return \@results;
 296         }
 297 }
 298 =head2 GetItemTypes
 299
 300   $itemtypes = &GetItemTypes();
 301
 302 Returns information about existing itemtypes.
 303
 304 build a HTML select with the following code :
 305
 306 =head3 in PERL SCRIPT
 307
 308     my $itemtypes = GetItemTypes;
 309     my @itemtypesloop;
 310     foreach my $thisitemtype (sort keys %$itemtypes) {
 311         my $selected = 1 if $thisitemtype eq $itemtype;
 312         my %row =(value => $thisitemtype,
 313                     selected => $selected,
 314                     description => $itemtypes->{$thisitemtype}->{'description'},
 315                 );
 316         push @itemtypesloop, \%row;
 317     }
 318     $template->param(itemtypeloop => \@itemtypesloop);
 319
 320 =head3 in TEMPLATE
 321
 322     <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 323         <select name="itemtype">
 324             <option value="">Default</option>
 325         <!-- TMPL_LOOP name="itemtypeloop" -->
 326             <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
 327         <!-- /TMPL_LOOP -->
 328         </select>
 329         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 330         <input type="submit" value="OK" class="button">
 331     </form>
 332
 333 =cut
 334
 335 sub GetItemTypes {
 336
 337     # returns a reference to a hash of references to itemtypes...
 338     my %itemtypes;
 339     my $dbh   = C4::Context->dbh;
 340     my $query = qq|
 341         SELECT *
 342         FROM   itemtypes
 343     |;
 344     my $sth = $dbh->prepare($query);
 345     $sth->execute;
 346     while ( my $IT = $sth->fetchrow_hashref ) {
 347         $itemtypes{ $IT->{'itemtype'} } = $IT;
 348     }
 349     return ( \%itemtypes );
 350 }
 351
 352 sub get_itemtypeinfos_of {
 353     my @itemtypes = @_;
 354
 355     my $placeholders = join( ', ', map { '?' } @itemtypes );
 356     my $query = <<"END_SQL";
 357 SELECT itemtype,
 358        description,
 359        imageurl,
 360        notforloan
 361   FROM itemtypes
 362   WHERE itemtype IN ( $placeholders )
 363 END_SQL
 364
 365     return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
 366 }
 367
 368 # this is temporary until we separate collection codes and item types
 369 sub GetCcodes {
 370     my $count = 0;
 371     my @results;
 372     my $dbh = C4::Context->dbh;
 373     my $sth =
 374       $dbh->prepare(
 375         "SELECT * FROM authorised_values ORDER BY authorised_value");
 376     $sth->execute;
 377     while ( my $data = $sth->fetchrow_hashref ) {
 378         if ( $data->{category} eq "CCODE" ) {
 379             $count++;
 380             $results[$count] = $data;
 381
 382             #warn "data: $data";
 383         }
 384     }
 385     $sth->finish;
 386     return ( $count, @results );
 387 }
 388
 389 =head2 getauthtypes
 390
 391   $authtypes = &getauthtypes();
 392
 393 Returns information about existing authtypes.
 394
 395 build a HTML select with the following code :
 396
 397 =head3 in PERL SCRIPT
 398
 399    my $authtypes = getauthtypes;
 400    my @authtypesloop;
 401    foreach my $thisauthtype (keys %$authtypes) {
 402        my $selected = 1 if $thisauthtype eq $authtype;
 403        my %row =(value => $thisauthtype,
 404                 selected => $selected,
 405                 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
 406             );
 407         push @authtypesloop, \%row;
 408     }
 409     $template->param(itemtypeloop => \@itemtypesloop);
 410
 411 =head3 in TEMPLATE
 412
 413   <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 414     <select name="authtype">
 415     <!-- TMPL_LOOP name="authtypeloop" -->
 416         <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
 417     <!-- /TMPL_LOOP -->
 418     </select>
 419     <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 420     <input type="submit" value="OK" class="button">
 421   </form>
 422
 423
 424 =cut
 425
 426 sub getauthtypes {
 427
 428     # returns a reference to a hash of references to authtypes...
 429     my %authtypes;
 430     my $dbh = C4::Context->dbh;
 431     my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
 432     $sth->execute;
 433     while ( my $IT = $sth->fetchrow_hashref ) {
 434         $authtypes{ $IT->{'authtypecode'} } = $IT;
 435     }
 436     return ( \%authtypes );
 437 }
 438
 439 sub getauthtype {
 440     my ($authtypecode) = @_;
 441
 442     # returns a reference to a hash of references to authtypes...
 443     my %authtypes;
 444     my $dbh = C4::Context->dbh;
 445     my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
 446     $sth->execute($authtypecode);
 447     my $res = $sth->fetchrow_hashref;
 448     return $res;
 449 }
 450
 451 =head2 getframework
 452
 453   $frameworks = &getframework();
 454
 455 Returns information about existing frameworks
 456
 457 build a HTML select with the following code :
 458
 459 =head3 in PERL SCRIPT
 460
 461   my $frameworks = frameworks();
 462   my @frameworkloop;
 463   foreach my $thisframework (keys %$frameworks) {
 464     my $selected = 1 if $thisframework eq $frameworkcode;
 465     my %row =(value => $thisframework,
 466                 selected => $selected,
 467                 description => $frameworks->{$thisframework}->{'frameworktext'},
 468             );
 469     push @frameworksloop, \%row;
 470   }
 471   $template->param(frameworkloop => \@frameworksloop);
 472
 473 =head3 in TEMPLATE
 474
 475   <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 476     <select name="frameworkcode">
 477         <option value="">Default</option>
 478     <!-- TMPL_LOOP name="frameworkloop" -->
 479         <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
 480     <!-- /TMPL_LOOP -->
 481     </select>
 482     <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 483     <input type="submit" value="OK" class="button">
 484   </form>
 485
 486 =cut
 487
 488 sub getframeworks {
 489
 490     # returns a reference to a hash of references to branches...
 491     my %itemtypes;
 492     my $dbh = C4::Context->dbh;
 493     my $sth = $dbh->prepare("select * from biblio_framework");
 494     $sth->execute;
 495     while ( my $IT = $sth->fetchrow_hashref ) {
 496         $itemtypes{ $IT->{'frameworkcode'} } = $IT;
 497     }
 498     return ( \%itemtypes );
 499 }
 500
 501 =head2 getframeworkinfo
 502
 503   $frameworkinfo = &getframeworkinfo($frameworkcode);
 504
 505 Returns information about an frameworkcode.
 506
 507 =cut
 508
 509 sub getframeworkinfo {
 510     my ($frameworkcode) = @_;
 511     my $dbh             = C4::Context->dbh;
 512     my $sth             =
 513       $dbh->prepare("select * from biblio_framework where frameworkcode=?");
 514     $sth->execute($frameworkcode);
 515     my $res = $sth->fetchrow_hashref;
 516     return $res;
 517 }
 518
 519 =head2 getitemtypeinfo
 520
 521   $itemtype = &getitemtype($itemtype);
 522
 523 Returns information about an itemtype.
 524
 525 =cut
 526
 527 sub getitemtypeinfo {
 528     my ($itemtype) = @_;
 529     my $dbh        = C4::Context->dbh;
 530     my $sth        = $dbh->prepare("select * from itemtypes where itemtype=?");
 531     $sth->execute($itemtype);
 532     my $res = $sth->fetchrow_hashref;
 533
 534     $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} );
 535
 536     return $res;
 537 }
 538
 539 =head2 getitemtypeimagedir
 540
 541   my $directory = getitemtypeimagedir( 'opac' );
 542
 543 pass in 'opac' or 'intranet'. Defaults to 'opac'.
 544
 545 returns the full path to the appropriate directory containing images.
 546
 547 =cut
 548
 549 sub getitemtypeimagedir {
 550         my $src = shift || 'opac';
 551         if ($src eq 'intranet') {
 552                 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
 553         } else {
 554                 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
 555         }
 556 }
 557
 558 sub getitemtypeimagesrc {
 559         my $src = shift || 'opac';
 560         if ($src eq 'intranet') {
 561                 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
 562         } else {
 563                 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
 564         }
 565 }
 566
 567 sub getitemtypeimagelocation($$) {
 568         my ( $src, $image ) = @_;
 569
 570         return '' if ( !$image );
 571
 572         my $scheme = ( uri_split( $image ) )[0];
 573
 574         return $image if ( $scheme );
 575
 576         return getitemtypeimagesrc( $src ) . '/' . $image;
 577 }
 578
 579 =head3 _getImagesFromDirectory
 580
 581 Find all of the image files in a directory in the filesystem
 582
 583 parameters: a directory name
 584
 585 returns: a list of images in that directory.
 586
 587 Notes: this does not traverse into subdirectories. See
 588 _getSubdirectoryNames for help with that.
 589 Images are assumed to be files with .gif or .png file extensions.
 590 The image names returned do not have the directory name on them.
 591
 592 =cut
 593
 594 sub _getImagesFromDirectory {
 595     my $directoryname = shift;
 596     return unless defined $directoryname;
 597     return unless -d $directoryname;
 598
 599     if ( opendir ( my $dh, $directoryname ) ) {
 600         my @images = grep { /\.(gif|png)$/i } readdir( $dh );
 601         closedir $dh;
 602         @images = sort(@images);
 603         return @images;
 604     } else {
 605         warn "unable to opendir $directoryname: $!";
 606         return;
 607     }
 608 }
 609
 610 =head3 _getSubdirectoryNames
 611
 612 Find all of the directories in a directory in the filesystem
 613
 614 parameters: a directory name
 615
 616 returns: a list of subdirectories in that directory.
 617
 618 Notes: this does not traverse into subdirectories. Only the first
 619 level of subdirectories are returned.
 620 The directory names returned don't have the parent directory name on them.
 621
 622 =cut
 623
 624 sub _getSubdirectoryNames {
 625     my $directoryname = shift;
 626     return unless defined $directoryname;
 627     return unless -d $directoryname;
 628
 629     if ( opendir ( my $dh, $directoryname ) ) {
 630         my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
 631         closedir $dh;
 632         return @directories;
 633     } else {
 634         warn "unable to opendir $directoryname: $!";
 635         return;
 636     }
 637 }
 638
 639 =head3 getImageSets
 640
 641 returns: a listref of hashrefs. Each hash represents another collection of images.
 642
 643  { imagesetname => 'npl', # the name of the image set (npl is the original one)
 644          images => listref of image hashrefs
 645  }
 646
 647 each image is represented by a hashref like this:
 648
 649  { KohaImage     => 'npl/image.gif',
 650    StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
 651    OpacImageURL  => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
 652    checked       => 0 or 1: was this the image passed to this method?
 653                     Note: I'd like to remove this somehow.
 654  }
 655
 656 =cut
 657
 658 sub getImageSets {
 659     my %params = @_;
 660     my $checked = $params{'checked'} || '';
 661
 662     my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
 663                              url        => getitemtypeimagesrc('intranet'),
 664                         },
 665                   opac => { filesystem => getitemtypeimagedir('opac'),
 666                              url       => getitemtypeimagesrc('opac'),
 667                         }
 668                   };
 669
 670     my @imagesets = (); # list of hasrefs of image set data to pass to template
 671     my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
 672
 673     foreach my $imagesubdir ( @subdirectories ) {
 674         my @imagelist     = (); # hashrefs of image info
 675         my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
 676         foreach my $thisimage ( @imagenames ) {
 677             push( @imagelist,
 678                   { KohaImage     => "$imagesubdir/$thisimage",
 679                     StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
 680                     OpacImageUrl  => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
 681                     checked       => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
 682                }
 683              );
 684         }
 685         push @imagesets, { imagesetname => $imagesubdir,
 686                            images       => \@imagelist };
 687
 688     }
 689     return \@imagesets;
 690 }
 691
 692 =head2 GetPrinters
 693
 694   $printers = &GetPrinters();
 695   @queues = keys %$printers;
 696
 697 Returns information about existing printer queues.
 698
 699 C<$printers> is a reference-to-hash whose keys are the print queues
 700 defined in the printers table of the Koha database. The values are
 701 references-to-hash, whose keys are the fields in the printers table.
 702
 703 =cut
 704
 705 sub GetPrinters {
 706     my %printers;
 707     my $dbh = C4::Context->dbh;
 708     my $sth = $dbh->prepare("select * from printers");
 709     $sth->execute;
 710     while ( my $printer = $sth->fetchrow_hashref ) {
 711         $printers{ $printer->{'printqueue'} } = $printer;
 712     }
 713     return ( \%printers );
 714 }
 715
 716 =head2 GetPrinter
 717
 718   $printer = GetPrinter( $query, $printers );
 719
 720 =cut
 721
 722 sub GetPrinter ($$) {
 723     my ( $query, $printers ) = @_;    # get printer for this query from printers
 724     my $printer = $query->param('printer');
 725     my %cookie = $query->cookie('userenv');
 726     ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
 727     ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
 728     return $printer;
 729 }
 730
 731 =head2 getnbpages
 732
 733 Returns the number of pages to display in a pagination bar, given the number
 734 of items and the number of items per page.
 735
 736 =cut
 737
 738 sub getnbpages {
 739     my ( $nb_items, $nb_items_per_page ) = @_;
 740
 741     return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
 742 }
 743
 744 =head2 getallthemes
 745
 746   (@themes) = &getallthemes('opac');
 747   (@themes) = &getallthemes('intranet');
 748
 749 Returns an array of all available themes.
 750
 751 =cut
 752
 753 sub getallthemes {
 754     my $type = shift;
 755     my $htdocs;
 756     my @themes;
 757     if ( $type eq 'intranet' ) {
 758         $htdocs = C4::Context->config('intrahtdocs');
 759     }
 760     else {
 761         $htdocs = C4::Context->config('opachtdocs');
 762     }
 763     opendir D, "$htdocs";
 764     my @dirlist = readdir D;
 765     foreach my $directory (@dirlist) {
 766         -d "$htdocs/$directory/en" and push @themes, $directory;
 767     }
 768     return @themes;
 769 }
 770
 771 sub getFacets {
 772     my $facets;
 773     if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
 774         $facets = [
 775             {
 776                 link_value  => 'su-to',
 777                 label_value => 'Topics',
 778                 tags        =>
 779                   [ '600', '601', '602', '603', '604', '605', '606', '610' ],
 780                 subfield => 'a',
 781             },
 782             {
 783                 link_value  => 'su-geo',
 784                 label_value => 'Places',
 785                 tags        => ['651'],
 786                 subfield    => 'a',
 787             },
 788             {
 789                 link_value  => 'su-ut',
 790                 label_value => 'Titles',
 791                 tags        => [ '500', '501', '502', '503', '504', ],
 792                 subfield    => 'a',
 793             },
 794             {
 795                 link_value  => 'au',
 796                 label_value => 'Authors',
 797                 tags        => [ '700', '701', '702', ],
 798                 subfield    => 'a',
 799             },
 800             {
 801                 link_value  => 'se',
 802                 label_value => 'Series',
 803                 tags        => ['225'],
 804                 subfield    => 'a',
 805             },
 806             ];
 807
 808             my $library_facet;
 809
 810             $library_facet = {
 811                 link_value  => 'branch',
 812                 label_value => 'Libraries',
 813                 tags        => [ '995', ],
 814                 subfield    => 'b',
 815                 expanded    => '1',
 816             };
 817             push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
 818     }
 819     else {
 820         $facets = [
 821             {
 822                 link_value  => 'su-to',
 823                 label_value => 'Topics',
 824                 tags        => ['650'],
 825                 subfield    => 'a',
 826             },
 827
 828             #        {
 829             #        link_value => 'su-na',
 830             #        label_value => 'People and Organizations',
 831             #        tags => ['600', '610', '611'],
 832             #        subfield => 'a',
 833             #        },
 834             {
 835                 link_value  => 'su-geo',
 836                 label_value => 'Places',
 837                 tags        => ['651'],
 838                 subfield    => 'a',
 839             },
 840             {
 841                 link_value  => 'su-ut',
 842                 label_value => 'Titles',
 843                 tags        => ['630'],
 844                 subfield    => 'a',
 845             },
 846             {
 847                 link_value  => 'au',
 848                 label_value => 'Authors',
 849                 tags        => [ '100', '110', '700', ],
 850                 subfield    => 'a',
 851             },
 852             {
 853                 link_value  => 'se',
 854                 label_value => 'Series',
 855                 tags        => [ '440', '490', ],
 856                 subfield    => 'a',
 857             },
 858             ];
 859             my $library_facet;
 860             $library_facet = {
 861                 link_value  => 'branch',
 862                 label_value => 'Libraries',
 863                 tags        => [ '952', ],
 864                 subfield    => 'b',
 865                 expanded    => '1',
 866             };
 867             push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
 868     }
 869     return $facets;
 870 }
 871
 872 =head2 get_infos_of
 873
 874 Return a href where a key is associated to a href. You give a query,
 875 the name of the key among the fields returned by the query. If you
 876 also give as third argument the name of the value, the function
 877 returns a href of scalar. The optional 4th argument is an arrayref of
 878 items passed to the C<execute()> call. It is designed to bind
 879 parameters to any placeholders in your SQL.
 880
 881   my $query = '
 882 SELECT itemnumber,
 883        notforloan,
 884        barcode
 885   FROM items
 886 ';
 887
 888   # generic href of any information on the item, href of href.
 889   my $iteminfos_of = get_infos_of($query, 'itemnumber');
 890   print $iteminfos_of->{$itemnumber}{barcode};
 891
 892   # specific information, href of scalar
 893   my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
 894   print $barcode_of_item->{$itemnumber};
 895
 896 =cut
 897
 898 sub get_infos_of {
 899     my ( $query, $key_name, $value_name, $bind_params ) = @_;
 900
 901     my $dbh = C4::Context->dbh;
 902
 903     my $sth = $dbh->prepare($query);
 904     $sth->execute( @$bind_params );
 905
 906     my %infos_of;
 907     while ( my $row = $sth->fetchrow_hashref ) {
 908         if ( defined $value_name ) {
 909             $infos_of{ $row->{$key_name} } = $row->{$value_name};
 910         }
 911         else {
 912             $infos_of{ $row->{$key_name} } = $row;
 913         }
 914     }
 915     $sth->finish;
 916
 917     return \%infos_of;
 918 }
 919
 920 =head2 get_notforloan_label_of
 921
 922   my $notforloan_label_of = get_notforloan_label_of();
 923
 924 Each authorised value of notforloan (information available in items and
 925 itemtypes) is link to a single label.
 926
 927 Returns a href where keys are authorised values and values are corresponding
 928 labels.
 929
 930   foreach my $authorised_value (keys %{$notforloan_label_of}) {
 931     printf(
 932         "authorised_value: %s => %s\n",
 933         $authorised_value,
 934         $notforloan_label_of->{$authorised_value}
 935     );
 936   }
 937
 938 =cut
 939
 940 # FIXME - why not use GetAuthorisedValues ??
 941 #
 942 sub get_notforloan_label_of {
 943     my $dbh = C4::Context->dbh;
 944
 945     my $query = '
 946 SELECT authorised_value
 947   FROM marc_subfield_structure
 948   WHERE kohafield = \'items.notforloan\'
 949   LIMIT 0, 1
 950 ';
 951     my $sth = $dbh->prepare($query);
 952     $sth->execute();
 953     my ($statuscode) = $sth->fetchrow_array();
 954
 955     $query = '
 956 SELECT lib,
 957        authorised_value
 958   FROM authorised_values
 959   WHERE category = ?
 960 ';
 961     $sth = $dbh->prepare($query);
 962     $sth->execute($statuscode);
 963     my %notforloan_label_of;
 964     while ( my $row = $sth->fetchrow_hashref ) {
 965         $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
 966     }
 967     $sth->finish;
 968
 969     return \%notforloan_label_of;
 970 }
 971
 972 =head2 displayServers
 973
 974    my $servers = displayServers();
 975    my $servers = displayServers( $position );
 976    my $servers = displayServers( $position, $type );
 977
 978 displayServers returns a listref of hashrefs, each containing
 979 information about available z3950 servers. Each hashref has a format
 980 like:
 981
 982     {
 983       'checked'    => 'checked',
 984       'encoding'   => 'MARC-8'
 985       'icon'       => undef,
 986       'id'         => 'LIBRARY OF CONGRESS',
 987       'label'      => '',
 988       'name'       => 'server',
 989       'opensearch' => '',
 990       'value'      => 'z3950.loc.gov:7090/',
 991       'zed'        => 1,
 992     },
 993
 994 =cut
 995
 996 sub displayServers {
 997     my ( $position, $type ) = @_;
 998     my $dbh = C4::Context->dbh;
 999
1000     my $strsth = 'SELECT * FROM z3950servers';
1001     my @where_clauses;
1002     my @bind_params;
1003
1004     if ($position) {
1005         push @bind_params,   $position;
1006         push @where_clauses, ' position = ? ';
1007     }
1008
1009     if ($type) {
1010         push @bind_params,   $type;
1011         push @where_clauses, ' type = ? ';
1012     }
1013
1014     # reassemble where clause from where clause pieces
1015     if (@where_clauses) {
1016         $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1017     }
1018
1019     my $rq = $dbh->prepare($strsth);
1020     $rq->execute(@bind_params);
1021     my @primaryserverloop;
1022
1023     while ( my $data = $rq->fetchrow_hashref ) {
1024         push @primaryserverloop,
1025           { label    => $data->{description},
1026             id       => $data->{name},
1027             name     => "server",
1028             value    => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1029             encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1030             checked  => "checked",
1031             icon     => $data->{icon},
1032             zed        => $data->{type} eq 'zed',
1033             opensearch => $data->{type} eq 'opensearch'
1034           };
1035     }
1036     return \@primaryserverloop;
1037 }
1038
1039 =head2 GetAuthValCode
1040
1041   $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1042
1043 =cut
1044
1045 sub GetAuthValCode {
1046         my ($kohafield,$fwcode) = @_;
1047         my $dbh = C4::Context->dbh;
1048         $fwcode='' unless $fwcode;
1049         my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1050         $sth->execute($kohafield,$fwcode);
1051         my ($authvalcode) = $sth->fetchrow_array;
1052         return $authvalcode;
1053 }
1054
1055 =head2 GetAuthValCodeFromField
1056
1057   $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1058
1059 C<$subfield> can be undefined
1060
1061 =cut
1062
1063 sub GetAuthValCodeFromField {
1064         my ($field,$subfield,$fwcode) = @_;
1065         my $dbh = C4::Context->dbh;
1066         $fwcode='' unless $fwcode;
1067         my $sth;
1068         if (defined $subfield) {
1069             $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1070             $sth->execute($field,$subfield,$fwcode);
1071         } else {
1072             $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1073             $sth->execute($field,$fwcode);
1074         }
1075         my ($authvalcode) = $sth->fetchrow_array;
1076         return $authvalcode;
1077 }
1078
1079 =head2 GetAuthorisedValues
1080
1081   $authvalues = GetAuthorisedValues([$category], [$selected]);
1082
1083 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1084
1085 C<$category> returns authorised values for just one category (optional).
1086
1087 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1088
1089 =cut
1090
1091 sub GetAuthorisedValues {
1092     my ($category,$selected,$opac) = @_;
1093         my @results;
1094     my $dbh      = C4::Context->dbh;
1095     my $query    = "SELECT * FROM authorised_values";
1096     $query .= " WHERE category = '" . $category . "'" if $category;
1097     $query .= " ORDER BY category, lib, lib_opac";
1098     my $sth = $dbh->prepare($query);
1099     $sth->execute;
1100         while (my $data=$sth->fetchrow_hashref) {
1101             if ($selected && $selected eq $data->{'authorised_value'} ) {
1102                     $data->{'selected'} = 1;
1103             }
1104             if ($opac && $data->{'lib_opac'}) {
1105                 $data->{'lib'} = $data->{'lib_opac'};
1106             }
1107             push @results, $data;
1108         }
1109     #my $data = $sth->fetchall_arrayref({});
1110     return \@results; #$data;
1111 }
1112
1113 =head2 GetAuthorisedValueCategories
1114
1115   $auth_categories = GetAuthorisedValueCategories();
1116
1117 Return an arrayref of all of the available authorised
1118 value categories.
1119
1120 =cut
1121
1122 sub GetAuthorisedValueCategories {
1123     my $dbh = C4::Context->dbh;
1124     my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1125     $sth->execute;
1126     my @results;
1127     while (my $category = $sth->fetchrow_array) {
1128         push @results, $category;
1129     }
1130     return \@results;
1131 }
1132
1133 =head2 GetKohaAuthorisedValues
1134
1135 Takes $kohafield, $fwcode as parameters.
1136
1137 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1138
1139 Returns hashref of Code => description
1140
1141 Returns undef if no authorised value category is defined for the kohafield.
1142
1143 =cut
1144
1145 sub GetKohaAuthorisedValues {
1146   my ($kohafield,$fwcode,$opac) = @_;
1147   $fwcode='' unless $fwcode;
1148   my %values;
1149   my $dbh = C4::Context->dbh;
1150   my $avcode = GetAuthValCode($kohafield,$fwcode);
1151   if ($avcode) {
1152         my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1153         $sth->execute($avcode);
1154         while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1155                 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1156         }
1157         return \%values;
1158   } else {
1159         return undef;
1160   }
1161 }
1162
1163 =head2 GetKohaAuthorisedValuesFromField
1164
1165 Takes $field, $subfield, $fwcode as parameters.
1166
1167 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1168 $subfield can be undefined
1169
1170 Returns hashref of Code => description
1171
1172 Returns undef if no authorised value category is defined for the given field and subfield
1173
1174 =cut
1175
1176 sub GetKohaAuthorisedValuesFromField {
1177   my ($field, $subfield, $fwcode,$opac) = @_;
1178   $fwcode='' unless $fwcode;
1179   my %values;
1180   my $dbh = C4::Context->dbh;
1181   my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1182   if ($avcode) {
1183         my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1184         $sth->execute($avcode);
1185         while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1186                 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1187         }
1188         return \%values;
1189   } else {
1190         return undef;
1191   }
1192 }
1193
1194 =head2 xml_escape
1195
1196   my $escaped_string = C4::Koha::xml_escape($string);
1197
1198 Convert &, <, >, ', and " in a string to XML entities
1199
1200 =cut
1201
1202 sub xml_escape {
1203     my $str = shift;
1204     return '' unless defined $str;
1205     $str =~ s/&/&amp;/g;
1206     $str =~ s/</&lt;/g;
1207     $str =~ s/>/&gt;/g;
1208     $str =~ s/'/&apos;/g;
1209     $str =~ s/"/&quot;/g;
1210     return $str;
1211 }
1212
1213 =head2 display_marc_indicators
1214
1215   my $display_form = C4::Koha::display_marc_indicators($field);
1216
1217 C<$field> is a MARC::Field object
1218
1219 Generate a display form of the indicators of a variable
1220 MARC field, replacing any blanks with '#'.
1221
1222 =cut
1223
1224 sub display_marc_indicators {
1225     my $field = shift;
1226     my $indicators = '';
1227     if ($field->tag() >= 10) {
1228         $indicators = $field->indicator(1) . $field->indicator(2);
1229         $indicators =~ s/ /#/g;
1230     }
1231     return $indicators;
1232 }
1233
1234 sub GetNormalizedUPC {
1235  my ($record,$marcflavour) = @_;
1236     my (@fields,$upc);
1237
1238     if ($marcflavour eq 'MARC21') {
1239         @fields = $record->field('024');
1240         foreach my $field (@fields) {
1241             my $indicator = $field->indicator(1);
1242             my $upc = _normalize_match_point($field->subfield('a'));
1243             if ($indicator == 1 and $upc ne '') {
1244                 return $upc;
1245             }
1246         }
1247     }
1248     else { # assume unimarc if not marc21
1249         @fields = $record->field('072');
1250         foreach my $field (@fields) {
1251             my $upc = _normalize_match_point($field->subfield('a'));
1252             if ($upc ne '') {
1253                 return $upc;
1254             }
1255         }
1256     }
1257 }
1258
1259 # Normalizes and returns the first valid ISBN found in the record
1260 # ISBN13 are converted into ISBN10. This is required to get Amazon cover book.
1261 sub GetNormalizedISBN {
1262     my ($isbn,$record,$marcflavour) = @_;
1263     my @fields;
1264     if ($isbn) {
1265         # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1266         # anything after " | " should be removed, along with the delimiter
1267         $isbn =~ s/(.*)( \| )(.*)/$1/;
1268         return _isbn_cleanup($isbn);
1269     }
1270     return undef unless $record;
1271
1272     if ($marcflavour eq 'MARC21') {
1273         @fields = $record->field('020');
1274         foreach my $field (@fields) {
1275             $isbn = $field->subfield('a');
1276             if ($isbn) {
1277                 return _isbn_cleanup($isbn);
1278             } else {
1279                 return undef;
1280             }
1281         }
1282     }
1283     else { # assume unimarc if not marc21
1284         @fields = $record->field('010');
1285         foreach my $field (@fields) {
1286             my $isbn = $field->subfield('a');
1287             if ($isbn) {
1288                 return _isbn_cleanup($isbn);
1289             } else {
1290                 return undef;
1291             }
1292         }
1293     }
1294
1295 }
1296
1297 sub GetNormalizedEAN {
1298     my ($record,$marcflavour) = @_;
1299     my (@fields,$ean);
1300
1301     if ($marcflavour eq 'MARC21') {
1302         @fields = $record->field('024');
1303         foreach my $field (@fields) {
1304             my $indicator = $field->indicator(1);
1305             $ean = _normalize_match_point($field->subfield('a'));
1306             if ($indicator == 3 and $ean ne '') {
1307                 return $ean;
1308             }
1309         }
1310     }
1311     else { # assume unimarc if not marc21
1312         @fields = $record->field('073');
1313         foreach my $field (@fields) {
1314             $ean = _normalize_match_point($field->subfield('a'));
1315             if ($ean ne '') {
1316                 return $ean;
1317             }
1318         }
1319     }
1320 }
1321 sub GetNormalizedOCLCNumber {
1322     my ($record,$marcflavour) = @_;
1323     my (@fields,$oclc);
1324
1325     if ($marcflavour eq 'MARC21') {
1326         @fields = $record->field('035');
1327         foreach my $field (@fields) {
1328             $oclc = $field->subfield('a');
1329             if ($oclc =~ /OCoLC/) {
1330                 $oclc =~ s/\(OCoLC\)//;
1331                 return $oclc;
1332             } else {
1333                 return undef;
1334             }
1335         }
1336     }
1337     else { # TODO: add UNIMARC fields
1338     }
1339 }
1340
1341 sub _normalize_match_point {
1342     my $match_point = shift;
1343     (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1344     $normalized_match_point =~ s/-//g;
1345
1346     return $normalized_match_point;
1347 }
1348
1349 sub _isbn_cleanup ($) {
1350     my $isbn = Business::ISBN->new( shift );
1351     return undef unless $isbn;
1352     $isbn = $isbn->as_isbn10 if $isbn->type eq 'ISBN13';
1353     return undef unless $isbn;
1354     $isbn = $isbn->as_string;
1355     $isbn =~ s/-//g;
1356     return $isbn;
1357 }
1358
1359 1;
1360
1361 __END__
1362
1363 =head1 AUTHOR
1364
1365 Koha Team
1366
1367 =cut