X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=C4%2FLabels.pm;h=23307139dda4cd806db847e6d767fbef0b70f73e;hb=bfebda4ad9ea0cf50497cd8eebbaeeb9fac2a0e1;hp=82d4c6b228c3753210ca9c024f542d5a701eb809;hpb=1d9d3cbcbe0c157c823fe023b84c65a65d48e6e1;p=koha.git diff --git a/C4/Labels.pm b/C4/Labels.pm index 82d4c6b228..23307139dd 100644 --- a/C4/Labels.pm +++ b/C4/Labels.pm @@ -18,6 +18,7 @@ package C4::Labels; # Suite 330, Boston, MA 02111-1307 USA use strict; +# use warnings; # FIXME use vars qw($VERSION @ISA @EXPORT); use PDF::Reuse; @@ -29,7 +30,6 @@ use C4::Debug; use C4::Biblio; use Text::CSV_XS; use Data::Dumper; -# use Smart::Comments; BEGIN { $VERSION = 0.03; @@ -42,8 +42,11 @@ BEGIN { &GetAllLabelTemplates &DeleteTemplate &GetSingleLabelTemplate &SaveTemplate &CreateTemplate &SetActiveTemplate - &SaveConf &DrawSpineText &GetTextWrapCols - &GetUnitsValue &DrawBarcode &DrawPatronCardText + &SaveConf &GetTextWrapCols + &GetUnitsValue + &DrawSpineText + &DrawBarcode + &DrawPatronCardText &get_printingtypes &GetPatronCardItems &get_layouts &get_barcode_types @@ -57,9 +60,9 @@ BEGIN { &delete_layout &get_active_layout &get_highest_batch &deduplicate_batch - &GetAllPrinterProfiles &GetSinglePrinterProfile - &SaveProfile &CreateProfile &DeleteProfile - &GetAssociatedProfile &SetAssociatedProfile + &GetAllPrinterProfiles &GetSinglePrinterProfile + &SaveProfile &CreateProfile &DeleteProfile + &GetAssociatedProfile &SetAssociatedProfile ); } @@ -70,9 +73,7 @@ C4::Labels - Functions for printing spine labels and barcodes in Koha =head1 FUNCTIONS -=over 2 - -=item get_label_options; +=head2 get_label_options; $options = get_label_options() @@ -80,7 +81,6 @@ Return a pointer on a hash list containing info from labels_conf table in Koha D =cut -#' sub get_label_options { my $query2 = " SELECT * FROM labels_conf where active = 1"; # FIXME: exact same as get_active_layout my $sth = C4::Context->dbh->prepare($query2); @@ -89,36 +89,26 @@ sub get_label_options { } sub get_layouts { - -## FIXME: this if/else could be compacted... my $dbh = C4::Context->dbh; - my @data; my $query = " Select * from labels_conf"; my $sth = $dbh->prepare($query); $sth->execute(); my @resultsloop; while ( my $data = $sth->fetchrow_hashref ) { - $data->{'fieldlist'} = get_text_fields( $data->{'id'} ); push( @resultsloop, $data ); } - $sth->finish; - - # @resultsloop - return @resultsloop; } sub get_layout { my ($layout_id) = @_; my $dbh = C4::Context->dbh; - # get the actual items to be printed. my $query = " Select * from labels_conf where id = ?"; my $sth = $dbh->prepare($query); $sth->execute($layout_id); my $data = $sth->fetchrow_hashref; - $sth->finish; return $data; } @@ -132,18 +122,16 @@ sub get_active_layout { sub delete_layout { my ($layout_id) = @_; my $dbh = C4::Context->dbh; - # get the actual items to be printed. my $query = "delete from labels_conf where id = ?"; my $sth = $dbh->prepare($query); $sth->execute($layout_id); - $sth->finish; } sub get_printingtypes { my ($layout_id) = @_; my @printtypes; -# FIXME: hard coded print types +# FIXME hard coded print types push( @printtypes, { code => 'BAR', desc => "barcode only" } ); push( @printtypes, { code => 'BIB', desc => "biblio only" } ); push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } ); @@ -170,11 +158,7 @@ sub get_printingtypes { # sub build_text_dropbox { my ($order) = @_; - - # my @fields = get_text_fields(); - # my $field_count = scalar @fields; - my $field_count = 10; # <----------- FIXME hard coded - + my $field_count = 7; # <----------- FIXME hard coded my @lines; !$order ? push( @lines, { num => '', selected => '1' } ) @@ -184,123 +168,112 @@ sub build_text_dropbox { $line->{'selected'} = 1 if $i eq $order; push( @lines, $line ); } - - # add a blank row too - return @lines; } sub get_text_fields { - my ($layout_id, $sorttype) = @_; - my @sorted_fields; - my $error; + my ( $layout_id, $sorttype ) = @_; + my @sorted_fields; + my $error; my $sortorder = get_layout($layout_id); - if( $sortorder->{formatstring}) { - if(! $sorttype) { - return $sortorder->{formatstring} ; - } else { - my $csv = Text::CSV_XS->new( { allow_whitespace => 1 } ) ; - my $line= $sortorder->{formatstring} ; - my $status = $csv->parse( $line ); - @sorted_fields = map {{ 'code' => $_ , desc => $_ } } $csv->fields() ; - $error = $csv->error_input(); - warn $error if $error ; # TODO - do more with this. - } - } else { - # These fields are hardcoded based on the template for label-edit-layout.pl - my @text_fields = ( - { - code => 'itemtype', - desc => "Item Type", - order => $sortorder->{'itemtype'} - }, - { - code => 'dewey', - desc => "Dewey", - order => $sortorder->{'dewey'} - }, - { - code => 'issn', - desc => "ISSN", - order => $sortorder->{'issn'} - }, - { - code => 'isbn', - desc => "ISBN", - order => $sortorder->{'isbn'} - }, - { - code => 'class', - desc => "Classification", - order => $sortorder->{'class'} - }, - { - code => 'subclass', - desc => "Sub-Class", - order => $sortorder->{'subclass'} - }, - { - code => 'barcode', - desc => "Barcode", - order => $sortorder->{'barcode'} - }, - { - code => 'author', - desc => "Author", - order => $sortorder->{'author'} - }, - { - code => 'title', - desc => "Title", - order => $sortorder->{'title'} - }, - { - code => 'itemcallnumber', - desc => "Call Number", - order => $sortorder->{'itemcallnumber'} - }, - { - code => 'subtitle', - desc => "Subtitle", - order => $sortorder->{'subtitle'} + if ( $sortorder->{formatstring} ) { + if ( !$sorttype ) { + return $sortorder->{formatstring}; } - ); - + else { + my $csv = Text::CSV_XS->new( { allow_whitespace => 1 } ); + my $line = $sortorder->{formatstring}; + my $status = $csv->parse($line); + @sorted_fields = + map { { 'code' => $_, desc => $_ } } $csv->fields(); + $error = $csv->error_input(); + warn $error if $error; # TODO - do more with this. + } + } + else { - my @new_fields; - foreach my $field (@text_fields) { - push( @new_fields, $field ) if $field->{'order'} > 0; - } - - @sorted_fields = sort { $$a{order} <=> $$b{order} } @new_fields; + # These fields are hardcoded based on the template for label-edit-layout.pl + my @text_fields = ( + { + code => 'itemtype', + desc => "Item Type", + order => $sortorder->{'itemtype'} + }, + { + code => 'issn', + desc => "ISSN", + order => $sortorder->{'issn'} + }, + { + code => 'isbn', + desc => "ISBN", + order => $sortorder->{'isbn'} + }, + { + code => 'barcode', + desc => "Barcode", + order => $sortorder->{'barcode'} + }, + { + code => 'author', + desc => "Author", + order => $sortorder->{'author'} + }, + { + code => 'title', + desc => "Title", + order => $sortorder->{'title'} + }, + { + code => 'itemcallnumber', + desc => "Call Number", + order => $sortorder->{'itemcallnumber'} + }, + ); + + my @new_fields = (); + foreach my $field (@text_fields) { + push( @new_fields, $field ) if $field->{'order'} > 0; + } + + @sorted_fields = sort { $$a{order} <=> $$b{order} } @new_fields; } - # if we have a 'formatstring', then we ignore these hardcoded fields. + + # if we have a 'formatstring', then we ignore these hardcoded fields. my $active_fields; - if ($sorttype eq 'codes') { # FIXME: This sub should really always return the array of hashrefs and let the caller take what he wants from that -fbcit + if ( $sorttype eq 'codes' ) + { # FIXME: This sub should really always return the array of hashrefs and let the caller take what he wants from that -fbcit return @sorted_fields; - } else { + } + else { foreach my $field (@sorted_fields) { $active_fields .= "$field->{'desc'} "; } return $active_fields; } - } =head2 sub add_batch + =over 4 + add_batch($batch_type,\@batch_list); if $batch_list is supplied, create a new batch with those items. else, return the next available batch_id. -=return + +=back + =cut + sub add_batch ($;$) { my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels'; my $batch_list = (@_) ? shift : undef; my $dbh = C4::Context->dbh; - my $q ="SELECT MAX(DISTINCT batch_id) FROM $table"; + # FIXME : batch_id should be an auto_incr INT. Temporarily casting as int ( see koha bug 2555 ) + # until a label_batches table is added, and we can convert batch_id to int. + my $q ="SELECT MAX( CAST(batch_id AS SIGNED) ) FROM $table"; my $sth = $dbh->prepare($q); $sth->execute(); my ($batch_id) = $sth->fetchrow_array || 0; @@ -342,12 +315,10 @@ sub get_batches (;$) { sub delete_batch { my ($batch_id, $batch_type) = @_; - warn "Deleteing batch of type $batch_type"; - my $dbh = C4::Context->dbh; - my $q = "DELETE FROM $batch_type WHERE batch_id = ?"; - my $sth = $dbh->prepare($q); + warn "Deleteing batch (id:$batch_id) of type $batch_type"; + my $q = "DELETE FROM $batch_type WHERE batch_id = ?"; + my $sth = C4::Context->dbh->prepare($q); $sth->execute($batch_id); - $sth->finish; } sub get_barcode_types { @@ -365,7 +336,6 @@ sub get_barcode_types { if ( $line->{'code'} eq $barcode ) { $line->{'active'} = 1; } - } return @array; } @@ -373,7 +343,6 @@ sub get_barcode_types { sub GetUnitsValue { my ($units) = @_; my $unitvalue; - $unitvalue = '1' if ( $units eq 'POINT' ); $unitvalue = '2.83464567' if ( $units eq 'MM' ); $unitvalue = '28.3464567' if ( $units eq 'CM' ); @@ -404,7 +373,6 @@ sub GetActiveLabelTemplate { my $sth = $dbh->prepare($query); $sth->execute(); my $active_tmpl = $sth->fetchrow_hashref; - $sth->finish; return $active_tmpl; } @@ -415,14 +383,11 @@ sub GetSingleLabelTemplate { my $sth = $dbh->prepare($query); $sth->execute($tmpl_id); my $template = $sth->fetchrow_hashref; - $sth->finish; return $template; } sub SetActiveTemplate { - my ($tmpl_id) = @_; - my $dbh = C4::Context->dbh; my $query = " UPDATE labels_templates SET active = NULL"; my $sth = $dbh->prepare($query); @@ -431,11 +396,9 @@ sub SetActiveTemplate { $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?"; $sth = $dbh->prepare($query); $sth->execute($tmpl_id); - $sth->finish; } sub set_active_layout { - my ($layout_id) = @_; my $dbh = C4::Context->dbh; my $query = " UPDATE labels_conf SET active = NULL"; @@ -445,7 +408,6 @@ sub set_active_layout { $query = "UPDATE labels_conf SET active = 1 WHERE id = ?"; $sth = $dbh->prepare($query); $sth->execute($layout_id); - $sth->finish; } sub DeleteTemplate { @@ -454,7 +416,6 @@ sub DeleteTemplate { my $query = " DELETE FROM labels_templates where tmpl_id = ?"; my $sth = $dbh->prepare($query); $sth->execute($tmpl_id); - $sth->finish; } sub SaveTemplate { @@ -481,7 +442,6 @@ sub SaveTemplate { $font, $fontsize, $units, $tmpl_id ); my $dberror = $sth->errstr; - $sth->finish; return $dberror; } @@ -509,13 +469,11 @@ sub CreateTemplate { $font, $fontsize, $units ); my $dberror = $sth->errstr; - $sth->finish; return $dberror; } sub GetAllLabelTemplates { my $dbh = C4::Context->dbh; - # get the actual items to be printed. my @data; my $query = " Select * from labels_templates "; @@ -525,8 +483,6 @@ sub GetAllLabelTemplates { while ( my $data = $sth->fetchrow_hashref ) { push( @resultsloop, $data ); } - $sth->finish; - #warn Dumper @resultsloop; return @resultsloop; } @@ -536,8 +492,8 @@ sub add_layout { my ( $barcodetype, $title, $subtitle, $isbn, $issn, - $itemtype, $bcn, $dcn, $classif, - $subclass, $itemcallnumber, $author, $tmpl_id, + $itemtype, $bcn, $text_justify, $callnum_split, + $itemcallnumber, $author, $tmpl_id, $printingtype, $guidebox, $startlabel, $layoutname, $formatstring ) = @_; @@ -547,29 +503,25 @@ sub add_layout { $sth2->execute(); $query2 = "INSERT INTO labels_conf ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode, - dewey, classification, subclass, itemcallnumber, author, printingtype, + text_justify, callnum_split, itemcallnumber, author, printingtype, guidebox, startlabel, layoutname, formatstring, active ) - values ( ?, ?,?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )"; + values ( ?, ?,?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?,?,?, 1 )"; $sth2 = $dbh->prepare($query2); $sth2->execute( $barcodetype, $title, $subtitle, $isbn, $issn, - - $itemtype, $bcn, $dcn, $classif, - $subclass, $itemcallnumber, $author, $printingtype, + $itemtype, $bcn, $text_justify, $callnum_split, + $itemcallnumber, $author, $printingtype, $guidebox, $startlabel, $layoutname, $formatstring ); - $sth2->finish; - SetActiveTemplate($tmpl_id); - return; } sub save_layout { my ( $barcodetype, $title, $subtitle, $isbn, $issn, - $itemtype, $bcn, $dcn, $classif, - $subclass, $itemcallnumber, $author, $tmpl_id, + $itemtype, $bcn, $text_justify, $callnum_split, + $itemcallnumber, $author, $tmpl_id, $printingtype, $guidebox, $startlabel, $layoutname, $formatstring, $layout_id ) = @_; @@ -579,22 +531,19 @@ sub save_layout { my $dbh = C4::Context->dbh; my $query2 = "update labels_conf set barcodetype=?, title=?, subtitle=?, isbn=?,issn=?, - itemtype=?, barcode=?, dewey=?, classification=?, - subclass=?, itemcallnumber=?, author=?, printingtype=?, + itemtype=?, barcode=?, text_justify=?, callnum_split=?, + itemcallnumber=?, author=?, printingtype=?, guidebox=?, startlabel=?, layoutname=?, formatstring=? where id = ?"; my $sth2 = $dbh->prepare($query2); $sth2->execute( $barcodetype, $title, $subtitle, $isbn, $issn, - $itemtype, $bcn, $dcn, $classif, - $subclass, $itemcallnumber, $author, $printingtype, + $itemtype, $bcn, $text_justify, $callnum_split, + $itemcallnumber, $author, $printingtype, $guidebox, $startlabel, $layoutname, $formatstring, $layout_id ); - $sth2->finish; - - return; } -=item GetAllPrinterProfiles; +=head2 GetAllPrinterProfiles; @profiles = GetAllPrinterProfiles() @@ -603,22 +552,19 @@ Returns an array of references-to-hash, whos keys are ..... =cut sub GetAllPrinterProfiles { - my $dbh = C4::Context->dbh; my @data; - my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; "; + my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id"; my $sth = $dbh->prepare($query); $sth->execute(); my @resultsloop; while ( my $data = $sth->fetchrow_hashref ) { push( @resultsloop, $data ); } - $sth->finish; - return @resultsloop; } -=item GetSinglePrinterProfile; +=head2 GetSinglePrinterProfile; $profile = GetSinglePrinterProfile() @@ -628,16 +574,14 @@ Returns a hashref whos keys are... sub GetSinglePrinterProfile { my ($prof_id) = @_; - my $dbh = C4::Context->dbh; - my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; "; - my $sth = $dbh->prepare($query); + my $query = "SELECT * FROM printers_profile WHERE prof_id = ?"; + my $sth = C4::Context->dbh->prepare($query); $sth->execute($prof_id); my $template = $sth->fetchrow_hashref; - $sth->finish; return $template; } -=item SaveProfile; +=head2 SaveProfile; SaveProfile('parameters') @@ -658,10 +602,9 @@ sub SaveProfile { $sth->execute( $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id ); - $sth->finish; } -=item CreateProfile; +=head2 CreateProfile; CreateProfile('parameters') @@ -686,11 +629,10 @@ sub CreateProfile { $offset_vert, $creep_horz, $creep_vert, $units ); my $error = $sth->errstr; - $sth->finish; return $error; } -=item DeleteProfile; +=head2 DeleteProfile; DeleteProfile(prof_id) @@ -705,11 +647,10 @@ sub DeleteProfile { my $sth = $dbh->prepare($query); $sth->execute($prof_id); my $error = $sth->errstr; - $sth->finish; return $error; } -=item GetAssociatedProfile; +=head2 GetAssociatedProfile; $assoc_prof = GetAssociatedProfile(tmpl_id) @@ -725,14 +666,13 @@ sub GetAssociatedProfile { my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?"; my $sth = $dbh->prepare($query); $sth->execute($tmpl_id); - my $assoc_prof = $sth->fetchrow_hashref; - $sth->finish; + my $assoc_prof = $sth->fetchrow_hashref or return; # Then we retrieve that profile and return it to the caller... $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'}); return $assoc_prof; } -=item SetAssociatedProfile; +=head2 SetAssociatedProfile; SetAssociatedProfile($prof_id, $tmpl_id) @@ -742,25 +682,22 @@ than one profile may be associated with any given template at the same time. =cut sub SetAssociatedProfile { - my ($prof_id, $tmpl_id) = @_; - my $dbh = C4::Context->dbh; my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?"; my $sth = $dbh->prepare($query); $sth->execute($prof_id, $tmpl_id, $prof_id); - $sth->finish; } -=item GetLabelItems; + +=head2 GetLabelItems; $options = GetLabelItems() -Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database. +Returns an array of references-to-hash, whos keys are the fields from the biblio, biblioitems, items and labels tables in the Koha database. =cut -#' sub GetLabelItems { my ($batch_id) = @_; my $dbh = C4::Context->dbh; @@ -769,16 +706,20 @@ sub GetLabelItems { my $count; my @data; my $sth; - + if ($batch_id) { - my $query3 = "Select * from labels where batch_id = ? order by labelid "; + my $query3 = " + SELECT * + FROM labels + WHERE batch_id = ? + ORDER BY labelid"; $sth = $dbh->prepare($query3); $sth->execute($batch_id); - } else { - - my $query3 = "Select * from labels"; + my $query3 = " + SELECT * + FROM labels"; $sth = $dbh->prepare($query3); $sth->execute(); } @@ -787,20 +728,21 @@ sub GetLabelItems { while ( my $data = $sth->fetchrow_hashref ) { # lets get some summary info from each item - my $query1 = " - select i.*, bi.*, b.* from items i,biblioitems bi,biblio b - where itemnumber=? and i.biblioitemnumber=bi.biblioitemnumber and - bi.biblionumber=b.biblionumber"; - - my $sth1 = $dbh->prepare($query1); + my $query1 = +# FIXME This makes for a very bulky data structure; data from tables w/duplicate col names also gets overwritten. +# Something like this, perhaps, but this also causes problems because we need more fields sometimes. +# SELECT i.barcode, i.itemcallnumber, i.itype, bi.isbn, bi.issn, b.title, b.author + "SELECT bi.*, i.*, b.* + FROM items AS i, biblioitems AS bi ,biblio AS b + WHERE itemnumber=? AND i.biblioitemnumber=bi.biblioitemnumber AND bi.biblionumber=b.biblionumber"; + my $sth1 = $dbh->prepare($query1); $sth1->execute( $data->{'itemnumber'} ); my $data1 = $sth1->fetchrow_hashref(); $data1->{'labelno'} = $i1; $data1->{'labelid'} = $data->{'labelid'}; $data1->{'batch_id'} = $batch_id; - $data1->{'summary'} = - "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}"; + $data1->{'summary'} = "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}"; push( @resultsloop, $data1 ); $sth1->finish; @@ -814,50 +756,81 @@ sub GetLabelItems { sub GetItemFields { my @fields = qw ( - barcode title subtitle - dewey isbn issn author class - itemtype subclass itemcallnumber - + barcode title + isbn issn + author itemtype + itemcallnumber ); return @fields; } -=head GetBarcodeData +=head2 GetBarcodeData =over 4 + Parse labels_conf.formatstring value (one value of the csv, which has already been split) and return string from koha tables or MARC record. + =back + =cut -#' + sub GetBarcodeData { - my ($f,$item,$record) = @_; - my $kohatables= &_descKohaTables(); - my $datastring; - my $last_f = $f; - my $match_kohatable = join('|', (@{$kohatables->{biblio}},@{$kohatables->{biblioitems}},@{$kohatables->{items}}) ); - while( $f ) { - if( $f =~ /^'(.*)'.*/ ) { - # single quotes indicate a static text string. - $datastring .= $1 ; - $f = $'; - } elsif ( $f =~ /^($match_kohatable).*/ ) { - # grep /$f/, (@$kohatables->{biblio},@$kohatables->{biblioitems},@$kohatables->{items}) ) { - $datastring .= $item->{$f}; - $f = $'; - } elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W*).*/ ) { - $datastring .= $record->subfield($1,$2) . $3 if($record->subfield($1,$2)) ; - $f = $'; - } - last if ( $f eq $last_f ); # failed to match - } - return $datastring; + my ( $f, $item, $record ) = @_; + my $kohatables = &_descKohaTables(); + my $datastring = ''; + my $match_kohatable = join( + '|', + ( + @{ $kohatables->{biblio} }, + @{ $kohatables->{biblioitems} }, + @{ $kohatables->{items} } + ) + ); + while ($f) { + $f =~ s/^\s?//; + if ( $f =~ /^'(.*)'.*/ ) { + # single quotes indicate a static text string. + $datastring .= $1; + $f = $'; + } + elsif ( $f =~ /^($match_kohatable).*/ ) { + $datastring .= $item->{$f}; + $f = $'; + } + elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) { + my ($field,$subf,$ws) = ($1,$2,$3); + my $subf_data; + my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField("items.itemnumber",''); + my @marcfield = $record->field($field); + if(@marcfield) { + if($field eq $itemtag) { # item-level data, we need to get the right item. + foreach my $itemfield (@marcfield) { + if ( $itemfield->subfield($itemsubfieldcode) eq $item->{'itemnumber'} ) { + $datastring .= $itemfield->subfield($subf ) . $ws; + last; + } + } + } else { # bib-level data, we'll take the first matching tag/subfield. + $datastring .= $marcfield[0]->subfield($subf) . $ws ; + } + } + $f = $'; + } + else { + warn "failed to parse label formatstring: $f"; + last; # Failed to match + } + } + return $datastring; } -=head descKohaTables +=head2 descKohaTables + Return a hashref of an array of hashes, with name,type keys. + =cut sub _descKohaTables { @@ -868,13 +841,11 @@ sub _descKohaTables { while (my $info = $sth->fetchrow_hashref()){ push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ; } - $sth->finish; } return $kohatables; } sub GetPatronCardItems { - my ( $batch_id ) = @_; my @resultsloop; @@ -893,9 +864,7 @@ sub GetPatronCardItems { push( @resultsloop, $patron_data ); $cardno++; } - $sth->finish; return @resultsloop; - } sub deduplicate_batch { @@ -936,50 +905,122 @@ sub deduplicate_batch { return $killed, undef; } -sub DrawSpineText { +sub split_lccn { + my ($lccn) = @_; + my ($ll, $wnl, $dec, $cutter, $pubdate) = (0, 0, 0, 0, 0); + $_ = $lccn; + # lccn example 'HE8700.7 .P6T44 1983'; + my @splits = m/ + (^[a-zA-Z]+) # HE + ([0-9]+\.*[0-9]*) # 8700.7 + \s* + (\.*[a-zA-Z0-9]*) # P6T44 + \s* + ([0-9]*) # 1983 + /x; + + # strip something occuring spaces too + $splits[0] =~ s/\s+$//; + $splits[1] =~ s/\s+$//; + $splits[2] =~ s/\s+$//; + + return @splits; +} - my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin, - $text_wrap_cols, $item, $conf_data, $printingtype, $nowrap ) = @_; +sub split_ddcn { + my ($ddcn) = @_; + $ddcn =~ s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number... + $_ = $ddcn; + # ddcn example R220.3 H2793Z H32 c.2 + my @splits = m/^([A-Z]{0,3}) # R (OS, REF, etc. up do three letters) + ([0-9]+\.[0-9]*) # 220.3 + \s? # space (not requiring anything beyond the call number) + ([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism) + \s? # space if it exists + ([a-zA-Z]*\.?[0-9]*) # other indicators such as cutter for author of literary criticism in this example if it exists + \s? # space if ie exists + ([a-zA-Z]*\.?[0-9]*) # other indicators such as volume number, copy number, edition date, etc. if it exists + /x; + return @splits; +} - # Replaced item's itemtype with the more user-friendly description... - my $dbh = C4::Context->dbh; - my %itemtypes; - my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes"); - $sth->execute(); - while ( my $data = $sth->fetchrow_hashref ) { - $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'}); +sub split_fcn { + my ($fcn) = @_; + my @fcn_split = (); + # Split fiction call numbers based on spaces + SPLIT_FCN: + while ($fcn) { + if ($fcn =~ m/([A-Za-z0-9]+)(\W?).*?/x) { + push (@fcn_split, $1); + $fcn = $'; + } + else { + last SPLIT_FCN; # No match, break out of the loop + } + } + return @fcn_split; +} + +my %itemtypemap; +# Class variable to avoid querying itemtypes for every DrawSpineText call!! +sub get_itemtype_descriptions () { + unless (scalar keys %itemtypemap) { + my $sth = C4::Context->dbh->prepare("SELECT itemtype,description FROM itemtypes"); + $sth->execute(); + while (my $data = $sth->fetchrow_hashref) { + $itemtypemap{$data->{itemtype}} = $data->{description}; + } } + return \%itemtypemap; +} - my $str; +sub DrawSpineText { + my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin, + $text_wrap_cols, $item, $conf_data, $printingtype ) = @_; + + # Replace item's itemtype with the more user-friendly description... + my $descriptions = get_itemtype_descriptions(); + foreach (qw(itemtype itype)) { + my $description = $descriptions->{$$item->{$_}} or next; + $$item->{$_} = $description; + } + my $str = ''; my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in... - my $line_spacer = ( $fontsize * 1 ); # number of pixels between text rows (This is actually leading: baseline to baseline minus font size. Recommended starting point is 20% of font size.). + my $line_spacer = ( $fontsize * 1 ); # number of pixels between text rows (This is actually leading: baseline to baseline minus font size. Recommended starting point is 20% of font size.). my $layout_id = $$conf_data->{'id'}; my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) ); - my @str_fields = get_text_fields($layout_id, 'codes' ); - my $record = GetMarcBiblio($$item->{biblionumber}); - # FIXME - returns all items, so you can't get data from an embedded holdings field. - # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum). + my @str_fields = get_text_fields($layout_id, 'codes' ); + my $record = GetMarcBiblio($$item->{biblionumber}); + # FIXME - returns all items, so you can't get data from an embedded holdings field. + # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum). my $old_fontname = $fontname; # We need to keep track of the original font passed in... - - for my $field (@str_fields) { - $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field"; - if ($$conf_data->{'formatstring'}) { - $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ; - } else { - $field->{data} = $$item->{$field->{'code'}} ; - } + # Grab the cn_source and if that is NULL, the DefaultClassificationSource syspref + my $cn_source = ($$item->{'cn_source'} ? $$item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource')); + for my $field (@str_fields) { + $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field"; + if ($field->{'code'} eq 'itemtype') { + $field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'}; + } + elsif ($$conf_data->{'formatstring'}) { + # if labels_conf.formatstring has a value, then it overrides the hardcoded option. + $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ; + } + else { + $field->{'data'} = $$item->{$field->{'code'}}; + } # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.) # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname); my $font = prFont($fontname); # if the display option for this field is selected in the DB, # and the item record has some values for this field, display it. + # Or if there is a csv list of fields to display, display them. if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) { # get the string my $str = $field->{data} ; @@ -987,16 +1028,19 @@ sub DrawSpineText { $str =~ s/\n//g; $str =~ s/\r//g; my @strings; - if ($field->{code} eq 'itemcallnumber') { # If the field contains the call number, we do some special processing on it here... - if (($nowrap == 0) || (!$nowrap)) { # wrap lines based on segmentation markers: '/' (other types of segmentation markers can be added as needed here or this could be added as a syspref.) - while ( $str =~ /\// ) { - $str =~ /^(.*)\/(.*)$/; - unshift @strings, $2; - $str = $1; - } - unshift @strings, $str; + my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data ( 060? 090? 092? 099? ) + if ((grep {$field->{code} =~ m/$_/} @callnumber_list) and ($printingtype eq 'BIB') and ($$conf_data->{'callnum_split'})) { # If the field contains the call number, we do some sp + if ($cn_source eq 'lcc') { + @strings = split_lccn($str); + @strings = split_fcn($str) if !@strings; # If it was not a true lccn, try it as a fiction call number + push (@strings, $str) if !@strings; # If it was not that, send it on unsplit + } elsif ($cn_source eq 'ddc') { + @strings = split_ddcn($str); + @strings = split_fcn($str) if !@strings; + push (@strings, $str) if !@strings; } else { - push @strings, $str; # if $nowrap == 1 do not wrap or remove segmentation markers... + # FIXME Need error trapping here; something to be informative to the user perhaps -crn + push @strings, $str; } } else { $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number... @@ -1006,34 +1050,36 @@ sub DrawSpineText { $Text::Wrap::columns = $text_wrap_cols; my @line = split(/\n/ ,wrap('', '', $str)); # If this is a title field, limit to two lines; all others limit to one... - if ($field->{code} eq 'title' && scalar(@line) >= 2) { - while (scalar(@line) > 2) { - pop @line; - } - } else { - while (scalar(@line) > 1) { - pop @line; - } + my $limit = ($field->{code} eq 'title') ? 2 : 1; + while (scalar(@line) > $limit) { + pop @line; } push(@strings, @line); } # loop for each string line foreach my $str (@strings) { - my $hPos; - if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template... + my $hPos = $x_pos; + my $stringwidth = prStrWidth($str, $fontname, $fontsize); + if ( $$conf_data->{'text_justify'} eq 'R' ) { + $hPos += $label_width - ($left_text_margin + $stringwidth); + } elsif($$conf_data->{'text_justify'} eq 'C') { # some code to try and center each line on the label based on font size and string point width... - my $stringwidth = prStrWidth($str, $fontname, $fontsize); my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) ); - $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin ); + $hPos += ($whitespace / 2) + $left_text_margin; #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n"; } else { - $hPos = ( $x_pos + $left_text_margin ); + $hPos += $left_text_margin; } +# utf8::encode($str); +# Say $str has a diacritical like: The séance +# WITOUT encode, PrintText crashes with: Wide character in syswrite at /usr/local/share/perl/5.8.8/PDF/Reuse.pm line 968 +# WITH encode, PrintText prints: The seÌ•ancee +# Neither is appropriate. PrintText( $hPos, $vPos, $font, $fontsize, $str ); - $vPos = $vPos - $line_spacer; + $vPos -= $line_spacer; } - } - } #foreach field + } + } #foreach field } sub PrintText { @@ -1043,7 +1089,6 @@ sub PrintText { } sub DrawPatronCardText { - my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin, $text_wrap_cols, $text, $printingtype ) = @_; @@ -1053,7 +1098,7 @@ sub DrawPatronCardText { my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) ); my $font = prFont($fontname); - my $hPos; + my $hPos = 0; foreach my $line (keys %$text) { $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points"; @@ -1079,15 +1124,14 @@ sub DrawPatronCardText { #} sub DrawBarcode { - # x and y are from the top-left :) my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_; my $num_of_bars = length($barcode); my $bar_width = $width * .8; # %80 of length of label width - my $tot_bar_length; - my $bar_length; + my $tot_bar_length = 0; + my $bar_length = 0; my $guard_length = 10; - my $xsize_ratio; + my $xsize_ratio = 0; if ( $barcodetype eq 'CODE39' ) { $bar_length = '17.5'; @@ -1104,13 +1148,8 @@ sub DrawBarcode { hide_asterisk => 1, ); }; - if ($@) { - warn "$barcodetype, $barcode FAILED:$@"; - } } - elsif ( $barcodetype eq 'CODE39MOD' ) { - # get modulo43 checksum my $c39 = CheckDigits('code_39'); $barcode = $c39->complete($barcode); @@ -1129,13 +1168,8 @@ sub DrawBarcode { hide_asterisk => 1, ); }; - - if ($@) { - warn "$barcodetype, $barcode FAILED:$@"; - } } elsif ( $barcodetype eq 'CODE39MOD10' ) { - # get modulo43 checksum my $c39_10 = CheckDigits('visa'); $barcode = $c39_10->complete($barcode); @@ -1152,16 +1186,10 @@ sub DrawBarcode { ySize => ( .02 * $height ), xSize => $xsize_ratio, hide_asterisk => 1, - text => 0, + text => 0, ); }; - - if ($@) { - warn "$barcodetype, $barcode FAILED:$@"; - } } - - elsif ( $barcodetype eq 'COOP2OF5' ) { $bar_length = '9.43333333333333'; $tot_bar_length = @@ -1176,11 +1204,7 @@ sub DrawBarcode { xSize => $xsize_ratio, ); }; - if ($@) { - warn "$barcodetype, $barcode FAILED:$@"; - } } - elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) { $bar_length = '13.1333333333333'; $tot_bar_length = @@ -1195,136 +1219,88 @@ sub DrawBarcode { xSize => $xsize_ratio, ); }; - if ($@) { - warn "$barcodetype, $barcode FAILED:$@"; - } + } # else {die "Unknown barcodetype '$barcodetype'";} + + if ($@) { + warn "DrawBarcode (type: $barcodetype) FAILED for value '$barcode' :$@"; } my $moo2 = $tot_bar_length * $xsize_ratio; - warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug; - warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug; + warn "x_pos,y_pos,barcode,barcodetype = $x_pos, $y_pos, $barcode, $barcodetype\n" + . "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug; } -=item build_circ_barcode; +=head2 build_circ_barcode; - build_circ_barcode( $x_pos, $y_pos, $barcode, - $barcodetype, \$item); + build_circ_barcode( $x_pos, $y_pos, $barcode, $barcodetype, \$item); $item is the result of a previous call to GetLabelItems(); =cut -#' sub build_circ_barcode { my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_; #warn Dumper \$item; - - #warn "value = $value\n"; - + #warn "Barcode (type: $barcodetype) value = $value\n"; #$DB::single = 1; if ( $barcodetype eq 'EAN13' ) { - #testing EAN13 barcodes hack $value = $value . '000000000'; $value =~ s/-//; $value = substr( $value, 0, 12 ); - - #warn $value; + #warn "revised value: $value"; eval { PDF::Reuse::Barcode::EAN13( x => ( $x_pos_circ + 27 ), y => ( $y_pos + 15 ), value => $value, - - # prolong => 2.96, - # xSize => 1.5, - + # prolong => 2.96, + # xSize => 1.5, # ySize => 1.2, - # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k # i think its embedding extra fonts in the pdf file. # mode => 'graphic', ); }; - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "EAN13BARCODE FAILED:$@"; - } - - #warn $barcodetype; - } elsif ( $barcodetype eq 'Code39' ) { - eval { PDF::Reuse::Barcode::Code39( x => ( $x_pos_circ + 9 ), y => ( $y_pos + 15 ), value => $value, - - # prolong => 2.96, + # prolong => 2.96, xSize => .85, - ySize => 1.3, ); }; - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "CODE39BARCODE $value FAILED:$@"; - } - - #warn $barcodetype; - } - elsif ( $barcodetype eq 'Matrix2of5' ) { - - #warn "MATRIX ELSE:"; - - #testing MATRIX25 barcodes hack - # $value = $value.'000000000'; + # testing MATRIX25 barcodes hack + # $value = $value.'000000000'; $value =~ s/-//; - - # $value = substr( $value, 0, 12 ); - #warn $value; - + # $value = substr( $value, 0, 12 ); + #warn "revised value: $value"; eval { PDF::Reuse::Barcode::Matrix2of5( x => ( $x_pos_circ + 27 ), y => ( $y_pos + 15 ), value => $value, - - # prolong => 2.96, - # xSize => 1.5, - + # prolong => 2.96, + # xSize => 1.5, # ySize => 1.2, ); }; - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "BARCODE FAILED:$@"; - } - - #warn $barcodetype; - } - elsif ( $barcodetype eq 'EAN8' ) { - #testing ean8 barcodes hack $value = $value . '000000000'; $value =~ s/-//; $value = substr( $value, 0, 8 ); - - #warn $value; - - #warn "EAN8 ELSEIF"; + #warn "revised value: $value"; eval { PDF::Reuse::Barcode::EAN8( x => ( $x_pos_circ + 42 ), @@ -1332,21 +1308,10 @@ sub build_circ_barcode { value => $value, prolong => 2.96, xSize => 1.5, - # ySize => 1.2, ); }; - - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "BARCODE FAILED:$@"; - } - - #warn $barcodetype; - } - elsif ( $barcodetype eq 'UPC-E' ) { eval { PDF::Reuse::Barcode::UPCE( @@ -1355,19 +1320,9 @@ sub build_circ_barcode { value => $value, prolong => 2.96, xSize => 1.5, - # ySize => 1.2, ); }; - - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "BARCODE FAILED:$@"; - } - - #warn $barcodetype; - } elsif ( $barcodetype eq 'NW7' ) { eval { @@ -1377,19 +1332,9 @@ sub build_circ_barcode { value => $value, prolong => 2.96, xSize => 1.5, - # ySize => 1.2, ); }; - - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "BARCODE FAILED:$@"; - } - - #warn $barcodetype; - } elsif ( $barcodetype eq 'ITF' ) { eval { @@ -1399,19 +1344,9 @@ sub build_circ_barcode { value => $value, prolong => 2.96, xSize => 1.5, - # ySize => 1.2, ); }; - - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "BARCODE FAILED:$@"; - } - - #warn $barcodetype; - } elsif ( $barcodetype eq 'Industrial2of5' ) { eval { @@ -1421,18 +1356,9 @@ sub build_circ_barcode { value => $value, prolong => 2.96, xSize => 1.5, - # ySize => 1.2, ); }; - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "BARCODE FAILED:$@"; - } - - #warn $barcodetype; - } elsif ( $barcodetype eq 'IATA2of5' ) { eval { @@ -1442,20 +1368,10 @@ sub build_circ_barcode { value => $value, prolong => 2.96, xSize => 1.5, - # ySize => 1.2, ); }; - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "BARCODE FAILED:$@"; - } - - #warn $barcodetype; - } - elsif ( $barcodetype eq 'COOP2of5' ) { eval { PDF::Reuse::Barcode::COOP2of5( @@ -1464,21 +1380,11 @@ sub build_circ_barcode { value => $value, prolong => 2.96, xSize => 1.5, - # ySize => 1.2, ); }; - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "BARCODE FAILED:$@"; - } - - #warn $barcodetype; - } elsif ( $barcodetype eq 'UPC-A' ) { - eval { PDF::Reuse::Barcode::UPCA( x => ( $x_pos_circ + 27 ), @@ -1486,23 +1392,17 @@ sub build_circ_barcode { value => $value, prolong => 2.96, xSize => 1.5, - # ySize => 1.2, ); }; - if ($@) { - $item->{'barcodeerror'} = 1; - - #warn "BARCODE FAILED:$@"; - } - - #warn $barcodetype; - } - + if ($@) { + $item->{'barcodeerror'} = 1; + #warn "BARCODE (type: $barcodetype) FAILED:$@"; + } } -=item draw_boundaries +=head2 draw_boundaries sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos, $spine_width, $label_height, $circ_width) @@ -1511,9 +1411,7 @@ This sub draws boundary lines where the label outlines are, to aid in printer te =cut -#' sub draw_boundaries { - my ( $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos, $spine_width, $label_height, $circ_width @@ -1524,19 +1422,15 @@ sub draw_boundaries { my $i = 1; for ( $i = 1 ; $i <= 8 ; $i++ ) { - &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) ); - #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height"; &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) ); &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) ); - $y_pos = ( $y_pos - $label_height ); - } } -=item drawbox +=head2 drawbox sub drawbox { $lower_left_x, $lower_left_y, $upper_right_x, $upper_right_y ) @@ -1549,10 +1443,8 @@ and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out! =cut -#' sub drawbox { my ( $llx, $lly, $urx, $ury ) = @_; - # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n"; my $str = "q\n"; # save the graphic state @@ -1566,16 +1458,11 @@ sub drawbox { $str .= "Q\n"; # save the graphic state prAdd($str); - } -END { } # module clean-up code here (global destructor) - 1; __END__ -=back - =head1 AUTHOR Mason James