3 # Copyright 2000-2002 Katipo Communications
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it under the
8 # terms of the GNU General Public License as published by the Free Software
9 # Foundation; either version 2 of the License, or (at your option) any later
12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License along
17 # with Koha; if not, write to the Free Software Foundation, Inc.,
18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
22 #use warnings; FIXME - Bug 2505
25 use URI::Split qw(uri_split);
29 use vars qw($VERSION @ISA @EXPORT $DEBUG);
38 &subfield_is_koha_internal_p
39 &GetPrinters &GetPrinter
40 &GetItemTypes &getitemtypeinfo
42 &GetSupportName &GetSupportList
44 &getframeworks &getframeworkinfo
45 &getauthtypes &getauthtype
51 &get_notforloan_label_of
54 &getitemtypeimagelocation
56 &GetAuthorisedValueCategories
57 &GetKohaAuthorisedValues
58 &GetKohaAuthorisedValuesFromField
63 &GetNormalizedOCLCNumber
71 memoize('GetAuthorisedValues');
75 C4::Koha - Perl Module containing convenience functions for Koha scripts
83 Koha.pm provides many functions for Koha scripts.
91 $slash_date = &slashifyDate($dash_date);
93 Takes a string of the form "DD-MM-YYYY" (or anything separated by
94 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
100 # accepts a date of the form xx-xx-xx[xx] and returns it in the
102 my @dateOut = split( '-', shift );
103 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
109 my $string = DisplayISBN( $isbn );
115 if (length ($isbn)<13){
117 if ( substr( $isbn, 0, 1 ) <= 7 ) {
118 $seg1 = substr( $isbn, 0, 1 );
120 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
121 $seg1 = substr( $isbn, 0, 2 );
123 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
124 $seg1 = substr( $isbn, 0, 3 );
126 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
127 $seg1 = substr( $isbn, 0, 4 );
130 $seg1 = substr( $isbn, 0, 5 );
132 my $x = substr( $isbn, length($seg1) );
134 if ( substr( $x, 0, 2 ) <= 19 ) {
136 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
137 $seg2 = substr( $x, 0, 2 );
139 elsif ( substr( $x, 0, 3 ) <= 699 ) {
140 $seg2 = substr( $x, 0, 3 );
142 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
143 $seg2 = substr( $x, 0, 4 );
145 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
146 $seg2 = substr( $x, 0, 5 );
148 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
149 $seg2 = substr( $x, 0, 6 );
152 $seg2 = substr( $x, 0, 7 );
154 my $seg3 = substr( $x, length($seg2) );
155 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
156 my $seg4 = substr( $x, -1, 1 );
157 return "$seg1-$seg2-$seg3-$seg4";
160 $seg1 = substr( $isbn, 0, 3 );
162 if ( substr( $isbn, 3, 1 ) <= 7 ) {
163 $seg2 = substr( $isbn, 3, 1 );
165 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
166 $seg2 = substr( $isbn, 3, 2 );
168 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
169 $seg2 = substr( $isbn, 3, 3 );
171 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
172 $seg2 = substr( $isbn, 3, 4 );
175 $seg2 = substr( $isbn, 3, 5 );
177 my $x = substr( $isbn, length($seg2) +3);
179 if ( substr( $x, 0, 2 ) <= 19 ) {
181 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
182 $seg3 = substr( $x, 0, 2 );
184 elsif ( substr( $x, 0, 3 ) <= 699 ) {
185 $seg3 = substr( $x, 0, 3 );
187 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
188 $seg3 = substr( $x, 0, 4 );
190 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
191 $seg3 = substr( $x, 0, 5 );
193 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
194 $seg3 = substr( $x, 0, 6 );
197 $seg3 = substr( $x, 0, 7 );
199 my $seg4 = substr( $x, length($seg3) );
200 $seg4 = substr( $seg4, 0, length($seg4) - 1 );
201 my $seg5 = substr( $x, -1, 1 );
202 return "$seg1-$seg2-$seg3-$seg4-$seg5";
206 # FIXME.. this should be moved to a MARC-specific module
207 sub subfield_is_koha_internal_p ($) {
210 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
211 # But real MARC subfields are always single-character
212 # so it really is safer just to check the length
214 return length $subfield != 1;
217 =head2 GetSupportName
219 $itemtypename = &GetSupportName($codestring);
221 Returns a string with the name of the itemtype.
227 return if (! $codestring);
229 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
230 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
237 my $sth = C4::Context->dbh->prepare($query);
238 $sth->execute($codestring);
239 ($resultstring)=$sth->fetchrow;
240 return $resultstring;
243 C4::Context->dbh->prepare(
244 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
246 $sth->execute( $advanced_search_types, $codestring );
247 my $data = $sth->fetchrow_hashref;
248 return $$data{'lib'};
252 =head2 GetSupportList
254 $itemtypes = &GetSupportList();
256 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
258 build a HTML select with the following code :
260 =head3 in PERL SCRIPT
262 my $itemtypes = GetSupportList();
263 $template->param(itemtypeloop => $itemtypes);
267 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
268 <select name="itemtype">
269 <option value="">Default</option>
270 <!-- TMPL_LOOP name="itemtypeloop" -->
271 <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>
274 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
275 <input type="submit" value="OK" class="button">
281 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
282 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
288 my $sth = C4::Context->dbh->prepare($query);
290 return $sth->fetchall_arrayref({});
292 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
293 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
299 $itemtypes = &GetItemTypes();
301 Returns information about existing itemtypes.
303 build a HTML select with the following code :
305 =head3 in PERL SCRIPT
307 my $itemtypes = GetItemTypes;
309 foreach my $thisitemtype (sort keys %$itemtypes) {
310 my $selected = 1 if $thisitemtype eq $itemtype;
311 my %row =(value => $thisitemtype,
312 selected => $selected,
313 description => $itemtypes->{$thisitemtype}->{'description'},
315 push @itemtypesloop, \%row;
317 $template->param(itemtypeloop => \@itemtypesloop);
321 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
322 <select name="itemtype">
323 <option value="">Default</option>
324 <!-- TMPL_LOOP name="itemtypeloop" -->
325 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
328 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
329 <input type="submit" value="OK" class="button">
336 # returns a reference to a hash of references to itemtypes...
338 my $dbh = C4::Context->dbh;
343 my $sth = $dbh->prepare($query);
345 while ( my $IT = $sth->fetchrow_hashref ) {
346 $itemtypes{ $IT->{'itemtype'} } = $IT;
348 return ( \%itemtypes );
351 sub get_itemtypeinfos_of {
354 my $placeholders = join( ', ', map { '?' } @itemtypes );
355 my $query = <<"END_SQL";
361 WHERE itemtype IN ( $placeholders )
364 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
367 # this is temporary until we separate collection codes and item types
371 my $dbh = C4::Context->dbh;
374 "SELECT * FROM authorised_values ORDER BY authorised_value");
376 while ( my $data = $sth->fetchrow_hashref ) {
377 if ( $data->{category} eq "CCODE" ) {
379 $results[$count] = $data;
385 return ( $count, @results );
390 $authtypes = &getauthtypes();
392 Returns information about existing authtypes.
394 build a HTML select with the following code :
396 =head3 in PERL SCRIPT
398 my $authtypes = getauthtypes;
400 foreach my $thisauthtype (keys %$authtypes) {
401 my $selected = 1 if $thisauthtype eq $authtype;
402 my %row =(value => $thisauthtype,
403 selected => $selected,
404 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
406 push @authtypesloop, \%row;
408 $template->param(itemtypeloop => \@itemtypesloop);
412 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
413 <select name="authtype">
414 <!-- TMPL_LOOP name="authtypeloop" -->
415 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
418 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
419 <input type="submit" value="OK" class="button">
427 # returns a reference to a hash of references to authtypes...
429 my $dbh = C4::Context->dbh;
430 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
432 while ( my $IT = $sth->fetchrow_hashref ) {
433 $authtypes{ $IT->{'authtypecode'} } = $IT;
435 return ( \%authtypes );
439 my ($authtypecode) = @_;
441 # returns a reference to a hash of references to authtypes...
443 my $dbh = C4::Context->dbh;
444 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
445 $sth->execute($authtypecode);
446 my $res = $sth->fetchrow_hashref;
452 $frameworks = &getframework();
454 Returns information about existing frameworks
456 build a HTML select with the following code :
458 =head3 in PERL SCRIPT
460 my $frameworks = frameworks();
462 foreach my $thisframework (keys %$frameworks) {
463 my $selected = 1 if $thisframework eq $frameworkcode;
464 my %row =(value => $thisframework,
465 selected => $selected,
466 description => $frameworks->{$thisframework}->{'frameworktext'},
468 push @frameworksloop, \%row;
470 $template->param(frameworkloop => \@frameworksloop);
474 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
475 <select name="frameworkcode">
476 <option value="">Default</option>
477 <!-- TMPL_LOOP name="frameworkloop" -->
478 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
481 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
482 <input type="submit" value="OK" class="button">
489 # returns a reference to a hash of references to branches...
491 my $dbh = C4::Context->dbh;
492 my $sth = $dbh->prepare("select * from biblio_framework");
494 while ( my $IT = $sth->fetchrow_hashref ) {
495 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
497 return ( \%itemtypes );
500 =head2 getframeworkinfo
502 $frameworkinfo = &getframeworkinfo($frameworkcode);
504 Returns information about an frameworkcode.
508 sub getframeworkinfo {
509 my ($frameworkcode) = @_;
510 my $dbh = C4::Context->dbh;
512 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
513 $sth->execute($frameworkcode);
514 my $res = $sth->fetchrow_hashref;
518 =head2 getitemtypeinfo
520 $itemtype = &getitemtype($itemtype);
522 Returns information about an itemtype.
526 sub getitemtypeinfo {
528 my $dbh = C4::Context->dbh;
529 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
530 $sth->execute($itemtype);
531 my $res = $sth->fetchrow_hashref;
533 $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} );
538 =head2 getitemtypeimagedir
540 my $directory = getitemtypeimagedir( 'opac' );
542 pass in 'opac' or 'intranet'. Defaults to 'opac'.
544 returns the full path to the appropriate directory containing images.
548 sub getitemtypeimagedir {
549 my $src = shift || 'opac';
550 if ($src eq 'intranet') {
551 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
553 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
557 sub getitemtypeimagesrc {
558 my $src = shift || 'opac';
559 if ($src eq 'intranet') {
560 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
562 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
566 sub getitemtypeimagelocation($$) {
567 my ( $src, $image ) = @_;
569 return '' if ( !$image );
571 my $scheme = ( uri_split( $image ) )[0];
573 return $image if ( $scheme );
575 return getitemtypeimagesrc( $src ) . '/' . $image;
578 =head3 _getImagesFromDirectory
580 Find all of the image files in a directory in the filesystem
582 parameters: a directory name
584 returns: a list of images in that directory.
586 Notes: this does not traverse into subdirectories. See
587 _getSubdirectoryNames for help with that.
588 Images are assumed to be files with .gif or .png file extensions.
589 The image names returned do not have the directory name on them.
593 sub _getImagesFromDirectory {
594 my $directoryname = shift;
595 return unless defined $directoryname;
596 return unless -d $directoryname;
598 if ( opendir ( my $dh, $directoryname ) ) {
599 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
601 @images = sort(@images);
604 warn "unable to opendir $directoryname: $!";
609 =head3 _getSubdirectoryNames
611 Find all of the directories in a directory in the filesystem
613 parameters: a directory name
615 returns: a list of subdirectories in that directory.
617 Notes: this does not traverse into subdirectories. Only the first
618 level of subdirectories are returned.
619 The directory names returned don't have the parent directory name on them.
623 sub _getSubdirectoryNames {
624 my $directoryname = shift;
625 return unless defined $directoryname;
626 return unless -d $directoryname;
628 if ( opendir ( my $dh, $directoryname ) ) {
629 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
633 warn "unable to opendir $directoryname: $!";
640 returns: a listref of hashrefs. Each hash represents another collection of images.
642 { imagesetname => 'npl', # the name of the image set (npl is the original one)
643 images => listref of image hashrefs
646 each image is represented by a hashref like this:
648 { KohaImage => 'npl/image.gif',
649 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
650 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
651 checked => 0 or 1: was this the image passed to this method?
652 Note: I'd like to remove this somehow.
659 my $checked = $params{'checked'} || '';
661 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
662 url => getitemtypeimagesrc('intranet'),
664 opac => { filesystem => getitemtypeimagedir('opac'),
665 url => getitemtypeimagesrc('opac'),
669 my @imagesets = (); # list of hasrefs of image set data to pass to template
670 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
672 foreach my $imagesubdir ( @subdirectories ) {
673 my @imagelist = (); # hashrefs of image info
674 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
675 foreach my $thisimage ( @imagenames ) {
677 { KohaImage => "$imagesubdir/$thisimage",
678 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
679 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
680 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
684 push @imagesets, { imagesetname => $imagesubdir,
685 images => \@imagelist };
693 $printers = &GetPrinters();
694 @queues = keys %$printers;
696 Returns information about existing printer queues.
698 C<$printers> is a reference-to-hash whose keys are the print queues
699 defined in the printers table of the Koha database. The values are
700 references-to-hash, whose keys are the fields in the printers table.
706 my $dbh = C4::Context->dbh;
707 my $sth = $dbh->prepare("select * from printers");
709 while ( my $printer = $sth->fetchrow_hashref ) {
710 $printers{ $printer->{'printqueue'} } = $printer;
712 return ( \%printers );
717 $printer = GetPrinter( $query, $printers );
721 sub GetPrinter ($$) {
722 my ( $query, $printers ) = @_; # get printer for this query from printers
723 my $printer = $query->param('printer');
724 my %cookie = $query->cookie('userenv');
725 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
726 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
732 Returns the number of pages to display in a pagination bar, given the number
733 of items and the number of items per page.
738 my ( $nb_items, $nb_items_per_page ) = @_;
740 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
745 (@themes) = &getallthemes('opac');
746 (@themes) = &getallthemes('intranet');
748 Returns an array of all available themes.
756 if ( $type eq 'intranet' ) {
757 $htdocs = C4::Context->config('intrahtdocs');
760 $htdocs = C4::Context->config('opachtdocs');
762 opendir D, "$htdocs";
763 my @dirlist = readdir D;
764 foreach my $directory (@dirlist) {
765 -d "$htdocs/$directory/en" and push @themes, $directory;
772 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
775 link_value => 'su-to',
776 label_value => 'Topics',
778 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
782 link_value => 'su-geo',
783 label_value => 'Places',
788 link_value => 'su-ut',
789 label_value => 'Titles',
790 tags => [ '500', '501', '502', '503', '504', ],
795 label_value => 'Authors',
796 tags => [ '700', '701', '702', ],
801 label_value => 'Series',
810 link_value => 'branch',
811 label_value => 'Libraries',
816 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
821 link_value => 'su-to',
822 label_value => 'Topics',
828 # link_value => 'su-na',
829 # label_value => 'People and Organizations',
830 # tags => ['600', '610', '611'],
834 link_value => 'su-geo',
835 label_value => 'Places',
840 link_value => 'su-ut',
841 label_value => 'Titles',
847 label_value => 'Authors',
848 tags => [ '100', '110', '700', ],
853 label_value => 'Series',
854 tags => [ '440', '490', ],
860 link_value => 'branch',
861 label_value => 'Libraries',
866 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
873 Return a href where a key is associated to a href. You give a query,
874 the name of the key among the fields returned by the query. If you
875 also give as third argument the name of the value, the function
876 returns a href of scalar. The optional 4th argument is an arrayref of
877 items passed to the C<execute()> call. It is designed to bind
878 parameters to any placeholders in your SQL.
887 # generic href of any information on the item, href of href.
888 my $iteminfos_of = get_infos_of($query, 'itemnumber');
889 print $iteminfos_of->{$itemnumber}{barcode};
891 # specific information, href of scalar
892 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
893 print $barcode_of_item->{$itemnumber};
898 my ( $query, $key_name, $value_name, $bind_params ) = @_;
900 my $dbh = C4::Context->dbh;
902 my $sth = $dbh->prepare($query);
903 $sth->execute( @$bind_params );
906 while ( my $row = $sth->fetchrow_hashref ) {
907 if ( defined $value_name ) {
908 $infos_of{ $row->{$key_name} } = $row->{$value_name};
911 $infos_of{ $row->{$key_name} } = $row;
919 =head2 get_notforloan_label_of
921 my $notforloan_label_of = get_notforloan_label_of();
923 Each authorised value of notforloan (information available in items and
924 itemtypes) is link to a single label.
926 Returns a href where keys are authorised values and values are corresponding
929 foreach my $authorised_value (keys %{$notforloan_label_of}) {
931 "authorised_value: %s => %s\n",
933 $notforloan_label_of->{$authorised_value}
939 # FIXME - why not use GetAuthorisedValues ??
941 sub get_notforloan_label_of {
942 my $dbh = C4::Context->dbh;
945 SELECT authorised_value
946 FROM marc_subfield_structure
947 WHERE kohafield = \'items.notforloan\'
950 my $sth = $dbh->prepare($query);
952 my ($statuscode) = $sth->fetchrow_array();
957 FROM authorised_values
960 $sth = $dbh->prepare($query);
961 $sth->execute($statuscode);
962 my %notforloan_label_of;
963 while ( my $row = $sth->fetchrow_hashref ) {
964 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
968 return \%notforloan_label_of;
971 =head2 displayServers
973 my $servers = displayServers();
974 my $servers = displayServers( $position );
975 my $servers = displayServers( $position, $type );
977 displayServers returns a listref of hashrefs, each containing
978 information about available z3950 servers. Each hashref has a format
982 'checked' => 'checked',
983 'encoding' => 'MARC-8'
985 'id' => 'LIBRARY OF CONGRESS',
989 'value' => 'z3950.loc.gov:7090/',
996 my ( $position, $type ) = @_;
997 my $dbh = C4::Context->dbh;
999 my $strsth = 'SELECT * FROM z3950servers';
1004 push @bind_params, $position;
1005 push @where_clauses, ' position = ? ';
1009 push @bind_params, $type;
1010 push @where_clauses, ' type = ? ';
1013 # reassemble where clause from where clause pieces
1014 if (@where_clauses) {
1015 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1018 my $rq = $dbh->prepare($strsth);
1019 $rq->execute(@bind_params);
1020 my @primaryserverloop;
1022 while ( my $data = $rq->fetchrow_hashref ) {
1023 push @primaryserverloop,
1024 { label => $data->{description},
1025 id => $data->{name},
1027 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1028 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1029 checked => "checked",
1030 icon => $data->{icon},
1031 zed => $data->{type} eq 'zed',
1032 opensearch => $data->{type} eq 'opensearch'
1035 return \@primaryserverloop;
1038 =head2 GetAuthValCode
1040 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1044 sub GetAuthValCode {
1045 my ($kohafield,$fwcode) = @_;
1046 my $dbh = C4::Context->dbh;
1047 $fwcode='' unless $fwcode;
1048 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1049 $sth->execute($kohafield,$fwcode);
1050 my ($authvalcode) = $sth->fetchrow_array;
1051 return $authvalcode;
1054 =head2 GetAuthValCodeFromField
1056 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1058 C<$subfield> can be undefined
1062 sub GetAuthValCodeFromField {
1063 my ($field,$subfield,$fwcode) = @_;
1064 my $dbh = C4::Context->dbh;
1065 $fwcode='' unless $fwcode;
1067 if (defined $subfield) {
1068 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1069 $sth->execute($field,$subfield,$fwcode);
1071 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1072 $sth->execute($field,$fwcode);
1074 my ($authvalcode) = $sth->fetchrow_array;
1075 return $authvalcode;
1078 =head2 GetAuthorisedValues
1080 $authvalues = GetAuthorisedValues([$category], [$selected]);
1082 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1084 C<$category> returns authorised values for just one category (optional).
1086 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1090 sub GetAuthorisedValues {
1091 my ($category,$selected,$opac) = @_;
1093 my $dbh = C4::Context->dbh;
1094 my $query = "SELECT * FROM authorised_values";
1095 $query .= " WHERE category = '" . $category . "'" if $category;
1096 $query .= " ORDER BY category, lib, lib_opac";
1097 my $sth = $dbh->prepare($query);
1099 while (my $data=$sth->fetchrow_hashref) {
1100 if ($selected && $selected eq $data->{'authorised_value'} ) {
1101 $data->{'selected'} = 1;
1103 if ($opac && $data->{'lib_opac'}) {
1104 $data->{'lib'} = $data->{'lib_opac'};
1106 push @results, $data;
1108 #my $data = $sth->fetchall_arrayref({});
1109 return \@results; #$data;
1112 =head2 GetAuthorisedValueCategories
1114 $auth_categories = GetAuthorisedValueCategories();
1116 Return an arrayref of all of the available authorised
1121 sub GetAuthorisedValueCategories {
1122 my $dbh = C4::Context->dbh;
1123 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1126 while (my $category = $sth->fetchrow_array) {
1127 push @results, $category;
1132 =head2 GetKohaAuthorisedValues
1134 Takes $kohafield, $fwcode as parameters.
1136 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1138 Returns hashref of Code => description
1140 Returns undef if no authorised value category is defined for the kohafield.
1144 sub GetKohaAuthorisedValues {
1145 my ($kohafield,$fwcode,$opac) = @_;
1146 $fwcode='' unless $fwcode;
1148 my $dbh = C4::Context->dbh;
1149 my $avcode = GetAuthValCode($kohafield,$fwcode);
1151 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1152 $sth->execute($avcode);
1153 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1154 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1162 =head2 GetKohaAuthorisedValuesFromField
1164 Takes $field, $subfield, $fwcode as parameters.
1166 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1167 $subfield can be undefined
1169 Returns hashref of Code => description
1171 Returns undef if no authorised value category is defined for the given field and subfield
1175 sub GetKohaAuthorisedValuesFromField {
1176 my ($field, $subfield, $fwcode,$opac) = @_;
1177 $fwcode='' unless $fwcode;
1179 my $dbh = C4::Context->dbh;
1180 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1182 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1183 $sth->execute($avcode);
1184 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1185 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1193 =head2 display_marc_indicators
1195 my $display_form = C4::Koha::display_marc_indicators($field);
1197 C<$field> is a MARC::Field object
1199 Generate a display form of the indicators of a variable
1200 MARC field, replacing any blanks with '#'.
1204 sub display_marc_indicators {
1206 my $indicators = '';
1207 if ($field->tag() >= 10) {
1208 $indicators = $field->indicator(1) . $field->indicator(2);
1209 $indicators =~ s/ /#/g;
1214 sub GetNormalizedUPC {
1215 my ($record,$marcflavour) = @_;
1218 if ($marcflavour eq 'MARC21') {
1219 @fields = $record->field('024');
1220 foreach my $field (@fields) {
1221 my $indicator = $field->indicator(1);
1222 my $upc = _normalize_match_point($field->subfield('a'));
1223 if ($indicator == 1 and $upc ne '') {
1228 else { # assume unimarc if not marc21
1229 @fields = $record->field('072');
1230 foreach my $field (@fields) {
1231 my $upc = _normalize_match_point($field->subfield('a'));
1239 # Normalizes and returns the first valid ISBN found in the record
1240 # ISBN13 are converted into ISBN10. This is required to get Amazon cover book.
1241 sub GetNormalizedISBN {
1242 my ($isbn,$record,$marcflavour) = @_;
1245 return _isbn_cleanup($isbn);
1247 return undef unless $record;
1249 if ($marcflavour eq 'MARC21') {
1250 @fields = $record->field('020');
1251 foreach my $field (@fields) {
1252 $isbn = $field->subfield('a');
1254 return _isbn_cleanup($isbn);
1260 else { # assume unimarc if not marc21
1261 @fields = $record->field('010');
1262 foreach my $field (@fields) {
1263 my $isbn = $field->subfield('a');
1265 return _isbn_cleanup($isbn);
1274 sub GetNormalizedEAN {
1275 my ($record,$marcflavour) = @_;
1278 if ($marcflavour eq 'MARC21') {
1279 @fields = $record->field('024');
1280 foreach my $field (@fields) {
1281 my $indicator = $field->indicator(1);
1282 $ean = _normalize_match_point($field->subfield('a'));
1283 if ($indicator == 3 and $ean ne '') {
1288 else { # assume unimarc if not marc21
1289 @fields = $record->field('073');
1290 foreach my $field (@fields) {
1291 $ean = _normalize_match_point($field->subfield('a'));
1298 sub GetNormalizedOCLCNumber {
1299 my ($record,$marcflavour) = @_;
1302 if ($marcflavour eq 'MARC21') {
1303 @fields = $record->field('035');
1304 foreach my $field (@fields) {
1305 $oclc = $field->subfield('a');
1306 if ($oclc =~ /OCoLC/) {
1307 $oclc =~ s/\(OCoLC\)//;
1314 else { # TODO: add UNIMARC fields
1318 sub _normalize_match_point {
1319 my $match_point = shift;
1320 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1321 $normalized_match_point =~ s/-//g;
1323 return $normalized_match_point;
1326 sub _isbn_cleanup ($) {
1327 my $isbn = Business::ISBN->new( shift );
1328 return undef unless $isbn;
1329 $isbn = $isbn->as_isbn10 if $isbn->type eq 'ISBN13';
1330 $isbn = $isbn->as_string;