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;
35 use autouse 'Data::cselectall_arrayref' => qw(Dumper);
36 use DBI qw(:sql_types);
37 use vars qw(@ISA @EXPORT @EXPORT_OK $DEBUG);
43 &GetPrinters &GetPrinter
44 &GetItemTypesCategorized
50 &getitemtypeimagelocation
55 &GetNormalizedOCLCNumber
68 @EXPORT_OK = qw( GetDailyQuote );
73 C4::Koha - Perl Module containing convenience functions for Koha scripts
81 Koha.pm provides many functions for Koha scripts.
87 =head2 GetItemTypesCategorized
89 $categories = GetItemTypesCategorized();
91 Returns a hashref containing search categories.
92 A search category will be put in the hash if at least one of its itemtypes is visible in OPAC.
93 The categories must be part of Authorized Values (ITEMTYPECAT)
97 sub GetItemTypesCategorized {
98 my $dbh = C4::Context->dbh;
99 # Order is important, so that partially hidden (some items are not visible in OPAC) search
100 # categories will be visible. hideinopac=0 must be last.
102 SELECT itemtype, description, imageurl, hideinopac, 0 as 'iscat' FROM itemtypes WHERE ISNULL(searchcategory) or length(searchcategory) = 0
104 SELECT DISTINCT searchcategory AS `itemtype`,
105 COALESCE(authorised_values.lib_opac,authorised_values.lib) AS description,
106 authorised_values.imageurl AS imageurl,
107 hideinopac, 1 as 'iscat'
109 LEFT JOIN authorised_values ON searchcategory = authorised_value
110 WHERE searchcategory > '' and hideinopac=1
112 SELECT DISTINCT searchcategory AS `itemtype`,
113 COALESCE(authorised_values.lib_opac,authorised_values.lib) AS description,
114 authorised_values.imageurl AS imageurl,
115 hideinopac, 1 as 'iscat'
117 LEFT JOIN authorised_values ON searchcategory = authorised_value
118 WHERE searchcategory > '' and hideinopac=0
120 return ($dbh->selectall_hashref($query,'itemtype'));
123 =head2 getitemtypeimagedir
125 my $directory = getitemtypeimagedir( 'opac' );
127 pass in 'opac' or 'intranet'. Defaults to 'opac'.
129 returns the full path to the appropriate directory containing images.
133 sub getitemtypeimagedir {
134 my $src = shift || 'opac';
135 if ($src eq 'intranet') {
136 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
138 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
142 sub getitemtypeimagesrc {
143 my $src = shift || 'opac';
144 if ($src eq 'intranet') {
145 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
147 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
151 sub getitemtypeimagelocation {
152 my ( $src, $image ) = @_;
154 return '' if ( !$image );
157 my $scheme = ( URI::Split::uri_split( $image ) )[0];
159 return $image if ( $scheme );
161 return getitemtypeimagesrc( $src ) . '/' . $image;
164 =head3 _getImagesFromDirectory
166 Find all of the image files in a directory in the filesystem
168 parameters: a directory name
170 returns: a list of images in that directory.
172 Notes: this does not traverse into subdirectories. See
173 _getSubdirectoryNames for help with that.
174 Images are assumed to be files with .gif or .png file extensions.
175 The image names returned do not have the directory name on them.
179 sub _getImagesFromDirectory {
180 my $directoryname = shift;
181 return unless defined $directoryname;
182 return unless -d $directoryname;
184 if ( opendir ( my $dh, $directoryname ) ) {
185 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
187 @images = sort(@images);
190 warn "unable to opendir $directoryname: $!";
195 =head3 _getSubdirectoryNames
197 Find all of the directories in a directory in the filesystem
199 parameters: a directory name
201 returns: a list of subdirectories in that directory.
203 Notes: this does not traverse into subdirectories. Only the first
204 level of subdirectories are returned.
205 The directory names returned don't have the parent directory name on them.
209 sub _getSubdirectoryNames {
210 my $directoryname = shift;
211 return unless defined $directoryname;
212 return unless -d $directoryname;
214 if ( opendir ( my $dh, $directoryname ) ) {
215 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
219 warn "unable to opendir $directoryname: $!";
226 returns: a listref of hashrefs. Each hash represents another collection of images.
228 { imagesetname => 'npl', # the name of the image set (npl is the original one)
229 images => listref of image hashrefs
232 each image is represented by a hashref like this:
234 { KohaImage => 'npl/image.gif',
235 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
236 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
237 checked => 0 or 1: was this the image passed to this method?
238 Note: I'd like to remove this somehow.
245 my $checked = $params{'checked'} || '';
247 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
248 url => getitemtypeimagesrc('intranet'),
250 opac => { filesystem => getitemtypeimagedir('opac'),
251 url => getitemtypeimagesrc('opac'),
255 my @imagesets = (); # list of hasrefs of image set data to pass to template
256 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
257 foreach my $imagesubdir ( @subdirectories ) {
258 warn $imagesubdir if $DEBUG;
259 my @imagelist = (); # hashrefs of image info
260 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
261 my $imagesetactive = 0;
262 foreach my $thisimage ( @imagenames ) {
264 { KohaImage => "$imagesubdir/$thisimage",
265 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
266 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
267 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
270 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
272 push @imagesets, { imagesetname => $imagesubdir,
273 imagesetactive => $imagesetactive,
274 images => \@imagelist };
282 $printers = &GetPrinters();
283 @queues = keys %$printers;
285 Returns information about existing printer queues.
287 C<$printers> is a reference-to-hash whose keys are the print queues
288 defined in the printers table of the Koha database. The values are
289 references-to-hash, whose keys are the fields in the printers table.
295 my $dbh = C4::Context->dbh;
296 my $sth = $dbh->prepare("select * from printers");
298 while ( my $printer = $sth->fetchrow_hashref ) {
299 $printers{ $printer->{'printqueue'} } = $printer;
301 return ( \%printers );
306 $printer = GetPrinter( $query, $printers );
311 my ( $query, $printers ) = @_; # get printer for this query from printers
312 my $printer = $query->param('printer');
313 my %cookie = $query->cookie('userenv');
314 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
315 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
321 Returns the number of pages to display in a pagination bar, given the number
322 of items and the number of items per page.
327 my ( $nb_items, $nb_items_per_page ) = @_;
329 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
334 (@themes) = &getallthemes('opac');
335 (@themes) = &getallthemes('intranet');
337 Returns an array of all available themes.
345 if ( $type eq 'intranet' ) {
346 $htdocs = C4::Context->config('intrahtdocs');
349 $htdocs = C4::Context->config('opachtdocs');
351 opendir D, "$htdocs";
352 my @dirlist = readdir D;
353 foreach my $directory (@dirlist) {
354 next if $directory eq 'lib';
355 -d "$htdocs/$directory/en" and push @themes, $directory;
362 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
367 tags => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
373 tags => [ qw/ 607a / ],
379 tags => [ qw/ 700ab 701ab 702ab / ],
380 sep => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
385 tags => [ qw/ 225a / ],
391 tags => [ qw/ 995e / ],
395 label => 'CollectionCodes',
396 tags => [ qw / 099t 955h / ],
400 unless ( Koha::Libraries->search->count == 1 )
402 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
403 if ( $DisplayLibraryFacets eq 'both'
404 || $DisplayLibraryFacets eq 'holding' )
409 idx => 'holdingbranch',
410 label => 'HoldingLibrary',
411 tags => [qw / 995c /],
416 if ( $DisplayLibraryFacets eq 'both'
417 || $DisplayLibraryFacets eq 'home' )
423 label => 'HomeLibrary',
424 tags => [qw / 995b /],
435 tags => [ qw/ 650a / ],
440 # label => 'People and Organizations',
441 # tags => [ qw/ 600a 610a 611a / ],
447 tags => [ qw/ 651a / ],
453 tags => [ qw/ 630a / ],
459 tags => [ qw/ 100a 110a 700a / ],
465 tags => [ qw/ 440a 490a / ],
470 label => 'ItemTypes',
471 tags => [ qw/ 952y 942c / ],
477 tags => [ qw / 952c / ],
481 label => 'CollectionCodes',
482 tags => [ qw / 9528 / ],
486 unless ( Koha::Libraries->search->count == 1 )
488 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
489 if ( $DisplayLibraryFacets eq 'both'
490 || $DisplayLibraryFacets eq 'holding' )
495 idx => 'holdingbranch',
496 label => 'HoldingLibrary',
497 tags => [qw / 952b /],
502 if ( $DisplayLibraryFacets eq 'both'
503 || $DisplayLibraryFacets eq 'home' )
509 label => 'HomeLibrary',
510 tags => [qw / 952a /],
519 =head2 GetAuthorisedValues
521 $authvalues = GetAuthorisedValues([$category]);
523 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
525 C<$category> returns authorised values for just one category (optional).
527 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
531 sub GetAuthorisedValues {
532 my ( $category, $opac ) = @_;
534 # Is this cached already?
535 $opac = $opac ? 1 : 0; # normalise to be safe
537 C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
539 "AuthorisedValues-$category-$opac-$branch_limit";
540 my $cache = Koha::Caches->get_instance();
541 my $result = $cache->get_from_cache($cache_key);
542 return $result if $result;
545 my $dbh = C4::Context->dbh;
548 FROM authorised_values av
551 LEFT JOIN authorised_values_branches ON ( id = av_id )
556 push @where_strings, "category = ?";
557 push @where_args, $category;
560 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
561 push @where_args, $branch_limit;
563 if(@where_strings > 0) {
564 $query .= " WHERE " . join(" AND ", @where_strings);
566 $query .= ' ORDER BY category, ' . (
567 $opac ? 'COALESCE(lib_opac, lib)'
571 my $sth = $dbh->prepare($query);
573 $sth->execute( @where_args );
574 while (my $data=$sth->fetchrow_hashref) {
575 if ($opac && $data->{lib_opac}) {
576 $data->{lib} = $data->{lib_opac};
578 push @results, $data;
582 $cache->set_in_cache( $cache_key, \@results, { expiry => 5 } );
588 my $escaped_string = C4::Koha::xml_escape($string);
590 Convert &, <, >, ', and " in a string to XML entities
596 return '' unless defined $str;
600 $str =~ s/'/'/g;
601 $str =~ s/"/"/g;
605 =head2 display_marc_indicators
607 my $display_form = C4::Koha::display_marc_indicators($field);
609 C<$field> is a MARC::Field object
611 Generate a display form of the indicators of a variable
612 MARC field, replacing any blanks with '#'.
616 sub display_marc_indicators {
619 if ($field && $field->tag() >= 10) {
620 $indicators = $field->indicator(1) . $field->indicator(2);
621 $indicators =~ s/ /#/g;
626 sub GetNormalizedUPC {
627 my ($marcrecord,$marcflavour) = @_;
629 return unless $marcrecord;
630 if ($marcflavour eq 'UNIMARC') {
631 my @fields = $marcrecord->field('072');
632 foreach my $field (@fields) {
633 my $upc = _normalize_match_point($field->subfield('a'));
640 else { # assume marc21 if not unimarc
641 my @fields = $marcrecord->field('024');
642 foreach my $field (@fields) {
643 my $indicator = $field->indicator(1);
644 my $upc = _normalize_match_point($field->subfield('a'));
645 if ($upc && $indicator == 1 ) {
652 # Normalizes and returns the first valid ISBN found in the record
653 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
654 sub GetNormalizedISBN {
655 my ($isbn,$marcrecord,$marcflavour) = @_;
657 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
658 # anything after " | " should be removed, along with the delimiter
659 ($isbn) = split(/\|/, $isbn );
660 return _isbn_cleanup($isbn);
663 return unless $marcrecord;
665 if ($marcflavour eq 'UNIMARC') {
666 my @fields = $marcrecord->field('010');
667 foreach my $field (@fields) {
668 my $isbn = $field->subfield('a');
670 return _isbn_cleanup($isbn);
674 else { # assume marc21 if not unimarc
675 my @fields = $marcrecord->field('020');
676 foreach my $field (@fields) {
677 $isbn = $field->subfield('a');
679 return _isbn_cleanup($isbn);
685 sub GetNormalizedEAN {
686 my ($marcrecord,$marcflavour) = @_;
688 return unless $marcrecord;
690 if ($marcflavour eq 'UNIMARC') {
691 my @fields = $marcrecord->field('073');
692 foreach my $field (@fields) {
693 my $ean = _normalize_match_point($field->subfield('a'));
699 else { # assume marc21 if not unimarc
700 my @fields = $marcrecord->field('024');
701 foreach my $field (@fields) {
702 my $indicator = $field->indicator(1);
703 my $ean = _normalize_match_point($field->subfield('a'));
704 if ( $ean && $indicator == 3 ) {
711 sub GetNormalizedOCLCNumber {
712 my ($marcrecord,$marcflavour) = @_;
713 return unless $marcrecord;
715 if ($marcflavour ne 'UNIMARC' ) {
716 my @fields = $marcrecord->field('035');
717 foreach my $field (@fields) {
718 my $oclc = $field->subfield('a');
719 if ($oclc =~ /OCoLC/) {
720 $oclc =~ s/\(OCoLC\)//;
730 =head2 GetDailyQuote($opts)
732 Takes a hashref of options
734 Currently supported options are:
736 'id' An exact quote id
737 'random' Select a random quote
738 noop When no option is passed in, this sub will return the quote timestamped for the current day
740 The function returns an anonymous hash following this format:
743 'source' => 'source-of-quote',
744 'timestamp' => 'timestamp-value',
745 'text' => 'text-of-quote',
751 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
752 # at least for default option
756 my $dbh = C4::Context->dbh;
761 $query = 'SELECT * FROM quotes WHERE id = ?';
762 $sth = $dbh->prepare($query);
763 $sth->execute($opts{'id'});
764 $quote = $sth->fetchrow_hashref();
766 elsif ($opts{'random'}) {
767 # Fall through... we also return a random quote as a catch-all if all else fails
770 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
771 $sth = $dbh->prepare($query);
773 $quote = $sth->fetchrow_hashref();
775 unless ($quote) { # if there are not matches, choose a random quote
776 # get a list of all available quote ids
777 $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
779 my $range = ($sth->fetchrow_array)[0];
780 # chose a random id within that range if there is more than one quote
781 my $offset = int(rand($range));
783 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
784 $sth = C4::Context->dbh->prepare($query);
785 # see http://www.perlmonks.org/?node_id=837422 for why
786 # we're being verbose and using bind_param
787 $sth->bind_param(1, $offset, SQL_INTEGER);
789 $quote = $sth->fetchrow_hashref();
790 # update the timestamp for that quote
791 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
792 $sth = C4::Context->dbh->prepare($query);
794 DateTime::Format::MySQL->format_datetime( dt_from_string() ),
801 sub _normalize_match_point {
802 my $match_point = shift;
803 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
804 $normalized_match_point =~ s/-//g;
806 return $normalized_match_point;
811 return NormalizeISBN(
822 my $isbns = NormalizeISBN({
824 strip_hyphens => [0,1],
825 format => ['ISBN-10', 'ISBN-13']
828 Returns an isbn validated by Business::ISBN.
829 Optionally strips hyphens and/or forces the isbn
830 to be of the specified format.
832 If the string cannot be validated as an isbn,
833 it returns nothing unless return_invalid param is passed.
835 #FIXME This routine (and others?) should be moved to Koha::Util::Normalize
842 my $string = $params->{isbn};
843 my $strip_hyphens = $params->{strip_hyphens};
844 my $format = $params->{format};
845 my $return_invalid = $params->{return_invalid};
847 return unless $string;
849 my $isbn = Business::ISBN->new($string);
851 if ( $isbn && $isbn->is_valid() ) {
853 if ( $format eq 'ISBN-10' ) {
854 $isbn = $isbn->as_isbn10();
856 elsif ( $format eq 'ISBN-13' ) {
857 $isbn = $isbn->as_isbn13();
861 if ($strip_hyphens) {
862 $string = $isbn->as_string( [] );
864 $string = $isbn->as_string();
868 } elsif ( $return_invalid ) {
874 =head2 GetVariationsOfISBN
876 my @isbns = GetVariationsOfISBN( $isbn );
878 Returns a list of variations of the given isbn in
879 both ISBN-10 and ISBN-13 formats, with and without
882 In a scalar context, the isbns are returned as a
883 string delimited by ' | '.
887 sub GetVariationsOfISBN {
894 push( @isbns, NormalizeISBN({ isbn => $isbn, return_invalid => 1 }) );
895 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
896 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
897 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
898 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
900 # Strip out any "empty" strings from the array
901 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
903 return wantarray ? @isbns : join( " | ", @isbns );
906 =head2 GetVariationsOfISBNs
908 my @isbns = GetVariationsOfISBNs( @isbns );
910 Returns a list of variations of the given isbns in
911 both ISBN-10 and ISBN-13 formats, with and without
914 In a scalar context, the isbns are returned as a
915 string delimited by ' | '.
919 sub GetVariationsOfISBNs {
922 @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
924 return wantarray ? @isbns : join( " | ", @isbns );
927 =head2 NormalizedISSN
929 my $issns = NormalizedISSN({
931 strip_hyphen => [0,1]
934 Returns an issn validated by Business::ISSN.
935 Optionally strips hyphen.
937 If the string cannot be validated as an issn,
945 my $string = $params->{issn};
946 my $strip_hyphen = $params->{strip_hyphen};
948 my $issn = Business::ISSN->new($string);
950 if ( $issn && $issn->is_valid ){
953 $string = $issn->_issn;
956 $string = $issn->as_string;
963 =head2 GetVariationsOfISSN
965 my @issns = GetVariationsOfISSN( $issn );
967 Returns a list of variations of the given issn in
968 with and without a hyphen.
970 In a scalar context, the issns are returned as a
971 string delimited by ' | '.
975 sub GetVariationsOfISSN {
981 my $str = NormalizeISSN({ issn => $issn });
984 push @issns, NormalizeISSN({ issn => $issn, strip_hyphen => 1 });
989 # Strip out any "empty" strings from the array
990 @issns = grep { defined($_) && $_ =~ /\S/ } @issns;
992 return wantarray ? @issns : join( " | ", @issns );
995 =head2 GetVariationsOfISSNs
997 my @issns = GetVariationsOfISSNs( @issns );
999 Returns a list of variations of the given issns in
1000 with and without a hyphen.
1002 In a scalar context, the issns are returned as a
1003 string delimited by ' | '.
1007 sub GetVariationsOfISSNs {
1010 @issns = map { GetVariationsOfISSN( $_ ) } @issns;
1012 return wantarray ? @issns : join( " | ", @issns );