File Coverage

blib/lib/Palm/PalmDoc.pm

Criterion	Covered	Total	%
statement	6	272	2.2
branch	0	100	0.0
condition	0	56	0.0
subroutine	2	17	11.7
pod	12	15	80.0
total	20	460	4.3

package Palm::PalmDoc;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw();
$VERSION = '0.13';

# Palm::PalmDoc Constructor

sub new {
 my $proto = shift;
 my $class = ref($proto) || $proto;
 my $self = {};
 $self->{TITLE} = "PalmDoc Document";
 $self->{INFILE} = undef;
 $self->{OUTFILE} = undef;
 $self->{INFILEH} = undef;
 $self->{OUTFILEH} = undef;
 $self->{BODY} = undef;
 $self->{COMPRESS} = 0;
 $self->{BLOCK_SIZE} = [];
 $self->{IGNORENL} = 0;
 bless($self,$class);
 if (@_)
 { my $ref = shift;
   my %params = ();
   if (ref $ref eq 'ARRAY')
   { %params = @{$ref}; }
   if (ref $ref eq 'HASH')
   { %params = %{$ref}; }
   if (ref $ref eq '')
   { unshift @_,$ref;
     if (!(@_ % 2))
     { %params = @_; }
   }
   foreach (keys %params) { my $tkey = uc $_; my $tvalue = $params{$_}; delete $params{$_}; $params{$tkey} = $tvalue; }
   $self->infile($params{INFILE}) if exists $params{INFILE};
   $self->outfile($params{OUTFILE}) if exists $params{OUTFILE};
   $self->title($params{TITLE}) if exists $params{TITLE};
   $self->compression($params{COMPRESS}) if exists $params{COMPRESS};
   $self->ignorenl($params{IGNORENL}) if exists $params{IGNORENL};
   $self->body($params{BODY}) if exists $params{BODY};
   $self->compressed(0);
 }
 return $self;
}

sub body {
 my $self = shift;
 if (@_) {
 $self->{BODY} = shift;
 if ($self->ignorenl)
    { my @body = split(/\n/, $self->{BODY});
      my $sep = "";
      $self->{BODY} = "";
      foreach (@body)
      { if (/^\s*$/)
        { $self->{BODY} .= "\n";
          $sep = "";
        } else
        { $self->{BODY} .= "$sep$_";
          $sep = " ";
        }
      }
     if ($sep eq " ")
     { $self->{BODY} .= "\n"; }
   }
 $self->length(CORE::length $self->{BODY});
 if ($self->compression && !$self->compressed) { $self->compressed(1); $self->{BODY} = $self->compr_text($self->{BODY}); }
 }
 return($self->{BODY});
}

sub length {
 my $self = shift;
 if (@_) { $self->{LENGTH} = shift; }
 return($self->{LENGTH});
}

sub title {
 my $self = shift;
 if (@_) { $self->{TITLE} = shift; }
 return($self->{TITLE});
}

sub compression {
 my $self = shift;
 if (@_) { $self->{COMPRESS} = shift @_ ? 1 : 0; }
 return($self->{COMPRESS});
}

sub compressed {
 my $self = shift;
 if (@_) { $self->{COMPRESSED} = shift @_ ? 1 : 0; }
 return($self->{COMPRESSED});
}

sub ignorenl {
 my $self = shift;
 if (@_) { $self->{IGNORENL} = shift @_ ? 1 : 0; }
 return($self->{IGNORENL});
}


