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