# Suite 330, Boston, MA 02111-1307 USA
use strict;
+# use warnings; # FIXME
use vars qw($VERSION @ISA @EXPORT);
use PDF::Reuse;
use C4::Biblio;
use Text::CSV_XS;
use Data::Dumper;
-# use Smart::Comments;
BEGIN {
$VERSION = 0.03;
&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
&delete_layout &get_active_layout
&get_highest_batch
&deduplicate_batch
- &GetAllPrinterProfiles &GetSinglePrinterProfile
- &SaveProfile &CreateProfile &DeleteProfile
- &GetAssociatedProfile &SetAssociatedProfile
+ &GetAllPrinterProfiles &GetSinglePrinterProfile
+ &SaveProfile &CreateProfile &DeleteProfile
+ &GetAssociatedProfile &SetAssociatedProfile
);
}
=head1 FUNCTIONS
-=over 2
-
-=item get_label_options;
+=head2 get_label_options;
$options = get_label_options()
=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);
}
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;
}
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" } );
#
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' } )
$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;
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 {
if ( $line->{'code'} eq $barcode ) {
$line->{'active'} = 1;
}
-
}
return @array;
}
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' );
my $sth = $dbh->prepare($query);
$sth->execute();
my $active_tmpl = $sth->fetchrow_hashref;
- $sth->finish;
return $active_tmpl;
}
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);
$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";
$query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
$sth = $dbh->prepare($query);
$sth->execute($layout_id);
- $sth->finish;
}
sub DeleteTemplate {
my $query = " DELETE FROM labels_templates where tmpl_id = ?";
my $sth = $dbh->prepare($query);
$sth->execute($tmpl_id);
- $sth->finish;
}
sub SaveTemplate {
$font, $fontsize, $units, $tmpl_id
);
my $dberror = $sth->errstr;
- $sth->finish;
return $dberror;
}
$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 ";
while ( my $data = $sth->fetchrow_hashref ) {
push( @resultsloop, $data );
}
- $sth->finish;
-
#warn Dumper @resultsloop;
return @resultsloop;
}
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
) = @_;
$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
) = @_;
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()
=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()
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')
$sth->execute(
$offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
);
- $sth->finish;
}
-=item CreateProfile;
+=head2 CreateProfile;
CreateProfile('parameters')
$offset_vert, $creep_horz, $creep_vert, $units
);
my $error = $sth->errstr;
- $sth->finish;
return $error;
}
-=item DeleteProfile;
+=head2 DeleteProfile;
DeleteProfile(prof_id)
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)
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)
=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;
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();
}
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;
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 {
while (my $info = $sth->fetchrow_hashref()){
push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
}
- $sth->finish;
}
return $kohatables;
}
sub GetPatronCardItems {
-
my ( $batch_id ) = @_;
my @resultsloop;
push( @resultsloop, $patron_data );
$cardno++;
}
- $sth->finish;
return @resultsloop;
-
}
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} ;
$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...
$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 {
}
sub DrawPatronCardText {
-
my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
$text_wrap_cols, $text, $printingtype )
= @_;
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";
#}
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';
hide_asterisk => 1,
);
};
- if ($@) {
- warn "$barcodetype, $barcode FAILED:$@";
- }
}
-
elsif ( $barcodetype eq 'CODE39MOD' ) {
-
# get modulo43 checksum
my $c39 = CheckDigits('code_39');
$barcode = $c39->complete($barcode);
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);
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 =
xSize => $xsize_ratio,
);
};
- if ($@) {
- warn "$barcodetype, $barcode FAILED:$@";
- }
}
-
elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
$bar_length = '13.1333333333333';
$tot_bar_length =
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 ),
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(
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 {
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 {
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 {
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 {
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(
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 ),
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)
=cut
-#'
sub draw_boundaries {
-
my (
$x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
$spine_width, $label_height, $circ_width
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 )
=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
$str .= "Q\n"; # save the graphic state
prAdd($str);
-
}
-END { } # module clean-up code here (global destructor)
-
1;
__END__
-=back
-
=head1 AUTHOR
Mason James <mason@katipo.co.nz>
projects / koha.git / blobdiff