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
28 use Koha::DateUtils qw(dt_from_string);
29 use Koha::AuthorisedValues;
31 use Koha::MarcSubfieldStructures;
32 use DateTime::Format::MySQL;
34 use autouse 'Data::cselectall_arrayref' => qw(Dumper);
35 use DBI qw(:sql_types);
36 use vars qw(@ISA @EXPORT @EXPORT_OK $DEBUG);
42 &GetPrinters &GetPrinter
43 &GetItemTypes &getitemtypeinfo
44 &GetItemTypesCategorized &GetItemTypesByCategory
45 &getframeworks &getframeworkinfo
51 &get_notforloan_label_of
54 &getitemtypeimagelocation
56 &GetAuthorisedValueCategories
60 &GetNormalizedOCLCNumber
70 @EXPORT_OK = qw( GetDailyQuote );
75 C4::Koha - Perl Module containing convenience functions for Koha scripts
83 Koha.pm provides many functions for Koha scripts.
91 $itemtypes = &GetItemTypes( style => $style );
93 Returns information about existing itemtypes.
96 style: either 'array' or 'hash', defaults to 'hash'.
97 'array' returns an arrayref,
98 'hash' return a hashref with the itemtype value as the key
100 build a HTML select with the following code :
102 =head3 in PERL SCRIPT
104 my $itemtypes = GetItemTypes;
106 foreach my $thisitemtype (sort keys %$itemtypes) {
107 my $selected = 1 if $thisitemtype eq $itemtype;
108 my %row =(value => $thisitemtype,
109 selected => $selected,
110 description => $itemtypes->{$thisitemtype}->{'description'},
112 push @itemtypesloop, \%row;
114 $template->param(itemtypeloop => \@itemtypesloop);
118 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
119 <select name="itemtype">
120 <option value="">Default</option>
121 <!-- TMPL_LOOP name="itemtypeloop" -->
122 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
125 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
126 <input type="submit" value="OK" class="button">
133 my $style = defined( $params{'style'} ) ? $params{'style'} : 'hash';
135 require C4::Languages;
136 my $language = C4::Languages::getlanguage();
137 # returns a reference to a hash of references to itemtypes...
138 my $dbh = C4::Context->dbh;
142 itemtypes.description,
143 itemtypes.rentalcharge,
144 itemtypes.notforloan,
147 itemtypes.checkinmsg,
148 itemtypes.checkinmsgtype,
149 itemtypes.sip_media_type,
150 itemtypes.hideinopac,
151 itemtypes.searchcategory,
152 COALESCE( localization.translation, itemtypes.description ) AS translated_description
154 LEFT JOIN localization ON itemtypes.itemtype = localization.code
155 AND localization.entity = 'itemtypes'
156 AND localization.lang = ?
159 my $sth = $dbh->prepare($query);
160 $sth->execute( $language );
162 if ( $style eq 'hash' ) {
164 while ( my $IT = $sth->fetchrow_hashref ) {
165 $itemtypes{ $IT->{'itemtype'} } = $IT;
167 return ( \%itemtypes );
169 return [ sort { lc $a->{translated_description} cmp lc $b->{translated_description} } @{ $sth->fetchall_arrayref( {} ) } ];
173 =head2 GetItemTypesCategorized
175 $categories = GetItemTypesCategorized();
177 Returns a hashref containing search categories.
178 A search category will be put in the hash if at least one of its itemtypes is visible in OPAC.
179 The categories must be part of Authorized Values (ITEMTYPECAT)
183 sub GetItemTypesCategorized {
184 my $dbh = C4::Context->dbh;
185 # Order is important, so that partially hidden (some items are not visible in OPAC) search
186 # categories will be visible. hideinopac=0 must be last.
188 SELECT itemtype, description, imageurl, hideinopac, 0 as 'iscat' FROM itemtypes WHERE ISNULL(searchcategory) or length(searchcategory) = 0
190 SELECT DISTINCT searchcategory AS `itemtype`,
191 authorised_values.lib_opac AS description,
192 authorised_values.imageurl AS imageurl,
193 hideinopac, 1 as 'iscat'
195 LEFT JOIN authorised_values ON searchcategory = authorised_value
196 WHERE searchcategory > '' and hideinopac=1
198 SELECT DISTINCT searchcategory AS `itemtype`,
199 authorised_values.lib_opac AS description,
200 authorised_values.imageurl AS imageurl,
201 hideinopac, 1 as 'iscat'
203 LEFT JOIN authorised_values ON searchcategory = authorised_value
204 WHERE searchcategory > '' and hideinopac=0
206 return ($dbh->selectall_hashref($query,'itemtype'));
209 =head2 GetItemTypesByCategory
211 @results = GetItemTypesByCategory( $searchcategory );
213 Returns the itemtype code of all itemtypes included in a searchcategory.
217 sub GetItemTypesByCategory {
221 my $dbh = C4::Context->dbh;
222 my $query = qq|SELECT itemtype FROM itemtypes WHERE searchcategory=?|;
223 my $tmp=$dbh->selectcol_arrayref($query,undef,$category);
229 $frameworks = &getframework();
231 Returns information about existing frameworks
233 build a HTML select with the following code :
235 =head3 in PERL SCRIPT
237 my $frameworks = getframeworks();
239 foreach my $thisframework (keys %$frameworks) {
240 my $selected = 1 if $thisframework eq $frameworkcode;
242 value => $thisframework,
243 selected => $selected,
244 description => $frameworks->{$thisframework}->{'frameworktext'},
246 push @frameworksloop, \%row;
248 $template->param(frameworkloop => \@frameworksloop);
252 <form action="[% script_name %] method=post>
253 <select name="frameworkcode">
254 <option value="">Default</option>
255 [% FOREACH framework IN frameworkloop %]
256 [% IF ( framework.selected ) %]
257 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
259 <option value="[% framework.value %]">[% framework.description %]</option>
263 <input type=text name=searchfield value="[% searchfield %]">
264 <input type="submit" value="OK" class="button">
271 # returns a reference to a hash of references to branches...
273 my $dbh = C4::Context->dbh;
274 my $sth = $dbh->prepare("select * from biblio_framework");
276 while ( my $IT = $sth->fetchrow_hashref ) {
277 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
279 return ( \%itemtypes );
282 =head2 GetFrameworksLoop
284 $frameworks = GetFrameworksLoop( $frameworkcode );
286 Returns the loop suggested on getframework(), but ordered by framework description.
288 build a HTML select with the following code :
290 =head3 in PERL SCRIPT
292 $template->param( frameworkloop => GetFrameworksLoop( $frameworkcode ) );
296 Same as getframework()
298 <form action="[% script_name %] method=post>
299 <select name="frameworkcode">
300 <option value="">Default</option>
301 [% FOREACH framework IN frameworkloop %]
302 [% IF ( framework.selected ) %]
303 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
305 <option value="[% framework.value %]">[% framework.description %]</option>
309 <input type=text name=searchfield value="[% searchfield %]">
310 <input type="submit" value="OK" class="button">
315 sub GetFrameworksLoop {
316 my $frameworkcode = shift;
317 my $frameworks = getframeworks();
319 foreach my $thisframework (sort { uc($frameworks->{$a}->{'frameworktext'}) cmp uc($frameworks->{$b}->{'frameworktext'}) } keys %$frameworks) {
320 my $selected = ( $thisframework eq $frameworkcode ) ? 1 : undef;
322 value => $thisframework,
323 selected => $selected,
324 description => $frameworks->{$thisframework}->{'frameworktext'},
326 push @frameworkloop, \%row;
328 return \@frameworkloop;
331 =head2 getframeworkinfo
333 $frameworkinfo = &getframeworkinfo($frameworkcode);
335 Returns information about an frameworkcode.
339 sub getframeworkinfo {
340 my ($frameworkcode) = @_;
341 my $dbh = C4::Context->dbh;
343 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
344 $sth->execute($frameworkcode);
345 my $res = $sth->fetchrow_hashref;
349 =head2 getitemtypeinfo
351 $itemtype = &getitemtypeinfo($itemtype, [$interface]);
353 Returns information about an itemtype. The optional $interface argument
354 sets which interface ('opac' or 'intranet') to return the imageurl for.
355 Defaults to intranet.
359 sub getitemtypeinfo {
360 my ($itemtype, $interface) = @_;
361 my $dbh = C4::Context->dbh;
362 require C4::Languages;
363 my $language = C4::Languages::getlanguage();
364 my $it = $dbh->selectrow_hashref(q|
367 itemtypes.description,
368 itemtypes.rentalcharge,
369 itemtypes.notforloan,
372 itemtypes.checkinmsg,
373 itemtypes.checkinmsgtype,
374 itemtypes.sip_media_type,
375 COALESCE( localization.translation, itemtypes.description ) AS translated_description
377 LEFT JOIN localization ON itemtypes.itemtype = localization.code
378 AND localization.entity = 'itemtypes'
379 AND localization.lang = ?
380 WHERE itemtypes.itemtype = ?
381 |, undef, $language, $itemtype );
383 $it->{imageurl} = getitemtypeimagelocation( ( ( defined $interface && $interface eq 'opac' ) ? 'opac' : 'intranet' ), $it->{imageurl} );
388 =head2 getitemtypeimagedir
390 my $directory = getitemtypeimagedir( 'opac' );
392 pass in 'opac' or 'intranet'. Defaults to 'opac'.
394 returns the full path to the appropriate directory containing images.
398 sub getitemtypeimagedir {
399 my $src = shift || 'opac';
400 if ($src eq 'intranet') {
401 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
403 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
407 sub getitemtypeimagesrc {
408 my $src = shift || 'opac';
409 if ($src eq 'intranet') {
410 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
412 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
416 sub getitemtypeimagelocation {
417 my ( $src, $image ) = @_;
419 return '' if ( !$image );
422 my $scheme = ( URI::Split::uri_split( $image ) )[0];
424 return $image if ( $scheme );
426 return getitemtypeimagesrc( $src ) . '/' . $image;
429 =head3 _getImagesFromDirectory
431 Find all of the image files in a directory in the filesystem
433 parameters: a directory name
435 returns: a list of images in that directory.
437 Notes: this does not traverse into subdirectories. See
438 _getSubdirectoryNames for help with that.
439 Images are assumed to be files with .gif or .png file extensions.
440 The image names returned do not have the directory name on them.
444 sub _getImagesFromDirectory {
445 my $directoryname = shift;
446 return unless defined $directoryname;
447 return unless -d $directoryname;
449 if ( opendir ( my $dh, $directoryname ) ) {
450 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
452 @images = sort(@images);
455 warn "unable to opendir $directoryname: $!";
460 =head3 _getSubdirectoryNames
462 Find all of the directories in a directory in the filesystem
464 parameters: a directory name
466 returns: a list of subdirectories in that directory.
468 Notes: this does not traverse into subdirectories. Only the first
469 level of subdirectories are returned.
470 The directory names returned don't have the parent directory name on them.
474 sub _getSubdirectoryNames {
475 my $directoryname = shift;
476 return unless defined $directoryname;
477 return unless -d $directoryname;
479 if ( opendir ( my $dh, $directoryname ) ) {
480 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
484 warn "unable to opendir $directoryname: $!";
491 returns: a listref of hashrefs. Each hash represents another collection of images.
493 { imagesetname => 'npl', # the name of the image set (npl is the original one)
494 images => listref of image hashrefs
497 each image is represented by a hashref like this:
499 { KohaImage => 'npl/image.gif',
500 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
501 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
502 checked => 0 or 1: was this the image passed to this method?
503 Note: I'd like to remove this somehow.
510 my $checked = $params{'checked'} || '';
512 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
513 url => getitemtypeimagesrc('intranet'),
515 opac => { filesystem => getitemtypeimagedir('opac'),
516 url => getitemtypeimagesrc('opac'),
520 my @imagesets = (); # list of hasrefs of image set data to pass to template
521 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
522 foreach my $imagesubdir ( @subdirectories ) {
523 warn $imagesubdir if $DEBUG;
524 my @imagelist = (); # hashrefs of image info
525 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
526 my $imagesetactive = 0;
527 foreach my $thisimage ( @imagenames ) {
529 { KohaImage => "$imagesubdir/$thisimage",
530 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
531 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
532 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
535 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
537 push @imagesets, { imagesetname => $imagesubdir,
538 imagesetactive => $imagesetactive,
539 images => \@imagelist };
547 $printers = &GetPrinters();
548 @queues = keys %$printers;
550 Returns information about existing printer queues.
552 C<$printers> is a reference-to-hash whose keys are the print queues
553 defined in the printers table of the Koha database. The values are
554 references-to-hash, whose keys are the fields in the printers table.
560 my $dbh = C4::Context->dbh;
561 my $sth = $dbh->prepare("select * from printers");
563 while ( my $printer = $sth->fetchrow_hashref ) {
564 $printers{ $printer->{'printqueue'} } = $printer;
566 return ( \%printers );
571 $printer = GetPrinter( $query, $printers );
576 my ( $query, $printers ) = @_; # get printer for this query from printers
577 my $printer = $query->param('printer');
578 my %cookie = $query->cookie('userenv');
579 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
580 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
586 Returns the number of pages to display in a pagination bar, given the number
587 of items and the number of items per page.
592 my ( $nb_items, $nb_items_per_page ) = @_;
594 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
599 (@themes) = &getallthemes('opac');
600 (@themes) = &getallthemes('intranet');
602 Returns an array of all available themes.
610 if ( $type eq 'intranet' ) {
611 $htdocs = C4::Context->config('intrahtdocs');
614 $htdocs = C4::Context->config('opachtdocs');
616 opendir D, "$htdocs";
617 my @dirlist = readdir D;
618 foreach my $directory (@dirlist) {
619 next if $directory eq 'lib';
620 -d "$htdocs/$directory/en" and push @themes, $directory;
627 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
632 tags => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
638 tags => [ qw/ 607a / ],
644 tags => [ qw/ 500a 501a 503a / ],
650 tags => [ qw/ 700ab 701ab 702ab / ],
651 sep => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
656 tags => [ qw/ 225a / ],
662 tags => [ qw/ 995e / ],
666 unless ( Koha::Libraries->search->count == 1 )
668 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
669 if ( $DisplayLibraryFacets eq 'both'
670 || $DisplayLibraryFacets eq 'holding' )
675 idx => 'holdingbranch',
676 label => 'HoldingLibrary',
677 tags => [qw / 995c /],
682 if ( $DisplayLibraryFacets eq 'both'
683 || $DisplayLibraryFacets eq 'home' )
689 label => 'HomeLibrary',
690 tags => [qw / 995b /],
701 tags => [ qw/ 650a / ],
706 # label => 'People and Organizations',
707 # tags => [ qw/ 600a 610a 611a / ],
713 tags => [ qw/ 651a / ],
719 tags => [ qw/ 630a / ],
725 tags => [ qw/ 100a 110a 700a / ],
731 tags => [ qw/ 440a 490a / ],
736 label => 'ItemTypes',
737 tags => [ qw/ 952y 942c / ],
743 tags => [ qw / 952c / ],
747 unless ( Koha::Libraries->search->count == 1 )
749 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
750 if ( $DisplayLibraryFacets eq 'both'
751 || $DisplayLibraryFacets eq 'holding' )
756 idx => 'holdingbranch',
757 label => 'HoldingLibrary',
758 tags => [qw / 952b /],
763 if ( $DisplayLibraryFacets eq 'both'
764 || $DisplayLibraryFacets eq 'home' )
770 label => 'HomeLibrary',
771 tags => [qw / 952a /],
782 Return a href where a key is associated to a href. You give a query,
783 the name of the key among the fields returned by the query. If you
784 also give as third argument the name of the value, the function
785 returns a href of scalar. The optional 4th argument is an arrayref of
786 items passed to the C<execute()> call. It is designed to bind
787 parameters to any placeholders in your SQL.
796 # generic href of any information on the item, href of href.
797 my $iteminfos_of = get_infos_of($query, 'itemnumber');
798 print $iteminfos_of->{$itemnumber}{barcode};
800 # specific information, href of scalar
801 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
802 print $barcode_of_item->{$itemnumber};
807 my ( $query, $key_name, $value_name, $bind_params ) = @_;
809 my $dbh = C4::Context->dbh;
811 my $sth = $dbh->prepare($query);
812 $sth->execute( @$bind_params );
815 while ( my $row = $sth->fetchrow_hashref ) {
816 if ( defined $value_name ) {
817 $infos_of{ $row->{$key_name} } = $row->{$value_name};
820 $infos_of{ $row->{$key_name} } = $row;
828 =head2 get_notforloan_label_of
830 my $notforloan_label_of = get_notforloan_label_of();
832 Each authorised value of notforloan (information available in items and
833 itemtypes) is link to a single label.
835 Returns a href where keys are authorised values and values are corresponding
838 foreach my $authorised_value (keys %{$notforloan_label_of}) {
840 "authorised_value: %s => %s\n",
842 $notforloan_label_of->{$authorised_value}
848 # FIXME - why not use GetAuthorisedValues ??
850 sub get_notforloan_label_of {
851 my $dbh = C4::Context->dbh;
854 SELECT authorised_value
855 FROM marc_subfield_structure
856 WHERE kohafield = \'items.notforloan\'
859 my $sth = $dbh->prepare($query);
861 my ($statuscode) = $sth->fetchrow_array();
866 FROM authorised_values
869 $sth = $dbh->prepare($query);
870 $sth->execute($statuscode);
871 my %notforloan_label_of;
872 while ( my $row = $sth->fetchrow_hashref ) {
873 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
877 return \%notforloan_label_of;
880 =head2 GetAuthorisedValues
882 $authvalues = GetAuthorisedValues([$category]);
884 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
886 C<$category> returns authorised values for just one category (optional).
888 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
892 sub GetAuthorisedValues {
893 my ( $category, $opac ) = @_;
895 # Is this cached already?
896 $opac = $opac ? 1 : 0; # normalise to be safe
898 C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
900 "AuthorisedValues-$category-$opac-$branch_limit";
901 my $cache = Koha::Caches->get_instance();
902 my $result = $cache->get_from_cache($cache_key);
903 return $result if $result;
906 my $dbh = C4::Context->dbh;
909 FROM authorised_values av
912 LEFT JOIN authorised_values_branches ON ( id = av_id )
917 push @where_strings, "category = ?";
918 push @where_args, $category;
921 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
922 push @where_args, $branch_limit;
924 if(@where_strings > 0) {
925 $query .= " WHERE " . join(" AND ", @where_strings);
927 $query .= ' ORDER BY category, ' . (
928 $opac ? 'COALESCE(lib_opac, lib)'
932 my $sth = $dbh->prepare($query);
934 $sth->execute( @where_args );
935 while (my $data=$sth->fetchrow_hashref) {
936 if ($opac && $data->{lib_opac}) {
937 $data->{lib} = $data->{lib_opac};
939 push @results, $data;
943 $cache->set_in_cache( $cache_key, \@results, { expiry => 5 } );
947 =head2 GetAuthorisedValueCategories
949 $auth_categories = GetAuthorisedValueCategories();
951 Return an arrayref of all of the available authorised
956 sub GetAuthorisedValueCategories {
957 my $dbh = C4::Context->dbh;
958 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
961 while (defined (my $category = $sth->fetchrow_array) ) {
962 push @results, $category;
969 my $escaped_string = C4::Koha::xml_escape($string);
971 Convert &, <, >, ', and " in a string to XML entities
977 return '' unless defined $str;
981 $str =~ s/'/'/g;
982 $str =~ s/"/"/g;
986 =head2 display_marc_indicators
988 my $display_form = C4::Koha::display_marc_indicators($field);
990 C<$field> is a MARC::Field object
992 Generate a display form of the indicators of a variable
993 MARC field, replacing any blanks with '#'.
997 sub display_marc_indicators {
1000 if ($field && $field->tag() >= 10) {
1001 $indicators = $field->indicator(1) . $field->indicator(2);
1002 $indicators =~ s/ /#/g;
1007 sub GetNormalizedUPC {
1008 my ($marcrecord,$marcflavour) = @_;
1010 return unless $marcrecord;
1011 if ($marcflavour eq 'UNIMARC') {
1012 my @fields = $marcrecord->field('072');
1013 foreach my $field (@fields) {
1014 my $upc = _normalize_match_point($field->subfield('a'));
1021 else { # assume marc21 if not unimarc
1022 my @fields = $marcrecord->field('024');
1023 foreach my $field (@fields) {
1024 my $indicator = $field->indicator(1);
1025 my $upc = _normalize_match_point($field->subfield('a'));
1026 if ($upc && $indicator == 1 ) {
1033 # Normalizes and returns the first valid ISBN found in the record
1034 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1035 sub GetNormalizedISBN {
1036 my ($isbn,$marcrecord,$marcflavour) = @_;
1038 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1039 # anything after " | " should be removed, along with the delimiter
1040 ($isbn) = split(/\|/, $isbn );
1041 return _isbn_cleanup($isbn);
1044 return unless $marcrecord;
1046 if ($marcflavour eq 'UNIMARC') {
1047 my @fields = $marcrecord->field('010');
1048 foreach my $field (@fields) {
1049 my $isbn = $field->subfield('a');
1051 return _isbn_cleanup($isbn);
1055 else { # assume marc21 if not unimarc
1056 my @fields = $marcrecord->field('020');
1057 foreach my $field (@fields) {
1058 $isbn = $field->subfield('a');
1060 return _isbn_cleanup($isbn);
1066 sub GetNormalizedEAN {
1067 my ($marcrecord,$marcflavour) = @_;
1069 return unless $marcrecord;
1071 if ($marcflavour eq 'UNIMARC') {
1072 my @fields = $marcrecord->field('073');
1073 foreach my $field (@fields) {
1074 my $ean = _normalize_match_point($field->subfield('a'));
1080 else { # assume marc21 if not unimarc
1081 my @fields = $marcrecord->field('024');
1082 foreach my $field (@fields) {
1083 my $indicator = $field->indicator(1);
1084 my $ean = _normalize_match_point($field->subfield('a'));
1085 if ( $ean && $indicator == 3 ) {
1092 sub GetNormalizedOCLCNumber {
1093 my ($marcrecord,$marcflavour) = @_;
1094 return unless $marcrecord;
1096 if ($marcflavour ne 'UNIMARC' ) {
1097 my @fields = $marcrecord->field('035');
1098 foreach my $field (@fields) {
1099 my $oclc = $field->subfield('a');
1100 if ($oclc =~ /OCoLC/) {
1101 $oclc =~ s/\(OCoLC\)//;
1111 sub GetAuthvalueDropbox {
1112 my ( $authcat, $default ) = @_;
1113 my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1114 my $dbh = C4::Context->dbh;
1118 FROM authorised_values
1121 LEFT JOIN authorised_values_branches ON ( id = av_id )
1126 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1127 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1128 my $sth = $dbh->prepare($query);
1129 $sth->execute( $authcat, $branch_limit ? $branch_limit : () );
1132 my $option_list = [];
1133 my @authorised_values = ( q{} );
1134 while (my $av = $sth->fetchrow_hashref) {
1135 push @{$option_list}, {
1136 value => $av->{authorised_value},
1137 label => $av->{lib},
1138 default => ($default eq $av->{authorised_value}),
1142 if ( @{$option_list} ) {
1143 return $option_list;
1149 =head2 GetDailyQuote($opts)
1151 Takes a hashref of options
1153 Currently supported options are:
1155 'id' An exact quote id
1156 'random' Select a random quote
1157 noop When no option is passed in, this sub will return the quote timestamped for the current day
1159 The function returns an anonymous hash following this format:
1162 'source' => 'source-of-quote',
1163 'timestamp' => 'timestamp-value',
1164 'text' => 'text-of-quote',
1170 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1171 # at least for default option
1175 my $dbh = C4::Context->dbh;
1180 $query = 'SELECT * FROM quotes WHERE id = ?';
1181 $sth = $dbh->prepare($query);
1182 $sth->execute($opts{'id'});
1183 $quote = $sth->fetchrow_hashref();
1185 elsif ($opts{'random'}) {
1186 # Fall through... we also return a random quote as a catch-all if all else fails
1189 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1190 $sth = $dbh->prepare($query);
1192 $quote = $sth->fetchrow_hashref();
1194 unless ($quote) { # if there are not matches, choose a random quote
1195 # get a list of all available quote ids
1196 $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1198 my $range = ($sth->fetchrow_array)[0];
1199 # chose a random id within that range if there is more than one quote
1200 my $offset = int(rand($range));
1202 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1203 $sth = C4::Context->dbh->prepare($query);
1204 # see http://www.perlmonks.org/?node_id=837422 for why
1205 # we're being verbose and using bind_param
1206 $sth->bind_param(1, $offset, SQL_INTEGER);
1208 $quote = $sth->fetchrow_hashref();
1209 # update the timestamp for that quote
1210 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1211 $sth = C4::Context->dbh->prepare($query);
1213 DateTime::Format::MySQL->format_datetime( dt_from_string() ),
1220 sub _normalize_match_point {
1221 my $match_point = shift;
1222 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1223 $normalized_match_point =~ s/-//g;
1225 return $normalized_match_point;
1230 return NormalizeISBN(
1233 format => 'ISBN-10',
1239 =head2 NormalizedISBN
1241 my $isbns = NormalizedISBN({
1243 strip_hyphens => [0,1],
1244 format => ['ISBN-10', 'ISBN-13']
1247 Returns an isbn validated by Business::ISBN.
1248 Optionally strips hyphens and/or forces the isbn
1249 to be of the specified format.
1251 If the string cannot be validated as an isbn,
1259 my $string = $params->{isbn};
1260 my $strip_hyphens = $params->{strip_hyphens};
1261 my $format = $params->{format};
1263 return unless $string;
1265 my $isbn = Business::ISBN->new($string);
1267 if ( $isbn && $isbn->is_valid() ) {
1269 if ( $format eq 'ISBN-10' ) {
1270 $isbn = $isbn->as_isbn10();
1272 elsif ( $format eq 'ISBN-13' ) {
1273 $isbn = $isbn->as_isbn13();
1275 return unless $isbn;
1277 if ($strip_hyphens) {
1278 $string = $isbn->as_string( [] );
1280 $string = $isbn->as_string();
1287 =head2 GetVariationsOfISBN
1289 my @isbns = GetVariationsOfISBN( $isbn );
1291 Returns a list of variations of the given isbn in
1292 both ISBN-10 and ISBN-13 formats, with and without
1295 In a scalar context, the isbns are returned as a
1296 string delimited by ' | '.
1300 sub GetVariationsOfISBN {
1303 return unless $isbn;
1307 push( @isbns, NormalizeISBN({ isbn => $isbn }) );
1308 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
1309 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
1310 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
1311 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
1313 # Strip out any "empty" strings from the array
1314 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1316 return wantarray ? @isbns : join( " | ", @isbns );
1319 =head2 GetVariationsOfISBNs
1321 my @isbns = GetVariationsOfISBNs( @isbns );
1323 Returns a list of variations of the given isbns in
1324 both ISBN-10 and ISBN-13 formats, with and without
1327 In a scalar context, the isbns are returned as a
1328 string delimited by ' | '.
1332 sub GetVariationsOfISBNs {
1335 @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
1337 return wantarray ? @isbns : join( " | ", @isbns );
1340 =head2 IsKohaFieldLinked
1342 my $is_linked = IsKohaFieldLinked({
1343 kohafield => $kohafield,
1344 frameworkcode => $frameworkcode,
1347 Return 1 if the field is linked
1351 sub IsKohaFieldLinked {
1352 my ( $params ) = @_;
1353 my $kohafield = $params->{kohafield};
1354 my $frameworkcode = $params->{frameworkcode} || '';
1355 my $dbh = C4::Context->dbh;
1356 my $is_linked = $dbh->selectcol_arrayref( q|
1358 FROM marc_subfield_structure
1359 WHERE frameworkcode = ?
1361 |,{}, $frameworkcode, $kohafield );
1362 return $is_linked->[0];