3 # Copyright 2000-2002 Katipo Communications
4 # Parts Copyright 2010 Nelsonville Public Library
6 # This file is part of Koha.
8 # Koha is free software; you can redistribute it and/or modify it under the
9 # terms of the GNU General Public License as published by the Free Software
10 # Foundation; either version 2 of the License, or (at your option) any later
13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
15 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License along
18 # with Koha; if not, write to the Free Software Foundation, Inc.,
19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
23 #use warnings; FIXME - Bug 2505
26 use URI::Split qw(uri_split);
30 use vars qw($VERSION @ISA @EXPORT $DEBUG);
39 &subfield_is_koha_internal_p
40 &GetPrinters &GetPrinter
41 &GetItemTypes &getitemtypeinfo
43 &GetSupportName &GetSupportList
45 &getframeworks &getframeworkinfo
46 &getauthtypes &getauthtype
52 &get_notforloan_label_of
55 &getitemtypeimagelocation
57 &GetAuthorisedValueCategories
58 &GetKohaAuthorisedValues
59 &GetKohaAuthorisedValuesFromField
64 &GetNormalizedOCLCNumber
72 memoize('GetAuthorisedValues');
76 C4::Koha - Perl Module containing convenience functions for Koha scripts
84 Koha.pm provides many functions for Koha scripts.
92 $slash_date = &slashifyDate($dash_date);
94 Takes a string of the form "DD-MM-YYYY" (or anything separated by
95 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
101 # accepts a date of the form xx-xx-xx[xx] and returns it in the
103 my @dateOut = split( '-', shift );
104 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
110 my $string = DisplayISBN( $isbn );
116 if (length ($isbn)<13){
118 if ( substr( $isbn, 0, 1 ) <= 7 ) {
119 $seg1 = substr( $isbn, 0, 1 );
121 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
122 $seg1 = substr( $isbn, 0, 2 );
124 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
125 $seg1 = substr( $isbn, 0, 3 );
127 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
128 $seg1 = substr( $isbn, 0, 4 );
131 $seg1 = substr( $isbn, 0, 5 );
133 my $x = substr( $isbn, length($seg1) );
135 if ( substr( $x, 0, 2 ) <= 19 ) {
137 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
138 $seg2 = substr( $x, 0, 2 );
140 elsif ( substr( $x, 0, 3 ) <= 699 ) {
141 $seg2 = substr( $x, 0, 3 );
143 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
144 $seg2 = substr( $x, 0, 4 );
146 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
147 $seg2 = substr( $x, 0, 5 );
149 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
150 $seg2 = substr( $x, 0, 6 );
153 $seg2 = substr( $x, 0, 7 );
155 my $seg3 = substr( $x, length($seg2) );
156 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
157 my $seg4 = substr( $x, -1, 1 );
158 return "$seg1-$seg2-$seg3-$seg4";
161 $seg1 = substr( $isbn, 0, 3 );
163 if ( substr( $isbn, 3, 1 ) <= 7 ) {
164 $seg2 = substr( $isbn, 3, 1 );
166 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
167 $seg2 = substr( $isbn, 3, 2 );
169 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
170 $seg2 = substr( $isbn, 3, 3 );
172 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
173 $seg2 = substr( $isbn, 3, 4 );
176 $seg2 = substr( $isbn, 3, 5 );
178 my $x = substr( $isbn, length($seg2) +3);
180 if ( substr( $x, 0, 2 ) <= 19 ) {
182 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
183 $seg3 = substr( $x, 0, 2 );
185 elsif ( substr( $x, 0, 3 ) <= 699 ) {
186 $seg3 = substr( $x, 0, 3 );
188 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
189 $seg3 = substr( $x, 0, 4 );
191 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
192 $seg3 = substr( $x, 0, 5 );
194 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
195 $seg3 = substr( $x, 0, 6 );
198 $seg3 = substr( $x, 0, 7 );
200 my $seg4 = substr( $x, length($seg3) );
201 $seg4 = substr( $seg4, 0, length($seg4) - 1 );
202 my $seg5 = substr( $x, -1, 1 );
203 return "$seg1-$seg2-$seg3-$seg4-$seg5";
207 # FIXME.. this should be moved to a MARC-specific module
208 sub subfield_is_koha_internal_p ($) {
211 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
212 # But real MARC subfields are always single-character
213 # so it really is safer just to check the length
215 return length $subfield != 1;
218 =head2 GetSupportName
220 $itemtypename = &GetSupportName($codestring);
222 Returns a string with the name of the itemtype.
228 return if (! $codestring);
230 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
231 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
238 my $sth = C4::Context->dbh->prepare($query);
239 $sth->execute($codestring);
240 ($resultstring)=$sth->fetchrow;
241 return $resultstring;
244 C4::Context->dbh->prepare(
245 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
247 $sth->execute( $advanced_search_types, $codestring );
248 my $data = $sth->fetchrow_hashref;
249 return $$data{'lib'};
253 =head2 GetSupportList
255 $itemtypes = &GetSupportList();
257 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
259 build a HTML select with the following code :
261 =head3 in PERL SCRIPT
263 my $itemtypes = GetSupportList();
264 $template->param(itemtypeloop => $itemtypes);
268 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
269 <select name="itemtype">
270 <option value="">Default</option>
271 <!-- TMPL_LOOP name="itemtypeloop" -->
272 <option value="<!-- TMPL_VAR name="itemtype" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->> <!--TMPL_IF Name="imageurl"--><img alt="<!-- TMPL_VAR name="description" -->" src="<!--TMPL_VAR Name="imageurl"-->><!--TMPL_ELSE-->"<!-- TMPL_VAR name="description" --><!--/TMPL_IF--></option>
275 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
276 <input type="submit" value="OK" class="button">
282 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
283 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
289 my $sth = C4::Context->dbh->prepare($query);
291 return $sth->fetchall_arrayref({});
293 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
294 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
300 $itemtypes = &GetItemTypes();
302 Returns information about existing itemtypes.
304 build a HTML select with the following code :
306 =head3 in PERL SCRIPT
308 my $itemtypes = GetItemTypes;
310 foreach my $thisitemtype (sort keys %$itemtypes) {
311 my $selected = 1 if $thisitemtype eq $itemtype;
312 my %row =(value => $thisitemtype,
313 selected => $selected,
314 description => $itemtypes->{$thisitemtype}->{'description'},
316 push @itemtypesloop, \%row;
318 $template->param(itemtypeloop => \@itemtypesloop);
322 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
323 <select name="itemtype">
324 <option value="">Default</option>
325 <!-- TMPL_LOOP name="itemtypeloop" -->
326 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
329 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
330 <input type="submit" value="OK" class="button">
337 # returns a reference to a hash of references to itemtypes...
339 my $dbh = C4::Context->dbh;
344 my $sth = $dbh->prepare($query);
346 while ( my $IT = $sth->fetchrow_hashref ) {
347 $itemtypes{ $IT->{'itemtype'} } = $IT;
349 return ( \%itemtypes );
352 sub get_itemtypeinfos_of {
355 my $placeholders = join( ', ', map { '?' } @itemtypes );
356 my $query = <<"END_SQL";
362 WHERE itemtype IN ( $placeholders )
365 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
368 # this is temporary until we separate collection codes and item types
372 my $dbh = C4::Context->dbh;
375 "SELECT * FROM authorised_values ORDER BY authorised_value");
377 while ( my $data = $sth->fetchrow_hashref ) {
378 if ( $data->{category} eq "CCODE" ) {
380 $results[$count] = $data;
386 return ( $count, @results );
391 $authtypes = &getauthtypes();
393 Returns information about existing authtypes.
395 build a HTML select with the following code :
397 =head3 in PERL SCRIPT
399 my $authtypes = getauthtypes;
401 foreach my $thisauthtype (keys %$authtypes) {
402 my $selected = 1 if $thisauthtype eq $authtype;
403 my %row =(value => $thisauthtype,
404 selected => $selected,
405 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
407 push @authtypesloop, \%row;
409 $template->param(itemtypeloop => \@itemtypesloop);
413 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
414 <select name="authtype">
415 <!-- TMPL_LOOP name="authtypeloop" -->
416 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
419 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
420 <input type="submit" value="OK" class="button">
428 # returns a reference to a hash of references to authtypes...
430 my $dbh = C4::Context->dbh;
431 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
433 while ( my $IT = $sth->fetchrow_hashref ) {
434 $authtypes{ $IT->{'authtypecode'} } = $IT;
436 return ( \%authtypes );
440 my ($authtypecode) = @_;
442 # returns a reference to a hash of references to authtypes...
444 my $dbh = C4::Context->dbh;
445 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
446 $sth->execute($authtypecode);
447 my $res = $sth->fetchrow_hashref;
453 $frameworks = &getframework();
455 Returns information about existing frameworks
457 build a HTML select with the following code :
459 =head3 in PERL SCRIPT
461 my $frameworks = frameworks();
463 foreach my $thisframework (keys %$frameworks) {
464 my $selected = 1 if $thisframework eq $frameworkcode;
465 my %row =(value => $thisframework,
466 selected => $selected,
467 description => $frameworks->{$thisframework}->{'frameworktext'},
469 push @frameworksloop, \%row;
471 $template->param(frameworkloop => \@frameworksloop);
475 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
476 <select name="frameworkcode">
477 <option value="">Default</option>
478 <!-- TMPL_LOOP name="frameworkloop" -->
479 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
482 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
483 <input type="submit" value="OK" class="button">
490 # returns a reference to a hash of references to branches...
492 my $dbh = C4::Context->dbh;
493 my $sth = $dbh->prepare("select * from biblio_framework");
495 while ( my $IT = $sth->fetchrow_hashref ) {
496 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
498 return ( \%itemtypes );
501 =head2 getframeworkinfo
503 $frameworkinfo = &getframeworkinfo($frameworkcode);
505 Returns information about an frameworkcode.
509 sub getframeworkinfo {
510 my ($frameworkcode) = @_;
511 my $dbh = C4::Context->dbh;
513 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
514 $sth->execute($frameworkcode);
515 my $res = $sth->fetchrow_hashref;
519 =head2 getitemtypeinfo
521 $itemtype = &getitemtype($itemtype);
523 Returns information about an itemtype.
527 sub getitemtypeinfo {
529 my $dbh = C4::Context->dbh;
530 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
531 $sth->execute($itemtype);
532 my $res = $sth->fetchrow_hashref;
534 $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} );
539 =head2 getitemtypeimagedir
541 my $directory = getitemtypeimagedir( 'opac' );
543 pass in 'opac' or 'intranet'. Defaults to 'opac'.
545 returns the full path to the appropriate directory containing images.
549 sub getitemtypeimagedir {
550 my $src = shift || 'opac';
551 if ($src eq 'intranet') {
552 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
554 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
558 sub getitemtypeimagesrc {
559 my $src = shift || 'opac';
560 if ($src eq 'intranet') {
561 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
563 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
567 sub getitemtypeimagelocation($$) {
568 my ( $src, $image ) = @_;
570 return '' if ( !$image );
572 my $scheme = ( uri_split( $image ) )[0];
574 return $image if ( $scheme );
576 return getitemtypeimagesrc( $src ) . '/' . $image;
579 =head3 _getImagesFromDirectory
581 Find all of the image files in a directory in the filesystem
583 parameters: a directory name
585 returns: a list of images in that directory.
587 Notes: this does not traverse into subdirectories. See
588 _getSubdirectoryNames for help with that.
589 Images are assumed to be files with .gif or .png file extensions.
590 The image names returned do not have the directory name on them.
594 sub _getImagesFromDirectory {
595 my $directoryname = shift;
596 return unless defined $directoryname;
597 return unless -d $directoryname;
599 if ( opendir ( my $dh, $directoryname ) ) {
600 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
602 @images = sort(@images);
605 warn "unable to opendir $directoryname: $!";
610 =head3 _getSubdirectoryNames
612 Find all of the directories in a directory in the filesystem
614 parameters: a directory name
616 returns: a list of subdirectories in that directory.
618 Notes: this does not traverse into subdirectories. Only the first
619 level of subdirectories are returned.
620 The directory names returned don't have the parent directory name on them.
624 sub _getSubdirectoryNames {
625 my $directoryname = shift;
626 return unless defined $directoryname;
627 return unless -d $directoryname;
629 if ( opendir ( my $dh, $directoryname ) ) {
630 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
634 warn "unable to opendir $directoryname: $!";
641 returns: a listref of hashrefs. Each hash represents another collection of images.
643 { imagesetname => 'npl', # the name of the image set (npl is the original one)
644 images => listref of image hashrefs
647 each image is represented by a hashref like this:
649 { KohaImage => 'npl/image.gif',
650 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
651 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
652 checked => 0 or 1: was this the image passed to this method?
653 Note: I'd like to remove this somehow.
660 my $checked = $params{'checked'} || '';
662 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
663 url => getitemtypeimagesrc('intranet'),
665 opac => { filesystem => getitemtypeimagedir('opac'),
666 url => getitemtypeimagesrc('opac'),
670 my @imagesets = (); # list of hasrefs of image set data to pass to template
671 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
673 foreach my $imagesubdir ( @subdirectories ) {
674 my @imagelist = (); # hashrefs of image info
675 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
676 my $imagesetactive = 0;
677 foreach my $thisimage ( @imagenames ) {
679 { KohaImage => "$imagesubdir/$thisimage",
680 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
681 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
682 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
685 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
687 push @imagesets, { imagesetname => $imagesubdir,
688 imagesetactive => $imagesetactive,
689 images => \@imagelist };
697 $printers = &GetPrinters();
698 @queues = keys %$printers;
700 Returns information about existing printer queues.
702 C<$printers> is a reference-to-hash whose keys are the print queues
703 defined in the printers table of the Koha database. The values are
704 references-to-hash, whose keys are the fields in the printers table.
710 my $dbh = C4::Context->dbh;
711 my $sth = $dbh->prepare("select * from printers");
713 while ( my $printer = $sth->fetchrow_hashref ) {
714 $printers{ $printer->{'printqueue'} } = $printer;
716 return ( \%printers );
721 $printer = GetPrinter( $query, $printers );
725 sub GetPrinter ($$) {
726 my ( $query, $printers ) = @_; # get printer for this query from printers
727 my $printer = $query->param('printer');
728 my %cookie = $query->cookie('userenv');
729 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
730 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
736 Returns the number of pages to display in a pagination bar, given the number
737 of items and the number of items per page.
742 my ( $nb_items, $nb_items_per_page ) = @_;
744 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
749 (@themes) = &getallthemes('opac');
750 (@themes) = &getallthemes('intranet');
752 Returns an array of all available themes.
760 if ( $type eq 'intranet' ) {
761 $htdocs = C4::Context->config('intrahtdocs');
764 $htdocs = C4::Context->config('opachtdocs');
766 opendir D, "$htdocs";
767 my @dirlist = readdir D;
768 foreach my $directory (@dirlist) {
769 -d "$htdocs/$directory/en" and push @themes, $directory;
776 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
779 link_value => 'su-to',
780 label_value => 'Topics',
782 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
786 link_value => 'su-geo',
787 label_value => 'Places',
792 link_value => 'su-ut',
793 label_value => 'Titles',
794 tags => [ '500', '501', '502', '503', '504', ],
799 label_value => 'Authors',
800 tags => [ '700', '701', '702', ],
805 label_value => 'Series',
814 link_value => 'branch',
815 label_value => 'Libraries',
820 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
825 link_value => 'su-to',
826 label_value => 'Topics',
832 # link_value => 'su-na',
833 # label_value => 'People and Organizations',
834 # tags => ['600', '610', '611'],
838 link_value => 'su-geo',
839 label_value => 'Places',
844 link_value => 'su-ut',
845 label_value => 'Titles',
851 label_value => 'Authors',
852 tags => [ '100', '110', '700', ],
857 label_value => 'Series',
858 tags => [ '440', '490', ],
864 link_value => 'branch',
865 label_value => 'Libraries',
870 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
877 Return a href where a key is associated to a href. You give a query,
878 the name of the key among the fields returned by the query. If you
879 also give as third argument the name of the value, the function
880 returns a href of scalar. The optional 4th argument is an arrayref of
881 items passed to the C<execute()> call. It is designed to bind
882 parameters to any placeholders in your SQL.
891 # generic href of any information on the item, href of href.
892 my $iteminfos_of = get_infos_of($query, 'itemnumber');
893 print $iteminfos_of->{$itemnumber}{barcode};
895 # specific information, href of scalar
896 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
897 print $barcode_of_item->{$itemnumber};
902 my ( $query, $key_name, $value_name, $bind_params ) = @_;
904 my $dbh = C4::Context->dbh;
906 my $sth = $dbh->prepare($query);
907 $sth->execute( @$bind_params );
910 while ( my $row = $sth->fetchrow_hashref ) {
911 if ( defined $value_name ) {
912 $infos_of{ $row->{$key_name} } = $row->{$value_name};
915 $infos_of{ $row->{$key_name} } = $row;
923 =head2 get_notforloan_label_of
925 my $notforloan_label_of = get_notforloan_label_of();
927 Each authorised value of notforloan (information available in items and
928 itemtypes) is link to a single label.
930 Returns a href where keys are authorised values and values are corresponding
933 foreach my $authorised_value (keys %{$notforloan_label_of}) {
935 "authorised_value: %s => %s\n",
937 $notforloan_label_of->{$authorised_value}
943 # FIXME - why not use GetAuthorisedValues ??
945 sub get_notforloan_label_of {
946 my $dbh = C4::Context->dbh;
949 SELECT authorised_value
950 FROM marc_subfield_structure
951 WHERE kohafield = \'items.notforloan\'
954 my $sth = $dbh->prepare($query);
956 my ($statuscode) = $sth->fetchrow_array();
961 FROM authorised_values
964 $sth = $dbh->prepare($query);
965 $sth->execute($statuscode);
966 my %notforloan_label_of;
967 while ( my $row = $sth->fetchrow_hashref ) {
968 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
972 return \%notforloan_label_of;
975 =head2 displayServers
977 my $servers = displayServers();
978 my $servers = displayServers( $position );
979 my $servers = displayServers( $position, $type );
981 displayServers returns a listref of hashrefs, each containing
982 information about available z3950 servers. Each hashref has a format
986 'checked' => 'checked',
987 'encoding' => 'MARC-8'
989 'id' => 'LIBRARY OF CONGRESS',
993 'value' => 'z3950.loc.gov:7090/',
1000 my ( $position, $type ) = @_;
1001 my $dbh = C4::Context->dbh;
1003 my $strsth = 'SELECT * FROM z3950servers';
1008 push @bind_params, $position;
1009 push @where_clauses, ' position = ? ';
1013 push @bind_params, $type;
1014 push @where_clauses, ' type = ? ';
1017 # reassemble where clause from where clause pieces
1018 if (@where_clauses) {
1019 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1022 my $rq = $dbh->prepare($strsth);
1023 $rq->execute(@bind_params);
1024 my @primaryserverloop;
1026 while ( my $data = $rq->fetchrow_hashref ) {
1027 push @primaryserverloop,
1028 { label => $data->{description},
1029 id => $data->{name},
1031 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1032 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1033 checked => "checked",
1034 icon => $data->{icon},
1035 zed => $data->{type} eq 'zed',
1036 opensearch => $data->{type} eq 'opensearch'
1039 return \@primaryserverloop;
1042 =head2 GetAuthValCode
1044 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1048 sub GetAuthValCode {
1049 my ($kohafield,$fwcode) = @_;
1050 my $dbh = C4::Context->dbh;
1051 $fwcode='' unless $fwcode;
1052 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1053 $sth->execute($kohafield,$fwcode);
1054 my ($authvalcode) = $sth->fetchrow_array;
1055 return $authvalcode;
1058 =head2 GetAuthValCodeFromField
1060 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1062 C<$subfield> can be undefined
1066 sub GetAuthValCodeFromField {
1067 my ($field,$subfield,$fwcode) = @_;
1068 my $dbh = C4::Context->dbh;
1069 $fwcode='' unless $fwcode;
1071 if (defined $subfield) {
1072 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1073 $sth->execute($field,$subfield,$fwcode);
1075 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1076 $sth->execute($field,$fwcode);
1078 my ($authvalcode) = $sth->fetchrow_array;
1079 return $authvalcode;
1082 =head2 GetAuthorisedValues
1084 $authvalues = GetAuthorisedValues([$category], [$selected]);
1086 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1088 C<$category> returns authorised values for just one category (optional).
1090 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1094 sub GetAuthorisedValues {
1095 my ($category,$selected,$opac) = @_;
1097 my $dbh = C4::Context->dbh;
1098 my $query = "SELECT * FROM authorised_values";
1099 $query .= " WHERE category = '" . $category . "'" if $category;
1100 $query .= " ORDER BY category, lib, lib_opac";
1101 my $sth = $dbh->prepare($query);
1103 while (my $data=$sth->fetchrow_hashref) {
1104 if ($selected && $selected eq $data->{'authorised_value'} ) {
1105 $data->{'selected'} = 1;
1107 if ($opac && $data->{'lib_opac'}) {
1108 $data->{'lib'} = $data->{'lib_opac'};
1110 push @results, $data;
1112 #my $data = $sth->fetchall_arrayref({});
1113 return \@results; #$data;
1116 =head2 GetAuthorisedValueCategories
1118 $auth_categories = GetAuthorisedValueCategories();
1120 Return an arrayref of all of the available authorised
1125 sub GetAuthorisedValueCategories {
1126 my $dbh = C4::Context->dbh;
1127 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1130 while (my $category = $sth->fetchrow_array) {
1131 push @results, $category;
1136 =head2 GetKohaAuthorisedValues
1138 Takes $kohafield, $fwcode as parameters.
1140 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1142 Returns hashref of Code => description
1144 Returns undef if no authorised value category is defined for the kohafield.
1148 sub GetKohaAuthorisedValues {
1149 my ($kohafield,$fwcode,$opac) = @_;
1150 $fwcode='' unless $fwcode;
1152 my $dbh = C4::Context->dbh;
1153 my $avcode = GetAuthValCode($kohafield,$fwcode);
1155 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1156 $sth->execute($avcode);
1157 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1158 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1166 =head2 GetKohaAuthorisedValuesFromField
1168 Takes $field, $subfield, $fwcode as parameters.
1170 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1171 $subfield can be undefined
1173 Returns hashref of Code => description
1175 Returns undef if no authorised value category is defined for the given field and subfield
1179 sub GetKohaAuthorisedValuesFromField {
1180 my ($field, $subfield, $fwcode,$opac) = @_;
1181 $fwcode='' unless $fwcode;
1183 my $dbh = C4::Context->dbh;
1184 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1186 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1187 $sth->execute($avcode);
1188 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1189 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1197 =head2 display_marc_indicators
1199 my $display_form = C4::Koha::display_marc_indicators($field);
1201 C<$field> is a MARC::Field object
1203 Generate a display form of the indicators of a variable
1204 MARC field, replacing any blanks with '#'.
1208 sub display_marc_indicators {
1210 my $indicators = '';
1211 if ($field->tag() >= 10) {
1212 $indicators = $field->indicator(1) . $field->indicator(2);
1213 $indicators =~ s/ /#/g;
1218 sub GetNormalizedUPC {
1219 my ($record,$marcflavour) = @_;
1222 if ($marcflavour eq 'MARC21') {
1223 @fields = $record->field('024');
1224 foreach my $field (@fields) {
1225 my $indicator = $field->indicator(1);
1226 my $upc = _normalize_match_point($field->subfield('a'));
1227 if ($indicator == 1 and $upc ne '') {
1232 else { # assume unimarc if not marc21
1233 @fields = $record->field('072');
1234 foreach my $field (@fields) {
1235 my $upc = _normalize_match_point($field->subfield('a'));
1243 # Normalizes and returns the first valid ISBN found in the record
1244 # ISBN13 are converted into ISBN10. This is required to get Amazon cover book.
1245 sub GetNormalizedISBN {
1246 my ($isbn,$record,$marcflavour) = @_;
1249 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1250 # anything after " | " should be removed, along with the delimiter
1251 $isbn =~ s/(.*)( \| )(.*)/$1/;
1252 return _isbn_cleanup($isbn);
1254 return undef unless $record;
1256 if ($marcflavour eq 'MARC21') {
1257 @fields = $record->field('020');
1258 foreach my $field (@fields) {
1259 $isbn = $field->subfield('a');
1261 return _isbn_cleanup($isbn);
1267 else { # assume unimarc if not marc21
1268 @fields = $record->field('010');
1269 foreach my $field (@fields) {
1270 my $isbn = $field->subfield('a');
1272 return _isbn_cleanup($isbn);
1281 sub GetNormalizedEAN {
1282 my ($record,$marcflavour) = @_;
1285 if ($marcflavour eq 'MARC21') {
1286 @fields = $record->field('024');
1287 foreach my $field (@fields) {
1288 my $indicator = $field->indicator(1);
1289 $ean = _normalize_match_point($field->subfield('a'));
1290 if ($indicator == 3 and $ean ne '') {
1295 else { # assume unimarc if not marc21
1296 @fields = $record->field('073');
1297 foreach my $field (@fields) {
1298 $ean = _normalize_match_point($field->subfield('a'));
1305 sub GetNormalizedOCLCNumber {
1306 my ($record,$marcflavour) = @_;
1309 if ($marcflavour eq 'MARC21') {
1310 @fields = $record->field('035');
1311 foreach my $field (@fields) {
1312 $oclc = $field->subfield('a');
1313 if ($oclc =~ /OCoLC/) {
1314 $oclc =~ s/\(OCoLC\)//;
1321 else { # TODO: add UNIMARC fields
1325 sub _normalize_match_point {
1326 my $match_point = shift;
1327 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1328 $normalized_match_point =~ s/-//g;
1330 return $normalized_match_point;
1333 sub _isbn_cleanup ($) {
1334 my $isbn = Business::ISBN->new( shift );
1335 return undef unless $isbn;
1336 $isbn = $isbn->as_isbn10 if $isbn->type eq 'ISBN13';
1337 return undef unless $isbn;
1338 $isbn = $isbn->as_string;