C4/Labels.pm

   1 package C4::Labels;
   2
   3 # Copyright 2006 Katipo Communications.
   4 #
   5 # This file is part of Koha.
   6 #
   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
  10 # version.
  11 #
  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.
  15 #
  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
  19
  20 use strict;
  21 use vars qw($VERSION @ISA @EXPORT);
  22
  23 use PDF::Reuse;
  24 use Text::Wrap;
  25 use Algorithm::CheckDigits;
  26 # use Data::Dumper;
  27 # use Smart::Comments;
  28
  29 BEGIN {
  30         $VERSION = 0.03;
  31         require Exporter;
  32         @ISA    = qw(Exporter);
  33         @EXPORT = qw(
  34                 &get_label_options &get_label_items
  35                 &build_circ_barcode &draw_boundaries
  36                 &drawbox &GetActiveLabelTemplate
  37                 &GetAllLabelTemplates &DeleteTemplate
  38                 &GetSingleLabelTemplate &SaveTemplate
  39                 &CreateTemplate &SetActiveTemplate
  40                 &SaveConf &DrawSpineText &GetTextWrapCols
  41                 &GetUnitsValue &DrawBarcode
  42                 &get_printingtypes
  43                 &get_layouts
  44                 &get_barcode_types
  45                 &get_batches &delete_batch
  46                 &add_batch &SetFontSize &printText
  47                 &GetItemFields
  48                 &get_text_fields
  49                 get_layout &save_layout &add_layout
  50                 &set_active_layout &by_order
  51                 &build_text_dropbox
  52                 &delete_layout &get_active_layout
  53                 &get_highest_batch
  54                 &deduplicate_batch
  55                 &GetAllPrinterProfiles &GetSinglePrinterProfile
  56                 &SaveProfile &CreateProfile &DeleteProfile
  57                 &GetAssociatedProfile &SetAssociatedProfile
  58         );
  59 }
  60
  61 my $DEBUG = 0;
  62
  63 =head1 NAME
  64
  65 C4::Labels - Functions for printing spine labels and barcodes in Koha
  66
  67 =head1 FUNCTIONS
  68
  69 =over 2
  70
  71 =item get_label_options;
  72
  73         $options = get_label_options()
  74
  75 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
  76
  77 =cut
  78
  79 #'
  80 sub get_label_options {
  81     my $dbh    = C4::Context->dbh;
  82     my $query2 = " SELECT * FROM labels_conf where active = 1";
  83     my $sth    = $dbh->prepare($query2);
  84     $sth->execute();
  85     my $conf_data = $sth->fetchrow_hashref;
  86     $sth->finish;
  87     return $conf_data;
  88 }
  89
  90 sub get_layouts {
  91
  92 ## FIXME: this if/else could be compacted...
  93     my $dbh = C4::Context->dbh;
  94     my @data;
  95     my $query = " Select * from labels_conf";
  96     my $sth   = $dbh->prepare($query);
  97     $sth->execute();
  98     my @resultsloop;
  99     while ( my $data = $sth->fetchrow_hashref ) {
 100
 101         $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
 102         push( @resultsloop, $data );
 103     }
 104     $sth->finish;
 105
 106     # @resultsloop
 107
 108     return @resultsloop;
 109 }
 110
 111 sub get_layout {
 112     my ($layout_id) = @_;
 113     my $dbh = C4::Context->dbh;
 114
 115     # get the actual items to be printed.
 116     my $query = " Select * from labels_conf where id = ?";
 117     my $sth   = $dbh->prepare($query);
 118     $sth->execute($layout_id);
 119     my $data = $sth->fetchrow_hashref;
 120     $sth->finish;
 121     return $data;
 122 }
 123
 124 sub get_active_layout {
 125     my ($layout_id) = @_;
 126     my $dbh = C4::Context->dbh;
 127
 128     # get the actual items to be printed.
 129     my $query = " Select * from labels_conf where active = 1";
 130     my $sth   = $dbh->prepare($query);
 131     $sth->execute();
 132     my $data = $sth->fetchrow_hashref;
 133     $sth->finish;
 134     return $data;
 135 }
 136
 137 sub delete_layout {
 138     my ($layout_id) = @_;
 139     my $dbh = C4::Context->dbh;
 140
 141     # get the actual items to be printed.
 142     my $query = "delete from  labels_conf where id = ?";
 143     my $sth   = $dbh->prepare($query);
 144     $sth->execute($layout_id);
 145     $sth->finish;
 146 }
 147
 148 sub get_printingtypes {
 149     my ($layout_id) = @_;
 150     my @printtypes;
 151
 152     push( @printtypes, { code => 'BAR',    desc => "barcode" } );
 153     push( @printtypes, { code => 'BIB',    desc => "biblio" } );
 154     push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
 155     push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
 156     push( @printtypes, { code => 'ALT',    desc => "alternating labels" } );
 157
 158     my $conf             = get_layout($layout_id);
 159     my $active_printtype = $conf->{'printingtype'};
 160
 161     # lop thru layout, insert selected to hash
 162
 163     foreach my $printtype (@printtypes) {
 164         if ( $printtype->{'code'} eq $active_printtype ) {
 165             $printtype->{'active'} = 'MOO';
 166         }
 167     }
 168     return @printtypes;
 169 }
 170
 171 sub build_text_dropbox {
 172     my ($order) = @_;
 173
 174     #  my @fields      = get_text_fields();
 175     #    my $field_count = scalar @fields;
 176     my $field_count = 10;    # <-----------       FIXME hard coded
 177
 178     my @lines;
 179     !$order
 180       ? push( @lines, { num => '', selected => '1' } )
 181       : push( @lines, { num => '' } );
 182     for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
 183         my $line = { num => "$i" };
 184         $line->{'selected'} = 1 if $i eq $order;
 185         push( @lines, $line );
 186     }
 187
 188     # add a blank row too
 189
 190     return @lines;
 191 }
 192
 193 sub get_text_fields {
 194     my ($layout_id, $sorttype) = @_;
 195
 196     my ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
 197
 198     my $sortorder = get_layout($layout_id);
 199
 200     # $sortorder
 201
 202     $a = {
 203         code  => 'itemtype',
 204         desc  => "Item Type",
 205         order => $sortorder->{'itemtype'}
 206     };
 207     $b = {
 208         code  => 'dewey',
 209         desc  => "Dewey",
 210         order => $sortorder->{'dewey'}
 211     };
 212     $c = { code => 'issn', desc => "ISSN",
 213         order => $sortorder->{'issn'} };
 214     $d = { code => 'isbn', desc => "ISBN",
 215             order => $sortorder->{'isbn'} };
 216     $e = {
 217         code  => 'class',
 218         desc  => "Classification",
 219         order => $sortorder->{'class'}
 220     };
 221     $f = {
 222         code  => 'subclass',
 223         desc  => "Sub-Class",
 224         order => $sortorder->{'subclass'}
 225     };
 226     $g = {
 227         code  => 'barcode',
 228         desc  => "Barcode",
 229         order => $sortorder->{'barcode'}
 230     };
 231     $h =
 232       { code => 'author', desc => "Author", order => $sortorder->{'author'} };
 233     $i = { code => 'title', desc => "Title", order => $sortorder->{'title'} };
 234     $j = { code => 'itemcallnumber', desc => "Call Number", order => $sortorder->{'itemcallnumber'} };
 235         $k = { code => 'subtitle', desc => "Subtitle", order => $sortorder->{'subtitle'} };
 236
 237         my @text_fields = ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
 238
 239     my @new_fields;
 240     foreach my $field (@text_fields) {
 241         push( @new_fields, $field ) if $field->{'order'} > 0;
 242     }
 243
 244     my @sorted_fields = sort by_order @new_fields;
 245     my $active_fields;
 246     foreach my $field (@sorted_fields) {
 247      $sorttype eq 'codes' ?   $active_fields .= "$field->{'code'} " :
 248           $active_fields .= "$field->{'desc'} ";
 249     }
 250     return $active_fields;
 251
 252 }
 253
 254 sub by_order {
 255     $$a{order} <=> $$b{order};
 256 }
 257
 258 sub add_batch {
 259     my $new_batch;
 260     my $dbh = C4::Context->dbh;
 261     my $q =
 262       "select distinct batch_id from labels order by batch_id desc limit 1";
 263     my $sth = $dbh->prepare($q);
 264     $sth->execute();
 265     my $data = $sth->fetchrow_hashref;
 266     $sth->finish;
 267
 268     if ( !$data->{'batch_id'} ) {
 269         $new_batch = 1;
 270     }
 271     else {
 272         $new_batch = ( $data->{'batch_id'} + 1 );
 273     }
 274
 275     return $new_batch;
 276 }
 277
 278
 279 sub get_highest_batch {
 280     my $new_batch;
 281     my $dbh = C4::Context->dbh;
 282     my $q =
 283       "select distinct batch_id from labels order by batch_id desc limit 1";
 284     my $sth = $dbh->prepare($q);
 285     $sth->execute();
 286     my $data = $sth->fetchrow_hashref;
 287     $sth->finish;
 288
 289     if ( !$data->{'batch_id'} ) {
 290         $new_batch = 1;
 291     }
 292     else {
 293         $new_batch =  $data->{'batch_id'};
 294     }
 295
 296     return $new_batch;
 297 }
 298
 299
 300 sub get_batches {
 301     my $dbh = C4::Context->dbh;
 302     my $q   = "select batch_id, count(*) as num from labels group by batch_id";
 303     my $sth = $dbh->prepare($q);
 304     $sth->execute();
 305     my @resultsloop;
 306     while ( my $data = $sth->fetchrow_hashref ) {
 307         push( @resultsloop, $data );
 308     }
 309     $sth->finish;
 310
 311 # Not sure why we are doing this rather than simply telling the user that no batches are currently defined.
 312 # So I'm commenting this out and modifying label-manager.tmpl to properly inform the user as stated. -fbcit
 313     # adding a dummy batch=1 value , if none exists in the db
 314 #    if ( !scalar(@resultsloop) ) {
 315 #        push( @resultsloop, { batch_id => '1' , num => '0' } );
 316 #    }
 317     return @resultsloop;
 318 }
 319
 320 sub delete_batch {
 321     my ($batch_id) = @_;
 322     my $dbh        = C4::Context->dbh;
 323     my $q          = "DELETE FROM labels where batch_id  = ?";
 324     my $sth        = $dbh->prepare($q);
 325     $sth->execute($batch_id);
 326     $sth->finish;
 327 }
 328
 329 sub get_barcode_types {
 330     my ($layout_id) = @_;
 331     my $layout      = get_layout($layout_id);
 332     my $barcode     = $layout->{'barcodetype'};
 333     my @array;
 334
 335     push( @array, { code => 'CODE39',    desc => 'Code 39' } );
 336     push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
 337     push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
 338         push( @array, { code => 'ITF',       desc => 'Interleaved 2 of 5' } );
 339
 340     foreach my $line (@array) {
 341         if ( $line->{'code'} eq $barcode ) {
 342             $line->{'active'} = 1;
 343         }
 344
 345     }
 346     return @array;
 347 }
 348
 349 sub GetUnitsValue {
 350     my ($units) = @_;
 351     my $unitvalue;
 352
 353     $unitvalue = '1'          if ( $units eq 'POINT' );
 354     $unitvalue = '2.83464567' if ( $units eq 'MM' );
 355     $unitvalue = '28.3464567' if ( $units eq 'CM' );
 356     $unitvalue = 72           if ( $units eq 'INCH' );
 357     return $unitvalue;
 358 }
 359
 360 sub GetTextWrapCols {
 361     my ( $fontsize, $label_width ) = @_;
 362     my $string           = "0";
 363     my $left_text_margin = 3;
 364     my ( $strtmp, $strwidth );
 365     my $count     = 0;
 366     my $textlimit = $label_width - $left_text_margin;
 367
 368     while ( $strwidth < $textlimit ) {
 369         $strwidth = prStrWidth( $string, 'C', $fontsize );
 370         $string = $string . '0';
 371
 372         #       warn "strwidth $strwidth, $textlimit, $string";
 373         $count++;
 374     }
 375     return $count;
 376 }
 377
 378 sub GetActiveLabelTemplate {
 379     my $dbh   = C4::Context->dbh;
 380     my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
 381     my $sth   = $dbh->prepare($query);
 382     $sth->execute();
 383     my $active_tmpl = $sth->fetchrow_hashref;
 384     $sth->finish;
 385     return $active_tmpl;
 386 }
 387
 388 sub GetSingleLabelTemplate {
 389     my ($tmpl_id) = @_;
 390     my $dbh       = C4::Context->dbh;
 391     my $query     = " SELECT * FROM labels_templates where tmpl_id = ?";
 392     my $sth       = $dbh->prepare($query);
 393     $sth->execute($tmpl_id);
 394     my $template = $sth->fetchrow_hashref;
 395     $sth->finish;
 396     return $template;
 397 }
 398
 399 sub SetActiveTemplate {
 400
 401     my ($tmpl_id) = @_;
 402
 403     my $dbh   = C4::Context->dbh;
 404     my $query = " UPDATE labels_templates SET active = NULL";
 405     my $sth   = $dbh->prepare($query);
 406     $sth->execute();
 407
 408     $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
 409     $sth   = $dbh->prepare($query);
 410     $sth->execute($tmpl_id);
 411     $sth->finish;
 412 }
 413
 414 sub set_active_layout {
 415
 416     my ($layout_id) = @_;
 417     my $dbh         = C4::Context->dbh;
 418     my $query       = " UPDATE labels_conf SET active = NULL";
 419     my $sth         = $dbh->prepare($query);
 420     $sth->execute();
 421
 422     $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
 423     $sth   = $dbh->prepare($query);
 424     $sth->execute($layout_id);
 425     $sth->finish;
 426 }
 427
 428 sub DeleteTemplate {
 429     my ($tmpl_id) = @_;
 430     my $dbh       = C4::Context->dbh;
 431     my $query     = " DELETE  FROM labels_templates where tmpl_id = ?";
 432     my $sth       = $dbh->prepare($query);
 433     $sth->execute($tmpl_id);
 434     $sth->finish;
 435 }
 436
 437 sub SaveTemplate {
 438     my (
 439         $tmpl_id,     $tmpl_code,   $tmpl_desc,    $page_width,
 440         $page_height, $label_width, $label_height, $topmargin,
 441         $leftmargin,  $cols,        $rows,         $colgap,
 442         $rowgap,      $fontsize,     $units
 443     ) = @_;
 444     my $dbh = C4::Context->dbh;
 445     my $query =
 446       " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
 447                page_height=?, label_width=?, label_height=?, topmargin=?,
 448                leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, fontsize=?,
 449                            units=?
 450                   WHERE tmpl_id = ?";
 451
 452     my $sth = $dbh->prepare($query);
 453     $sth->execute(
 454         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 455         $label_width, $label_height, $topmargin,  $leftmargin,
 456         $cols,        $rows,         $colgap,     $rowgap,
 457         $fontsize,    $units,        $tmpl_id
 458     );
 459     $sth->finish;
 460 }
 461
 462 sub CreateTemplate {
 463     my $tmpl_id;
 464     my (
 465         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 466         $label_width, $label_height, $topmargin,  $leftmargin,
 467         $cols,        $rows,         $colgap,     $rowgap,
 468         $fontsize,     $units
 469     ) = @_;
 470
 471     my $dbh = C4::Context->dbh;
 472
 473     my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
 474                          page_height, label_width, label_height, topmargin,
 475                          leftmargin, cols, rows, colgap, rowgap, fontsize, units)
 476                          VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
 477
 478     my $sth = $dbh->prepare($query);
 479     $sth->execute(
 480         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 481         $label_width, $label_height, $topmargin,  $leftmargin,
 482         $cols,        $rows,         $colgap,     $rowgap,
 483         $fontsize,    $units
 484     );
 485 }
 486
 487 sub GetAllLabelTemplates {
 488     my $dbh = C4::Context->dbh;
 489
 490     # get the actual items to be printed.
 491     my @data;
 492     my $query = " Select * from labels_templates ";
 493     my $sth   = $dbh->prepare($query);
 494     $sth->execute();
 495     my @resultsloop;
 496     while ( my $data = $sth->fetchrow_hashref ) {
 497         push( @resultsloop, $data );
 498     }
 499     $sth->finish;
 500
 501     #warn Dumper @resultsloop;
 502     return @resultsloop;
 503 }
 504
 505 #sub SaveConf {
 506 sub add_layout {
 507
 508     my (
 509         $barcodetype,  $title,          $subtitle,      $isbn,       $issn,
 510         $itemtype,     $bcn,            $dcn,        $classif,
 511         $subclass,     $itemcallnumber, $author,     $tmpl_id,
 512         $printingtype, $guidebox,       $startlabel, $layoutname
 513     ) = @_;
 514
 515     my $dbh    = C4::Context->dbh;
 516     my $query2 = "update labels_conf set active = NULL";
 517     my $sth2   = $dbh->prepare($query2);
 518     $sth2->execute();
 519     $query2 = "INSERT INTO labels_conf
 520             ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
 521               dewey, class, subclass, itemcallnumber, author, printingtype,
 522                 guidebox, startlabel, layoutname, active )
 523                values ( ?, ?, ?, ?, ?, ?, ?,  ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
 524     $sth2 = $dbh->prepare($query2);
 525     $sth2->execute(
 526         $barcodetype, $title, $subtitle, $isbn, $issn,
 527
 528         $itemtype, $bcn,            $dcn,    $classif,
 529         $subclass, $itemcallnumber, $author, $printingtype,
 530         $guidebox, $startlabel,     $layoutname
 531     );
 532     $sth2->finish;
 533
 534     SetActiveTemplate($tmpl_id);
 535     return;
 536 }
 537
 538 sub save_layout {
 539
 540     my (
 541         $barcodetype,  $title,          $subtitle,      $isbn,       $issn,
 542         $itemtype,     $bcn,            $dcn,        $classif,
 543         $subclass,     $itemcallnumber, $author,     $tmpl_id,
 544         $printingtype, $guidebox,       $startlabel, $layoutname,
 545         $layout_id
 546     ) = @_;
 547 ### $layoutname
 548 ### $layout_id
 549
 550     my $dbh    = C4::Context->dbh;
 551     my $query2 = "update labels_conf set
 552              barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
 553             itemtype=?, barcode=?,    dewey=?, class=?,
 554              subclass=?, itemcallnumber=?, author=?,  printingtype=?,
 555                guidebox=?, startlabel=?, layoutname=? where id = ?";
 556     my $sth2 = $dbh->prepare($query2);
 557     $sth2->execute(
 558         $barcodetype, $title,          $subtitle,       $isbn,       $issn,
 559         $itemtype,    $bcn,            $dcn,        $classif,
 560         $subclass,    $itemcallnumber, $author,     $printingtype,
 561         $guidebox,    $startlabel,     $layoutname, $layout_id
 562     );
 563     $sth2->finish;
 564
 565     return;
 566 }
 567
 568 =item GetAllPrinterProfiles;
 569
 570     @profiles = GetAllPrinterProfiles()
 571
 572 Returns an array of references-to-hash, whos keys are .....
 573
 574 =cut
 575
 576 sub GetAllPrinterProfiles {
 577
 578     my $dbh = C4::Context->dbh;
 579     my @data;
 580     my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
 581     my $sth = $dbh->prepare($query);
 582     $sth->execute();
 583     my @resultsloop;
 584     while ( my $data = $sth->fetchrow_hashref ) {
 585         push( @resultsloop, $data );
 586     }
 587     $sth->finish;
 588
 589     return @resultsloop;
 590 }
 591
 592 =item GetSinglePrinterProfile;
 593
 594     $profile = GetSinglePrinterProfile()
 595
 596 Returns a hashref whos keys are...
 597
 598 =cut
 599
 600 sub GetSinglePrinterProfile {
 601     my ($prof_id) = @_;
 602     my $dbh       = C4::Context->dbh;
 603     my $query     = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
 604     my $sth       = $dbh->prepare($query);
 605     $sth->execute($prof_id);
 606     my $template = $sth->fetchrow_hashref;
 607     $sth->finish;
 608     return $template;
 609 }
 610
 611 =item SaveProfile;
 612
 613     SaveProfile('parameters')
 614
 615 When passed a set of parameters, this function updates the given profile with the new parameters.
 616
 617 =cut
 618
 619 sub SaveProfile {
 620     my (
 621         $prof_id,       $offset_horz,   $offset_vert,   $creep_horz,    $creep_vert,    $units
 622     ) = @_;
 623     my $dbh = C4::Context->dbh;
 624     my $query =
 625       " UPDATE printers_profile
 626         SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
 627         WHERE prof_id = ? ";
 628     my $sth = $dbh->prepare($query);
 629     $sth->execute(
 630         $offset_horz,   $offset_vert,   $creep_horz,    $creep_vert,    $units,         $prof_id
 631     );
 632     $sth->finish;
 633 }
 634
 635 =item CreateProfile;
 636
 637     CreateProfile('parameters')
 638
 639 When passed a set of parameters, this function creates a new profile containing those parameters
 640 and returns any errors.
 641
 642 =cut
 643
 644 sub CreateProfile {
 645     my (
 646         $prof_id,       $printername,   $paper_bin,     $tmpl_id,     $offset_horz,
 647         $offset_vert,   $creep_horz,    $creep_vert,    $units
 648     ) = @_;
 649     my $dbh = C4::Context->dbh;
 650     my $query =
 651         " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
 652                                         offset_horz, offset_vert, creep_horz, creep_vert, unit)
 653           VALUES(?,?,?,?,?,?,?,?,?) ";
 654     my $sth = $dbh->prepare($query);
 655     $sth->execute(
 656         $prof_id,       $printername,   $paper_bin,     $tmpl_id,     $offset_horz,
 657         $offset_vert,   $creep_horz,    $creep_vert,    $units
 658     );
 659     my $error =  $sth->errstr;
 660     $sth->finish;
 661     return $error;
 662 }
 663
 664 =item DeleteProfile;
 665
 666     DeleteProfile(prof_id)
 667
 668 When passed a profile id, this function deletes that profile from the database and returns any errors.
 669
 670 =cut
 671
 672 sub DeleteProfile {
 673     my ($prof_id) = @_;
 674     my $dbh       = C4::Context->dbh;
 675     my $query     = " DELETE FROM printers_profile WHERE prof_id = ?";
 676     my $sth       = $dbh->prepare($query);
 677     $sth->execute($prof_id);
 678     my $error = $sth->errstr;
 679     $sth->finish;
 680     return $error;
 681 }
 682
 683 =item GetAssociatedProfile;
 684
 685     $assoc_prof = GetAssociatedProfile(tmpl_id)
 686
 687 When passed a template id, this function returns the parameters from the currently associated printer profile
 688 in a hashref where key=fieldname and value=fieldvalue.
 689
 690 =cut
 691
 692 sub GetAssociatedProfile {
 693     my ($tmpl_id) = @_;
 694     my $dbh   = C4::Context->dbh;
 695     # First we find out the prof_id for the associated profile...
 696     my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
 697     my $sth   = $dbh->prepare($query);
 698     $sth->execute($tmpl_id);
 699     my $assoc_prof = $sth->fetchrow_hashref;
 700     $sth->finish;
 701     # Then we retrieve that profile and return it to the caller...
 702     $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
 703     return $assoc_prof;
 704 }
 705
 706 =item SetAssociatedProfile;
 707
 708     SetAssociatedProfile($prof_id, $tmpl_id)
 709
 710 When passed both a profile id and template id, this function establishes an association between the two. No more
 711 than one profile may be associated with any given template at the same time.
 712
 713 =cut
 714
 715 sub SetAssociatedProfile {
 716
 717     my ($prof_id, $tmpl_id) = @_;
 718
 719     my $dbh = C4::Context->dbh;
 720     my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
 721     my $sth = $dbh->prepare($query);
 722     $sth->execute($prof_id, $tmpl_id, $prof_id);
 723     $sth->finish;
 724 }
 725
 726 =item get_label_items;
 727
 728         $options = get_label_items()
 729
 730 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
 731
 732 =cut
 733
 734 #'
 735 sub get_label_items {
 736     my ($batch_id) = @_;
 737     my $dbh = C4::Context->dbh;
 738
 739     my @resultsloop = ();
 740     my $count;
 741     my @data;
 742     my $sth;
 743
 744     if ($batch_id) {
 745         my $query3 = "Select * from labels where batch_id = ? order by labelid ";
 746         $sth = $dbh->prepare($query3);
 747         $sth->execute($batch_id);
 748
 749     }
 750     else {
 751
 752         my $query3 = "Select * from labels";
 753         $sth = $dbh->prepare($query3);
 754         $sth->execute();
 755     }
 756     my $cnt = $sth->rows;
 757     my $i1  = 1;
 758     while ( my $data = $sth->fetchrow_hashref ) {
 759
 760         # lets get some summary info from each item
 761         my $query1 = "
 762          select i.*, bi.*, b.*  from items i,biblioitems bi,biblio b
 763                 where itemnumber=? and  i.biblioitemnumber=bi.biblioitemnumber and
 764                 bi.biblionumber=b.biblionumber";
 765
 766                 my $sth1 = $dbh->prepare($query1);
 767         $sth1->execute( $data->{'itemnumber'} );
 768
 769         my $data1 = $sth1->fetchrow_hashref();
 770         $data1->{'labelno'}  = $i1;
 771         $data1->{'labelid'}  = $data->{'labelid'};
 772         $data1->{'batch_id'} = $batch_id;
 773         $data1->{'summary'} =
 774           "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
 775
 776         push( @resultsloop, $data1 );
 777         $sth1->finish;
 778
 779         $i1++;
 780     }
 781     $sth->finish;
 782     return @resultsloop;
 783
 784 }
 785
 786 sub GetItemFields {
 787     my @fields = qw (
 788       barcode title subtitle
 789       dewey isbn issn author class
 790       itemtype subclass itemcallnumber
 791
 792     );
 793     return @fields;
 794 }
 795
 796 sub deduplicate_batch {
 797         my $batch_id = shift or return undef;
 798         my $query = "
 799         SELECT DISTINCT
 800                         batch_id,itemnumber,
 801                         count(labelid) as count
 802         FROM     labels
 803         WHERE    batch_id = ?
 804         GROUP BY itemnumber,batch_id
 805         HAVING   count > 1
 806         ORDER BY batch_id,
 807                          count DESC  ";
 808         my $sth = C4::Context->dbh->prepare($query);
 809         $sth->execute($batch_id);
 810         $sth->rows or return undef;
 811
 812         my $del_query = qq(
 813         DELETE
 814         FROM     labels
 815         WHERE    batch_id = ?
 816         AND      itemnumber = ?
 817         ORDER BY timestamp ASC
 818         );
 819         my $killed = 0;
 820         while (my $data = $sth->fetchrow_hashref()) {
 821                 my $itemnumber = $data->{itemnumber} or next;
 822                 my $limit      = $data->{count} - 1  or next;
 823                 my $sth2 = C4::Context->dbh->prepare("$del_query  LIMIT $limit");
 824                 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
 825                 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
 826                 $sth2->execute($batch_id, $itemnumber) and
 827                         $killed += ($data->{count} - 1);
 828         }
 829         return $killed;
 830 }
 831
 832 sub DrawSpineText {
 833
 834     my ( $y_pos, $label_height, $fontsize, $x_pos, $left_text_margin,
 835         $text_wrap_cols, $item, $conf_data )
 836       = @_;
 837 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
 838         $$item->{'class'} = $$item->{'classification'};
 839
 840     $Text::Wrap::columns   = $text_wrap_cols;
 841     $Text::Wrap::separator = "\n";
 842
 843     my $str;
 844     ##      $item
 845
 846     my $top_text_margin = ( $fontsize + 3 );
 847     my $line_spacer = ($fontsize);    # number of pixels between text rows.
 848
 849     # add your printable fields manually in here
 850
 851 my $layout_id = $$conf_data->{'id'};
 852
 853 #    my @fields = GetItemFields();
 854
 855 my $str_fields = get_text_fields($layout_id, 'codes' );
 856 my @fields = split(/ /, $str_fields);
 857 #warn Dumper(@fields);
 858 ### @fields
 859
 860     my $vPos   = ( $y_pos + ( $label_height - $top_text_margin ) );
 861     my $hPos   = ( $x_pos + $left_text_margin );
 862
 863     # warn Dumper $conf_data;
 864     #warn Dumper $item;
 865
 866     foreach my $field (@fields) {
 867
 868         # testing hack
 869 #     $$item->{"$field"} = $field . ": " . $$item->{"$field"};
 870
 871         # if the display option for this field is selected in the DB,
 872         # and the item record has some values for this field, display it.
 873         if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
 874
 875             #            warn "CONF_TYPE = $field";
 876
 877             # get the string
 878             $str = $$item->{"$field"};
 879             # strip out naughty existing nl/cr's
 880             $str =~ s/\n//g;
 881             $str =~ s/\r//g;
 882
 883             # chop the string up into _upto_ 12 chunks
 884             # and seperate the chunks with newlines
 885
 886             $str = wrap( "", "", "$str" );
 887             $str = wrap( "", "", "$str" );
 888
 889             # split the chunks between newline's, into an array
 890             my @strings = split /\n/, $str;
 891
 892             # then loop for each string line
 893             foreach my $str (@strings) {
 894
 895                 #warn "HPOS ,  VPOS $hPos, $vPos ";
 896                 # set the font size A
 897
 898                 #   prText( $hPos, $vPos, $str );
 899                 PrintText( $hPos, $vPos, $fontsize, $str );
 900                 $vPos = $vPos - $line_spacer;
 901             }
 902         }    # if field is     }    #foreach feild
 903     }
 904 }
 905
 906 sub PrintText {
 907     my ( $hPos, $vPos, $fontsize, $text ) = @_;
 908     my $str = "BT /Ft1 $fontsize Tf $hPos $vPos Td ($text) Tj ET";
 909     prAdd($str);
 910 }
 911
 912 sub SetFontSize {
 913
 914     my ($fontsize) = @_;
 915 ### fontsize
 916     my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
 917     prAdd($str);
 918 }
 919
 920 sub DrawBarcode {
 921
 922     # x and y are from the top-left :)
 923     my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
 924     my $num_of_bars = length($barcode);
 925     my $bar_width   = $width * .8;        # %80 of length of label width
 926     my $tot_bar_length;
 927     my $bar_length;
 928     my $guard_length = 10;
 929     my $xsize_ratio;
 930
 931     if ( $barcodetype eq 'CODE39' ) {
 932         $bar_length = '17.5';
 933         $tot_bar_length =
 934           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 935         $xsize_ratio = ( $bar_width / $tot_bar_length );
 936         eval {
 937             PDF::Reuse::Barcode::Code39(
 938                 x => ( $x_pos + ( $width / 10 ) ),
 939                 y => ( $y_pos + ( $height / 10 ) ),
 940                 value         => "*$barcode*",
 941                 ySize         => ( .02 * $height ),
 942                 xSize         => $xsize_ratio,
 943                 hide_asterisk => 1,
 944             );
 945         };
 946         if ($@) {
 947             warn "$barcodetype, $barcode FAILED:$@";
 948         }
 949     }
 950
 951     elsif ( $barcodetype eq 'CODE39MOD' ) {
 952
 953         # get modulo43 checksum
 954         my $c39 = CheckDigits('code_39');
 955         $barcode = $c39->complete($barcode);
 956
 957         $bar_length = '19';
 958         $tot_bar_length =
 959           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 960         $xsize_ratio = ( $bar_width / $tot_bar_length );
 961         eval {
 962             PDF::Reuse::Barcode::Code39(
 963                 x => ( $x_pos + ( $width / 10 ) ),
 964                 y => ( $y_pos + ( $height / 10 ) ),
 965                 value         => "*$barcode*",
 966                 ySize         => ( .02 * $height ),
 967                 xSize         => $xsize_ratio,
 968                 hide_asterisk => 1,
 969             );
 970         };
 971
 972         if ($@) {
 973             warn "$barcodetype, $barcode FAILED:$@";
 974         }
 975     }
 976     elsif ( $barcodetype eq 'CODE39MOD10' ) {
 977
 978         # get modulo43 checksum
 979         my $c39_10 = CheckDigits('visa');
 980         $barcode = $c39_10->complete($barcode);
 981
 982         $bar_length = '19';
 983         $tot_bar_length =
 984           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 985         $xsize_ratio = ( $bar_width / $tot_bar_length );
 986         eval {
 987             PDF::Reuse::Barcode::Code39(
 988                 x => ( $x_pos + ( $width / 10 ) ),
 989                 y => ( $y_pos + ( $height / 10 ) ),
 990                 value         => "*$barcode*",
 991                 ySize         => ( .02 * $height ),
 992                 xSize         => $xsize_ratio,
 993                 hide_asterisk => 1,
 994                                 text         => 0,
 995             );
 996         };
 997
 998         if ($@) {
 999             warn "$barcodetype, $barcode FAILED:$@";
1000         }
1001     }
1002
1003
1004     elsif ( $barcodetype eq 'COOP2OF5' ) {
1005         $bar_length = '9.43333333333333';
1006         $tot_bar_length =
1007           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1008         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1009         eval {
1010             PDF::Reuse::Barcode::COOP2of5(
1011                 x => ( $x_pos + ( $width / 10 ) ),
1012                 y => ( $y_pos + ( $height / 10 ) ),
1013                 value => $barcode,
1014                 ySize => ( .02 * $height ),
1015                 xSize => $xsize_ratio,
1016             );
1017         };
1018         if ($@) {
1019             warn "$barcodetype, $barcode FAILED:$@";
1020         }
1021     }
1022
1023     elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1024         $bar_length = '13.1333333333333';
1025         $tot_bar_length =
1026           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1027         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1028         eval {
1029             PDF::Reuse::Barcode::Industrial2of5(
1030                 x => ( $x_pos + ( $width / 10 ) ),
1031                 y => ( $y_pos + ( $height / 10 ) ),
1032                 value => $barcode,
1033                 ySize => ( .02 * $height ),
1034                 xSize => $xsize_ratio,
1035             );
1036         };
1037         if ($@) {
1038             warn "$barcodetype, $barcode FAILED:$@";
1039         }
1040     }
1041
1042     my $moo2 = $tot_bar_length * $xsize_ratio;
1043
1044     warn "$x_pos, $y_pos, $barcode, $barcodetype" if $DEBUG;
1045     warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length  R*TOT.BAR =$moo2" if $DEBUG;
1046 }
1047
1048 =item build_circ_barcode;
1049
1050   build_circ_barcode( $x_pos, $y_pos, $barcode,
1051                 $barcodetype, \$item);
1052
1053 $item is the result of a previous call to get_label_items();
1054
1055 =cut
1056
1057 #'
1058 sub build_circ_barcode {
1059     my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1060
1061     #warn Dumper \$item;
1062
1063     #warn "value = $value\n";
1064
1065     #$DB::single = 1;
1066
1067     if ( $barcodetype eq 'EAN13' ) {
1068
1069         #testing EAN13 barcodes hack
1070         $value = $value . '000000000';
1071         $value =~ s/-//;
1072         $value = substr( $value, 0, 12 );
1073
1074         #warn $value;
1075         eval {
1076             PDF::Reuse::Barcode::EAN13(
1077                 x     => ( $x_pos_circ + 27 ),
1078                 y     => ( $y_pos + 15 ),
1079                 value => $value,
1080
1081                 #            prolong => 2.96,
1082                 #            xSize   => 1.5,
1083
1084                 # ySize   => 1.2,
1085
1086 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1087 # i think its embedding extra fonts in the pdf file.
1088 #  mode => 'graphic',
1089             );
1090         };
1091         if ($@) {
1092             $item->{'barcodeerror'} = 1;
1093
1094             #warn "EAN13BARCODE FAILED:$@";
1095         }
1096
1097         #warn $barcodetype;
1098
1099     }
1100     elsif ( $barcodetype eq 'Code39' ) {
1101
1102         eval {
1103             PDF::Reuse::Barcode::Code39(
1104                 x     => ( $x_pos_circ + 9 ),
1105                 y     => ( $y_pos + 15 ),
1106                 value => $value,
1107
1108                 #           prolong => 2.96,
1109                 xSize => .85,
1110
1111                 ySize => 1.3,
1112             );
1113         };
1114         if ($@) {
1115             $item->{'barcodeerror'} = 1;
1116
1117             #warn "CODE39BARCODE $value FAILED:$@";
1118         }
1119
1120         #warn $barcodetype;
1121
1122     }
1123
1124     elsif ( $barcodetype eq 'Matrix2of5' ) {
1125
1126         #warn "MATRIX ELSE:";
1127
1128         #testing MATRIX25  barcodes hack
1129         #    $value = $value.'000000000';
1130         $value =~ s/-//;
1131
1132         #    $value = substr( $value, 0, 12 );
1133         #warn $value;
1134
1135         eval {
1136             PDF::Reuse::Barcode::Matrix2of5(
1137                 x     => ( $x_pos_circ + 27 ),
1138                 y     => ( $y_pos + 15 ),
1139                 value => $value,
1140
1141                 #        prolong => 2.96,
1142                 #       xSize   => 1.5,
1143
1144                 # ySize   => 1.2,
1145             );
1146         };
1147         if ($@) {
1148             $item->{'barcodeerror'} = 1;
1149
1150             #warn "BARCODE FAILED:$@";
1151         }
1152
1153         #warn $barcodetype;
1154
1155     }
1156
1157     elsif ( $barcodetype eq 'EAN8' ) {
1158
1159         #testing ean8 barcodes hack
1160         $value = $value . '000000000';
1161         $value =~ s/-//;
1162         $value = substr( $value, 0, 8 );
1163
1164         #warn $value;
1165
1166         #warn "EAN8 ELSEIF";
1167         eval {
1168             PDF::Reuse::Barcode::EAN8(
1169                 x       => ( $x_pos_circ + 42 ),
1170                 y       => ( $y_pos + 15 ),
1171                 value   => $value,
1172                 prolong => 2.96,
1173                 xSize   => 1.5,
1174
1175                 # ySize   => 1.2,
1176             );
1177         };
1178
1179         if ($@) {
1180             $item->{'barcodeerror'} = 1;
1181
1182             #warn "BARCODE FAILED:$@";
1183         }
1184
1185         #warn $barcodetype;
1186
1187     }
1188
1189     elsif ( $barcodetype eq 'UPC-E' ) {
1190         eval {
1191             PDF::Reuse::Barcode::UPCE(
1192                 x       => ( $x_pos_circ + 27 ),
1193                 y       => ( $y_pos + 15 ),
1194                 value   => $value,
1195                 prolong => 2.96,
1196                 xSize   => 1.5,
1197
1198                 # ySize   => 1.2,
1199             );
1200         };
1201
1202         if ($@) {
1203             $item->{'barcodeerror'} = 1;
1204
1205             #warn "BARCODE FAILED:$@";
1206         }
1207
1208         #warn $barcodetype;
1209
1210     }
1211     elsif ( $barcodetype eq 'NW7' ) {
1212         eval {
1213             PDF::Reuse::Barcode::NW7(
1214                 x       => ( $x_pos_circ + 27 ),
1215                 y       => ( $y_pos + 15 ),
1216                 value   => $value,
1217                 prolong => 2.96,
1218                 xSize   => 1.5,
1219
1220                 # ySize   => 1.2,
1221             );
1222         };
1223
1224         if ($@) {
1225             $item->{'barcodeerror'} = 1;
1226
1227             #warn "BARCODE FAILED:$@";
1228         }
1229
1230         #warn $barcodetype;
1231
1232     }
1233     elsif ( $barcodetype eq 'ITF' ) {
1234         eval {
1235             PDF::Reuse::Barcode::ITF(
1236                 x       => ( $x_pos_circ + 27 ),
1237                 y       => ( $y_pos + 15 ),
1238                 value   => $value,
1239                 prolong => 2.96,
1240                 xSize   => 1.5,
1241
1242                 # ySize   => 1.2,
1243             );
1244         };
1245
1246         if ($@) {
1247             $item->{'barcodeerror'} = 1;
1248
1249             #warn "BARCODE FAILED:$@";
1250         }
1251
1252         #warn $barcodetype;
1253
1254     }
1255     elsif ( $barcodetype eq 'Industrial2of5' ) {
1256         eval {
1257             PDF::Reuse::Barcode::Industrial2of5(
1258                 x       => ( $x_pos_circ + 27 ),
1259                 y       => ( $y_pos + 15 ),
1260                 value   => $value,
1261                 prolong => 2.96,
1262                 xSize   => 1.5,
1263
1264                 # ySize   => 1.2,
1265             );
1266         };
1267         if ($@) {
1268             $item->{'barcodeerror'} = 1;
1269
1270             #warn "BARCODE FAILED:$@";
1271         }
1272
1273         #warn $barcodetype;
1274
1275     }
1276     elsif ( $barcodetype eq 'IATA2of5' ) {
1277         eval {
1278             PDF::Reuse::Barcode::IATA2of5(
1279                 x       => ( $x_pos_circ + 27 ),
1280                 y       => ( $y_pos + 15 ),
1281                 value   => $value,
1282                 prolong => 2.96,
1283                 xSize   => 1.5,
1284
1285                 # ySize   => 1.2,
1286             );
1287         };
1288         if ($@) {
1289             $item->{'barcodeerror'} = 1;
1290
1291             #warn "BARCODE FAILED:$@";
1292         }
1293
1294         #warn $barcodetype;
1295
1296     }
1297
1298     elsif ( $barcodetype eq 'COOP2of5' ) {
1299         eval {
1300             PDF::Reuse::Barcode::COOP2of5(
1301                 x       => ( $x_pos_circ + 27 ),
1302                 y       => ( $y_pos + 15 ),
1303                 value   => $value,
1304                 prolong => 2.96,
1305                 xSize   => 1.5,
1306
1307                 # ySize   => 1.2,
1308             );
1309         };
1310         if ($@) {
1311             $item->{'barcodeerror'} = 1;
1312
1313             #warn "BARCODE FAILED:$@";
1314         }
1315
1316         #warn $barcodetype;
1317
1318     }
1319     elsif ( $barcodetype eq 'UPC-A' ) {
1320
1321         eval {
1322             PDF::Reuse::Barcode::UPCA(
1323                 x       => ( $x_pos_circ + 27 ),
1324                 y       => ( $y_pos + 15 ),
1325                 value   => $value,
1326                 prolong => 2.96,
1327                 xSize   => 1.5,
1328
1329                 # ySize   => 1.2,
1330             );
1331         };
1332         if ($@) {
1333             $item->{'barcodeerror'} = 1;
1334
1335             #warn "BARCODE FAILED:$@";
1336         }
1337
1338         #warn $barcodetype;
1339
1340     }
1341
1342 }
1343
1344 =item draw_boundaries
1345
1346  sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1347                 $y_pos, $spine_width, $label_height, $circ_width)
1348
1349 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1350
1351 =cut
1352
1353 #'
1354 sub draw_boundaries {
1355
1356     my (
1357         $x_pos_spine, $x_pos_circ1,  $x_pos_circ2, $y_pos,
1358         $spine_width, $label_height, $circ_width
1359     ) = @_;
1360
1361     my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1362     $y_pos            = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1363     my $i             = 1;
1364
1365     for ( $i = 1 ; $i <= 8 ; $i++ ) {
1366
1367         &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1368
1369    #warn "OLD BOXES  x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1370         &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1371         &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1372
1373         $y_pos = ( $y_pos - $label_height );
1374
1375     }
1376 }
1377
1378 =item drawbox
1379
1380         sub drawbox {   $lower_left_x, $lower_left_y,
1381                         $upper_right_x, $upper_right_y )
1382
1383 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1384
1385 FYI: the  $upper_right_x and $upper_right_y values are RELATIVE to  $lower_left_x and $lower_left_y
1386
1387 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1388
1389 =cut
1390
1391 #'
1392 sub drawbox {
1393     my ( $llx, $lly, $urx, $ury ) = @_;
1394
1395     #    warn "llx,y= $llx,$lly  ,   urx,y=$urx,$ury \n";
1396
1397     my $str = "q\n";    # save the graphic state
1398     $str .= "0.5 w\n";              # border color red
1399     $str .= "1.0 0.0 0.0  RG\n";    # border color red
1400          #   $str .= "0.5 0.75 1.0 rg\n";           # fill color blue
1401     $str .= "1.0 1.0 1.0  rg\n";    # fill color white
1402
1403     $str .= "$llx $lly $urx $ury re\n";    # a rectangle
1404     $str .= "B\n";                         # fill (and a little more)
1405     $str .= "Q\n";                         # save the graphic state
1406
1407     prAdd($str);
1408
1409 }
1410
1411 END { }    # module clean-up code here (global destructor)
1412
1413 1;
1414 __END__
1415
1416 =back
1417
1418 =head1 AUTHOR
1419
1420 Mason James <mason@katipo.co.nz>
1421
1422 =cut
1423