C4/Koha.pm

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