C4/Koha.pm

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