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);
26 use vars qw($VERSION @ISA @EXPORT $DEBUG);
35 &subfield_is_koha_internal_p
36 &GetPrinters &GetPrinter
37 &GetItemTypes &getitemtypeinfo
40 &getframeworks &getframeworkinfo
41 &getauthtypes &getauthtype
47 &get_notforloan_label_of
50 &getitemtypeimagelocation
52 &GetAuthorisedValueCategories
53 &GetKohaAuthorisedValues
58 &GetNormalizedOCLCNumber
66 C4::Koha - Perl Module containing convenience functions for Koha scripts
75 Koha.pm provides many functions for Koha scripts.
83 $slash_date = &slashifyDate($dash_date);
85 Takes a string of the form "DD-MM-YYYY" (or anything separated by
86 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
92 # accepts a date of the form xx-xx-xx[xx] and returns it in the
94 my @dateOut = split( '-', shift );
95 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
101 my $string = DisplayISBN( $isbn );
107 if (length ($isbn)<13){
109 if ( substr( $isbn, 0, 1 ) <= 7 ) {
110 $seg1 = substr( $isbn, 0, 1 );
112 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
113 $seg1 = substr( $isbn, 0, 2 );
115 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
116 $seg1 = substr( $isbn, 0, 3 );
118 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
119 $seg1 = substr( $isbn, 0, 4 );
122 $seg1 = substr( $isbn, 0, 5 );
124 my $x = substr( $isbn, length($seg1) );
126 if ( substr( $x, 0, 2 ) <= 19 ) {
128 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
129 $seg2 = substr( $x, 0, 2 );
131 elsif ( substr( $x, 0, 3 ) <= 699 ) {
132 $seg2 = substr( $x, 0, 3 );
134 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
135 $seg2 = substr( $x, 0, 4 );
137 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
138 $seg2 = substr( $x, 0, 5 );
140 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
141 $seg2 = substr( $x, 0, 6 );
144 $seg2 = substr( $x, 0, 7 );
146 my $seg3 = substr( $x, length($seg2) );
147 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
148 my $seg4 = substr( $x, -1, 1 );
149 return "$seg1-$seg2-$seg3-$seg4";
152 $seg1 = substr( $isbn, 0, 3 );
154 if ( substr( $isbn, 3, 1 ) <= 7 ) {
155 $seg2 = substr( $isbn, 3, 1 );
157 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
158 $seg2 = substr( $isbn, 3, 2 );
160 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
161 $seg2 = substr( $isbn, 3, 3 );
163 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
164 $seg2 = substr( $isbn, 3, 4 );
167 $seg2 = substr( $isbn, 3, 5 );
169 my $x = substr( $isbn, length($seg2) +3);
171 if ( substr( $x, 0, 2 ) <= 19 ) {
173 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
174 $seg3 = substr( $x, 0, 2 );
176 elsif ( substr( $x, 0, 3 ) <= 699 ) {
177 $seg3 = substr( $x, 0, 3 );
179 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
180 $seg3 = substr( $x, 0, 4 );
182 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
183 $seg3 = substr( $x, 0, 5 );
185 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
186 $seg3 = substr( $x, 0, 6 );
189 $seg3 = substr( $x, 0, 7 );
191 my $seg4 = substr( $x, length($seg3) );
192 $seg4 = substr( $seg4, 0, length($seg4) - 1 );
193 my $seg5 = substr( $x, -1, 1 );
194 return "$seg1-$seg2-$seg3-$seg4-$seg5";
198 # FIXME.. this should be moved to a MARC-specific module
199 sub subfield_is_koha_internal_p ($) {
202 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
203 # But real MARC subfields are always single-character
204 # so it really is safer just to check the length
206 return length $subfield != 1;
211 $itemtypes = &GetItemTypes();
213 Returns information about existing itemtypes.
215 build a HTML select with the following code :
217 =head3 in PERL SCRIPT
219 my $itemtypes = GetItemTypes;
221 foreach my $thisitemtype (sort keys %$itemtypes) {
222 my $selected = 1 if $thisitemtype eq $itemtype;
223 my %row =(value => $thisitemtype,
224 selected => $selected,
225 description => $itemtypes->{$thisitemtype}->{'description'},
227 push @itemtypesloop, \%row;
229 $template->param(itemtypeloop => \@itemtypesloop);
233 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
234 <select name="itemtype">
235 <option value="">Default</option>
236 <!-- TMPL_LOOP name="itemtypeloop" -->
237 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
240 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
241 <input type="submit" value="OK" class="button">
248 # returns a reference to a hash of references to itemtypes...
250 my $dbh = C4::Context->dbh;
255 my $sth = $dbh->prepare($query);
257 while ( my $IT = $sth->fetchrow_hashref ) {
258 $itemtypes{ $IT->{'itemtype'} } = $IT;
260 return ( \%itemtypes );
263 sub get_itemtypeinfos_of {
266 my $placeholders = join( ', ', map { '?' } @itemtypes );
267 my $query = <<"END_SQL";
273 WHERE itemtype IN ( $placeholders )
276 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
279 # this is temporary until we separate collection codes and item types
283 my $dbh = C4::Context->dbh;
286 "SELECT * FROM authorised_values ORDER BY authorised_value");
288 while ( my $data = $sth->fetchrow_hashref ) {
289 if ( $data->{category} eq "CCODE" ) {
291 $results[$count] = $data;
297 return ( $count, @results );
302 $authtypes = &getauthtypes();
304 Returns information about existing authtypes.
306 build a HTML select with the following code :
308 =head3 in PERL SCRIPT
310 my $authtypes = getauthtypes;
312 foreach my $thisauthtype (keys %$authtypes) {
313 my $selected = 1 if $thisauthtype eq $authtype;
314 my %row =(value => $thisauthtype,
315 selected => $selected,
316 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
318 push @authtypesloop, \%row;
320 $template->param(itemtypeloop => \@itemtypesloop);
324 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
325 <select name="authtype">
326 <!-- TMPL_LOOP name="authtypeloop" -->
327 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
330 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
331 <input type="submit" value="OK" class="button">
339 # returns a reference to a hash of references to authtypes...
341 my $dbh = C4::Context->dbh;
342 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
344 while ( my $IT = $sth->fetchrow_hashref ) {
345 $authtypes{ $IT->{'authtypecode'} } = $IT;
347 return ( \%authtypes );
351 my ($authtypecode) = @_;
353 # returns a reference to a hash of references to authtypes...
355 my $dbh = C4::Context->dbh;
356 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
357 $sth->execute($authtypecode);
358 my $res = $sth->fetchrow_hashref;
364 $frameworks = &getframework();
366 Returns information about existing frameworks
368 build a HTML select with the following code :
370 =head3 in PERL SCRIPT
372 my $frameworks = frameworks();
374 foreach my $thisframework (keys %$frameworks) {
375 my $selected = 1 if $thisframework eq $frameworkcode;
376 my %row =(value => $thisframework,
377 selected => $selected,
378 description => $frameworks->{$thisframework}->{'frameworktext'},
380 push @frameworksloop, \%row;
382 $template->param(frameworkloop => \@frameworksloop);
386 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
387 <select name="frameworkcode">
388 <option value="">Default</option>
389 <!-- TMPL_LOOP name="frameworkloop" -->
390 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
393 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
394 <input type="submit" value="OK" class="button">
402 # returns a reference to a hash of references to branches...
404 my $dbh = C4::Context->dbh;
405 my $sth = $dbh->prepare("select * from biblio_framework");
407 while ( my $IT = $sth->fetchrow_hashref ) {
408 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
410 return ( \%itemtypes );
413 =head2 getframeworkinfo
415 $frameworkinfo = &getframeworkinfo($frameworkcode);
417 Returns information about an frameworkcode.
421 sub getframeworkinfo {
422 my ($frameworkcode) = @_;
423 my $dbh = C4::Context->dbh;
425 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
426 $sth->execute($frameworkcode);
427 my $res = $sth->fetchrow_hashref;
431 =head2 getitemtypeinfo
433 $itemtype = &getitemtype($itemtype);
435 Returns information about an itemtype.
439 sub getitemtypeinfo {
441 my $dbh = C4::Context->dbh;
442 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
443 $sth->execute($itemtype);
444 my $res = $sth->fetchrow_hashref;
446 $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} );
451 =head2 getitemtypeimagedir
457 my $directory = getitemtypeimagedir( 'opac' );
459 pass in 'opac' or 'intranet'. Defaults to 'opac'.
461 returns the full path to the appropriate directory containing images.
467 sub getitemtypeimagedir {
468 my $src = shift || 'opac';
469 if ($src eq 'intranet') {
470 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
472 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
476 sub getitemtypeimagesrc {
477 my $src = shift || 'opac';
478 if ($src eq 'intranet') {
479 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
481 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
485 sub getitemtypeimagelocation($$) {
486 my ( $src, $image ) = @_;
488 return '' if ( !$image );
490 my $scheme = ( uri_split( $image ) )[0];
492 return $image if ( $scheme );
494 return getitemtypeimagesrc( $src ) . '/' . $image;
497 =head3 _getImagesFromDirectory
499 Find all of the image files in a directory in the filesystem
504 returns: a list of images in that directory.
506 Notes: this does not traverse into subdirectories. See
507 _getSubdirectoryNames for help with that.
508 Images are assumed to be files with .gif or .png file extensions.
509 The image names returned do not have the directory name on them.
513 sub _getImagesFromDirectory {
514 my $directoryname = shift;
515 return unless defined $directoryname;
516 return unless -d $directoryname;
518 if ( opendir ( my $dh, $directoryname ) ) {
519 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
523 warn "unable to opendir $directoryname: $!";
528 =head3 _getSubdirectoryNames
530 Find all of the directories in a directory in the filesystem
535 returns: a list of subdirectories in that directory.
537 Notes: this does not traverse into subdirectories. Only the first
538 level of subdirectories are returned.
539 The directory names returned don't have the parent directory name
544 sub _getSubdirectoryNames {
545 my $directoryname = shift;
546 return unless defined $directoryname;
547 return unless -d $directoryname;
549 if ( opendir ( my $dh, $directoryname ) ) {
550 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
554 warn "unable to opendir $directoryname: $!";
561 returns: a listref of hashrefs. Each hash represents another collection of images.
562 { imagesetname => 'npl', # the name of the image set (npl is the original one)
563 images => listref of image hashrefs
566 each image is represented by a hashref like this:
567 { KohaImage => 'npl/image.gif',
568 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
569 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
570 checked => 0 or 1: was this the image passed to this method?
571 Note: I'd like to remove this somehow.
578 my $checked = $params{'checked'} || '';
580 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
581 url => getitemtypeimagesrc('intranet'),
583 opac => { filesystem => getitemtypeimagedir('opac'),
584 url => getitemtypeimagesrc('opac'),
588 my @imagesets = (); # list of hasrefs of image set data to pass to template
589 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
591 foreach my $imagesubdir ( @subdirectories ) {
592 my @imagelist = (); # hashrefs of image info
593 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
594 foreach my $thisimage ( @imagenames ) {
596 { KohaImage => "$imagesubdir/$thisimage",
597 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
598 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
599 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
603 push @imagesets, { imagesetname => $imagesubdir,
604 images => \@imagelist };
612 $printers = &GetPrinters();
613 @queues = keys %$printers;
615 Returns information about existing printer queues.
617 C<$printers> is a reference-to-hash whose keys are the print queues
618 defined in the printers table of the Koha database. The values are
619 references-to-hash, whose keys are the fields in the printers table.
625 my $dbh = C4::Context->dbh;
626 my $sth = $dbh->prepare("select * from printers");
628 while ( my $printer = $sth->fetchrow_hashref ) {
629 $printers{ $printer->{'printqueue'} } = $printer;
631 return ( \%printers );
636 $printer = GetPrinter( $query, $printers );
640 sub GetPrinter ($$) {
641 my ( $query, $printers ) = @_; # get printer for this query from printers
642 my $printer = $query->param('printer');
643 my %cookie = $query->cookie('userenv');
644 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
645 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
651 Returns the number of pages to display in a pagination bar, given the number
652 of items and the number of items per page.
657 my ( $nb_items, $nb_items_per_page ) = @_;
659 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
664 (@themes) = &getallthemes('opac');
665 (@themes) = &getallthemes('intranet');
667 Returns an array of all available themes.
675 if ( $type eq 'intranet' ) {
676 $htdocs = C4::Context->config('intrahtdocs');
679 $htdocs = C4::Context->config('opachtdocs');
681 opendir D, "$htdocs";
682 my @dirlist = readdir D;
683 foreach my $directory (@dirlist) {
684 -d "$htdocs/$directory/en" and push @themes, $directory;
691 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
694 link_value => 'su-to',
695 label_value => 'Topics',
697 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
701 link_value => 'su-geo',
702 label_value => 'Places',
707 link_value => 'su-ut',
708 label_value => 'Titles',
709 tags => [ '500', '501', '502', '503', '504', ],
714 label_value => 'Authors',
715 tags => [ '700', '701', '702', ],
720 label_value => 'Series',
729 link_value => 'branch',
730 label_value => 'Libraries',
735 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
740 link_value => 'su-to',
741 label_value => 'Topics',
747 # link_value => 'su-na',
748 # label_value => 'People and Organizations',
749 # tags => ['600', '610', '611'],
753 link_value => 'su-geo',
754 label_value => 'Places',
759 link_value => 'su-ut',
760 label_value => 'Titles',
766 label_value => 'Authors',
767 tags => [ '100', '110', '700', ],
772 label_value => 'Series',
773 tags => [ '440', '490', ],
779 link_value => 'branch',
780 label_value => 'Libraries',
785 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
792 Return a href where a key is associated to a href. You give a query,
793 the name of the key among the fields returned by the query. If you
794 also give as third argument the name of the value, the function
795 returns a href of scalar. The optional 4th argument is an arrayref of
796 items passed to the C<execute()> call. It is designed to bind
797 parameters to any placeholders in your SQL.
806 # generic href of any information on the item, href of href.
807 my $iteminfos_of = get_infos_of($query, 'itemnumber');
808 print $iteminfos_of->{$itemnumber}{barcode};
810 # specific information, href of scalar
811 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
812 print $barcode_of_item->{$itemnumber};
817 my ( $query, $key_name, $value_name, $bind_params ) = @_;
819 my $dbh = C4::Context->dbh;
821 my $sth = $dbh->prepare($query);
822 $sth->execute( @$bind_params );
825 while ( my $row = $sth->fetchrow_hashref ) {
826 if ( defined $value_name ) {
827 $infos_of{ $row->{$key_name} } = $row->{$value_name};
830 $infos_of{ $row->{$key_name} } = $row;
838 =head2 get_notforloan_label_of
840 my $notforloan_label_of = get_notforloan_label_of();
842 Each authorised value of notforloan (information available in items and
843 itemtypes) is link to a single label.
845 Returns a href where keys are authorised values and values are corresponding
848 foreach my $authorised_value (keys %{$notforloan_label_of}) {
850 "authorised_value: %s => %s\n",
852 $notforloan_label_of->{$authorised_value}
858 # FIXME - why not use GetAuthorisedValues ??
860 sub get_notforloan_label_of {
861 my $dbh = C4::Context->dbh;
864 SELECT authorised_value
865 FROM marc_subfield_structure
866 WHERE kohafield = \'items.notforloan\'
869 my $sth = $dbh->prepare($query);
871 my ($statuscode) = $sth->fetchrow_array();
876 FROM authorised_values
879 $sth = $dbh->prepare($query);
880 $sth->execute($statuscode);
881 my %notforloan_label_of;
882 while ( my $row = $sth->fetchrow_hashref ) {
883 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
887 return \%notforloan_label_of;
890 =head2 displayServers
894 my $servers = displayServers();
896 my $servers = displayServers( $position );
898 my $servers = displayServers( $position, $type );
902 displayServers returns a listref of hashrefs, each containing
903 information about available z3950 servers. Each hashref has a format
907 'checked' => 'checked',
908 'encoding' => 'MARC-8'
910 'id' => 'LIBRARY OF CONGRESS',
914 'value' => 'z3950.loc.gov:7090/',
922 my ( $position, $type ) = @_;
923 my $dbh = C4::Context->dbh;
925 my $strsth = 'SELECT * FROM z3950servers';
930 push @bind_params, $position;
931 push @where_clauses, ' position = ? ';
935 push @bind_params, $type;
936 push @where_clauses, ' type = ? ';
939 # reassemble where clause from where clause pieces
940 if (@where_clauses) {
941 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
944 my $rq = $dbh->prepare($strsth);
945 $rq->execute(@bind_params);
946 my @primaryserverloop;
948 while ( my $data = $rq->fetchrow_hashref ) {
949 push @primaryserverloop,
950 { label => $data->{description},
953 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
954 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
955 checked => "checked",
956 icon => $data->{icon},
957 zed => $data->{type} eq 'zed',
958 opensearch => $data->{type} eq 'opensearch'
961 return \@primaryserverloop;
964 sub displaySecondaryServers {
966 # my $secondary_servers_loop = [
967 # { inner_sup_servers_loop => [
968 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
969 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
970 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
971 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
975 return; #$secondary_servers_loop;
978 =head2 GetAuthValCode
980 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
985 my ($kohafield,$fwcode) = @_;
986 my $dbh = C4::Context->dbh;
987 $fwcode='' unless $fwcode;
988 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
989 $sth->execute($kohafield,$fwcode);
990 my ($authvalcode) = $sth->fetchrow_array;
994 =head2 GetAuthorisedValues
996 $authvalues = GetAuthorisedValues([$category], [$selected]);
998 This function returns all authorised values from the'authosied_value' table in a reference to array of hashrefs.
1000 C<$category> returns authorised values for just one category (optional).
1004 sub GetAuthorisedValues {
1005 my ($category,$selected) = @_;
1007 my $dbh = C4::Context->dbh;
1008 my $query = "SELECT * FROM authorised_values";
1009 $query .= " WHERE category = '" . $category . "'" if $category;
1011 my $sth = $dbh->prepare($query);
1013 while (my $data=$sth->fetchrow_hashref) {
1014 if ($selected eq $data->{'authorised_value'} ) {
1015 $data->{'selected'} = 1;
1017 push @results, $data;
1019 #my $data = $sth->fetchall_arrayref({});
1020 return \@results; #$data;
1023 =head2 GetAuthorisedValueCategories
1025 $auth_categories = GetAuthorisedValueCategories();
1027 Return an arrayref of all of the available authorised
1032 sub GetAuthorisedValueCategories {
1033 my $dbh = C4::Context->dbh;
1034 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1037 while (my $category = $sth->fetchrow_array) {
1038 push @results, $category;
1043 =head2 GetKohaAuthorisedValues
1045 Takes $kohafield, $fwcode as parameters.
1046 Returns hashref of Code => description
1048 if no authorised value category is defined for the kohafield.
1052 sub GetKohaAuthorisedValues {
1053 my ($kohafield,$fwcode,$codedvalue) = @_;
1054 $fwcode='' unless $fwcode;
1056 my $dbh = C4::Context->dbh;
1057 my $avcode = GetAuthValCode($kohafield,$fwcode);
1059 my $sth = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
1060 $sth->execute($avcode);
1061 while ( my ($val, $lib) = $sth->fetchrow_array ) {
1062 $values{$val}= $lib;
1070 =head2 display_marc_indicators
1074 # field is a MARC::Field object
1075 my $display_form = C4::Koha::display_marc_indicators($field);
1079 Generate a display form of the indicators of a variable
1080 MARC field, replacing any blanks with '#'.
1084 sub display_marc_indicators {
1086 my $indicators = '';
1087 if ($field->tag() >= 10) {
1088 $indicators = $field->indicator(1) . $field->indicator(2);
1089 $indicators =~ s/ /#/g;
1094 sub GetNormalizedUPC {
1095 my ($record,$marcflavour) = @_;
1098 if ($marcflavour eq 'MARC21') {
1099 @fields = $record->field('024');
1100 foreach my $field (@fields) {
1101 my $indicator = $field->indicator(1);
1102 my $upc = _normalize_match_point($field->subfield('a'));
1103 if ($indicator == 1 and $upc ne '') {
1108 else { # assume unimarc if not marc21
1109 @fields = $record->field('072');
1110 foreach my $field (@fields) {
1111 my $upc = _normalize_match_point($field->subfield('a'));
1119 # Normalizes and returns the first valid ISBN found in the record
1120 sub GetNormalizedISBN {
1121 my ($isbn,$record,$marcflavour) = @_;
1124 return _isbn_cleanup($isbn);
1126 return undef unless $record;
1128 if ($marcflavour eq 'MARC21') {
1129 @fields = $record->field('020');
1130 foreach my $field (@fields) {
1131 $isbn = $field->subfield('a');
1133 return _isbn_cleanup($isbn);
1139 else { # assume unimarc if not marc21
1140 @fields = $record->field('010');
1141 foreach my $field (@fields) {
1142 my $isbn = $field->subfield('a');
1144 return _isbn_cleanup($isbn);
1153 sub GetNormalizedEAN {
1154 my ($record,$marcflavour) = @_;
1157 if ($marcflavour eq 'MARC21') {
1158 @fields = $record->field('024');
1159 foreach my $field (@fields) {
1160 my $indicator = $field->indicator(1);
1161 $ean = _normalize_match_point($field->subfield('a'));
1162 if ($indicator == 3 and $ean ne '') {
1167 else { # assume unimarc if not marc21
1168 @fields = $record->field('073');
1169 foreach my $field (@fields) {
1170 $ean = _normalize_match_point($field->subfield('a'));
1177 sub GetNormalizedOCLCNumber {
1178 my ($record,$marcflavour) = @_;
1181 if ($marcflavour eq 'MARC21') {
1182 @fields = $record->field('035');
1183 foreach my $field (@fields) {
1184 $oclc = $field->subfield('a');
1185 if ($oclc =~ /OCoLC/) {
1186 $oclc =~ s/\(OCoLC\)//;
1193 else { # TODO: add UNIMARC fields
1197 sub _normalize_match_point {
1198 my $match_point = shift;
1199 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1200 $normalized_match_point =~ s/-//g;
1202 return $normalized_match_point;
1205 sub _isbn_cleanup ($) {
1206 my $normalized_isbn = shift;
1207 $normalized_isbn =~ s/-//g;
1208 $normalized_isbn =~/([0-9x]{1,})/i;
1209 $normalized_isbn = $1;
1211 $normalized_isbn =~ /\b(\d{13})\b/ or
1212 $normalized_isbn =~ /\b(\d{12})\b/i or
1213 $normalized_isbn =~ /\b(\d{10})\b/ or
1214 $normalized_isbn =~ /\b(\d{9}X)\b/i