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