3 # Copyright 2000-2002 Katipo Communications
4 # Parts Copyright 2010 Nelsonville Public Library
5 # Parts copyright 2010 BibLibre
7 # This file is part of Koha.
9 # Koha is free software; you can redistribute it and/or modify it
10 # under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 3 of the License, or
12 # (at your option) any later version.
14 # Koha is distributed in the hope that it will be useful, but
15 # WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with Koha; if not, see <http://www.gnu.org/licenses>.
24 #use warnings; FIXME - Bug 2505
27 use C4::Branch; # Can be removed?
29 use Koha::DateUtils qw(dt_from_string);
31 use DateTime::Format::MySQL;
33 use autouse 'Data::cselectall_arrayref' => qw(Dumper);
34 use DBI qw(:sql_types);
35 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $DEBUG);
38 $VERSION = 3.07.00.049;
43 &subfield_is_koha_internal_p
44 &GetPrinters &GetPrinter
45 &GetItemTypes &getitemtypeinfo
46 &GetItemTypesCategorized &GetItemTypesByCategory
47 &GetSupportName &GetSupportList
49 &getframeworks &getframeworkinfo
56 &get_notforloan_label_of
59 &getitemtypeimagelocation
61 &GetAuthorisedValueCategories
62 &IsAuthorisedValueCategory
63 &GetKohaAuthorisedValues
64 &GetKohaAuthorisedValuesFromField
65 &GetKohaAuthorisedValuesMapping
66 &GetKohaAuthorisedValueLib
67 &GetAuthorisedValueByCode
73 &GetNormalizedOCLCNumber
83 @EXPORT_OK = qw( GetDailyQuote );
88 C4::Koha - Perl Module containing convenience functions for Koha scripts
96 Koha.pm provides many functions for Koha scripts.
104 $slash_date = &slashifyDate($dash_date);
106 Takes a string of the form "DD-MM-YYYY" (or anything separated by
107 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
113 # accepts a date of the form xx-xx-xx[xx] and returns it in the
115 my @dateOut = split( '-', shift );
116 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
119 # FIXME.. this should be moved to a MARC-specific module
120 sub subfield_is_koha_internal_p {
123 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
124 # But real MARC subfields are always single-character
125 # so it really is safer just to check the length
127 return length $subfield != 1;
130 =head2 GetSupportName
132 $itemtypename = &GetSupportName($codestring);
134 Returns a string with the name of the itemtype.
140 return if (! $codestring);
142 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
143 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
150 my $sth = C4::Context->dbh->prepare($query);
151 $sth->execute($codestring);
152 ($resultstring)=$sth->fetchrow;
153 return $resultstring;
156 C4::Context->dbh->prepare(
157 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
159 $sth->execute( $advanced_search_types, $codestring );
160 my $data = $sth->fetchrow_hashref;
161 return $$data{'lib'};
165 =head2 GetSupportList
167 $itemtypes = &GetSupportList();
169 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
171 build a HTML select with the following code :
173 =head3 in PERL SCRIPT
175 my $itemtypes = GetSupportList();
176 $template->param(itemtypeloop => $itemtypes);
180 <select name="itemtype" id="itemtype">
181 <option value=""></option>
182 [% FOREACH itemtypeloo IN itemtypeloop %]
183 [% IF ( itemtypeloo.selected ) %]
184 <option value="[% itemtypeloo.itemtype %]" selected="selected">[% itemtypeloo.description %]</option>
186 <option value="[% itemtypeloo.itemtype %]">[% itemtypeloo.description %]</option>
194 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
195 if (!$advanced_search_types or $advanced_search_types =~ /itemtypes/) {
196 return GetItemTypes( style => 'array' );
198 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
199 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
205 $itemtypes = &GetItemTypes( style => $style );
207 Returns information about existing itemtypes.
210 style: either 'array' or 'hash', defaults to 'hash'.
211 'array' returns an arrayref,
212 'hash' return a hashref with the itemtype value as the key
214 build a HTML select with the following code :
216 =head3 in PERL SCRIPT
218 my $itemtypes = GetItemTypes;
220 foreach my $thisitemtype (sort keys %$itemtypes) {
221 my $selected = 1 if $thisitemtype eq $itemtype;
222 my %row =(value => $thisitemtype,
223 selected => $selected,
224 description => $itemtypes->{$thisitemtype}->{'description'},
226 push @itemtypesloop, \%row;
228 $template->param(itemtypeloop => \@itemtypesloop);
232 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
233 <select name="itemtype">
234 <option value="">Default</option>
235 <!-- TMPL_LOOP name="itemtypeloop" -->
236 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
239 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
240 <input type="submit" value="OK" class="button">
247 my $style = defined( $params{'style'} ) ? $params{'style'} : 'hash';
249 require C4::Languages;
250 my $language = C4::Languages::getlanguage();
251 # returns a reference to a hash of references to itemtypes...
252 my $dbh = C4::Context->dbh;
256 itemtypes.description,
257 itemtypes.rentalcharge,
258 itemtypes.notforloan,
261 itemtypes.checkinmsg,
262 itemtypes.checkinmsgtype,
263 itemtypes.sip_media_type,
264 itemtypes.hideinopac,
265 itemtypes.searchcategory,
266 COALESCE( localization.translation, itemtypes.description ) AS translated_description
268 LEFT JOIN localization ON itemtypes.itemtype = localization.code
269 AND localization.entity = 'itemtypes'
270 AND localization.lang = ?
273 my $sth = $dbh->prepare($query);
274 $sth->execute( $language );
276 if ( $style eq 'hash' ) {
278 while ( my $IT = $sth->fetchrow_hashref ) {
279 $itemtypes{ $IT->{'itemtype'} } = $IT;
281 return ( \%itemtypes );
283 return [ sort { lc $a->{translated_description} cmp lc $b->{translated_description} } @{ $sth->fetchall_arrayref( {} ) } ];
287 =head2 GetItemTypesCategorized
289 $categories = GetItemTypesCategorized();
291 Returns a hashref containing search categories.
292 A search category will be put in the hash if at least one of its itemtypes is visible in OPAC.
293 The categories must be part of Authorized Values (ITEMTYPECAT)
297 sub GetItemTypesCategorized {
298 my $dbh = C4::Context->dbh;
299 # Order is important, so that partially hidden (some items are not visible in OPAC) search
300 # categories will be visible. hideinopac=0 must be last.
302 SELECT itemtype, description, imageurl, hideinopac, 0 as 'iscat' FROM itemtypes WHERE ISNULL(searchcategory) or length(searchcategory) = 0
304 SELECT DISTINCT searchcategory AS `itemtype`,
305 authorised_values.lib_opac AS description,
306 authorised_values.imageurl AS imageurl,
307 hideinopac, 1 as 'iscat'
309 LEFT JOIN authorised_values ON searchcategory = authorised_value
310 WHERE searchcategory > '' and hideinopac=1
312 SELECT DISTINCT searchcategory AS `itemtype`,
313 authorised_values.lib_opac AS description,
314 authorised_values.imageurl AS imageurl,
315 hideinopac, 1 as 'iscat'
317 LEFT JOIN authorised_values ON searchcategory = authorised_value
318 WHERE searchcategory > '' and hideinopac=0
320 return ($dbh->selectall_hashref($query,'itemtype'));
323 =head2 GetItemTypesByCategory
325 @results = GetItemTypesByCategory( $searchcategory );
327 Returns the itemtype code of all itemtypes included in a searchcategory.
331 sub GetItemTypesByCategory {
335 my $dbh = C4::Context->dbh;
336 my $query = qq|SELECT itemtype FROM itemtypes WHERE searchcategory=?|;
337 my $tmp=$dbh->selectcol_arrayref($query,undef,$category);
341 sub get_itemtypeinfos_of {
344 my $placeholders = join( ', ', map { '?' } @itemtypes );
345 my $query = <<"END_SQL";
351 WHERE itemtype IN ( $placeholders )
354 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
359 $frameworks = &getframework();
361 Returns information about existing frameworks
363 build a HTML select with the following code :
365 =head3 in PERL SCRIPT
367 my $frameworks = getframeworks();
369 foreach my $thisframework (keys %$frameworks) {
370 my $selected = 1 if $thisframework eq $frameworkcode;
372 value => $thisframework,
373 selected => $selected,
374 description => $frameworks->{$thisframework}->{'frameworktext'},
376 push @frameworksloop, \%row;
378 $template->param(frameworkloop => \@frameworksloop);
382 <form action="[% script_name %] method=post>
383 <select name="frameworkcode">
384 <option value="">Default</option>
385 [% FOREACH framework IN frameworkloop %]
386 [% IF ( framework.selected ) %]
387 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
389 <option value="[% framework.value %]">[% framework.description %]</option>
393 <input type=text name=searchfield value="[% searchfield %]">
394 <input type="submit" value="OK" class="button">
401 # returns a reference to a hash of references to branches...
403 my $dbh = C4::Context->dbh;
404 my $sth = $dbh->prepare("select * from biblio_framework");
406 while ( my $IT = $sth->fetchrow_hashref ) {
407 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
409 return ( \%itemtypes );
412 =head2 GetFrameworksLoop
414 $frameworks = GetFrameworksLoop( $frameworkcode );
416 Returns the loop suggested on getframework(), but ordered by framework description.
418 build a HTML select with the following code :
420 =head3 in PERL SCRIPT
422 $template->param( frameworkloop => GetFrameworksLoop( $frameworkcode ) );
426 Same as getframework()
428 <form action="[% script_name %] method=post>
429 <select name="frameworkcode">
430 <option value="">Default</option>
431 [% FOREACH framework IN frameworkloop %]
432 [% IF ( framework.selected ) %]
433 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
435 <option value="[% framework.value %]">[% framework.description %]</option>
439 <input type=text name=searchfield value="[% searchfield %]">
440 <input type="submit" value="OK" class="button">
445 sub GetFrameworksLoop {
446 my $frameworkcode = shift;
447 my $frameworks = getframeworks();
449 foreach my $thisframework (sort { uc($frameworks->{$a}->{'frameworktext'}) cmp uc($frameworks->{$b}->{'frameworktext'}) } keys %$frameworks) {
450 my $selected = ( $thisframework eq $frameworkcode ) ? 1 : undef;
452 value => $thisframework,
453 selected => $selected,
454 description => $frameworks->{$thisframework}->{'frameworktext'},
456 push @frameworkloop, \%row;
458 return \@frameworkloop;
461 =head2 getframeworkinfo
463 $frameworkinfo = &getframeworkinfo($frameworkcode);
465 Returns information about an frameworkcode.
469 sub getframeworkinfo {
470 my ($frameworkcode) = @_;
471 my $dbh = C4::Context->dbh;
473 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
474 $sth->execute($frameworkcode);
475 my $res = $sth->fetchrow_hashref;
479 =head2 getitemtypeinfo
481 $itemtype = &getitemtypeinfo($itemtype, [$interface]);
483 Returns information about an itemtype. The optional $interface argument
484 sets which interface ('opac' or 'intranet') to return the imageurl for.
485 Defaults to intranet.
489 sub getitemtypeinfo {
490 my ($itemtype, $interface) = @_;
491 my $dbh = C4::Context->dbh;
492 require C4::Languages;
493 my $language = C4::Languages::getlanguage();
494 my $it = $dbh->selectrow_hashref(q|
497 itemtypes.description,
498 itemtypes.rentalcharge,
499 itemtypes.notforloan,
502 itemtypes.checkinmsg,
503 itemtypes.checkinmsgtype,
504 itemtypes.sip_media_type,
505 COALESCE( localization.translation, itemtypes.description ) AS translated_description
507 LEFT JOIN localization ON itemtypes.itemtype = localization.code
508 AND localization.entity = 'itemtypes'
509 AND localization.lang = ?
510 WHERE itemtypes.itemtype = ?
511 |, undef, $language, $itemtype );
513 $it->{imageurl} = getitemtypeimagelocation( ( ( defined $interface && $interface eq 'opac' ) ? 'opac' : 'intranet' ), $it->{imageurl} );
518 =head2 getitemtypeimagedir
520 my $directory = getitemtypeimagedir( 'opac' );
522 pass in 'opac' or 'intranet'. Defaults to 'opac'.
524 returns the full path to the appropriate directory containing images.
528 sub getitemtypeimagedir {
529 my $src = shift || 'opac';
530 if ($src eq 'intranet') {
531 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
533 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
537 sub getitemtypeimagesrc {
538 my $src = shift || 'opac';
539 if ($src eq 'intranet') {
540 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
542 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
546 sub getitemtypeimagelocation {
547 my ( $src, $image ) = @_;
549 return '' if ( !$image );
552 my $scheme = ( URI::Split::uri_split( $image ) )[0];
554 return $image if ( $scheme );
556 return getitemtypeimagesrc( $src ) . '/' . $image;
559 =head3 _getImagesFromDirectory
561 Find all of the image files in a directory in the filesystem
563 parameters: a directory name
565 returns: a list of images in that directory.
567 Notes: this does not traverse into subdirectories. See
568 _getSubdirectoryNames for help with that.
569 Images are assumed to be files with .gif or .png file extensions.
570 The image names returned do not have the directory name on them.
574 sub _getImagesFromDirectory {
575 my $directoryname = shift;
576 return unless defined $directoryname;
577 return unless -d $directoryname;
579 if ( opendir ( my $dh, $directoryname ) ) {
580 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
582 @images = sort(@images);
585 warn "unable to opendir $directoryname: $!";
590 =head3 _getSubdirectoryNames
592 Find all of the directories in a directory in the filesystem
594 parameters: a directory name
596 returns: a list of subdirectories in that directory.
598 Notes: this does not traverse into subdirectories. Only the first
599 level of subdirectories are returned.
600 The directory names returned don't have the parent directory name on them.
604 sub _getSubdirectoryNames {
605 my $directoryname = shift;
606 return unless defined $directoryname;
607 return unless -d $directoryname;
609 if ( opendir ( my $dh, $directoryname ) ) {
610 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
614 warn "unable to opendir $directoryname: $!";
621 returns: a listref of hashrefs. Each hash represents another collection of images.
623 { imagesetname => 'npl', # the name of the image set (npl is the original one)
624 images => listref of image hashrefs
627 each image is represented by a hashref like this:
629 { KohaImage => 'npl/image.gif',
630 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
631 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
632 checked => 0 or 1: was this the image passed to this method?
633 Note: I'd like to remove this somehow.
640 my $checked = $params{'checked'} || '';
642 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
643 url => getitemtypeimagesrc('intranet'),
645 opac => { filesystem => getitemtypeimagedir('opac'),
646 url => getitemtypeimagesrc('opac'),
650 my @imagesets = (); # list of hasrefs of image set data to pass to template
651 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
652 foreach my $imagesubdir ( @subdirectories ) {
653 warn $imagesubdir if $DEBUG;
654 my @imagelist = (); # hashrefs of image info
655 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
656 my $imagesetactive = 0;
657 foreach my $thisimage ( @imagenames ) {
659 { KohaImage => "$imagesubdir/$thisimage",
660 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
661 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
662 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
665 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
667 push @imagesets, { imagesetname => $imagesubdir,
668 imagesetactive => $imagesetactive,
669 images => \@imagelist };
677 $printers = &GetPrinters();
678 @queues = keys %$printers;
680 Returns information about existing printer queues.
682 C<$printers> is a reference-to-hash whose keys are the print queues
683 defined in the printers table of the Koha database. The values are
684 references-to-hash, whose keys are the fields in the printers table.
690 my $dbh = C4::Context->dbh;
691 my $sth = $dbh->prepare("select * from printers");
693 while ( my $printer = $sth->fetchrow_hashref ) {
694 $printers{ $printer->{'printqueue'} } = $printer;
696 return ( \%printers );
701 $printer = GetPrinter( $query, $printers );
706 my ( $query, $printers ) = @_; # get printer for this query from printers
707 my $printer = $query->param('printer');
708 my %cookie = $query->cookie('userenv');
709 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
710 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
716 Returns the number of pages to display in a pagination bar, given the number
717 of items and the number of items per page.
722 my ( $nb_items, $nb_items_per_page ) = @_;
724 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
729 (@themes) = &getallthemes('opac');
730 (@themes) = &getallthemes('intranet');
732 Returns an array of all available themes.
740 if ( $type eq 'intranet' ) {
741 $htdocs = C4::Context->config('intrahtdocs');
744 $htdocs = C4::Context->config('opachtdocs');
746 opendir D, "$htdocs";
747 my @dirlist = readdir D;
748 foreach my $directory (@dirlist) {
749 next if $directory eq 'lib';
750 -d "$htdocs/$directory/en" and push @themes, $directory;
757 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
762 tags => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
768 tags => [ qw/ 607a / ],
774 tags => [ qw/ 500a 501a 503a / ],
780 tags => [ qw/ 700ab 701ab 702ab / ],
781 sep => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
786 tags => [ qw/ 225a / ],
792 tags => [ qw/ 995e / ],
796 unless ( C4::Context->preference("singleBranchMode")
797 || Koha::Libraries->search->count == 1 )
799 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
800 if ( $DisplayLibraryFacets eq 'both'
801 || $DisplayLibraryFacets eq 'holding' )
806 idx => 'holdingbranch',
807 label => 'HoldingLibrary',
808 tags => [qw / 995c /],
813 if ( $DisplayLibraryFacets eq 'both'
814 || $DisplayLibraryFacets eq 'home' )
820 label => 'HomeLibrary',
821 tags => [qw / 995b /],
832 tags => [ qw/ 650a / ],
837 # label => 'People and Organizations',
838 # tags => [ qw/ 600a 610a 611a / ],
844 tags => [ qw/ 651a / ],
850 tags => [ qw/ 630a / ],
856 tags => [ qw/ 100a 110a 700a / ],
862 tags => [ qw/ 440a 490a / ],
867 label => 'ItemTypes',
868 tags => [ qw/ 952y 942c / ],
874 tags => [ qw / 952c / ],
878 unless ( C4::Context->preference("singleBranchMode")
879 || Koha::Libraries->search->count == 1 )
881 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
882 if ( $DisplayLibraryFacets eq 'both'
883 || $DisplayLibraryFacets eq 'holding' )
888 idx => 'holdingbranch',
889 label => 'HoldingLibrary',
890 tags => [qw / 952b /],
895 if ( $DisplayLibraryFacets eq 'both'
896 || $DisplayLibraryFacets eq 'home' )
902 label => 'HomeLibrary',
903 tags => [qw / 952a /],
914 Return a href where a key is associated to a href. You give a query,
915 the name of the key among the fields returned by the query. If you
916 also give as third argument the name of the value, the function
917 returns a href of scalar. The optional 4th argument is an arrayref of
918 items passed to the C<execute()> call. It is designed to bind
919 parameters to any placeholders in your SQL.
928 # generic href of any information on the item, href of href.
929 my $iteminfos_of = get_infos_of($query, 'itemnumber');
930 print $iteminfos_of->{$itemnumber}{barcode};
932 # specific information, href of scalar
933 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
934 print $barcode_of_item->{$itemnumber};
939 my ( $query, $key_name, $value_name, $bind_params ) = @_;
941 my $dbh = C4::Context->dbh;
943 my $sth = $dbh->prepare($query);
944 $sth->execute( @$bind_params );
947 while ( my $row = $sth->fetchrow_hashref ) {
948 if ( defined $value_name ) {
949 $infos_of{ $row->{$key_name} } = $row->{$value_name};
952 $infos_of{ $row->{$key_name} } = $row;
960 =head2 get_notforloan_label_of
962 my $notforloan_label_of = get_notforloan_label_of();
964 Each authorised value of notforloan (information available in items and
965 itemtypes) is link to a single label.
967 Returns a href where keys are authorised values and values are corresponding
970 foreach my $authorised_value (keys %{$notforloan_label_of}) {
972 "authorised_value: %s => %s\n",
974 $notforloan_label_of->{$authorised_value}
980 # FIXME - why not use GetAuthorisedValues ??
982 sub get_notforloan_label_of {
983 my $dbh = C4::Context->dbh;
986 SELECT authorised_value
987 FROM marc_subfield_structure
988 WHERE kohafield = \'items.notforloan\'
991 my $sth = $dbh->prepare($query);
993 my ($statuscode) = $sth->fetchrow_array();
998 FROM authorised_values
1001 $sth = $dbh->prepare($query);
1002 $sth->execute($statuscode);
1003 my %notforloan_label_of;
1004 while ( my $row = $sth->fetchrow_hashref ) {
1005 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
1009 return \%notforloan_label_of;
1012 =head2 displayServers
1014 my $servers = displayServers();
1015 my $servers = displayServers( $position );
1016 my $servers = displayServers( $position, $type );
1018 displayServers returns a listref of hashrefs, each containing
1019 information about available z3950 servers. Each hashref has a format
1023 'checked' => 'checked',
1024 'encoding' => 'utf8',
1026 'id' => 'LIBRARY OF CONGRESS',
1030 'value' => 'lx2.loc.gov:210/',
1036 sub displayServers {
1037 my ( $position, $type ) = @_;
1038 my $dbh = C4::Context->dbh;
1040 my $strsth = 'SELECT * FROM z3950servers';
1045 push @bind_params, $position;
1046 push @where_clauses, ' position = ? ';
1050 push @bind_params, $type;
1051 push @where_clauses, ' type = ? ';
1054 # reassemble where clause from where clause pieces
1055 if (@where_clauses) {
1056 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1059 my $rq = $dbh->prepare($strsth);
1060 $rq->execute(@bind_params);
1061 my @primaryserverloop;
1063 while ( my $data = $rq->fetchrow_hashref ) {
1064 push @primaryserverloop,
1065 { label => $data->{description},
1066 id => $data->{name},
1068 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1069 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1070 checked => "checked",
1071 icon => $data->{icon},
1072 zed => $data->{type} eq 'zed',
1073 opensearch => $data->{type} eq 'opensearch'
1076 return \@primaryserverloop;
1079 =head2 GetAuthValCode
1081 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1085 sub GetAuthValCode {
1086 my ($kohafield,$fwcode) = @_;
1087 my $dbh = C4::Context->dbh;
1088 $fwcode='' unless $fwcode;
1089 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1090 $sth->execute($kohafield,$fwcode);
1091 my ($authvalcode) = $sth->fetchrow_array;
1092 return $authvalcode;
1095 =head2 GetAuthValCodeFromField
1097 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1099 C<$subfield> can be undefined
1103 sub GetAuthValCodeFromField {
1104 my ($field,$subfield,$fwcode) = @_;
1105 my $dbh = C4::Context->dbh;
1106 $fwcode='' unless $fwcode;
1108 if (defined $subfield) {
1109 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1110 $sth->execute($field,$subfield,$fwcode);
1112 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1113 $sth->execute($field,$fwcode);
1115 my ($authvalcode) = $sth->fetchrow_array;
1116 return $authvalcode;
1119 =head2 GetAuthorisedValues
1121 $authvalues = GetAuthorisedValues([$category], [$selected]);
1123 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1125 C<$category> returns authorised values for just one category (optional).
1127 C<$selected> adds a "selected => 1" entry to the hash if the
1128 authorised_value matches it. B<NOTE:> this feature should be considered
1129 deprecated as it may be removed in the future.
1131 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1135 sub GetAuthorisedValues {
1136 my ( $category, $selected, $opac ) = @_;
1138 # TODO: the "selected" feature should be replaced by a utility function
1139 # somewhere else, it doesn't belong in here. For starters it makes
1140 # caching much more complicated. Or just let the UI logic handle it, it's
1143 # Is this cached already?
1144 $opac = $opac ? 1 : 0; # normalise to be safe
1146 C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1147 my $selected_key = defined($selected) ? $selected : '';
1149 "AuthorisedValues-$category-$selected_key-$opac-$branch_limit";
1150 my $cache = Koha::Cache->get_instance();
1151 my $result = $cache->get_from_cache($cache_key);
1152 return $result if $result;
1155 my $dbh = C4::Context->dbh;
1158 FROM authorised_values
1161 LEFT JOIN authorised_values_branches ON ( id = av_id )
1166 push @where_strings, "category = ?";
1167 push @where_args, $category;
1170 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
1171 push @where_args, $branch_limit;
1173 if(@where_strings > 0) {
1174 $query .= " WHERE " . join(" AND ", @where_strings);
1176 $query .= " GROUP BY lib";
1177 $query .= ' ORDER BY category, ' . (
1178 $opac ? 'COALESCE(lib_opac, lib)'
1182 my $sth = $dbh->prepare($query);
1184 $sth->execute( @where_args );
1185 while (my $data=$sth->fetchrow_hashref) {
1186 if ( defined $selected and $selected eq $data->{authorised_value} ) {
1187 $data->{selected} = 1;
1190 $data->{selected} = 0;
1193 if ($opac && $data->{lib_opac}) {
1194 $data->{lib} = $data->{lib_opac};
1196 push @results, $data;
1200 # We can't cache for long because of that "selected" thing which
1201 # makes it impossible to clear the cache without iterating through every
1202 # value, which sucks. This'll cover this request, and not a whole lot more.
1203 $cache->set_in_cache( $cache_key, \@results, { deepcopy => 1, expiry => 5 } );
1207 =head2 GetAuthorisedValueCategories
1209 $auth_categories = GetAuthorisedValueCategories();
1211 Return an arrayref of all of the available authorised
1216 sub GetAuthorisedValueCategories {
1217 my $dbh = C4::Context->dbh;
1218 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1221 while (defined (my $category = $sth->fetchrow_array) ) {
1222 push @results, $category;
1227 =head2 IsAuthorisedValueCategory
1229 $is_auth_val_category = IsAuthorisedValueCategory($category);
1231 Returns whether a given category name is a valid one
1235 sub IsAuthorisedValueCategory {
1236 my $category = shift;
1239 FROM authorised_values
1243 my $sth = C4::Context->dbh->prepare($query);
1244 $sth->execute($category);
1245 $sth->fetchrow ? return 1
1249 =head2 GetAuthorisedValueByCode
1251 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1253 Return the lib attribute from authorised_values from the row identified
1254 by the passed category and code
1258 sub GetAuthorisedValueByCode {
1259 my ( $category, $authvalcode, $opac ) = @_;
1261 my $field = $opac ? 'lib_opac' : 'lib';
1262 my $dbh = C4::Context->dbh;
1263 my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1264 $sth->execute( $category, $authvalcode );
1265 while ( my $data = $sth->fetchrow_hashref ) {
1266 return $data->{ $field };
1270 =head2 GetKohaAuthorisedValues
1272 Takes $kohafield, $fwcode as parameters.
1274 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1276 Returns hashref of Code => description
1278 Returns undef if no authorised value category is defined for the kohafield.
1282 sub GetKohaAuthorisedValues {
1283 my ($kohafield,$fwcode,$opac) = @_;
1284 $fwcode='' unless $fwcode;
1286 my $dbh = C4::Context->dbh;
1287 my $avcode = GetAuthValCode($kohafield,$fwcode);
1289 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1290 $sth->execute($avcode);
1291 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1292 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1300 =head2 GetKohaAuthorisedValuesFromField
1302 Takes $field, $subfield, $fwcode as parameters.
1304 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1305 $subfield can be undefined
1307 Returns hashref of Code => description
1309 Returns undef if no authorised value category is defined for the given field and subfield
1313 sub GetKohaAuthorisedValuesFromField {
1314 my ($field, $subfield, $fwcode,$opac) = @_;
1315 $fwcode='' unless $fwcode;
1317 my $dbh = C4::Context->dbh;
1318 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1320 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1321 $sth->execute($avcode);
1322 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1323 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1331 =head2 GetKohaAuthorisedValuesMapping
1333 Takes a hash as a parameter. The interface key indicates the
1334 description to use in the mapping.
1337 "{kohafield},{frameworkcode},{authorised_value}" => "{description}"
1338 for all the kohafields, frameworkcodes, and authorised values.
1340 Returns undef if nothing is found.
1344 sub GetKohaAuthorisedValuesMapping {
1345 my ($parameter) = @_;
1346 my $interface = $parameter->{'interface'} // '';
1348 my $query_mapping = q{
1349 SELECT TA.kohafield,TA.authorised_value AS category,
1350 TA.frameworkcode,TB.authorised_value,
1351 IF(TB.lib_opac>'',TB.lib_opac,TB.lib) AS OPAC,
1352 TB.lib AS Intranet,TB.lib_opac
1353 FROM marc_subfield_structure AS TA JOIN
1354 authorised_values as TB ON
1355 TA.authorised_value=TB.category
1356 WHERE TA.kohafield>'' AND TA.authorised_value>'';
1358 my $dbh = C4::Context->dbh;
1359 my $sth = $dbh->prepare($query_mapping);
1362 if ($interface eq 'opac') {
1363 while (my $row = $sth->fetchrow_hashref) {
1364 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{OPAC};
1368 while (my $row = $sth->fetchrow_hashref) {
1369 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{Intranet};
1377 my $escaped_string = C4::Koha::xml_escape($string);
1379 Convert &, <, >, ', and " in a string to XML entities
1385 return '' unless defined $str;
1386 $str =~ s/&/&/g;
1389 $str =~ s/'/'/g;
1390 $str =~ s/"/"/g;
1394 =head2 GetKohaAuthorisedValueLib
1396 Takes $category, $authorised_value as parameters.
1398 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1400 Returns authorised value description
1404 sub GetKohaAuthorisedValueLib {
1405 my ($category,$authorised_value,$opac) = @_;
1407 my $dbh = C4::Context->dbh;
1408 my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1409 $sth->execute($category,$authorised_value);
1410 my $data = $sth->fetchrow_hashref;
1411 $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'};
1415 =head2 AddAuthorisedValue
1417 AddAuthorisedValue($category, $authorised_value, $lib, $lib_opac, $imageurl);
1419 Create a new authorised value.
1423 sub AddAuthorisedValue {
1424 my ($category, $authorised_value, $lib, $lib_opac, $imageurl) = @_;
1426 my $dbh = C4::Context->dbh;
1428 INSERT INTO authorised_values (category, authorised_value, lib, lib_opac, imageurl)
1431 my $sth = $dbh->prepare($query);
1432 $sth->execute($category, $authorised_value, $lib, $lib_opac, $imageurl);
1435 =head2 display_marc_indicators
1437 my $display_form = C4::Koha::display_marc_indicators($field);
1439 C<$field> is a MARC::Field object
1441 Generate a display form of the indicators of a variable
1442 MARC field, replacing any blanks with '#'.
1446 sub display_marc_indicators {
1448 my $indicators = '';
1449 if ($field && $field->tag() >= 10) {
1450 $indicators = $field->indicator(1) . $field->indicator(2);
1451 $indicators =~ s/ /#/g;
1456 sub GetNormalizedUPC {
1457 my ($marcrecord,$marcflavour) = @_;
1459 return unless $marcrecord;
1460 if ($marcflavour eq 'UNIMARC') {
1461 my @fields = $marcrecord->field('072');
1462 foreach my $field (@fields) {
1463 my $upc = _normalize_match_point($field->subfield('a'));
1470 else { # assume marc21 if not unimarc
1471 my @fields = $marcrecord->field('024');
1472 foreach my $field (@fields) {
1473 my $indicator = $field->indicator(1);
1474 my $upc = _normalize_match_point($field->subfield('a'));
1475 if ($upc && $indicator == 1 ) {
1482 # Normalizes and returns the first valid ISBN found in the record
1483 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1484 sub GetNormalizedISBN {
1485 my ($isbn,$marcrecord,$marcflavour) = @_;
1487 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1488 # anything after " | " should be removed, along with the delimiter
1489 ($isbn) = split(/\|/, $isbn );
1490 return _isbn_cleanup($isbn);
1493 return unless $marcrecord;
1495 if ($marcflavour eq 'UNIMARC') {
1496 my @fields = $marcrecord->field('010');
1497 foreach my $field (@fields) {
1498 my $isbn = $field->subfield('a');
1500 return _isbn_cleanup($isbn);
1504 else { # assume marc21 if not unimarc
1505 my @fields = $marcrecord->field('020');
1506 foreach my $field (@fields) {
1507 $isbn = $field->subfield('a');
1509 return _isbn_cleanup($isbn);
1515 sub GetNormalizedEAN {
1516 my ($marcrecord,$marcflavour) = @_;
1518 return unless $marcrecord;
1520 if ($marcflavour eq 'UNIMARC') {
1521 my @fields = $marcrecord->field('073');
1522 foreach my $field (@fields) {
1523 my $ean = _normalize_match_point($field->subfield('a'));
1529 else { # assume marc21 if not unimarc
1530 my @fields = $marcrecord->field('024');
1531 foreach my $field (@fields) {
1532 my $indicator = $field->indicator(1);
1533 my $ean = _normalize_match_point($field->subfield('a'));
1534 if ( $ean && $indicator == 3 ) {
1541 sub GetNormalizedOCLCNumber {
1542 my ($marcrecord,$marcflavour) = @_;
1543 return unless $marcrecord;
1545 if ($marcflavour ne 'UNIMARC' ) {
1546 my @fields = $marcrecord->field('035');
1547 foreach my $field (@fields) {
1548 my $oclc = $field->subfield('a');
1549 if ($oclc =~ /OCoLC/) {
1550 $oclc =~ s/\(OCoLC\)//;
1560 sub GetAuthvalueDropbox {
1561 my ( $authcat, $default ) = @_;
1562 my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1563 my $dbh = C4::Context->dbh;
1567 FROM authorised_values
1570 LEFT JOIN authorised_values_branches ON ( id = av_id )
1575 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1576 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1577 my $sth = $dbh->prepare($query);
1578 $sth->execute( $authcat, $branch_limit ? $branch_limit : () );
1581 my $option_list = [];
1582 my @authorised_values = ( q{} );
1583 while (my $av = $sth->fetchrow_hashref) {
1584 push @{$option_list}, {
1585 value => $av->{authorised_value},
1586 label => $av->{lib},
1587 default => ($default eq $av->{authorised_value}),
1591 if ( @{$option_list} ) {
1592 return $option_list;
1598 =head2 GetDailyQuote($opts)
1600 Takes a hashref of options
1602 Currently supported options are:
1604 'id' An exact quote id
1605 'random' Select a random quote
1606 noop When no option is passed in, this sub will return the quote timestamped for the current day
1608 The function returns an anonymous hash following this format:
1611 'source' => 'source-of-quote',
1612 'timestamp' => 'timestamp-value',
1613 'text' => 'text-of-quote',
1619 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1620 # at least for default option
1624 my $dbh = C4::Context->dbh;
1629 $query = 'SELECT * FROM quotes WHERE id = ?';
1630 $sth = $dbh->prepare($query);
1631 $sth->execute($opts{'id'});
1632 $quote = $sth->fetchrow_hashref();
1634 elsif ($opts{'random'}) {
1635 # Fall through... we also return a random quote as a catch-all if all else fails
1638 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1639 $sth = $dbh->prepare($query);
1641 $quote = $sth->fetchrow_hashref();
1643 unless ($quote) { # if there are not matches, choose a random quote
1644 # get a list of all available quote ids
1645 $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1647 my $range = ($sth->fetchrow_array)[0];
1648 # chose a random id within that range if there is more than one quote
1649 my $offset = int(rand($range));
1651 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1652 $sth = C4::Context->dbh->prepare($query);
1653 # see http://www.perlmonks.org/?node_id=837422 for why
1654 # we're being verbose and using bind_param
1655 $sth->bind_param(1, $offset, SQL_INTEGER);
1657 $quote = $sth->fetchrow_hashref();
1658 # update the timestamp for that quote
1659 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1660 $sth = C4::Context->dbh->prepare($query);
1662 DateTime::Format::MySQL->format_datetime( dt_from_string() ),
1669 sub _normalize_match_point {
1670 my $match_point = shift;
1671 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1672 $normalized_match_point =~ s/-//g;
1674 return $normalized_match_point;
1679 return NormalizeISBN(
1682 format => 'ISBN-10',
1688 =head2 NormalizedISBN
1690 my $isbns = NormalizedISBN({
1692 strip_hyphens => [0,1],
1693 format => ['ISBN-10', 'ISBN-13']
1696 Returns an isbn validated by Business::ISBN.
1697 Optionally strips hyphens and/or forces the isbn
1698 to be of the specified format.
1700 If the string cannot be validated as an isbn,
1708 my $string = $params->{isbn};
1709 my $strip_hyphens = $params->{strip_hyphens};
1710 my $format = $params->{format};
1712 return unless $string;
1714 my $isbn = Business::ISBN->new($string);
1716 if ( $isbn && $isbn->is_valid() ) {
1718 if ( $format eq 'ISBN-10' ) {
1719 $isbn = $isbn->as_isbn10();
1721 elsif ( $format eq 'ISBN-13' ) {
1722 $isbn = $isbn->as_isbn13();
1724 return unless $isbn;
1726 if ($strip_hyphens) {
1727 $string = $isbn->as_string( [] );
1729 $string = $isbn->as_string();
1736 =head2 GetVariationsOfISBN
1738 my @isbns = GetVariationsOfISBN( $isbn );
1740 Returns a list of variations of the given isbn in
1741 both ISBN-10 and ISBN-13 formats, with and without
1744 In a scalar context, the isbns are returned as a
1745 string delimited by ' | '.
1749 sub GetVariationsOfISBN {
1752 return unless $isbn;
1756 push( @isbns, NormalizeISBN({ isbn => $isbn }) );
1757 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
1758 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
1759 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
1760 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
1762 # Strip out any "empty" strings from the array
1763 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1765 return wantarray ? @isbns : join( " | ", @isbns );
1768 =head2 GetVariationsOfISBNs
1770 my @isbns = GetVariationsOfISBNs( @isbns );
1772 Returns a list of variations of the given isbns in
1773 both ISBN-10 and ISBN-13 formats, with and without
1776 In a scalar context, the isbns are returned as a
1777 string delimited by ' | '.
1781 sub GetVariationsOfISBNs {
1784 @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
1786 return wantarray ? @isbns : join( " | ", @isbns );
1789 =head2 IsKohaFieldLinked
1791 my $is_linked = IsKohaFieldLinked({
1792 kohafield => $kohafield,
1793 frameworkcode => $frameworkcode,
1796 Return 1 if the field is linked
1800 sub IsKohaFieldLinked {
1801 my ( $params ) = @_;
1802 my $kohafield = $params->{kohafield};
1803 my $frameworkcode = $params->{frameworkcode} || '';
1804 my $dbh = C4::Context->dbh;
1805 my $is_linked = $dbh->selectcol_arrayref( q|
1807 FROM marc_subfield_structure
1808 WHERE frameworkcode = ?
1810 |,{}, $frameworkcode, $kohafield );
1811 return $is_linked->[0];