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