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