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 qw(GetBranchesCount);
29 use Koha::DateUtils qw(dt_from_string);
30 use DateTime::Format::MySQL;
32 use autouse 'Data::cselectall_arrayref' => qw(Dumper);
33 use DBI qw(:sql_types);
34 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $DEBUG);
37 $VERSION = 3.07.00.049;
42 &subfield_is_koha_internal_p
43 &GetPrinters &GetPrinter
44 &GetItemTypes &getitemtypeinfo
45 &GetItemTypesCategorized &GetItemTypesByCategory
46 &GetSupportName &GetSupportList
48 &getframeworks &getframeworkinfo
55 &get_notforloan_label_of
58 &getitemtypeimagelocation
60 &GetAuthorisedValueCategories
61 &IsAuthorisedValueCategory
62 &GetKohaAuthorisedValues
63 &GetKohaAuthorisedValuesFromField
64 &GetKohaAuthorisedValuesMapping
65 &GetKohaAuthorisedValueLib
66 &GetAuthorisedValueByCode
67 &GetKohaImageurlFromAuthorisedValues
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...
253 my $dbh = C4::Context->dbh;
257 itemtypes.description,
258 itemtypes.rentalcharge,
259 itemtypes.notforloan,
262 itemtypes.checkinmsg,
263 itemtypes.checkinmsgtype,
264 itemtypes.sip_media_type,
265 itemtypes.hideinopac,
266 itemtypes.searchcategory,
267 COALESCE( localization.translation, itemtypes.description ) AS translated_description
269 LEFT JOIN localization ON itemtypes.itemtype = localization.code
270 AND localization.entity = 'itemtypes'
271 AND localization.lang = ?
274 my $sth = $dbh->prepare($query);
275 $sth->execute( $language );
277 if ( $style eq 'hash' ) {
278 while ( my $IT = $sth->fetchrow_hashref ) {
279 $itemtypes{ $IT->{'itemtype'} } = $IT;
281 return ( \%itemtypes );
283 return $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 || GetBranchesCount() == 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 || GetBranchesCount() == 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;
1080 =head2 GetKohaImageurlFromAuthorisedValues
1082 $authhorised_value = GetKohaImageurlFromAuthorisedValues( $category, $authvalcode );
1084 Return the first url of the authorised value image represented by $lib.
1088 sub GetKohaImageurlFromAuthorisedValues {
1089 my ( $category, $lib ) = @_;
1090 my $dbh = C4::Context->dbh;
1091 my $sth = $dbh->prepare("SELECT imageurl FROM authorised_values WHERE category=? AND lib =?");
1092 $sth->execute( $category, $lib );
1093 while ( my $data = $sth->fetchrow_hashref ) {
1094 return $data->{'imageurl'};
1098 =head2 GetAuthValCode
1100 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1104 sub GetAuthValCode {
1105 my ($kohafield,$fwcode) = @_;
1106 my $dbh = C4::Context->dbh;
1107 $fwcode='' unless $fwcode;
1108 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1109 $sth->execute($kohafield,$fwcode);
1110 my ($authvalcode) = $sth->fetchrow_array;
1111 return $authvalcode;
1114 =head2 GetAuthValCodeFromField
1116 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1118 C<$subfield> can be undefined
1122 sub GetAuthValCodeFromField {
1123 my ($field,$subfield,$fwcode) = @_;
1124 my $dbh = C4::Context->dbh;
1125 $fwcode='' unless $fwcode;
1127 if (defined $subfield) {
1128 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1129 $sth->execute($field,$subfield,$fwcode);
1131 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1132 $sth->execute($field,$fwcode);
1134 my ($authvalcode) = $sth->fetchrow_array;
1135 return $authvalcode;
1138 =head2 GetAuthorisedValues
1140 $authvalues = GetAuthorisedValues([$category], [$selected]);
1142 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1144 C<$category> returns authorised values for just one category (optional).
1146 C<$selected> adds a "selected => 1" entry to the hash if the
1147 authorised_value matches it. B<NOTE:> this feature should be considered
1148 deprecated as it may be removed in the future.
1150 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1154 sub GetAuthorisedValues {
1155 my ( $category, $selected, $opac ) = @_;
1157 # TODO: the "selected" feature should be replaced by a utility function
1158 # somewhere else, it doesn't belong in here. For starters it makes
1159 # caching much more complicated. Or just let the UI logic handle it, it's
1162 # Is this cached already?
1163 $opac = $opac ? 1 : 0; # normalise to be safe
1165 C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1166 my $selected_key = defined($selected) ? $selected : '';
1168 "AuthorisedValues-$category-$selected_key-$opac-$branch_limit";
1169 my $cache = Koha::Cache->get_instance();
1170 my $result = $cache->get_from_cache($cache_key);
1171 return $result if $result;
1174 my $dbh = C4::Context->dbh;
1177 FROM authorised_values
1180 LEFT JOIN authorised_values_branches ON ( id = av_id )
1185 push @where_strings, "category = ?";
1186 push @where_args, $category;
1189 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
1190 push @where_args, $branch_limit;
1192 if(@where_strings > 0) {
1193 $query .= " WHERE " . join(" AND ", @where_strings);
1195 $query .= " GROUP BY lib";
1196 $query .= ' ORDER BY category, ' . (
1197 $opac ? 'COALESCE(lib_opac, lib)'
1201 my $sth = $dbh->prepare($query);
1203 $sth->execute( @where_args );
1204 while (my $data=$sth->fetchrow_hashref) {
1205 if ( defined $selected and $selected eq $data->{authorised_value} ) {
1206 $data->{selected} = 1;
1209 $data->{selected} = 0;
1212 if ($opac && $data->{lib_opac}) {
1213 $data->{lib} = $data->{lib_opac};
1215 push @results, $data;
1219 # We can't cache for long because of that "selected" thing which
1220 # makes it impossible to clear the cache without iterating through every
1221 # value, which sucks. This'll cover this request, and not a whole lot more.
1222 $cache->set_in_cache( $cache_key, \@results, { deepcopy => 1, expiry => 5 } );
1226 =head2 GetAuthorisedValueCategories
1228 $auth_categories = GetAuthorisedValueCategories();
1230 Return an arrayref of all of the available authorised
1235 sub GetAuthorisedValueCategories {
1236 my $dbh = C4::Context->dbh;
1237 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1240 while (defined (my $category = $sth->fetchrow_array) ) {
1241 push @results, $category;
1246 =head2 IsAuthorisedValueCategory
1248 $is_auth_val_category = IsAuthorisedValueCategory($category);
1250 Returns whether a given category name is a valid one
1254 sub IsAuthorisedValueCategory {
1255 my $category = shift;
1258 FROM authorised_values
1262 my $sth = C4::Context->dbh->prepare($query);
1263 $sth->execute($category);
1264 $sth->fetchrow ? return 1
1268 =head2 GetAuthorisedValueByCode
1270 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1272 Return the lib attribute from authorised_values from the row identified
1273 by the passed category and code
1277 sub GetAuthorisedValueByCode {
1278 my ( $category, $authvalcode, $opac ) = @_;
1280 my $field = $opac ? 'lib_opac' : 'lib';
1281 my $dbh = C4::Context->dbh;
1282 my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1283 $sth->execute( $category, $authvalcode );
1284 while ( my $data = $sth->fetchrow_hashref ) {
1285 return $data->{ $field };
1289 =head2 GetKohaAuthorisedValues
1291 Takes $kohafield, $fwcode as parameters.
1293 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1295 Returns hashref of Code => description
1297 Returns undef if no authorised value category is defined for the kohafield.
1301 sub GetKohaAuthorisedValues {
1302 my ($kohafield,$fwcode,$opac) = @_;
1303 $fwcode='' unless $fwcode;
1305 my $dbh = C4::Context->dbh;
1306 my $avcode = GetAuthValCode($kohafield,$fwcode);
1308 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1309 $sth->execute($avcode);
1310 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1311 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1319 =head2 GetKohaAuthorisedValuesFromField
1321 Takes $field, $subfield, $fwcode as parameters.
1323 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1324 $subfield can be undefined
1326 Returns hashref of Code => description
1328 Returns undef if no authorised value category is defined for the given field and subfield
1332 sub GetKohaAuthorisedValuesFromField {
1333 my ($field, $subfield, $fwcode,$opac) = @_;
1334 $fwcode='' unless $fwcode;
1336 my $dbh = C4::Context->dbh;
1337 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1339 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1340 $sth->execute($avcode);
1341 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1342 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1350 =head2 GetKohaAuthorisedValuesMapping
1352 Takes a hash as a parameter. The interface key indicates the
1353 description to use in the mapping.
1356 "{kohafield},{frameworkcode},{authorised_value}" => "{description}"
1357 for all the kohafields, frameworkcodes, and authorised values.
1359 Returns undef if nothing is found.
1363 sub GetKohaAuthorisedValuesMapping {
1364 my ($parameter) = @_;
1365 my $interface = $parameter->{'interface'} // '';
1367 my $query_mapping = q{
1368 SELECT TA.kohafield,TA.authorised_value AS category,
1369 TA.frameworkcode,TB.authorised_value,
1370 IF(TB.lib_opac>'',TB.lib_opac,TB.lib) AS OPAC,
1371 TB.lib AS Intranet,TB.lib_opac
1372 FROM marc_subfield_structure AS TA JOIN
1373 authorised_values as TB ON
1374 TA.authorised_value=TB.category
1375 WHERE TA.kohafield>'' AND TA.authorised_value>'';
1377 my $dbh = C4::Context->dbh;
1378 my $sth = $dbh->prepare($query_mapping);
1381 if ($interface eq 'opac') {
1382 while (my $row = $sth->fetchrow_hashref) {
1383 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{OPAC};
1387 while (my $row = $sth->fetchrow_hashref) {
1388 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{Intranet};
1396 my $escaped_string = C4::Koha::xml_escape($string);
1398 Convert &, <, >, ', and " in a string to XML entities
1404 return '' unless defined $str;
1405 $str =~ s/&/&/g;
1408 $str =~ s/'/'/g;
1409 $str =~ s/"/"/g;
1413 =head2 GetKohaAuthorisedValueLib
1415 Takes $category, $authorised_value as parameters.
1417 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1419 Returns authorised value description
1423 sub GetKohaAuthorisedValueLib {
1424 my ($category,$authorised_value,$opac) = @_;
1426 my $dbh = C4::Context->dbh;
1427 my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1428 $sth->execute($category,$authorised_value);
1429 my $data = $sth->fetchrow_hashref;
1430 $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'};
1434 =head2 AddAuthorisedValue
1436 AddAuthorisedValue($category, $authorised_value, $lib, $lib_opac, $imageurl);
1438 Create a new authorised value.
1442 sub AddAuthorisedValue {
1443 my ($category, $authorised_value, $lib, $lib_opac, $imageurl) = @_;
1445 my $dbh = C4::Context->dbh;
1447 INSERT INTO authorised_values (category, authorised_value, lib, lib_opac, imageurl)
1450 my $sth = $dbh->prepare($query);
1451 $sth->execute($category, $authorised_value, $lib, $lib_opac, $imageurl);
1454 =head2 display_marc_indicators
1456 my $display_form = C4::Koha::display_marc_indicators($field);
1458 C<$field> is a MARC::Field object
1460 Generate a display form of the indicators of a variable
1461 MARC field, replacing any blanks with '#'.
1465 sub display_marc_indicators {
1467 my $indicators = '';
1468 if ($field->tag() >= 10) {
1469 $indicators = $field->indicator(1) . $field->indicator(2);
1470 $indicators =~ s/ /#/g;
1475 sub GetNormalizedUPC {
1476 my ($record,$marcflavour) = @_;
1479 if ($marcflavour eq 'UNIMARC') {
1480 @fields = $record->field('072');
1481 foreach my $field (@fields) {
1482 my $upc = _normalize_match_point($field->subfield('a'));
1489 else { # assume marc21 if not unimarc
1490 @fields = $record->field('024');
1491 foreach my $field (@fields) {
1492 my $indicator = $field->indicator(1);
1493 my $upc = _normalize_match_point($field->subfield('a'));
1494 if ($indicator == 1 and $upc ne '') {
1501 # Normalizes and returns the first valid ISBN found in the record
1502 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1503 sub GetNormalizedISBN {
1504 my ($isbn,$record,$marcflavour) = @_;
1507 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1508 # anything after " | " should be removed, along with the delimiter
1509 ($isbn) = split(/\|/, $isbn );
1510 return _isbn_cleanup($isbn);
1512 return unless $record;
1514 if ($marcflavour eq 'UNIMARC') {
1515 @fields = $record->field('010');
1516 foreach my $field (@fields) {
1517 my $isbn = $field->subfield('a');
1519 return _isbn_cleanup($isbn);
1525 else { # assume marc21 if not unimarc
1526 @fields = $record->field('020');
1527 foreach my $field (@fields) {
1528 $isbn = $field->subfield('a');
1530 return _isbn_cleanup($isbn);
1538 sub GetNormalizedEAN {
1539 my ($record,$marcflavour) = @_;
1542 if ($marcflavour eq 'UNIMARC') {
1543 @fields = $record->field('073');
1544 foreach my $field (@fields) {
1545 $ean = _normalize_match_point($field->subfield('a'));
1551 else { # assume marc21 if not unimarc
1552 @fields = $record->field('024');
1553 foreach my $field (@fields) {
1554 my $indicator = $field->indicator(1);
1555 $ean = _normalize_match_point($field->subfield('a'));
1556 if ($indicator == 3 and $ean ne '') {
1562 sub GetNormalizedOCLCNumber {
1563 my ($record,$marcflavour) = @_;
1566 if ($marcflavour eq 'UNIMARC') {
1567 # TODO: add UNIMARC fields
1569 else { # assume marc21 if not unimarc
1570 @fields = $record->field('035');
1571 foreach my $field (@fields) {
1572 $oclc = $field->subfield('a');
1573 if ($oclc =~ /OCoLC/) {
1574 $oclc =~ s/\(OCoLC\)//;
1583 sub GetAuthvalueDropbox {
1584 my ( $authcat, $default ) = @_;
1585 my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1586 my $dbh = C4::Context->dbh;
1590 FROM authorised_values
1593 LEFT JOIN authorised_values_branches ON ( id = av_id )
1598 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1599 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1600 my $sth = $dbh->prepare($query);
1601 $sth->execute( $authcat, $branch_limit ? $branch_limit : () );
1604 my $option_list = [];
1605 my @authorised_values = ( q{} );
1606 while (my $av = $sth->fetchrow_hashref) {
1607 push @{$option_list}, {
1608 value => $av->{authorised_value},
1609 label => $av->{lib},
1610 default => ($default eq $av->{authorised_value}),
1614 if ( @{$option_list} ) {
1615 return $option_list;
1621 =head2 GetDailyQuote($opts)
1623 Takes a hashref of options
1625 Currently supported options are:
1627 'id' An exact quote id
1628 'random' Select a random quote
1629 noop When no option is passed in, this sub will return the quote timestamped for the current day
1631 The function returns an anonymous hash following this format:
1634 'source' => 'source-of-quote',
1635 'timestamp' => 'timestamp-value',
1636 'text' => 'text-of-quote',
1642 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1643 # at least for default option
1647 my $dbh = C4::Context->dbh;
1652 $query = 'SELECT * FROM quotes WHERE id = ?';
1653 $sth = $dbh->prepare($query);
1654 $sth->execute($opts{'id'});
1655 $quote = $sth->fetchrow_hashref();
1657 elsif ($opts{'random'}) {
1658 # Fall through... we also return a random quote as a catch-all if all else fails
1661 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1662 $sth = $dbh->prepare($query);
1664 $quote = $sth->fetchrow_hashref();
1666 unless ($quote) { # if there are not matches, choose a random quote
1667 # get a list of all available quote ids
1668 $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1670 my $range = ($sth->fetchrow_array)[0];
1671 # chose a random id within that range if there is more than one quote
1672 my $offset = int(rand($range));
1674 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1675 $sth = C4::Context->dbh->prepare($query);
1676 # see http://www.perlmonks.org/?node_id=837422 for why
1677 # we're being verbose and using bind_param
1678 $sth->bind_param(1, $offset, SQL_INTEGER);
1680 $quote = $sth->fetchrow_hashref();
1681 # update the timestamp for that quote
1682 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1683 $sth = C4::Context->dbh->prepare($query);
1685 DateTime::Format::MySQL->format_datetime( dt_from_string() ),
1692 sub _normalize_match_point {
1693 my $match_point = shift;
1694 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1695 $normalized_match_point =~ s/-//g;
1697 return $normalized_match_point;
1702 return NormalizeISBN(
1705 format => 'ISBN-10',
1711 =head2 NormalizedISBN
1713 my $isbns = NormalizedISBN({
1715 strip_hyphens => [0,1],
1716 format => ['ISBN-10', 'ISBN-13']
1719 Returns an isbn validated by Business::ISBN.
1720 Optionally strips hyphens and/or forces the isbn
1721 to be of the specified format.
1723 If the string cannot be validated as an isbn,
1731 my $string = $params->{isbn};
1732 my $strip_hyphens = $params->{strip_hyphens};
1733 my $format = $params->{format};
1735 return unless $string;
1737 my $isbn = Business::ISBN->new($string);
1739 if ( $isbn && $isbn->is_valid() ) {
1741 if ( $format eq 'ISBN-10' ) {
1742 $isbn = $isbn->as_isbn10();
1744 elsif ( $format eq 'ISBN-13' ) {
1745 $isbn = $isbn->as_isbn13();
1747 return unless $isbn;
1749 if ($strip_hyphens) {
1750 $string = $isbn->as_string( [] );
1752 $string = $isbn->as_string();
1759 =head2 GetVariationsOfISBN
1761 my @isbns = GetVariationsOfISBN( $isbn );
1763 Returns a list of variations of the given isbn in
1764 both ISBN-10 and ISBN-13 formats, with and without
1767 In a scalar context, the isbns are returned as a
1768 string delimited by ' | '.
1772 sub GetVariationsOfISBN {
1775 return unless $isbn;
1779 push( @isbns, NormalizeISBN({ isbn => $isbn }) );
1780 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
1781 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
1782 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
1783 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
1785 # Strip out any "empty" strings from the array
1786 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1788 return wantarray ? @isbns : join( " | ", @isbns );
1791 =head2 GetVariationsOfISBNs
1793 my @isbns = GetVariationsOfISBNs( @isbns );
1795 Returns a list of variations of the given isbns in
1796 both ISBN-10 and ISBN-13 formats, with and without
1799 In a scalar context, the isbns are returned as a
1800 string delimited by ' | '.
1804 sub GetVariationsOfISBNs {
1807 @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
1809 return wantarray ? @isbns : join( " | ", @isbns );
1812 =head2 IsKohaFieldLinked
1814 my $is_linked = IsKohaFieldLinked({
1815 kohafield => $kohafield,
1816 frameworkcode => $frameworkcode,
1819 Return 1 if the field is linked
1823 sub IsKohaFieldLinked {
1824 my ( $params ) = @_;
1825 my $kohafield = $params->{kohafield};
1826 my $frameworkcode = $params->{frameworkcode} || '';
1827 my $dbh = C4::Context->dbh;
1828 my $is_linked = $dbh->selectcol_arrayref( q|
1830 FROM marc_subfield_structure
1831 WHERE frameworkcode = ?
1833 |,{}, $frameworkcode, $kohafield );
1834 return $is_linked->[0];