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