sub infile {
 my $self = shift;
 if (@_)
 { $self->{INFILE} = shift;
   $self->{INFILE} =~ s/([;\`'\\\|"*~<>^\(\)\[\]\{\}\$\n\r\0\t\s])//g;
 }
 return($self->{INFILE});
}

sub outfile {
 my $self = shift;
 if (@_) {
 $self->{OUTFILE} = shift;
 $self->{OUTFILE} =~ s/([;\`'\\\|"*~<>^\(\)\[\]\{\}\$\n\r\0\t\s])//g;
 }
 return($self->{OUTFILE});
}

sub parse_from_file {
 my $self = shift;
 $self->infile(shift) if @_;
 $self->outfile(shift) if @_;
}

sub parse_from_filehandle {
 my $self = shift;
 ($self->{INFILEH},$self->{OUTFILEH}) = @_;
 $self->{INFILEH} ||= \*STDIN;
 $self->{OUTFILEH} ||= \*STDOUT;
}

sub read_text {
 my $self = shift;
 if ($self->infile)
 { open (IN, "<".$self->infile) || die "Can't open ".$self->infile.": $!\n";
   { local $/ = undef;
     $self->body();
   }
   close (IN);
   if ($self->{INFILEH} && !$self->infile)
   { local $/ = undef;
     $self->body();
   }
   $self->{INFILEH} and close($self->{INFILEH}) || die "Can't close input filehandle after reading: $!";
   if ($self->compression && !$self->compressed) { $self->compressed(1); $self->body($self->compr_text($self->body)); }
   return ($self->body);
 } else { return(0); }
}

sub write_text {
 my $self = shift;
 if ($self->body)
 { if ($self->outfile)
   { open (OUT,">".$self->outfile) || die "Can't open ".$self->outfile.": $!\n";
     binmode(OUT);
     print OUT $self->pdb_header(),$self->body;
     close (OUT);
   }
   if ($self->{OUTFILEH} && !$self->outfile)
   { binmode($self->{OUTFILEH});
     my $foo = $self->{OUTFILEH};
     print $foo $self->pdb_header,$self->body;
     $self->{OUTFILEH} and close($self->{OUTFILEH}) || die "Can't close output filehandle after reading: $!";
   }
   return (1);
  } else { return(0); }
}

sub pdb_header {
my $self = shift;
my $COUNT_BITS = 3;
my $DISP_BITS = 11;
my $DOC_CREATOR = "REAd";
my $DOC_TYPE = "TEXt";
my $RECORD_SIZE_MAX = 4096;	# 4k record size
my $dmDBNameLength = 32;	# 31 chars + 1 null

my $pdb_rec_offset;		# PDB record offset
my $header_buff = "";		# Temporary buffer to build the headers in.
my $x;
my $y;
my $pdb_header_size = 78;
my $pdb_attributes = 0;
my $pdb_version = 0;
my $pdb_create_time = 0x11111111;			# Palm Desktop demands
my $pdb_modify_time = 0x11111111;			# a timestamp.
my $pdb_backup_time = 0;
my $pdb_modificationNumber = 0;
my $pdb_appInfoID = 0;
my $pdb_sortInfoID = 0;
my $pdb_type = $DOC_TYPE;
my $pdb_creator = $DOC_CREATOR;
my $pdb_id_seed = 0;
my $pdb_id_nextRecordList = 0;
my $pdb_numRecords = (int ($self->length / 4096)) + 2;	# +1 for record 0
							# +1 for fractional part

my $pdb_header = pack("a32nnNNNNNNa4a4NNn",substr($self->title,0,31)."\0",$pdb_attributes,
					 $pdb_version,$pdb_create_time,
					 $pdb_modify_time,$pdb_backup_time,
					 $pdb_modificationNumber,$pdb_appInfoID,
					 $pdb_sortInfoID,$pdb_type,$pdb_creator,
					 $pdb_id_seed,$pdb_id_nextRecordList,
					 $pdb_numRecords);

if ( (CORE::length $pdb_header) != 78) { die "pdb_header malformed\n"; }

my $doc_header_size = 16;
my $doc_version = 1 + $self->compression;
my $reserved1 = 0;
my $doc_doc_size = $self->length;
my $doc_rec_size = 4096;
my $doc_num_recs = (int ($self->length / 4096)) + 1;
my $doc_reserved2 = 0;

my $doc_header = pack("nnNnnN",$doc_version,$reserved1,$doc_doc_size,
			     $doc_num_recs,$doc_rec_size,$doc_reserved2);

if ( (CORE::length $doc_header) != 16) { die "doc_header malformed\n"; }

my $pdb_rec_header_size = 8;
my $pdb_rec_attributes = 0x40;		# We'll fake this, 0x40 = 'dirty'
my $pdb_rec_uniqueID = 0x3D0;		# Simple increment

my $pdb_rec_header_template = "Nccn";

	$pdb_rec_offset = $pdb_header_size +
			  (($pdb_numRecords)* $pdb_rec_header_size) + 2;

	$header_buff = $pdb_header . pack($pdb_rec_header_template,
					  $pdb_rec_offset, $pdb_rec_attributes,
					  ord('a'),$pdb_rec_uniqueID );
	$pdb_rec_offset += $doc_header_size;	# Add offset for doc_header

	for ($x = 0; $x < $pdb_numRecords - 1; $x++) {

#		if ($x > 0 )
#			{ $self->{BLOCK_SIZE}[$x] = $RECORD_SIZE_MAX; }

		$pdb_rec_offset += $self->{BLOCK_SIZE}[$x];
		++$pdb_rec_uniqueID;
		$header_buff .=	pack($pdb_rec_header_template,$pdb_rec_offset,
				     $pdb_rec_attributes,ord('a'),$pdb_rec_uniqueID);
	}

	$header_buff .= 0x00 . 0x00;

	$header_buff .= $doc_header;

return ($header_buff);
}

sub compr_text {
my $self = shift;
my $total_compr_size = 0;		# Final compressed text size
my $compr_buff = "";			# Temporary output buffer
my $numrecords = (int($self->{LENGTH} / 4096) +1);	# Number of blocks to compress.
my $x;
my $y;
my $block_offset;
my $block;			# Contains the current 4096 byte block of text
my $block_len;			# Length of current block
my $index;			# Current scan position in block
my $byte;			# Char at index (for space + char compression)
my $byte2;			# Char at index+1
my $test;			# Potentially compressible text for
				# LZ77 compression.

my $frag_size;			# Current size of above
my $frag_size2;			# Spare for lazy byte compression
my $test2;			# spare for above
my $test3; 			# second spare
my $pos;			# Position (in $block) of reference text
				# for $test
				# to compress against.

my $pos2;			# spare for above
my $pos3;			# second spare
my $back;			# $index - pos
my $mask;			# Bitwise mask to do LZ77 'magic'
my $compr_ratio;		# Compression ratio
my $done;
my $comp_block_offset = 0;	# The $compr_buff index
				# block begins.
my $FRAG_MAX = 10;		# Max LZ77 fragment size
my $FRAG_MIN = 3;		# Min LZ77 fragment size
my $LAZY_BYTE_FRAG = $FRAG_MAX + $FRAG_MIN - 1;


$self->{BLOCK_SIZE}[0] = 0;	# Record 0 is already written and
				# is not compressed.
for ($x = 1; $x <= $numrecords; $x++) {

	$block_offset = ($x - 1) * 4096;
	$block = substr($_[0],$block_offset, 4096);
	if ($x >= $numrecords) {			# Last block
		$block = substr($block,0,($self->{LENGTH} % 4096));

	}

$block_len = CORE::length($block);

$index = 0;

while ( $index < $block_len ) {

	$byte = substr($block,$index,1);	# Char at $index
	if ($byte =~ /[\200-\377]/) {   # is high bit set?

		$y = 1;			# found at least one!

		while ( (substr($block,$index + $y ,1)  =~
			      /[\200-\377]/) &&
			($y < 8) ) {

			++$y;		# If found, increment counter

		}

		$compr_buff .= chr($y); # Write escape code
		$compr_buff .= substr($block,$index,$y); # Write text
		$index += $y;		# Increment the index

	 } else { 			# Real compression routines

	$frag_size = $FRAG_MIN;		# We don't care about anything less

	$test = substr($block,$index,$frag_size); # pull the current fragment
	$pos = rindex($block, $test, $index - 1); # check against the buffer

	if ( ($pos > 0) &&
	     ($index - $pos <= 2047) && 	# Inside our 2047 byte window
	     ( $index < $block_len - $frag_size) ) {

		for ($y = 4; $y <= $FRAG_MAX; $y++ ) {
			++$frag_size ;
			$test2 = substr($block,$index,$frag_size);
			$pos2 = rindex($block, $test2, $index - 1);
			if (($pos2 > 0) &&
			    ($index - $pos2 <= 2047) &&
			    ($index < $block_len - $frag_size) ) {
						# found a match!
				$pos = $pos2;
				$test = $test2;
			} else {		# no match, go back
				--$frag_size;
				last;

			}

		}
						# Sanity check
		if ($frag_size > $FRAG_MAX)
		  { die "frag_size too big!!!: $frag_size\n"; }

	   $frag_size2 = $frag_size + 2;
	   $test2 = substr($block,$index + 1, $frag_size2);
	   $pos2 = rindex($block, $test2, $index - 1);
	   if (($pos2 > 0) &&
		    ($index - $pos2 <= 2047) &&
		    ($index < $block_len - $frag_size2) ) {

		   for ($y = $frag_size2;$y <= $LAZY_BYTE_FRAG;
		        $y++ ) { 		# Look for more
			++$frag_size2;
			$test2 = substr($block,$index + 1, $frag_size2);
			$pos2 = rindex($block, $test2, $index - 1);
			if (($pos2 > 0) &&
			    ($index - $pos2 <= 2047) &&
			    ($index < $block_len - $frag_size2) ) {
							# found a match!

			} else {			# no match, go back
				--$frag_size2;
			        last;

			}
		   }
		  if ($frag_size2 < $LAZY_BYTE_FRAG)  {

		       $pos = 0;
		       $compr_buff .= substr($block,$index,1);
		       ++$index;
		  }
	    }

	   if ($pos > 0) {		# Did we abort the compression?

	      $back = $index - $pos;
	      $mask = 0x8000 | int($frag_size - 3);

	      $compr_buff .= pack("n",int($back << 3) | $mask);
	      $index += $frag_size;
	   }

	} else {

		$byte = substr($block,$index,1);	# Char at $index
		$byte2 = substr($block,$index + 1,1);	# next char as well
		if ( ($byte eq " ") &&
		     ($byte2 =~ /[\100-\176]/ ) &&
		     ($index <= $block_len - 1)) {
		       					# Got a space + char

							# Set the high bit
							# and add to output
							# buffer.
	         		$compr_buff .= pack("C", ord ($byte2) | 0x80 );
				$index += 2;		# Compressed 2 bytes

		} else {
			$compr_buff .= $byte;		# No compression
		     	++$index;
		}
	}
}
}

$self->{BLOCK_SIZE}[$x] = (CORE::length ($compr_buff)) - $total_compr_size;
$total_compr_size = CORE::length ($compr_buff);

}

return ($compr_buff);
}


1;
__END__