koha-dev.rot13.org Git - koha_gimpoz/blob - C4/Koha.pm

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