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