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