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