#!/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/&\;/&/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/&\;/&/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]);
}
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;
Thank you all for those who have helped me get this sytem up and working... :) |