Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

comment on
( [id://3333]=superdoc: print w/replies, xml ) Need Help?? 
#!/usr/bin/perl
use Text::Autoformat;
use Text::ParseWords;
use PDF::Create;
use strict;

my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(t
+ime);
my $pdf = new PDF::Create('filename' => "mypdf.pdf",
              'PageMode' => 'UseOutlines',
              'Author'   => 'My Author',
              'Title'    => 'My Title',
              'CreationDate' => [ localtime ],
             );
my $root = $pdf->new_page('MediaBox' => [ 0, 0, 612, 792 ]);

# Add a page which inherits its attributes from $root
my $mpage = $root->new_page;

# Prepare 2 fonts
my $f1 = $pdf->font('Subtype'  => 'Type1',
                    'Encoding' => 'WinAnsiEncoding',
                    'BaseFont' => 'Helvetica'
                   );
my $f2 = $pdf->font('Subtype'  => 'Type1',
                    'Encoding' => 'WinAnsiEncoding',
                    'BaseFont' => 'Helvetica-Bold'
                   );

# Prepare a Table of Content
my $toc = $pdf->new_outline('Title' => 'Retention Reports',
                            'Destination' => $mpage
                           );

my $gif = $pdf->image("mypicture.jpg");
$mpage->image('image' => $gif,
              'xpos' => 100,
              'ypos' => 426,
             );

$mpage->stringc($f2, 40, 306, 426, "My Data For PDF");
$year = 1900 + $year;
$mpage->stringc($f1, 20, 306, 396, "Final Draft $mon-$mday-$year");

# starting location
my $loc = 680;
my $firstpage = 0;
my $partc = 0;
my $recc = 0;
my $retc = 0;
my $citrc = 0;

## The Part below is/was for me opening a data file and dumpign the da
+ta into an array. Then I took the array and parsed the data out to pr
+int it.
## To do a new line all I had to do was subtract 14 from each $loc and
+ then if $loc ever goes below 60.. begin a new page.
## I know most of this is kind of ugly... but hey it may help those wh
+o have the task of making a PDF on the fly.
## Sorry for the lack of comments in the code... That is one of my dow
+n falls...

foreach my $cat (@catagories) {
    chomp $cat;
    $cat =~ s/&amp\;/&/g;
    ($catid, $catname) = split(/#!#/,$cat);
    $catid = uc$catid;
    $page{"$catid"} = $root->new_page;
    $s{"$catid"} = $toc->new_outline('Title' => "$catname");
    foreach $entry (@series) {
        chomp $entry;
        $entry =~ s/&amp\;/&/g;
        my ($id, $title, $retent, $smdesc, $lngdesc, $recordcopy, $ret
+ention, $citref) = split(/\t/,$entry);
        my ($letter,$number) = $id =~ /(\w+?)(\d+)/;
        $letter = uc$letter;
        if ($letter eq $catid) {
            if ($firstpage != 1) {
                $page{"$catid"}->stringl($f2, 15, 36, 710, "$catname /
+ Category $catid");
                $firstpage = 1;
            }
            $page{"$catid"}->stringl($f2, 12, 36, $loc, "($number) $ti
+tle");
            $loc -= 14;
            if ($lngdesc) {
                $formatted = autoformat $lngdesc, { left=>0, right=>80
+ };
            } else {
                $formatted = " ";
            }
            my @lng = split(/\n/,$formatted);
            foreach my $part (@lng) {
                if ($loc < 60) {
                    $page{"$catid"} = $root->new_page;
                    $loc = 700;
                }
                if ($partc != 1) {
                    $page{"$catid"}->stringl($f2, 12, 36, $loc, "Expla
+nation: ");
                    $page{"$catid"}->stringl($f1, 12, 110, $loc, $part
+);
                    $loc -= 14;
                    $partc = 1;
                } else {
                    if ($part) {
                        $page{"$catid"}->stringl($f1, 12, 113, $loc, $
+part);
                        $loc -= 14;
                    }
                }
            }
            if ($recordcopy) {
                $formatted = autoformat $recordcopy, { left=>0, right=
+>80 };
            } else {
                $formatted = " ";
            }
            my @recordcopy = split(/\n/,$formatted);
            foreach my $rec (@recordcopy) {
                chomp $rec;
                $rec =~ s/^\s+//g;
                $rec =~ s/\s+$//g;
                if ($loc < 60) {
                    $page{"$catid"} = $root->new_page;
                    $loc = 700;
                }
                if ($recc != 1) {
                    $page{"$catid"}->stringl($f2, 12, 36, $loc, "Recor
+d Copy: ");
                    $page{"$catid"}->stringl($f1, 12, 120, $loc, $rec)
+;
                    $loc -= 14;
                    $recc = 1;
                } else {
                    if ($rec) {
                        $page{"$catid"}->stringl($f1, 12, 125, $loc, $
+rec);
                        $loc -= 14;
                    }
                }
            }
            if ($retention) {
                $formatted = autoformat $retention, { left=>0, right=>
+80 };
            } else {
                $formatted = " ";
            }
            my @retention = split(/\n/,$formatted);
            foreach my $ret (@retention) {
                chomp $ret;
                $ret =~ s/^\s+//g;
                $ret =~ s/\s+$//g;
                if ($loc < 60) {
                    $page{"$catid"} = $root->new_page;
                    $loc = 700;
                }
                if ($retc != 1) {
                    $page{"$catid"}->stringl($f2, 12, 36, $loc, "Reten
+tion: ");
                    $page{"$catid"}->stringl($f1, 12, 100, $loc, $ret)
+;
                    $loc -= 14;
                    $retc = 1;
                } else {
                    if ($ret) {
                        $page{"$catid"}->stringl($f1, 12, 105, $loc, $
+ret);
                        $loc -= 14;
                    }
                }
            }
            if ($citref) {
                $formatted = autoformat $citref, { left=>0, right=>80 
+};
            } else {
                $formatted = " ";
            }
            my @citref = split(/\n/,$formatted);
            foreach my $citr (@citref) {
                chomp $citr;
                $citr =~ s/^\s+//g;
                $citr =~ s/\s+$//g;
                if ($loc < 60) {
                    $page{"$catid"} = $root->new_page;
                    $loc = 700;
                }
                if ($citrc != 1) {
                    $page{"$catid"}->stringl($f2, 12, 36, $loc, "Citat
+ion or Reference: ");
                    $page{"$catid"}->stringl($f1, 12, 165, $loc, $citr
+);
                    $loc -= 14;
                    $citrc = 1;
                } else {
                    if ($citr) {
                        $page{"$catid"}->stringl($f1, 12, 170, $loc, $
+citr);
                        $loc -= 14;
                    }
                }
            }
            $loc -= 14;
            if ($loc < 60) {
                $page{"$catid"} = $root->new_page;
                $loc = 700;
            }
        }
        $partc = 0;
        $recc = 0;
        $retc = 0;
        $citrc = 0;
    }
    $loc = 680;
    $firstpage = 0;
}

$pdf->close;

sub parse2array {
    return quotewords($_[1],0,$_[0]);
}

[download]
Updated GIFImage.pm in the PDF::Image part... Fixed by the creator himself :) NOTE: This is an update for Perl 5.6.1 ... I cant seem to get the GIF part working on 5.005_3 :( 
# -*- mode: Perl -*-

# PDF::Image::GIFImage - GIF image support
# Author: Michael Gross <mdgrosse@sbox.tugraz.at>
# Version: 0.06
# Copyright 2001 Michael Gross <mdgrosse@sbox.tugraz.at>

package GIFImage;
use strict;
use vars qw(@ISA @EXPORT $VERSION $DEBUG);
use Exporter;
use FileHandle;

@ISA     = qw(Exporter);
@EXPORT  = qw();
$VERSION = 0.06;
$DEBUG   = 0;

sub new {
    my $self  = {};
    
    $self->{private} = {};
    $self->{colorspace} = 0;
    $self->{width} = 0;
    $self->{height} = 0;    
    $self->{colorspace} = "DeviceRGB";
    $self->{colorspacedata} = "";
    $self->{colorspacesize} = 0;
    $self->{filename} = "";
    $self->{error} = "";
    $self->{imagesize} = 0;
    $self->{transparent} = 0;
    $self->{filter} = ["LZWDecode"];
    $self->{decodeparms} = {'EarlyChange' => 0};
    $self->{private}->{interlaced} = 0;
    
    bless($self);
    return $self;
}

sub LZW {
    my $self = shift;
    my $data = shift;
    my $result = "";
    my $prefix = "";
    my $c;
    my %hash;
    my $num;
    my $codesize = 9;

    #init hash-table
    for ($num=0; $num<256; $num++) {
        $hash{chr($num)} = $num;
    }
 
    #start with a clear
    $num = 258;
    my $currentvalue = 256;
    my $bits = 9;

    my $pos = 0;
    while ($pos < length($data)) {
        $c = substr($data, $pos, 1);
    
        if (exists($hash{$prefix . $c})) {
            $prefix.=$c;
        } else {
            #save $hash{$prefix}
            $currentvalue<<=$codesize;
            $currentvalue|=$hash{$prefix};
            $bits+=$codesize;    
            while ($bits >= 8) {
                $result.=chr(($currentvalue >> ($bits-8)) & 255);
                $bits-=8;
                $currentvalue&=(1 << $bits) - 1;
            }

            $hash{$prefix . $c} = $num;
            $prefix = $c;
            $num++;
            
            #increase code size?
            if ($num==513 || $num==1025 || $num==2049) {
                $codesize++;
            } 
        
            #hash table overflow?
            if ($num==4097) {
                #save clear
                $currentvalue<<=$codesize;
                $currentvalue|=256;
                $bits+=$codesize;    
                while ($bits >= 8) {
                    $result.=chr(($currentvalue >> ($bits-8)) & 255);
                    $bits-=8;
                    $currentvalue&=(1 << $bits) - 1;
                }

                #reset hash table
                $codesize = 9;
                %hash = ();
                for ($num=0; $num<256; $num++) {
                    $hash{chr($num)} = $num;
                }
                $num=258;
            } 
        }    
        $pos++;
    }    

    #save value for prefix
    $currentvalue<<=$codesize;
    $currentvalue|=$hash{$prefix};
    $bits+=$codesize;    
    while ($bits >= 8) {
        $result.=chr(($currentvalue >> ($bits-8)) & 255);
        $bits-=8;
        $currentvalue&=(1 << $bits) - 1;
    }

    #save eoi
    $currentvalue<<=$codesize;
    $currentvalue|=257;
    $bits+=$codesize;    
    while ($bits >= 8) {
        $result.=chr(($currentvalue >> ($bits-8)) & 255);
        $bits-=8;
        $currentvalue&=(1 << $bits) - 1;
    }

    #save remainder in $currentvalue
    if ($bits > 0) {
        $currentvalue = $currentvalue << (8-$bits);
        $result.=chr($currentvalue & 255);
    }
    
    $result;
}


sub UnLZW {
    my $self = shift;
    my $data = shift;
    my $result = "";

    my $bits = 0;
    my $currentvalue = 0;
    my $codesize = 9;
    my $pos = 0;
    
    my $prefix = "";
    my $suffix;
    my @table;

    #initialize lookup-table
    my $num;
    for ($num=0; $num<256; $num++) {
        $table[$num] = chr($num);
    }
    $table[256] = "";
    
    $num = 257;

    my $c1;
    #get first word
    while ($bits < $codesize) {
        my $d = ord(substr($data, $pos, 1));
        $currentvalue = ($currentvalue<<8) + $d;
        $bits+=8;
        $pos++;
    }    
    my $c2 = $currentvalue >> ($bits - $codesize);
    $bits-=$codesize;
    my $mask = (1 << $bits) - 1;
    $currentvalue = $currentvalue & $mask;    
    
    
    DECOMPRESS: while ($pos < length($data)) {
        $c1 = $c2;    

        #get next word
        while ($bits < $codesize) {
            my $d = ord(substr($data, $pos, 1));
            $currentvalue = ($currentvalue<<8) + $d;
            $bits+=8;
            $pos++;
        }    
        $c2 = $currentvalue >> ($bits - $codesize);
        $bits-=$codesize;
        $mask = (1 << $bits) - 1;
        $currentvalue = $currentvalue & $mask;    
    
        #clear code?
        if ($c2 == 256) {
            $result.=$table[$c1];
            $#table = 256;
            $codesize = 9;
            $num = 257;
            next DECOMPRESS;
        }
    
        #End Of Image?
        if ($c2 == 257) {
            last DECOMPRESS;
        }    

        #get prefix
        if ($c1 < $num) {
            $prefix = $table[$c1];
        } else {
            print "Compression Error ($c1>=$num)\n";
        }    
    
        #write prefix
        $result.=$prefix;
    
        #get suffix
        if ($c2 < $num) {
            $suffix = substr($table[$c2], 0, 1);
        } elsif ($c2 == $num) {
            $suffix = substr($prefix, 0, 1);
        } else {
            print "Compression Error ($c2>$num)\n";
        }
        
        #new table entry is prefix.suffix
        $table[$num] = $prefix . $suffix;
        
        #next table entry
        $num++;

        #increase code size?
        if ($num==512 || $num==1024 || $num==2048) {
            $codesize++;
        } 
    }
    $result.=$table[$c1];
    
    $result;
}

sub UnInterlace {
    my $self = shift;
    my $data = shift;
    my $row;
    my @result;
    my $width = $self->{width};
    my $height = $self->{height};
    my $idx = 0;
    
    #Pass 1 - every 8th row, starting with row 0
    $row = 0;
    while ($row < $height) {
        $result[$row] = substr($data, $idx*$width, $width);
        $row+=8;
        $idx++;
    }
    
    #Pass 2 - every 8th row, starting with row 4
    $row = 4;
    while ($row < $height) {
        $result[$row] = substr($data, $idx*$width, $width);
        $row+=8;
        $idx++;
    }
    
    #Pass 3 - every 4th row, starting with row 2
    $row = 2;
    while ($row < $height) {
        $result[$row] = substr($data, $idx*$width, $width);
        $row+=4;
        $idx++;
    }
    
    #Pass 4 - every 2th row, starting with row 1
    $row = 1;
    while ($row < $height) {
        $result[$row] = substr($data, $idx*$width, $width);
        $row+=2;
        $idx++;
    }
    
    join('', @result);
}

sub GetDataBlock { 
    my $self = shift;    
    my $fh = shift;
    my $s;
    my $count; 
    my $buf;
    read $fh, $s, 1;
    $count = unpack("C", $s);
    
    if ($count) {
        read $fh, $buf, $count;
    }
    
    ($count, $buf);    
}

sub ReadColorMap {
    my $self = shift;
    my $fh = shift;
    read $fh, $self->{'colorspacedata'}, 3 * $self->{'colormapsize'};
    1;
} 

sub DoExtension { 
    my $self = shift;
    my $label = shift;
    my $fh = shift;
    my $res;
    my $buf;
    my $c;
    my $c2;
    my $c3;
    
    if ($label eq "\001") {         #Plain Text Extension
    } elsif (ord($label)==0xFF) {    #Application Extension
    } elsif (ord($label)==0xFE) {    #Comment Extension
    } elsif (ord($label)==0xF9) {    #Grapgic Control Extension
        ($res, $buf) = $self->GetDataBlock($fh); #(p, image, (unsigned
+ char*) buf);
        ($c, $c2, $c2, $c3) = unpack("CCCC", $buf);
        if ($c && 0x1 != 0) {
            $self->{transparent}=1;
            $self->{mask}=$c3;
        }    
    }
    
    BLOCK: while (1) {
        ($res, $buf) = $self->GetDataBlock($fh);
        if ($res == 0) {
            last BLOCK;
        }
    }        

    1;
} 




sub Open {
    my $self = shift;
    my $filename = shift;

    my $PDF_STRING_GIF = "\107\111\106";
    my $PDF_STRING_87a = "\070\067\141";
    my $PDF_STRING_89a = "\070\071\141";
    my $LOCALCOLORMAP  = 0x80;
    my $INTERLACE      = 0x40;
    
    my $s;
    my $c;
    my $ar;
    my $flags;
    
    $self->{filename} = $filename;
    my $fh = new FileHandle "$filename";
    read $fh, $s, 3;
    if ($s ne $PDF_STRING_GIF) {
        close $fh;
        $self->{error} = "Not a gif file.";
        return 0;
    }
    
    read $fh, $s, 3;
    if ($s ne $PDF_STRING_87a && $s ne $PDF_STRING_89a) {
        close $fh;
        $self->{error} = "GIF version $s not supported.";
        return 0;
    }
        
    read $fh, $s, 7;
    ($self->{width}, $self->{height}, $flags, $self->{private}->{backg
+round}, $ar) = unpack("SSCCC", $s);
    
    $self->{colormapsize} = 2 << ($flags & 0x07);
    $self->{colorspacesize} = 3 * $self->{colormapsize};
    if ($flags & $LOCALCOLORMAP) {
        if (!$self->ReadColorMap($fh)) {
            close $fh;
            $self->{error} = "Cant read color map.";
            return 0;
        }
    }
    

    if ($ar != 0) {
        $self->{private}->{dpi_x} = -($ar + 15.0) / 64.0;
        $self->{private}->{dpi_y} = -1.0;
    }
    

    my $imageCount = 0;
    IMAGES: while (1) {
        read $fh, $c, 1;
        if ($c eq ";") {  #GIF file terminator
            close $fh;
            $self->{error} = "Cant find image in gif file.";
            return 0;
        }   
        
        if ($c eq "!") {  #Extension
            read $fh, $c, 1;
            $self->DoExtension($c, $fh);
            next;
        }    

        if ($c ne ",") {  #must be comma
            next;  #ignore
        }    

        $imageCount++;

        read $fh, $s, 9;
        my $x;
        ($x, $c, $self->{width}, $self->{height}, $flags) = unpack("SS
+SSC", $s);
        
        if ($flags && $INTERLACE) {
            $self->{private}->{interlaced} = 1;
        }

        if ($flags & $LOCALCOLORMAP) {            
            if (!$self->ReadColorMap($fh)) {
                close $fh;
                $self->{error} = "Cant read color map.";
                return 0;
            }
        }

        read $fh, $s, 1; #read "LZW initial code size"
        $self->{bpc} = unpack("C", $s);
        if ($self->{bpc} != 8) {
            close $fh;
            $self->{error} = "LZW minimum code size other than 8 not s
+upported.";
            return 0;
        }
            

        if ($imageCount == 1) {
            last IMAGES;
        }
                
    }
    
    $self->{private}->{datapos} = tell($fh);
    close $fh;
    
    1;
}

sub ReadData {
    my $self = shift;


    # init the LZW transformation vars 
    my $c_size = 9;    # initial code size
    my $t_size = 257;  # initial "table" size
    my $i_buff = 0;       # input buffer
    my $i_bits = 0;       # input buffer empty
    my $o_bits = 0;       # output buffer empty       
    my $o_buff = 0;
    my $c_mask;
    my $bytes_available = 0;
    my $n_bytes;
    my $s;
    my $c;
    my $flag13;
    my $code;
    my $w_bits;
    
    my $result = "";
        
    my $fh = new FileHandle $self->{filename};
    seek($fh, $self->{private}->{datapos}, 0);
    my $pos = 0;
    my $data;
    read $fh, $data, (-s $self->{filename});

    use integer;
   
    $self->{imagesize} = 0;
    BLOCKS: while (1) {        
        $s = substr($data, $pos, 1); $pos++;
        $n_bytes = unpack("C", $s);
        if (!$n_bytes) {
            last BLOCKS;
        }

        $c_mask = (1 << $c_size) - 1;
        $flag13 = 0;

        BLOCK: while (1) {
            $w_bits = $c_size; # number of bits to write
            $code = 0;

            #get at least c_size bits into i_buff
            while ($i_bits < $c_size) {
                if ($n_bytes == 0) {
                    last BLOCK;
                }
                $n_bytes--;
                $s = substr($data, $pos, 1); $pos++;
                $c = unpack("C", $s);
                $i_buff |= $c << $i_bits; #EOF will be caught later
                $i_bits += 8;
            }

            $code = $i_buff & $c_mask;
            
            $i_bits -= $c_size;
            $i_buff >>= $c_size;

            if ($flag13 && $code!=256 && $code!=257) {
                $self->{error} = "LZW code size overflow.";
                return 0;
            }

            if ($o_bits > 0) {
                $o_buff |= $code >> ($c_size - 8 + $o_bits);
                $w_bits -= 8 - $o_bits;
                $result.=chr($o_buff & 255);
            }
        
            if ($w_bits >= 8) {
                $w_bits -= 8;
                $result.=chr(($code >> $w_bits) & 255);
            }
            $o_bits = $w_bits;
            if ($o_bits > 0) {
                $o_buff = $code << (8 - $o_bits);
            }    

            $t_size++;
            if ($code == 256) { #clear code 
                $c_size = 9;
                $c_mask = (1 << $c_size) - 1;
                $t_size = 257;
                $flag13 = 0;
            }

            if ($code == 257) { #end code
                last BLOCK;
            }

            if ($t_size == (1 << $c_size)) {
                if (++$c_size > 12) {
                    $c_size--;
                    $flag13 = 1;
                } else {
                    $c_mask = (1 << $c_size) - 1;
                }    
            }
        } # while () for block
    } # while () for all blocks
    
    #interlaced?
    if ($self->{private}->{interlaced}) {
        #when interlaced first uncompress image
        $result = $self->UnLZW($result);
        #remove interlacing
        $result = $self->UnInterlace($result);
        #compress image again
        $result = $self->LZW($result);
    }    
    
    $self->{imagesize} = length($result);
    $result;
} 


1;

[download]
Thank you all for those who have helped me get this sytem up and working... :)

In reply to Dynamically Generate PDF's On The Fly by LostS

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others cooling their heels in the Monastery: (7)
As of 2024-04-23 14:37 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found