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>.
27 use Koha::DateUtils qw(dt_from_string);
28 use Koha::AuthorisedValues;
30 use Koha::MarcSubfieldStructures;
31 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 &GetItemTypesCategorized
49 &getitemtypeimagelocation
54 &GetNormalizedOCLCNumber
67 @EXPORT_OK = qw( GetDailyQuote );
72 C4::Koha - Perl Module containing convenience functions for Koha scripts
80 Koha.pm provides many functions for Koha scripts.
86 =head2 GetItemTypesCategorized
88 $categories = GetItemTypesCategorized();
90 Returns a hashref containing search categories.
91 A search category will be put in the hash if at least one of its itemtypes is visible in OPAC.
92 The categories must be part of Authorized Values (ITEMTYPECAT)
96 sub GetItemTypesCategorized {
97 my $dbh = C4::Context->dbh;
98 # Order is important, so that partially hidden (some items are not visible in OPAC) search
99 # categories will be visible. hideinopac=0 must be last.
101 SELECT itemtype, description, imageurl, hideinopac, 0 as 'iscat' FROM itemtypes WHERE ISNULL(searchcategory) or length(searchcategory) = 0
103 SELECT DISTINCT searchcategory AS `itemtype`,
104 authorised_values.lib_opac AS description,
105 authorised_values.imageurl AS imageurl,
106 hideinopac, 1 as 'iscat'
108 LEFT JOIN authorised_values ON searchcategory = authorised_value
109 WHERE searchcategory > '' and hideinopac=1
111 SELECT DISTINCT searchcategory AS `itemtype`,
112 authorised_values.lib_opac AS description,
113 authorised_values.imageurl AS imageurl,
114 hideinopac, 1 as 'iscat'
116 LEFT JOIN authorised_values ON searchcategory = authorised_value
117 WHERE searchcategory > '' and hideinopac=0
119 return ($dbh->selectall_hashref($query,'itemtype'));
122 =head2 getitemtypeimagedir
124 my $directory = getitemtypeimagedir( 'opac' );
126 pass in 'opac' or 'intranet'. Defaults to 'opac'.
128 returns the full path to the appropriate directory containing images.
132 sub getitemtypeimagedir {
133 my $src = shift || 'opac';
134 if ($src eq 'intranet') {
135 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
137 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
141 sub getitemtypeimagesrc {
142 my $src = shift || 'opac';
143 if ($src eq 'intranet') {
144 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
146 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
150 sub getitemtypeimagelocation {
151 my ( $src, $image ) = @_;
153 return '' if ( !$image );
156 my $scheme = ( URI::Split::uri_split( $image ) )[0];
158 return $image if ( $scheme );
160 return getitemtypeimagesrc( $src ) . '/' . $image;
163 =head3 _getImagesFromDirectory
165 Find all of the image files in a directory in the filesystem
167 parameters: a directory name
169 returns: a list of images in that directory.
171 Notes: this does not traverse into subdirectories. See
172 _getSubdirectoryNames for help with that.
173 Images are assumed to be files with .gif or .png file extensions.
174 The image names returned do not have the directory name on them.
178 sub _getImagesFromDirectory {
179 my $directoryname = shift;
180 return unless defined $directoryname;
181 return unless -d $directoryname;
183 if ( opendir ( my $dh, $directoryname ) ) {
184 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
186 @images = sort(@images);
189 warn "unable to opendir $directoryname: $!";
194 =head3 _getSubdirectoryNames
196 Find all of the directories in a directory in the filesystem
198 parameters: a directory name
200 returns: a list of subdirectories in that directory.
202 Notes: this does not traverse into subdirectories. Only the first
203 level of subdirectories are returned.
204 The directory names returned don't have the parent directory name on them.
208 sub _getSubdirectoryNames {
209 my $directoryname = shift;
210 return unless defined $directoryname;
211 return unless -d $directoryname;
213 if ( opendir ( my $dh, $directoryname ) ) {
214 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
218 warn "unable to opendir $directoryname: $!";
225 returns: a listref of hashrefs. Each hash represents another collection of images.
227 { imagesetname => 'npl', # the name of the image set (npl is the original one)
228 images => listref of image hashrefs
231 each image is represented by a hashref like this:
233 { KohaImage => 'npl/image.gif',
234 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
235 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
236 checked => 0 or 1: was this the image passed to this method?
237 Note: I'd like to remove this somehow.
244 my $checked = $params{'checked'} || '';
246 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
247 url => getitemtypeimagesrc('intranet'),
249 opac => { filesystem => getitemtypeimagedir('opac'),
250 url => getitemtypeimagesrc('opac'),
254 my @imagesets = (); # list of hasrefs of image set data to pass to template
255 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
256 foreach my $imagesubdir ( @subdirectories ) {
257 warn $imagesubdir if $DEBUG;
258 my @imagelist = (); # hashrefs of image info
259 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
260 my $imagesetactive = 0;
261 foreach my $thisimage ( @imagenames ) {
263 { KohaImage => "$imagesubdir/$thisimage",
264 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
265 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
266 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
269 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
271 push @imagesets, { imagesetname => $imagesubdir,
272 imagesetactive => $imagesetactive,
273 images => \@imagelist };
281 $printers = &GetPrinters();
282 @queues = keys %$printers;
284 Returns information about existing printer queues.
286 C<$printers> is a reference-to-hash whose keys are the print queues
287 defined in the printers table of the Koha database. The values are
288 references-to-hash, whose keys are the fields in the printers table.
294 my $dbh = C4::Context->dbh;
295 my $sth = $dbh->prepare("select * from printers");
297 while ( my $printer = $sth->fetchrow_hashref ) {
298 $printers{ $printer->{'printqueue'} } = $printer;
300 return ( \%printers );
305 $printer = GetPrinter( $query, $printers );
310 my ( $query, $printers ) = @_; # get printer for this query from printers
311 my $printer = $query->param('printer');
312 my %cookie = $query->cookie('userenv');
313 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
314 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
320 Returns the number of pages to display in a pagination bar, given the number
321 of items and the number of items per page.
326 my ( $nb_items, $nb_items_per_page ) = @_;
328 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
333 (@themes) = &getallthemes('opac');
334 (@themes) = &getallthemes('intranet');
336 Returns an array of all available themes.
344 if ( $type eq 'intranet' ) {
345 $htdocs = C4::Context->config('intrahtdocs');
348 $htdocs = C4::Context->config('opachtdocs');
350 opendir D, "$htdocs";
351 my @dirlist = readdir D;
352 foreach my $directory (@dirlist) {
353 next if $directory eq 'lib';
354 -d "$htdocs/$directory/en" and push @themes, $directory;
361 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
366 tags => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
372 tags => [ qw/ 607a / ],
378 tags => [ qw/ 500a 501a 503a / ],
384 tags => [ qw/ 700ab 701ab 702ab / ],
385 sep => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
390 tags => [ qw/ 225a / ],
396 tags => [ qw/ 995e / ],
400 label => 'CollectionCodes',
401 tags => [ qw / 099t 955h / ],
405 unless ( Koha::Libraries->search->count == 1 )
407 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
408 if ( $DisplayLibraryFacets eq 'both'
409 || $DisplayLibraryFacets eq 'holding' )
414 idx => 'holdingbranch',
415 label => 'HoldingLibrary',
416 tags => [qw / 995c /],
421 if ( $DisplayLibraryFacets eq 'both'
422 || $DisplayLibraryFacets eq 'home' )
428 label => 'HomeLibrary',
429 tags => [qw / 995b /],
440 tags => [ qw/ 650a / ],
445 # label => 'People and Organizations',
446 # tags => [ qw/ 600a 610a 611a / ],
452 tags => [ qw/ 651a / ],
458 tags => [ qw/ 630a / ],
464 tags => [ qw/ 100a 110a 700a / ],
470 tags => [ qw/ 440a 490a / ],
475 label => 'ItemTypes',
476 tags => [ qw/ 952y 942c / ],
482 tags => [ qw / 952c / ],
486 label => 'CollectionCodes',
487 tags => [ qw / 9528 / ],
491 unless ( Koha::Libraries->search->count == 1 )
493 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
494 if ( $DisplayLibraryFacets eq 'both'
495 || $DisplayLibraryFacets eq 'holding' )
500 idx => 'holdingbranch',
501 label => 'HoldingLibrary',
502 tags => [qw / 952b /],
507 if ( $DisplayLibraryFacets eq 'both'
508 || $DisplayLibraryFacets eq 'home' )
514 label => 'HomeLibrary',
515 tags => [qw / 952a /],
524 =head2 GetAuthorisedValues
526 $authvalues = GetAuthorisedValues([$category]);
528 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
530 C<$category> returns authorised values for just one category (optional).
532 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
536 sub GetAuthorisedValues {
537 my ( $category, $opac ) = @_;
539 # Is this cached already?
540 $opac = $opac ? 1 : 0; # normalise to be safe
542 C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
544 "AuthorisedValues-$category-$opac-$branch_limit";
545 my $cache = Koha::Caches->get_instance();
546 my $result = $cache->get_from_cache($cache_key);
547 return $result if $result;
550 my $dbh = C4::Context->dbh;
553 FROM authorised_values av
556 LEFT JOIN authorised_values_branches ON ( id = av_id )
561 push @where_strings, "category = ?";
562 push @where_args, $category;
565 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
566 push @where_args, $branch_limit;
568 if(@where_strings > 0) {
569 $query .= " WHERE " . join(" AND ", @where_strings);
571 $query .= ' ORDER BY category, ' . (
572 $opac ? 'COALESCE(lib_opac, lib)'
576 my $sth = $dbh->prepare($query);
578 $sth->execute( @where_args );
579 while (my $data=$sth->fetchrow_hashref) {
580 if ($opac && $data->{lib_opac}) {
581 $data->{lib} = $data->{lib_opac};
583 push @results, $data;
587 $cache->set_in_cache( $cache_key, \@results, { expiry => 5 } );
593 my $escaped_string = C4::Koha::xml_escape($string);
595 Convert &, <, >, ', and " in a string to XML entities
601 return '' unless defined $str;
605 $str =~ s/'/'/g;
606 $str =~ s/"/"/g;
610 =head2 display_marc_indicators
612 my $display_form = C4::Koha::display_marc_indicators($field);
614 C<$field> is a MARC::Field object
616 Generate a display form of the indicators of a variable
617 MARC field, replacing any blanks with '#'.
621 sub display_marc_indicators {
624 if ($field && $field->tag() >= 10) {
625 $indicators = $field->indicator(1) . $field->indicator(2);
626 $indicators =~ s/ /#/g;
631 sub GetNormalizedUPC {
632 my ($marcrecord,$marcflavour) = @_;
634 return unless $marcrecord;
635 if ($marcflavour eq 'UNIMARC') {
636 my @fields = $marcrecord->field('072');
637 foreach my $field (@fields) {
638 my $upc = _normalize_match_point($field->subfield('a'));
645 else { # assume marc21 if not unimarc
646 my @fields = $marcrecord->field('024');
647 foreach my $field (@fields) {
648 my $indicator = $field->indicator(1);
649 my $upc = _normalize_match_point($field->subfield('a'));
650 if ($upc && $indicator == 1 ) {
657 # Normalizes and returns the first valid ISBN found in the record
658 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
659 sub GetNormalizedISBN {
660 my ($isbn,$marcrecord,$marcflavour) = @_;
662 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
663 # anything after " | " should be removed, along with the delimiter
664 ($isbn) = split(/\|/, $isbn );
665 return _isbn_cleanup($isbn);
668 return unless $marcrecord;
670 if ($marcflavour eq 'UNIMARC') {
671 my @fields = $marcrecord->field('010');
672 foreach my $field (@fields) {
673 my $isbn = $field->subfield('a');
675 return _isbn_cleanup($isbn);
679 else { # assume marc21 if not unimarc
680 my @fields = $marcrecord->field('020');
681 foreach my $field (@fields) {
682 $isbn = $field->subfield('a');
684 return _isbn_cleanup($isbn);
690 sub GetNormalizedEAN {
691 my ($marcrecord,$marcflavour) = @_;
693 return unless $marcrecord;
695 if ($marcflavour eq 'UNIMARC') {
696 my @fields = $marcrecord->field('073');
697 foreach my $field (@fields) {
698 my $ean = _normalize_match_point($field->subfield('a'));
704 else { # assume marc21 if not unimarc
705 my @fields = $marcrecord->field('024');
706 foreach my $field (@fields) {
707 my $indicator = $field->indicator(1);
708 my $ean = _normalize_match_point($field->subfield('a'));
709 if ( $ean && $indicator == 3 ) {
716 sub GetNormalizedOCLCNumber {
717 my ($marcrecord,$marcflavour) = @_;
718 return unless $marcrecord;
720 if ($marcflavour ne 'UNIMARC' ) {
721 my @fields = $marcrecord->field('035');
722 foreach my $field (@fields) {
723 my $oclc = $field->subfield('a');
724 if ($oclc =~ /OCoLC/) {
725 $oclc =~ s/\(OCoLC\)//;
735 =head2 GetDailyQuote($opts)
737 Takes a hashref of options
739 Currently supported options are:
741 'id' An exact quote id
742 'random' Select a random quote
743 noop When no option is passed in, this sub will return the quote timestamped for the current day
745 The function returns an anonymous hash following this format:
748 'source' => 'source-of-quote',
749 'timestamp' => 'timestamp-value',
750 'text' => 'text-of-quote',
756 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
757 # at least for default option
761 my $dbh = C4::Context->dbh;
766 $query = 'SELECT * FROM quotes WHERE id = ?';
767 $sth = $dbh->prepare($query);
768 $sth->execute($opts{'id'});
769 $quote = $sth->fetchrow_hashref();
771 elsif ($opts{'random'}) {
772 # Fall through... we also return a random quote as a catch-all if all else fails
775 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
776 $sth = $dbh->prepare($query);
778 $quote = $sth->fetchrow_hashref();
780 unless ($quote) { # if there are not matches, choose a random quote
781 # get a list of all available quote ids
782 $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
784 my $range = ($sth->fetchrow_array)[0];
785 # chose a random id within that range if there is more than one quote
786 my $offset = int(rand($range));
788 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
789 $sth = C4::Context->dbh->prepare($query);
790 # see http://www.perlmonks.org/?node_id=837422 for why
791 # we're being verbose and using bind_param
792 $sth->bind_param(1, $offset, SQL_INTEGER);
794 $quote = $sth->fetchrow_hashref();
795 # update the timestamp for that quote
796 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
797 $sth = C4::Context->dbh->prepare($query);
799 DateTime::Format::MySQL->format_datetime( dt_from_string() ),
806 sub _normalize_match_point {
807 my $match_point = shift;
808 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
809 $normalized_match_point =~ s/-//g;
811 return $normalized_match_point;
816 return NormalizeISBN(
827 my $isbns = NormalizeISBN({
829 strip_hyphens => [0,1],
830 format => ['ISBN-10', 'ISBN-13']
833 Returns an isbn validated by Business::ISBN.
834 Optionally strips hyphens and/or forces the isbn
835 to be of the specified format.
837 If the string cannot be validated as an isbn,
838 it returns nothing unless return_invalid param is passed.
840 #FIXME This routine (and others?) should be moved to Koha::Util::Normalize
847 my $string = $params->{isbn};
848 my $strip_hyphens = $params->{strip_hyphens};
849 my $format = $params->{format} || q{};
850 my $return_invalid = $params->{return_invalid};
852 return unless $string;
854 my $isbn = Business::ISBN->new($string);
856 if ( $isbn && $isbn->is_valid() ) {
858 if ( $format eq 'ISBN-10' ) {
859 $isbn = $isbn->as_isbn10();
861 elsif ( $format eq 'ISBN-13' ) {
862 $isbn = $isbn->as_isbn13();
866 if ($strip_hyphens) {
867 $string = $isbn->as_string( [] );
869 $string = $isbn->as_string();
873 } elsif ( $return_invalid ) {
879 =head2 GetVariationsOfISBN
881 my @isbns = GetVariationsOfISBN( $isbn );
883 Returns a list of variations of the given isbn in
884 both ISBN-10 and ISBN-13 formats, with and without
887 In a scalar context, the isbns are returned as a
888 string delimited by ' | '.
892 sub GetVariationsOfISBN {
899 push( @isbns, NormalizeISBN({ isbn => $isbn, return_invalid => 1 }) );
900 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
901 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
902 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
903 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
905 # Strip out any "empty" strings from the array
906 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
908 return wantarray ? @isbns : join( " | ", @isbns );
911 =head2 GetVariationsOfISBNs
913 my @isbns = GetVariationsOfISBNs( @isbns );
915 Returns a list of variations of the given isbns in
916 both ISBN-10 and ISBN-13 formats, with and without
919 In a scalar context, the isbns are returned as a
920 string delimited by ' | '.
924 sub GetVariationsOfISBNs {
927 @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
929 return wantarray ? @isbns : join( " | ", @isbns );
932 =head2 NormalizedISSN
934 my $issns = NormalizedISSN({
936 strip_hyphen => [0,1]
939 Returns an issn validated by Business::ISSN.
940 Optionally strips hyphen.
942 If the string cannot be validated as an issn,
950 my $string = $params->{issn};
951 my $strip_hyphen = $params->{strip_hyphen};
953 my $issn = Business::ISSN->new($string);
955 if ( $issn && $issn->is_valid ){
958 $string = $issn->_issn;
961 $string = $issn->as_string;
968 =head2 GetVariationsOfISSN
970 my @issns = GetVariationsOfISSN( $issn );
972 Returns a list of variations of the given issn in
973 with and without a hyphen.
975 In a scalar context, the issns are returned as a
976 string delimited by ' | '.
980 sub GetVariationsOfISSN {
986 my $str = NormalizeISSN({ issn => $issn });
989 push @issns, NormalizeISSN({ issn => $issn, strip_hyphen => 1 });
994 # Strip out any "empty" strings from the array
995 @issns = grep { defined($_) && $_ =~ /\S/ } @issns;
997 return wantarray ? @issns : join( " | ", @issns );
1000 =head2 GetVariationsOfISSNs
1002 my @issns = GetVariationsOfISSNs( @issns );
1004 Returns a list of variations of the given issns in
1005 with and without a hyphen.
1007 In a scalar context, the issns are returned as a
1008 string delimited by ' | '.
1012 sub GetVariationsOfISSNs {
1015 @issns = map { GetVariationsOfISSN( $_ ) } @issns;
1017 return wantarray ? @issns : join( " | ", @issns );