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         return @images;
 602     } else {
 603         warn "unable to opendir $directoryname: $!";
 604         return;
 605     }
 606 }
 607
 608 =head3 _getSubdirectoryNames
 609
 610 Find all of the directories in a directory in the filesystem
 611
 612 parameters: a directory name
 613
 614 returns: a list of subdirectories in that directory.
 615
 616 Notes: this does not traverse into subdirectories. Only the first
 617 level of subdirectories are returned.
 618 The directory names returned don't have the parent directory name on them.
 619
 620 =cut
 621
 622 sub _getSubdirectoryNames {
 623     my $directoryname = shift;
 624     return unless defined $directoryname;
 625     return unless -d $directoryname;
 626
 627     if ( opendir ( my $dh, $directoryname ) ) {
 628         my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
 629         closedir $dh;
 630         return @directories;
 631     } else {
 632         warn "unable to opendir $directoryname: $!";
 633         return;
 634     }
 635 }
 636
 637 =head3 getImageSets
 638
 639 returns: a listref of hashrefs. Each hash represents another collection of images.
 640
 641  { imagesetname => 'npl', # the name of the image set (npl is the original one)
 642          images => listref of image hashrefs
 643  }
 644
 645 each image is represented by a hashref like this:
 646
 647  { KohaImage     => 'npl/image.gif',
 648    StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
 649    OpacImageURL  => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
 650    checked       => 0 or 1: was this the image passed to this method?
 651                     Note: I'd like to remove this somehow.
 652  }
 653
 654 =cut
 655
 656 sub getImageSets {
 657     my %params = @_;
 658     my $checked = $params{'checked'} || '';
 659
 660     my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
 661                              url        => getitemtypeimagesrc('intranet'),
 662                         },
 663                   opac => { filesystem => getitemtypeimagedir('opac'),
 664                              url       => getitemtypeimagesrc('opac'),
 665                         }
 666                   };
 667
 668     my @imagesets = (); # list of hasrefs of image set data to pass to template
 669     my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
 670
 671     foreach my $imagesubdir ( @subdirectories ) {
 672         my @imagelist     = (); # hashrefs of image info
 673         my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
 674         foreach my $thisimage ( @imagenames ) {
 675             push( @imagelist,
 676                   { KohaImage     => "$imagesubdir/$thisimage",
 677                     StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
 678                     OpacImageUrl  => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
 679                     checked       => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
 680                }
 681              );
 682         }
 683         push @imagesets, { imagesetname => $imagesubdir,
 684                            images       => \@imagelist };
 685
 686     }
 687     return \@imagesets;
 688 }
 689
 690 =head2 GetPrinters
 691
 692   $printers = &GetPrinters();
 693   @queues = keys %$printers;
 694
 695 Returns information about existing printer queues.
 696
 697 C<$printers> is a reference-to-hash whose keys are the print queues
 698 defined in the printers table of the Koha database. The values are
 699 references-to-hash, whose keys are the fields in the printers table.
 700
 701 =cut
 702
 703 sub GetPrinters {
 704     my %printers;
 705     my $dbh = C4::Context->dbh;
 706     my $sth = $dbh->prepare("select * from printers");
 707     $sth->execute;
 708     while ( my $printer = $sth->fetchrow_hashref ) {
 709         $printers{ $printer->{'printqueue'} } = $printer;
 710     }
 711     return ( \%printers );
 712 }
 713
 714 =head2 GetPrinter
 715
 716   $printer = GetPrinter( $query, $printers );
 717
 718 =cut
 719
 720 sub GetPrinter ($$) {
 721     my ( $query, $printers ) = @_;    # get printer for this query from printers
 722     my $printer = $query->param('printer');
 723     my %cookie = $query->cookie('userenv');
 724     ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
 725     ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
 726     return $printer;
 727 }
 728
 729 =head2 getnbpages
 730
 731 Returns the number of pages to display in a pagination bar, given the number
 732 of items and the number of items per page.
 733
 734 =cut
 735
 736 sub getnbpages {
 737     my ( $nb_items, $nb_items_per_page ) = @_;
 738
 739     return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
 740 }
 741
 742 =head2 getallthemes
 743
 744   (@themes) = &getallthemes('opac');
 745   (@themes) = &getallthemes('intranet');
 746
 747 Returns an array of all available themes.
 748
 749 =cut
 750
 751 sub getallthemes {
 752     my $type = shift;
 753     my $htdocs;
 754     my @themes;
 755     if ( $type eq 'intranet' ) {
 756         $htdocs = C4::Context->config('intrahtdocs');
 757     }
 758     else {
 759         $htdocs = C4::Context->config('opachtdocs');
 760     }
 761     opendir D, "$htdocs";
 762     my @dirlist = readdir D;
 763     foreach my $directory (@dirlist) {
 764         -d "$htdocs/$directory/en" and push @themes, $directory;
 765     }
 766     return @themes;
 767 }
 768
 769 sub getFacets {
 770     my $facets;
 771     if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
 772         $facets = [
 773             {
 774                 link_value  => 'su-to',
 775                 label_value => 'Topics',
 776                 tags        =>
 777                   [ '600', '601', '602', '603', '604', '605', '606', '610' ],
 778                 subfield => 'a',
 779             },
 780             {
 781                 link_value  => 'su-geo',
 782                 label_value => 'Places',
 783                 tags        => ['651'],
 784                 subfield    => 'a',
 785             },
 786             {
 787                 link_value  => 'su-ut',
 788                 label_value => 'Titles',
 789                 tags        => [ '500', '501', '502', '503', '504', ],
 790                 subfield    => 'a',
 791             },
 792             {
 793                 link_value  => 'au',
 794                 label_value => 'Authors',
 795                 tags        => [ '700', '701', '702', ],
 796                 subfield    => 'a',
 797             },
 798             {
 799                 link_value  => 'se',
 800                 label_value => 'Series',
 801                 tags        => ['225'],
 802                 subfield    => 'a',
 803             },
 804             ];
 805
 806             my $library_facet;
 807
 808             $library_facet = {
 809                 link_value  => 'branch',
 810                 label_value => 'Libraries',
 811                 tags        => [ '995', ],
 812                 subfield    => 'b',
 813                 expanded    => '1',
 814             };
 815             push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
 816     }
 817     else {
 818         $facets = [
 819             {
 820                 link_value  => 'su-to',
 821                 label_value => 'Topics',
 822                 tags        => ['650'],
 823                 subfield    => 'a',
 824             },
 825
 826             #        {
 827             #        link_value => 'su-na',
 828             #        label_value => 'People and Organizations',
 829             #        tags => ['600', '610', '611'],
 830             #        subfield => 'a',
 831             #        },
 832             {
 833                 link_value  => 'su-geo',
 834                 label_value => 'Places',
 835                 tags        => ['651'],
 836                 subfield    => 'a',
 837             },
 838             {
 839                 link_value  => 'su-ut',
 840                 label_value => 'Titles',
 841                 tags        => ['630'],
 842                 subfield    => 'a',
 843             },
 844             {
 845                 link_value  => 'au',
 846                 label_value => 'Authors',
 847                 tags        => [ '100', '110', '700', ],
 848                 subfield    => 'a',
 849             },
 850             {
 851                 link_value  => 'se',
 852                 label_value => 'Series',
 853                 tags        => [ '440', '490', ],
 854                 subfield    => 'a',
 855             },
 856             ];
 857             my $library_facet;
 858             $library_facet = {
 859                 link_value  => 'branch',
 860                 label_value => 'Libraries',
 861                 tags        => [ '952', ],
 862                 subfield    => 'b',
 863                 expanded    => '1',
 864             };
 865             push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
 866     }
 867     return $facets;
 868 }
 869
 870 =head2 get_infos_of
 871
 872 Return a href where a key is associated to a href. You give a query,
 873 the name of the key among the fields returned by the query. If you
 874 also give as third argument the name of the value, the function
 875 returns a href of scalar. The optional 4th argument is an arrayref of
 876 items passed to the C<execute()> call. It is designed to bind
 877 parameters to any placeholders in your SQL.
 878
 879   my $query = '
 880 SELECT itemnumber,
 881        notforloan,
 882        barcode
 883   FROM items
 884 ';
 885
 886   # generic href of any information on the item, href of href.
 887   my $iteminfos_of = get_infos_of($query, 'itemnumber');
 888   print $iteminfos_of->{$itemnumber}{barcode};
 889
 890   # specific information, href of scalar
 891   my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
 892   print $barcode_of_item->{$itemnumber};
 893
 894 =cut
 895
 896 sub get_infos_of {
 897     my ( $query, $key_name, $value_name, $bind_params ) = @_;
 898
 899     my $dbh = C4::Context->dbh;
 900
 901     my $sth = $dbh->prepare($query);
 902     $sth->execute( @$bind_params );
 903
 904     my %infos_of;
 905     while ( my $row = $sth->fetchrow_hashref ) {
 906         if ( defined $value_name ) {
 907             $infos_of{ $row->{$key_name} } = $row->{$value_name};
 908         }
 909         else {
 910             $infos_of{ $row->{$key_name} } = $row;
 911         }
 912     }
 913     $sth->finish;
 914
 915     return \%infos_of;
 916 }
 917
 918 =head2 get_notforloan_label_of
 919
 920   my $notforloan_label_of = get_notforloan_label_of();
 921
 922 Each authorised value of notforloan (information available in items and
 923 itemtypes) is link to a single label.
 924
 925 Returns a href where keys are authorised values and values are corresponding
 926 labels.
 927
 928   foreach my $authorised_value (keys %{$notforloan_label_of}) {
 929     printf(
 930         "authorised_value: %s => %s\n",
 931         $authorised_value,
 932         $notforloan_label_of->{$authorised_value}
 933     );
 934   }
 935
 936 =cut
 937
 938 # FIXME - why not use GetAuthorisedValues ??
 939 #
 940 sub get_notforloan_label_of {
 941     my $dbh = C4::Context->dbh;
 942
 943     my $query = '
 944 SELECT authorised_value
 945   FROM marc_subfield_structure
 946   WHERE kohafield = \'items.notforloan\'
 947   LIMIT 0, 1
 948 ';
 949     my $sth = $dbh->prepare($query);
 950     $sth->execute();
 951     my ($statuscode) = $sth->fetchrow_array();
 952
 953     $query = '
 954 SELECT lib,
 955        authorised_value
 956   FROM authorised_values
 957   WHERE category = ?
 958 ';
 959     $sth = $dbh->prepare($query);
 960     $sth->execute($statuscode);
 961     my %notforloan_label_of;
 962     while ( my $row = $sth->fetchrow_hashref ) {
 963         $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
 964     }
 965     $sth->finish;
 966
 967     return \%notforloan_label_of;
 968 }
 969
 970 =head2 displayServers
 971
 972    my $servers = displayServers();
 973    my $servers = displayServers( $position );
 974    my $servers = displayServers( $position, $type );
 975
 976 displayServers returns a listref of hashrefs, each containing
 977 information about available z3950 servers. Each hashref has a format
 978 like:
 979
 980     {
 981       'checked'    => 'checked',
 982       'encoding'   => 'MARC-8'
 983       'icon'       => undef,
 984       'id'         => 'LIBRARY OF CONGRESS',
 985       'label'      => '',
 986       'name'       => 'server',
 987       'opensearch' => '',
 988       'value'      => 'z3950.loc.gov:7090/',
 989       'zed'        => 1,
 990     },
 991
 992 =cut
 993
 994 sub displayServers {
 995     my ( $position, $type ) = @_;
 996     my $dbh = C4::Context->dbh;
 997
 998     my $strsth = 'SELECT * FROM z3950servers';
 999     my @where_clauses;
1000     my @bind_params;
1001
1002     if ($position) {
1003         push @bind_params,   $position;
1004         push @where_clauses, ' position = ? ';
1005     }
1006
1007     if ($type) {
1008         push @bind_params,   $type;
1009         push @where_clauses, ' type = ? ';
1010     }
1011
1012     # reassemble where clause from where clause pieces
1013     if (@where_clauses) {
1014         $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1015     }
1016
1017     my $rq = $dbh->prepare($strsth);
1018     $rq->execute(@bind_params);
1019     my @primaryserverloop;
1020
1021     while ( my $data = $rq->fetchrow_hashref ) {
1022         push @primaryserverloop,
1023           { label    => $data->{description},
1024             id       => $data->{name},
1025             name     => "server",
1026             value    => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1027             encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1028             checked  => "checked",
1029             icon     => $data->{icon},
1030             zed        => $data->{type} eq 'zed',
1031             opensearch => $data->{type} eq 'opensearch'
1032           };
1033     }
1034     return \@primaryserverloop;
1035 }
1036
1037 =head2 GetAuthValCode
1038
1039   $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1040
1041 =cut
1042
1043 sub GetAuthValCode {
1044         my ($kohafield,$fwcode) = @_;
1045         my $dbh = C4::Context->dbh;
1046         $fwcode='' unless $fwcode;
1047         my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1048         $sth->execute($kohafield,$fwcode);
1049         my ($authvalcode) = $sth->fetchrow_array;
1050         return $authvalcode;
1051 }
1052
1053 =head2 GetAuthValCodeFromField
1054
1055   $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1056
1057 C<$subfield> can be undefined
1058
1059 =cut
1060
1061 sub GetAuthValCodeFromField {
1062         my ($field,$subfield,$fwcode) = @_;
1063         my $dbh = C4::Context->dbh;
1064         $fwcode='' unless $fwcode;
1065         my $sth;
1066         if (defined $subfield) {
1067             $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1068             $sth->execute($field,$subfield,$fwcode);
1069         } else {
1070             $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1071             $sth->execute($field,$fwcode);
1072         }
1073         my ($authvalcode) = $sth->fetchrow_array;
1074         return $authvalcode;
1075 }
1076
1077 =head2 GetAuthorisedValues
1078
1079   $authvalues = GetAuthorisedValues([$category], [$selected]);
1080
1081 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1082
1083 C<$category> returns authorised values for just one category (optional).
1084
1085 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1086
1087 =cut
1088
1089 sub GetAuthorisedValues {
1090     my ($category,$selected,$opac) = @_;
1091         my @results;
1092     my $dbh      = C4::Context->dbh;
1093     my $query    = "SELECT * FROM authorised_values";
1094     $query .= " WHERE category = '" . $category . "'" if $category;
1095     $query .= " ORDER BY category, lib, lib_opac";
1096     my $sth = $dbh->prepare($query);
1097     $sth->execute;
1098         while (my $data=$sth->fetchrow_hashref) {
1099             if ($selected && $selected eq $data->{'authorised_value'} ) {
1100                     $data->{'selected'} = 1;
1101             }
1102             if ($opac && $data->{'lib_opac'}) {
1103                 $data->{'lib'} = $data->{'lib_opac'};
1104             }
1105             push @results, $data;
1106         }
1107     #my $data = $sth->fetchall_arrayref({});
1108     return \@results; #$data;
1109 }
1110
1111 =head2 GetAuthorisedValueCategories
1112
1113   $auth_categories = GetAuthorisedValueCategories();
1114
1115 Return an arrayref of all of the available authorised
1116 value categories.
1117
1118 =cut
1119
1120 sub GetAuthorisedValueCategories {
1121     my $dbh = C4::Context->dbh;
1122     my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1123     $sth->execute;
1124     my @results;
1125     while (my $category = $sth->fetchrow_array) {
1126         push @results, $category;
1127     }
1128     return \@results;
1129 }
1130
1131 =head2 GetKohaAuthorisedValues
1132
1133 Takes $kohafield, $fwcode as parameters.
1134
1135 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1136
1137 Returns hashref of Code => description
1138
1139 Returns undef if no authorised value category is defined for the kohafield.
1140
1141 =cut
1142
1143 sub GetKohaAuthorisedValues {
1144   my ($kohafield,$fwcode,$opac) = @_;
1145   $fwcode='' unless $fwcode;
1146   my %values;
1147   my $dbh = C4::Context->dbh;
1148   my $avcode = GetAuthValCode($kohafield,$fwcode);
1149   if ($avcode) {
1150         my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1151         $sth->execute($avcode);
1152         while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1153                 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1154         }
1155         return \%values;
1156   } else {
1157         return undef;
1158   }
1159 }
1160
1161 =head2 GetKohaAuthorisedValuesFromField
1162
1163 Takes $field, $subfield, $fwcode as parameters.
1164
1165 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1166 $subfield can be undefined
1167
1168 Returns hashref of Code => description
1169
1170 Returns undef if no authorised value category is defined for the given field and subfield
1171
1172 =cut
1173
1174 sub GetKohaAuthorisedValuesFromField {
1175   my ($field, $subfield, $fwcode,$opac) = @_;
1176   $fwcode='' unless $fwcode;
1177   my %values;
1178   my $dbh = C4::Context->dbh;
1179   my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1180   if ($avcode) {
1181         my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1182         $sth->execute($avcode);
1183         while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1184                 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1185         }
1186         return \%values;
1187   } else {
1188         return undef;
1189   }
1190 }
1191
1192 =head2 display_marc_indicators
1193
1194   my $display_form = C4::Koha::display_marc_indicators($field);
1195
1196 C<$field> is a MARC::Field object
1197
1198 Generate a display form of the indicators of a variable
1199 MARC field, replacing any blanks with '#'.
1200
1201 =cut
1202
1203 sub display_marc_indicators {
1204     my $field = shift;
1205     my $indicators = '';
1206     if ($field->tag() >= 10) {
1207         $indicators = $field->indicator(1) . $field->indicator(2);
1208         $indicators =~ s/ /#/g;
1209     }
1210     return $indicators;
1211 }
1212
1213 sub GetNormalizedUPC {
1214  my ($record,$marcflavour) = @_;
1215     my (@fields,$upc);
1216
1217     if ($marcflavour eq 'MARC21') {
1218         @fields = $record->field('024');
1219         foreach my $field (@fields) {
1220             my $indicator = $field->indicator(1);
1221             my $upc = _normalize_match_point($field->subfield('a'));
1222             if ($indicator == 1 and $upc ne '') {
1223                 return $upc;
1224             }
1225         }
1226     }
1227     else { # assume unimarc if not marc21
1228         @fields = $record->field('072');
1229         foreach my $field (@fields) {
1230             my $upc = _normalize_match_point($field->subfield('a'));
1231             if ($upc ne '') {
1232                 return $upc;
1233             }
1234         }
1235     }
1236 }
1237
1238 # Normalizes and returns the first valid ISBN found in the record
1239 # ISBN13 are converted into ISBN10. This is required to get Amazon cover book.
1240 sub GetNormalizedISBN {
1241     my ($isbn,$record,$marcflavour) = @_;
1242     my @fields;
1243     if ($isbn) {
1244         return _isbn_cleanup($isbn);
1245     }
1246     return undef unless $record;
1247
1248     if ($marcflavour eq 'MARC21') {
1249         @fields = $record->field('020');
1250         foreach my $field (@fields) {
1251             $isbn = $field->subfield('a');
1252             if ($isbn) {
1253                 return _isbn_cleanup($isbn);
1254             } else {
1255                 return undef;
1256             }
1257         }
1258     }
1259     else { # assume unimarc if not marc21
1260         @fields = $record->field('010');
1261         foreach my $field (@fields) {
1262             my $isbn = $field->subfield('a');
1263             if ($isbn) {
1264                 return _isbn_cleanup($isbn);
1265             } else {
1266                 return undef;
1267             }
1268         }
1269     }
1270
1271 }
1272
1273 sub GetNormalizedEAN {
1274     my ($record,$marcflavour) = @_;
1275     my (@fields,$ean);
1276
1277     if ($marcflavour eq 'MARC21') {
1278         @fields = $record->field('024');
1279         foreach my $field (@fields) {
1280             my $indicator = $field->indicator(1);
1281             $ean = _normalize_match_point($field->subfield('a'));
1282             if ($indicator == 3 and $ean ne '') {
1283                 return $ean;
1284             }
1285         }
1286     }
1287     else { # assume unimarc if not marc21
1288         @fields = $record->field('073');
1289         foreach my $field (@fields) {
1290             $ean = _normalize_match_point($field->subfield('a'));
1291             if ($ean ne '') {
1292                 return $ean;
1293             }
1294         }
1295     }
1296 }
1297 sub GetNormalizedOCLCNumber {
1298     my ($record,$marcflavour) = @_;
1299     my (@fields,$oclc);
1300
1301     if ($marcflavour eq 'MARC21') {
1302         @fields = $record->field('035');
1303         foreach my $field (@fields) {
1304             $oclc = $field->subfield('a');
1305             if ($oclc =~ /OCoLC/) {
1306                 $oclc =~ s/\(OCoLC\)//;
1307                 return $oclc;
1308             } else {
1309                 return undef;
1310             }
1311         }
1312     }
1313     else { # TODO: add UNIMARC fields
1314     }
1315 }
1316
1317 sub _normalize_match_point {
1318     my $match_point = shift;
1319     (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1320     $normalized_match_point =~ s/-//g;
1321
1322     return $normalized_match_point;
1323 }
1324
1325 sub _isbn_cleanup ($) {
1326     my $isbn = Business::ISBN->new( shift );
1327     return undef unless $isbn;
1328     $isbn = $isbn->as_isbn10 if $isbn->type eq 'ISBN13';
1329     $isbn = $isbn->as_string;
1330     $isbn =~ s/-//g;
1331     return $isbn;
1332 }
1333
1334 1;
1335
1336 __END__
1337
1338 =head1 AUTHOR
1339
1340 Koha Team
1341
1342 =cut