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 with
17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
18 # Suite 330, Boston, MA 02111-1307 USA
24 use URI
::Split
qw(uri_split);
27 use vars
qw($VERSION @ISA @EXPORT $DEBUG);
36 &subfield_is_koha_internal_p
37 &GetPrinters &GetPrinter
38 &GetItemTypes &getitemtypeinfo
41 &getframeworks &getframeworkinfo
42 &getauthtypes &getauthtype
48 &get_notforloan_label_of
51 &getitemtypeimagelocation
53 &GetAuthorisedValueCategories
54 &GetKohaAuthorisedValues
59 &GetNormalizedOCLCNumber
67 memoize
('GetAuthorisedValues');
71 C4::Koha - Perl Module containing convenience functions for Koha scripts
80 Koha.pm provides many functions for Koha scripts.
88 $slash_date = &slashifyDate($dash_date);
90 Takes a string of the form "DD-MM-YYYY" (or anything separated by
91 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
97 # accepts a date of the form xx-xx-xx[xx] and returns it in the
99 my @dateOut = split( '-', shift );
100 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
106 my $string = DisplayISBN( $isbn );
112 if (length ($isbn)<13){
114 if ( substr( $isbn, 0, 1 ) <= 7 ) {
115 $seg1 = substr( $isbn, 0, 1 );
117 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
118 $seg1 = substr( $isbn, 0, 2 );
120 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
121 $seg1 = substr( $isbn, 0, 3 );
123 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
124 $seg1 = substr( $isbn, 0, 4 );
127 $seg1 = substr( $isbn, 0, 5 );
129 my $x = substr( $isbn, length($seg1) );
131 if ( substr( $x, 0, 2 ) <= 19 ) {
133 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
134 $seg2 = substr( $x, 0, 2 );
136 elsif ( substr( $x, 0, 3 ) <= 699 ) {
137 $seg2 = substr( $x, 0, 3 );
139 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
140 $seg2 = substr( $x, 0, 4 );
142 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
143 $seg2 = substr( $x, 0, 5 );
145 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
146 $seg2 = substr( $x, 0, 6 );
149 $seg2 = substr( $x, 0, 7 );
151 my $seg3 = substr( $x, length($seg2) );
152 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
153 my $seg4 = substr( $x, -1, 1 );
154 return "$seg1-$seg2-$seg3-$seg4";
157 $seg1 = substr( $isbn, 0, 3 );
159 if ( substr( $isbn, 3, 1 ) <= 7 ) {
160 $seg2 = substr( $isbn, 3, 1 );
162 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
163 $seg2 = substr( $isbn, 3, 2 );
165 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
166 $seg2 = substr( $isbn, 3, 3 );
168 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
169 $seg2 = substr( $isbn, 3, 4 );
172 $seg2 = substr( $isbn, 3, 5 );
174 my $x = substr( $isbn, length($seg2) +3);
176 if ( substr( $x, 0, 2 ) <= 19 ) {
178 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
179 $seg3 = substr( $x, 0, 2 );
181 elsif ( substr( $x, 0, 3 ) <= 699 ) {
182 $seg3 = substr( $x, 0, 3 );
184 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
185 $seg3 = substr( $x, 0, 4 );
187 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
188 $seg3 = substr( $x, 0, 5 );
190 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
191 $seg3 = substr( $x, 0, 6 );
194 $seg3 = substr( $x, 0, 7 );
196 my $seg4 = substr( $x, length($seg3) );
197 $seg4 = substr( $seg4, 0, length($seg4) - 1 );
198 my $seg5 = substr( $x, -1, 1 );
199 return "$seg1-$seg2-$seg3-$seg4-$seg5";
203 # FIXME.. this should be moved to a MARC-specific module
204 sub subfield_is_koha_internal_p
($) {
207 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
208 # But real MARC subfields are always single-character
209 # so it really is safer just to check the length
211 return length $subfield != 1;
216 $itemtypes = &GetItemTypes();
218 Returns information about existing itemtypes.
220 build a HTML select with the following code :
222 =head3 in PERL SCRIPT
224 my $itemtypes = GetItemTypes;
226 foreach my $thisitemtype (sort keys %$itemtypes) {
227 my $selected = 1 if $thisitemtype eq $itemtype;
228 my %row =(value => $thisitemtype,
229 selected => $selected,
230 description => $itemtypes->{$thisitemtype}->{'description'},
232 push @itemtypesloop, \%row;
234 $template->param(itemtypeloop => \@itemtypesloop);
238 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
239 <select name="itemtype">
240 <option value="">Default</option>
241 <!-- TMPL_LOOP name="itemtypeloop" -->
242 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
245 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
246 <input type="submit" value="OK" class="button">
253 # returns a reference to a hash of references to itemtypes...
255 my $dbh = C4
::Context
->dbh;
260 my $sth = $dbh->prepare($query);
262 while ( my $IT = $sth->fetchrow_hashref ) {
263 $itemtypes{ $IT->{'itemtype'} } = $IT;
265 return ( \
%itemtypes );
268 sub get_itemtypeinfos_of
{
271 my $placeholders = join( ', ', map { '?' } @itemtypes );
272 my $query = <<"END_SQL";
278 WHERE itemtype IN ( $placeholders )
281 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
284 # this is temporary until we separate collection codes and item types
288 my $dbh = C4::Context->dbh;
291 "SELECT * FROM authorised_values ORDER BY authorised_value");
293 while ( my $data = $sth->fetchrow_hashref ) {
294 if ( $data->{category} eq "CCODE" ) {
296 $results[$count] = $data;
302 return ( $count, @results );
307 $authtypes = &getauthtypes();
309 Returns information about existing authtypes.
311 build a HTML select with the following code :
313 =head3 in PERL SCRIPT
315 my $authtypes = getauthtypes;
317 foreach my $thisauthtype (keys %$authtypes) {
318 my $selected = 1 if $thisauthtype eq $authtype;
319 my %row =(value => $thisauthtype,
320 selected => $selected,
321 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
323 push @authtypesloop, \%row;
325 $template->param(itemtypeloop => \@itemtypesloop);
329 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
330 <select name="authtype">
331 <!-- TMPL_LOOP name="authtypeloop" -->
332 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
335 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
336 <input type="submit" value="OK" class="button">
344 # returns a reference to a hash of references to authtypes...
346 my $dbh = C4::Context->dbh;
347 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
349 while ( my $IT = $sth->fetchrow_hashref ) {
350 $authtypes{ $IT->{'authtypecode'} } = $IT;
352 return ( \%authtypes );
356 my ($authtypecode) = @_;
358 # returns a reference to a hash of references to authtypes...
360 my $dbh = C4::Context->dbh;
361 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
362 $sth->execute($authtypecode);
363 my $res = $sth->fetchrow_hashref;
369 $frameworks = &getframework();
371 Returns information about existing frameworks
373 build a HTML select with the following code :
375 =head3 in PERL SCRIPT
377 my $frameworks = frameworks();
379 foreach my $thisframework (keys %$frameworks) {
380 my $selected = 1 if $thisframework eq $frameworkcode;
381 my %row =(value => $thisframework,
382 selected => $selected,
383 description => $frameworks->{$thisframework}->{'frameworktext'},
385 push @frameworksloop, \%row;
387 $template->param(frameworkloop => \@frameworksloop);
391 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
392 <select name="frameworkcode">
393 <option value="">Default</option>
394 <!-- TMPL_LOOP name="frameworkloop" -->
395 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
398 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
399 <input type="submit" value="OK" class="button">
407 # returns a reference to a hash of references to branches...
409 my $dbh = C4::Context->dbh;
410 my $sth = $dbh->prepare("select * from biblio_framework");
412 while ( my $IT = $sth->fetchrow_hashref ) {
413 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
415 return ( \%itemtypes );
418 =head2 getframeworkinfo
420 $frameworkinfo = &getframeworkinfo($frameworkcode);
422 Returns information about an frameworkcode.
426 sub getframeworkinfo {
427 my ($frameworkcode) = @_;
428 my $dbh = C4::Context->dbh;
430 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
431 $sth->execute($frameworkcode);
432 my $res = $sth->fetchrow_hashref;
436 =head2 getitemtypeinfo
438 $itemtype = &getitemtype($itemtype);
440 Returns information about an itemtype.
444 sub getitemtypeinfo {
446 my $dbh = C4::Context->dbh;
447 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
448 $sth->execute($itemtype);
449 my $res = $sth->fetchrow_hashref;
451 $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} );
456 =head2 getitemtypeimagedir
462 my $directory = getitemtypeimagedir( 'opac' );
464 pass in 'opac' or 'intranet'. Defaults to 'opac'.
466 returns the full path to the appropriate directory containing images.
472 sub getitemtypeimagedir {
473 my $src = shift || 'opac';
474 if ($src eq 'intranet') {
475 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
477 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
481 sub getitemtypeimagesrc {
482 my $src = shift || 'opac';
483 if ($src eq 'intranet') {
484 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
486 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
490 sub getitemtypeimagelocation($$) {
491 my ( $src, $image ) = @_;
493 return '' if ( !$image );
495 my $scheme = ( uri_split( $image ) )[0];
497 return $image if ( $scheme );
499 return getitemtypeimagesrc( $src ) . '/' . $image;
502 =head3 _getImagesFromDirectory
504 Find all of the image files in a directory in the filesystem
509 returns: a list of images in that directory.
511 Notes: this does not traverse into subdirectories. See
512 _getSubdirectoryNames for help with that.
513 Images are assumed to be files with .gif or .png file extensions.
514 The image names returned do not have the directory name on them.
518 sub _getImagesFromDirectory {
519 my $directoryname = shift;
520 return unless defined $directoryname;
521 return unless -d $directoryname;
523 if ( opendir ( my $dh, $directoryname ) ) {
524 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
528 warn "unable to opendir $directoryname: $!";
533 =head3 _getSubdirectoryNames
535 Find all of the directories in a directory in the filesystem
540 returns: a list of subdirectories in that directory.
542 Notes: this does not traverse into subdirectories. Only the first
543 level of subdirectories are returned.
544 The directory names returned don't have the parent directory name
549 sub _getSubdirectoryNames {
550 my $directoryname = shift;
551 return unless defined $directoryname;
552 return unless -d $directoryname;
554 if ( opendir ( my $dh, $directoryname ) ) {
555 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
559 warn "unable to opendir $directoryname: $!";
566 returns: a listref of hashrefs. Each hash represents another collection of images.
567 { imagesetname => 'npl', # the name of the image set (npl is the original one)
568 images => listref of image hashrefs
571 each image is represented by a hashref like this:
572 { KohaImage => 'npl/image.gif',
573 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
574 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
575 checked => 0 or 1: was this the image passed to this method?
576 Note: I'd like to remove this somehow.
583 my $checked = $params{'checked'} || '';
585 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
586 url => getitemtypeimagesrc('intranet'),
588 opac => { filesystem => getitemtypeimagedir('opac'),
589 url => getitemtypeimagesrc('opac'),
593 my @imagesets = (); # list of hasrefs of image set data to pass to template
594 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
596 foreach my $imagesubdir ( @subdirectories ) {
597 my @imagelist = (); # hashrefs of image info
598 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
599 foreach my $thisimage ( @imagenames ) {
601 { KohaImage => "$imagesubdir/$thisimage",
602 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
603 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
604 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
608 push @imagesets, { imagesetname => $imagesubdir,
609 images => \@imagelist };
617 $printers = &GetPrinters();
618 @queues = keys %$printers;
620 Returns information about existing printer queues.
622 C<$printers> is a reference-to-hash whose keys are the print queues
623 defined in the printers table of the Koha database. The values are
624 references-to-hash, whose keys are the fields in the printers table.
630 my $dbh = C4::Context->dbh;
631 my $sth = $dbh->prepare("select * from printers");
633 while ( my $printer = $sth->fetchrow_hashref ) {
634 $printers{ $printer->{'printqueue'} } = $printer;
636 return ( \%printers );
641 $printer = GetPrinter( $query, $printers );
645 sub GetPrinter ($$) {
646 my ( $query, $printers ) = @_; # get printer for this query from printers
647 my $printer = $query->param('printer');
648 my %cookie = $query->cookie('userenv');
649 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
650 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
656 Returns the number of pages to display in a pagination bar, given the number
657 of items and the number of items per page.
662 my ( $nb_items, $nb_items_per_page ) = @_;
664 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
669 (@themes) = &getallthemes('opac');
670 (@themes) = &getallthemes('intranet');
672 Returns an array of all available themes.
680 if ( $type eq 'intranet' ) {
681 $htdocs = C4::Context->config('intrahtdocs');
684 $htdocs = C4::Context->config('opachtdocs');
686 opendir D, "$htdocs";
687 my @dirlist = readdir D;
688 foreach my $directory (@dirlist) {
689 -d "$htdocs/$directory/en" and push @themes, $directory;
696 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
699 link_value => 'su-to',
700 label_value => 'Topics',
702 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
706 link_value => 'su-geo',
707 label_value => 'Places',
712 link_value => 'su-ut',
713 label_value => 'Titles',
714 tags => [ '500', '501', '502', '503', '504', ],
719 label_value => 'Authors',
720 tags => [ '700', '701', '702', ],
725 label_value => 'Series',
734 link_value => 'branch',
735 label_value => 'Libraries',
740 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
745 link_value => 'su-to',
746 label_value => 'Topics',
752 # link_value => 'su-na',
753 # label_value => 'People and Organizations',
754 # tags => ['600', '610', '611'],
758 link_value => 'su-geo',
759 label_value => 'Places',
764 link_value => 'su-ut',
765 label_value => 'Titles',
771 label_value => 'Authors',
772 tags => [ '100', '110', '700', ],
777 label_value => 'Series',
778 tags => [ '440', '490', ],
784 link_value => 'branch',
785 label_value => 'Libraries',
790 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
797 Return a href where a key is associated to a href. You give a query,
798 the name of the key among the fields returned by the query. If you
799 also give as third argument the name of the value, the function
800 returns a href of scalar. The optional 4th argument is an arrayref of
801 items passed to the C<execute()> call. It is designed to bind
802 parameters to any placeholders in your SQL.
811 # generic href of any information on the item, href of href.
812 my $iteminfos_of = get_infos_of($query, 'itemnumber');
813 print $iteminfos_of->{$itemnumber}{barcode};
815 # specific information, href of scalar
816 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
817 print $barcode_of_item->{$itemnumber};
822 my ( $query, $key_name, $value_name, $bind_params ) = @_;
824 my $dbh = C4::Context->dbh;
826 my $sth = $dbh->prepare($query);
827 $sth->execute( @$bind_params );
830 while ( my $row = $sth->fetchrow_hashref ) {
831 if ( defined $value_name ) {
832 $infos_of{ $row->{$key_name} } = $row->{$value_name};
835 $infos_of{ $row->{$key_name} } = $row;
843 =head2 get_notforloan_label_of
845 my $notforloan_label_of = get_notforloan_label_of();
847 Each authorised value of notforloan (information available in items and
848 itemtypes) is link to a single label.
850 Returns a href where keys are authorised values and values are corresponding
853 foreach my $authorised_value (keys %{$notforloan_label_of}) {
855 "authorised_value: %s => %s\n",
857 $notforloan_label_of->{$authorised_value}
863 # FIXME - why not use GetAuthorisedValues ??
865 sub get_notforloan_label_of {
866 my $dbh = C4::Context->dbh;
869 SELECT authorised_value
870 FROM marc_subfield_structure
871 WHERE kohafield = \'items.notforloan\'
874 my $sth = $dbh->prepare($query);
876 my ($statuscode) = $sth->fetchrow_array();
881 FROM authorised_values
884 $sth = $dbh->prepare($query);
885 $sth->execute($statuscode);
886 my %notforloan_label_of;
887 while ( my $row = $sth->fetchrow_hashref ) {
888 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
892 return \%notforloan_label_of;
895 =head2 displayServers
899 my $servers = displayServers();
901 my $servers = displayServers( $position );
903 my $servers = displayServers( $position, $type );
907 displayServers returns a listref of hashrefs, each containing
908 information about available z3950 servers. Each hashref has a format
912 'checked' => 'checked',
913 'encoding' => 'MARC-8'
915 'id' => 'LIBRARY OF CONGRESS',
919 'value' => 'z3950.loc.gov:7090/',
927 my ( $position, $type ) = @_;
928 my $dbh = C4::Context->dbh;
930 my $strsth = 'SELECT * FROM z3950servers';
935 push @bind_params, $position;
936 push @where_clauses, ' position = ? ';
940 push @bind_params, $type;
941 push @where_clauses, ' type = ? ';
944 # reassemble where clause from where clause pieces
945 if (@where_clauses) {
946 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
949 my $rq = $dbh->prepare($strsth);
950 $rq->execute(@bind_params);
951 my @primaryserverloop;
953 while ( my $data = $rq->fetchrow_hashref ) {
954 push @primaryserverloop,
955 { label => $data->{description},
958 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
959 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
960 checked => "checked",
961 icon => $data->{icon},
962 zed => $data->{type} eq 'zed',
963 opensearch => $data->{type} eq 'opensearch'
966 return \@primaryserverloop;
969 sub displaySecondaryServers {
971 # my $secondary_servers_loop = [
972 # { inner_sup_servers_loop => [
973 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
974 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
975 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
976 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
980 return; #$secondary_servers_loop;
983 =head2 GetAuthValCode
985 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
990 my ($kohafield,$fwcode) = @_;
991 my $dbh = C4::Context->dbh;
992 $fwcode='' unless $fwcode;
993 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
994 $sth->execute($kohafield,$fwcode);
995 my ($authvalcode) = $sth->fetchrow_array;
999 =head2 GetAuthorisedValues
1001 $authvalues = GetAuthorisedValues([$category], [$selected]);
1003 This function returns all authorised values from the'authosied_value' table in a reference to array of hashrefs.
1005 C<$category> returns authorised values for just one category (optional).
1009 sub GetAuthorisedValues {
1010 my ($category,$selected) = @_;
1012 my $dbh = C4::Context->dbh;
1013 my $query = "SELECT * FROM authorised_values";
1014 $query .= " WHERE category = '" . $category . "'" if $category;
1016 my $sth = $dbh->prepare($query);
1018 while (my $data=$sth->fetchrow_hashref) {
1019 if ($selected eq $data->{'authorised_value'} ) {
1020 $data->{'selected'} = 1;
1022 push @results, $data;
1024 #my $data = $sth->fetchall_arrayref({});
1025 return \@results; #$data;
1028 =head2 GetAuthorisedValueCategories
1030 $auth_categories = GetAuthorisedValueCategories();
1032 Return an arrayref of all of the available authorised
1037 sub GetAuthorisedValueCategories {
1038 my $dbh = C4::Context->dbh;
1039 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1042 while (my $category = $sth->fetchrow_array) {
1043 push @results, $category;
1048 =head2 GetKohaAuthorisedValues
1050 Takes $kohafield, $fwcode as parameters.
1051 Returns hashref of Code => description
1053 if no authorised value category is defined for the kohafield.
1057 sub GetKohaAuthorisedValues {
1058 my ($kohafield,$fwcode,$codedvalue) = @_;
1059 $fwcode='' unless $fwcode;
1061 my $dbh = C4::Context->dbh;
1062 my $avcode = GetAuthValCode($kohafield,$fwcode);
1064 my $sth = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
1065 $sth->execute($avcode);
1066 while ( my ($val, $lib) = $sth->fetchrow_array ) {
1067 $values{$val}= $lib;
1075 =head2 display_marc_indicators
1079 # field is a MARC::Field object
1080 my $display_form = C4::Koha::display_marc_indicators($field);
1084 Generate a display form of the indicators of a variable
1085 MARC field, replacing any blanks with '#'.
1089 sub display_marc_indicators {
1091 my $indicators = '';
1092 if ($field->tag() >= 10) {
1093 $indicators = $field->indicator(1) . $field->indicator(2);
1094 $indicators =~ s/ /#/g;
1099 sub GetNormalizedUPC {
1100 my ($record,$marcflavour) = @_;
1103 if ($marcflavour eq 'MARC21') {
1104 @fields = $record->field('024');
1105 foreach my $field (@fields) {
1106 my $indicator = $field->indicator(1);
1107 my $upc = _normalize_match_point($field->subfield('a'));
1108 if ($indicator == 1 and $upc ne '') {
1113 else { # assume unimarc if not marc21
1114 @fields = $record->field('072');
1115 foreach my $field (@fields) {
1116 my $upc = _normalize_match_point($field->subfield('a'));
1124 # Normalizes and returns the first valid ISBN found in the record
1125 sub GetNormalizedISBN {
1126 my ($isbn,$record,$marcflavour) = @_;
1129 return _isbn_cleanup($isbn);
1131 return undef unless $record;
1133 if ($marcflavour eq 'MARC21') {
1134 @fields = $record->field('020');
1135 foreach my $field (@fields) {
1136 $isbn = $field->subfield('a');
1138 return _isbn_cleanup($isbn);
1144 else { # assume unimarc if not marc21
1145 @fields = $record->field('010');
1146 foreach my $field (@fields) {
1147 my $isbn = $field->subfield('a');
1149 return _isbn_cleanup($isbn);
1158 sub GetNormalizedEAN {
1159 my ($record,$marcflavour) = @_;
1162 if ($marcflavour eq 'MARC21') {
1163 @fields = $record->field('024');
1164 foreach my $field (@fields) {
1165 my $indicator = $field->indicator(1);
1166 $ean = _normalize_match_point($field->subfield('a'));
1167 if ($indicator == 3 and $ean ne '') {
1172 else { # assume unimarc if not marc21
1173 @fields = $record->field('073');
1174 foreach my $field (@fields) {
1175 $ean = _normalize_match_point($field->subfield('a'));
1182 sub GetNormalizedOCLCNumber {
1183 my ($record,$marcflavour) = @_;
1186 if ($marcflavour eq 'MARC21') {
1187 @fields = $record->field('035');
1188 foreach my $field (@fields) {
1189 $oclc = $field->subfield('a');
1190 if ($oclc =~ /OCoLC/) {
1191 $oclc =~ s/\(OCoLC\)//;
1198 else { # TODO: add UNIMARC fields
1202 sub _normalize_match_point {
1203 my $match_point = shift;
1204 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1205 $normalized_match_point =~ s/-//g;
1207 return $normalized_match_point;
1210 sub _isbn_cleanup ($) {
1211 my $normalized_isbn = shift;
1212 $normalized_isbn =~ s/-//g;
1213 $normalized_isbn =~/([0-9x]{1,})/i;
1214 $normalized_isbn = $1;
1216 $normalized_isbn =~ /\b(\d{13})\b/ or
1217 $normalized_isbn =~ /\b(\d{12})\b/i or
1218 $normalized_isbn =~ /\b(\d{10})\b/ or
1219 $normalized_isbn =~ /\b(\d{9}X)\b/i