EBook::Tools::IMP - Object class for manipulating the SoftBook/GEB/REB/eBookWise C<.IMP> and C<.RES> e-book formats

 use EBook::Tools::IMP qw(:all)
 my $imp = EBook::Tools::IMP->new();
 $imp->load('myfile.imp');

 $imp->set_book_properties(title => 'My Best Book',
                           category => 'Fiction',
                           firstname => 'John Q. Public');

package EBook::Tools::IMP;
use warnings; use strict; use utf8;
use English qw( -no_match_vars );
use version 0.74; our $VERSION = qv("0.4.8");

# Perl Critic overrides:
## no critic (Package variable)
# RequireBriefOpen seems to be way too brief to be useful
## no critic (RequireBriefOpen)
# Double-sigils are needed for lexical filehandles in clear print statements
## no critic (Double-sigil dereference)

require Exporter;
use base qw(Exporter);

our @EXPORT_OK;
@EXPORT_OK = qw (
    &detect_resource_type
    &parse_imp_resource_v1
    &parse_imp_resource_v2
    );
our %EXPORT_TAGS = ('all' => [@EXPORT_OK]);

use Carp;
use Cwd qw(getcwd realpath);
use EBook::Tools qw(:all);
use EBook::Tools::LZSS qw(:all);
use Encode;
use File::Basename qw(basename dirname fileparse);
use File::Path;     # Exports 'mkpath' and 'rmtree'
use Image::Size;
use List::MoreUtils qw(any none);
binmode(STDERR,":utf8");

my $drmsupport = 0;
eval
{
    require EBook::Tools::DRM;
    EBook::Tools::DRM->import();
}; # Trailing semicolon is required here
unless($@){ $drmsupport = 1; }


# Constants for $self->{device},
use constant DEVICE_SB200 => 0;         # SoftBook 200/250
use constant DEVICE_REB1200 => 1;       # REB 1200/GEB 2150
use constant DEVICE_EBW1150 => 2;       # EBW 1150/GEB 1150

use constant IMAGETYPES => ('png','jpg','gif','pic');
use constant IMAGERESOURCES => ('GIF ','JPEG','PICT','PIC2','PNG ');
my %IMAGE_RESOURCE_MAP = (
    'GIF ' => 'gif',
    'JPEG' => 'jpg',
    'PICT' => 'pic',
    'PIC2' => 'png',
    'PNG ' => 'png',
    );


####################################################
########## CONSTRUCTOR AND INITIALIZATION ##########
####################################################

my %rwfields = (
    'version'        => 'integer',
    'filename'       => 'string',
    'filecount'      => 'integer',
    'resdirlength'   => 'integer',
    'resdiroffset'   => 'integer',
    'compression'    => 'integer',
    'encryption'     => 'integer',
    'device'         => 'integer',
    'zoomstates'     => 'integer',
    'identifier'     => 'string',
    'category'       => 'string',
    'subcategory'    => 'string',
    'title'          => 'string',
    'lastname'       => 'string',
    'middlename'     => 'string',
    'firstname'      => 'string',
    'etiserverdata'  => 'hash',         # Extra data after book properties
    'resdirname'     => 'string',
    'RSRC.INF'       => 'string',
    'resfiles'       => 'array',        # Array of hashrefs
    'toc'            => 'array',        # Table of Contents, array of hashes
    'resources'      => 'hash',         # Hash of hashrefs keyed on 'type'
    'lzsslengthbits' => 'integer',
    'lzssoffsetbits' => 'integer',
    'text'           => 'string',       # Uncompressed text
    'imrn'           => 'hash',         # Hash of hashes of ImRn resource data
    'gif'            => 'hash',         # Hash of hashes of GIF image data
    'jpg'            => 'hash',         # Hash of hashes of JPEG image data
    'pic'            => 'hash',         # Hash of hashes of PICT image data
    'png'            => 'hash',         # Hash of hashes of PNG image data
    'offsetelements' => 'hash',         # Hash of text offsets to HTML elements
    );

my %rofields = (
    'unknown0x0a'   => 'string',
    'unknown0x18'   => 'integer',
    'unknown0x1c'   => 'integer',
    'unknown0x28'   => 'integer',
    'unknown0x2a'   => 'integer',
    'unknown0x2c'   => 'integer',
    );
my %privatefields = (
);

# A simple 'use fields' will not work here: use takes place inside
# BEGIN {}, so the @...fields variables won't exist.
require fields;
fields->import(
    keys(%rwfields),keys(%rofields),keys(%privatefields)
    );

sub new   ## no critic (Always unpack @_ first)
{
    my $self = shift;
    my $class = ref($self) || $self;
    my ($filename) = @_;
    my $subname = (caller(0))[3];
    debug(2,"DEBUG[",$subname,"]");

    $self = fields::new($class);
    if($filename)
    {
        $self->{filename} = $filename;
        $self->load();
    }
    return $self;
}

sub load :method
{
    my $self = shift;
    my ($filename) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    if(!$self->{filename} and !$filename)
    {
        carp($subname,"(): no filename specified!\n");
        return;
    }

    $self->{filename} = $filename if($filename);
    $filename = $self->{filename} if(!$filename);

    my $fh_imp;
    my $headerdata;
    my $bookpropdata;
    my $retval;
    my $toc_size;
    my $tocdata;
    my $entrydata;
    my $resource;       # Hashref


    if(! -f $filename)
    {
        carp($subname,"(): '",$filename,"' not found!\n");
        return;
    }

    open($fh_imp,'<:raw',$filename)
        or croak($subname,"(): unable to open '",$filename,
                 "' for reading!\n");
    sysread($fh_imp,$headerdata,48);
    $retval = $self->parse_imp_header($headerdata);
    if(!$retval)
    {
        carp($subname,"(): '",$filename,"' is not an IMP file!\n");
        return;
    }

    if(!$self->{resdiroffset})
    {
        carp($subname,"(): '",$filename,"' has no res dir offset!\n");
        return;
    }
    my $bookproplength = $self->{resdiroffset} - 24;
    sysread($fh_imp,$bookpropdata,$bookproplength);
    $retval = $self->parse_imp_book_properties($bookpropdata);

    if(!$self->{resdirlength})
    {
        carp($subname,"(): '",$filename,"' has no directory name!\n");
        return;
    }

    sysread($fh_imp,$self->{resdirname},$self->{resdirlength});

    debug(1,"DEBUG: resource directory = '",$self->{resdirname},"'");

    if($self->{version} == 1)
    {
        $toc_size = 10 * $self->{filecount};
        sysread($fh_imp,$tocdata,$toc_size)
            or croak($subname,"(): unable to read TOC data!\n");
        $self->parse_imp_toc_v1($tocdata);

        $self->{resources} = ();
        foreach my $entry (@{$self->{toc}})
        {
            sysread($fh_imp,$entrydata,$entry->{size}+10);
            $resource = parse_imp_resource_v1($entrydata);
            if($resource->{type} ne $entry->{type})
            {
                carp($subname,"():\n",
                     " '",$entry->{type},"' TOC entry pointed to '",
                     $resource->{type},"' resource!\n");
            }
            $self->{resources}->{$resource->{type}} = $resource;
        }
    }
    elsif($self->{version} == 2)
    {
        $toc_size = 20 * $self->{filecount};
        sysread($fh_imp,$tocdata,$toc_size)
            or croak($subname,"(): unable to read TOC data!\n");
        $self->parse_imp_toc_v2($tocdata);

        $self->{resources} = ();
        foreach my $entry (@{$self->{toc}})
        {
            sysread($fh_imp,$entrydata,$entry->{size}+20);
            $resource = parse_imp_resource_v2($entrydata);
            $self->{resources}->{$resource->{type}} = $resource;
        }
    }
    else
    {
        carp($subname,"(): IMP version ",$self->{version}," not supported!\n");
        return;
    }

    $self->parse_resource_images();
    $self->parse_resource_imrn();
    $self->parse_text();

    close($fh_imp)
        or croak($subname,"(): failed to close '",$filename,"'!\n");

    debug(3,$self->{text});
    return 1;
}

sub load_resdir
{
    my $self = shift;
    my ($dirname) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    if(!$dirname)
    {
        carp($subname,"(): no resource directory specified!\n");
        return;
    }

    if(! -d $dirname)
    {
        carp($subname,"(): resource directory '",$dirname,"' not found!\n");
        return;
    }

    if(! -f $dirname . '/DATA.FRK')
    {
        carp($subname,"():\n",
             " resource directory '",$dirname,"' has no text resource!\n");
        return;
    }
    if(! -f $dirname . '/RSRC.INF')
    {
        carp($subname,"()\n",
             " resource directory '",$dirname,"' has no RSRC.INF!\n");
        return;
    }

    my $fh_resource;
    my $rsrcinf;
    my @list;

    open($fh_resource,'<:raw',$dirname . '/RSRC.INF')
        or croak($subname,"():\n",
                 " unable to open '$dirname/RSRC.INF' for reading!\n");
    sysread($fh_resource,$rsrcinf,-s "$dirname/RSRC.INF");
    close($fh_resource)
        or croak($subname,"():\n",
                 " unable to close '$dirname/RSRC.INF'!\n");

    if(length($rsrcinf) < 48)
    {
        carp($subname,"():\n",
             " RSRC.INF is too short (only ",length($rsrcinf)," bytes)!\n");
        return;
    }

    if(substr($rsrcinf,2,8) ne 'BOOKDOUG')
    {
        carp($subname,"():\n",
             " RSRC.INF does not contain a valid header!\n");
        return;
    }

    $self->{resdirname} = basename($dirname);
    $self->{resdirlength} = length($self->{resdirname});
    debug(2,"DEBUG: IMP resdir name = ",$self->{resdirname});

    # We have no idea what to put here, so fill it with nulls
    $self->{unknown0x0a} = "\x00\x00\x00\x00\x00\x00\x00\x00";

    # No matter what the RSRC.INF says, we're going to use a v2 format
    $self->{version} = 2;
    @list = unpack('nNNNNnCCN',substr($rsrcinf,10,26));
    $self->{resdiroffset} = $list[0];
    $self->{unknown0x18}  = $list[1];
    $self->{unknown0x1c}  = $list[2];
    $self->{compression}  = $list[3];
    $self->{encryption}   = $list[4];
    $self->{unknown0x28}  = $list[5];
    $self->{unknown0x2a}  = $list[6];
    $self->{device}       = $list[7] >> 4;
    $self->{zoomstates}   = $list[7] & 0x0f;
    $self->{unknown0x2c}  = $list[8];

    debug(2,"DEBUG: IMP resdir offset = ",$self->{resdiroffset});
    debug(2,"DEBUG: Unknown 0x18 = ",$self->{unknown0x18});
    debug(2,"DEBUG: Unknown 0x1c = ",$self->{unknown0x1c});
    debug(2,"DEBUG: IMP compression = ",$self->{compression});
    debug(2,"DEBUG: IMP encryption = ",$self->{encryption});
    debug(2,"DEBUG: Unknown 0x28 = ",$self->{unknown0x28});
    debug(2,"DEBUG: Unknown 0x2A = ",$self->{unknown0x2a});
    debug(2,"DEBUG: IMP device = ",$self->{device});
    debug(2,"DEBUG: IMP zoom state = ",$self->{zoomstates});
    debug(2,"DEBUG: Unknown 0x2c = ",$self->{unknown0x2c});

    @list = unpack('Z*Z*Z*Z*Z*Z*Z*',substr($rsrcinf,36));
    $self->{identifier}  = $list[0];
    $self->{category}    = $list[1];
    $self->{subcategory} = $list[2];
    $self->{title}       = $list[3];
    $self->{lastname}    = $list[4];
    $self->{middlename}  = $list[5];
    $self->{firstname}   = $list[6];

    my $proplength = $self->bookproplength;
    if(length($rsrcinf) > $proplength + 36)
    {
        debug(1,"Book properties data has extra ETI server data appended");
        $self->parse_eti_server_data(substr($rsrcinf,$proplength + 36));
    }

    my $cwd = getcwd();

    if(! chdir($dirname))
    {
        carp($subname,"(): unable to enter directory '",$dirname,"'!\n");
        return;
    }

    my @filelist = <*>;
    $self->{resources} = {};
    $self->{toc} = ();
    foreach my $file (@filelist)
    {
        my $resdata;
        my %resource;
        my %tocentry;

        next if($file eq 'RSRC.INF');
        unless($file =~ /^ ([A-Z]{4} | DATA\.FRK) $/x)
        {
            debug(1,"DEBUG: invalid resource filename '",$file,
                  "' -- skipping");
            next;
        }
        if(-z $file)
        {
            debug(1,"DEBUG: resource file '",$file,
                  "' has zero size -- skipping");
            next;
        }
        open($fh_resource,'<:raw',$file)
            or croak($subname,"():\n",
                     " unable to open '",$file,"' for reading!\n");
        sysread($fh_resource,$resdata,-s $file);
        close($fh_resource)
            or croak($subname,"(): unable to close '",$file,"'!\n");
        if($file eq 'DATA.FRK')
        {
            $resource{name} = '    ';
            $resource{type} = '    ';
        }
        else
        {
            $resource{name} = $file;
            $resource{type} = detect_resource_type(\$resdata);
        }
        if(! $resource{type})
        {
            debug(1,"DEBUG: unable to determine resource type for file '",
                  $file,"' -- skipping");
            next;
        }
        $resource{unknown1} = 0;
        $resource{unknown2} = 0;
        $resource{size} = length($resdata);
        %tocentry = %resource;
        push(@{$self->{toc}},\%tocentry);

        $resource{data} = $resdata;
        $self->{resources}->{$resource{type}} = \%resource;
        debug(2,"DEBUG: found resource '",$resource{name},
              "', type '",$resource{type},"' [",$resource{size}," bytes]");
    }
    chdir($cwd);

    $self->parse_resource_images();
    $self->parse_resource_imrn();
    $self->parse_text();

    return 1;
}


######################################
########## ACCESSOR METHODS ##########
######################################

sub author :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my $author;
    if($self->{lastname})
    {
        $author = $self->{lastname};
        if($self->{firstname})
        {
            $author .= ", " . $self->{firstname};
            $author .= " " . $self->{middlename} if($self->{middlename});
        }
    }
    else
    {
        $author = $self->{firstname};
        $author .= " " . $self->{middlename} if($self->{middlename});
    }

    return $author;
}

sub bookproplength :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my $length = 0;
    $length += length($self->{identifier})  + 1;
    $length += length($self->{category})    + 1;
    $length += length($self->{subcategory}) + 1;
    $length += length($self->{title})       + 1;
    $length += length($self->{lastname})    + 1;
    $length += length($self->{middlename})  + 1;
    $length += length($self->{firstname})   + 1;

    return $length;
}

sub filecount :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");
    return $self->{filecount};
}

sub find_image_type :method
{
    my $self = shift;
    my ($id,@excluded) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    return unless($id);

    foreach my $type (IMAGETYPES)
    {
        next if(any {$type eq $_} @excluded);
        return $type if($self->{$type}->{$id});
    }
    return;
}

sub find_resource_by_name :method
{
    my $self = shift;
    my ($name) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    return unless($name);
    return unless($self->{resources});

    foreach my $type (keys %{$self->{resources}})
    {
        return $type if($self->{resources}->{$type}->{name} eq $name);
    }
    return;
}

sub image :method
{
    my $self = shift;
    my ($type,$id) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    if(!$type)
    {
        carp($subname,"(): no image type specified!\n");
        return;
    }
    if(none { $type eq $_ } IMAGETYPES)
    {
        carp($subname,"(): invalid image type '",$type,"'!\n");
        return;
    }
    if(!$id)
    {
        carp($subname,"(): ID not specified!\n");
        return;
    }
    return $self->{$type}->{$id}->{data};
}

sub image_hashref :method
{
    my $self = shift;
    my ($type,$id) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    if(!$type)
    {
        carp($subname,"(): no image type specified!\n");
        return;
    }
    if(none { $type eq $_ } IMAGETYPES)
    {
        carp($subname,"(): invalid image type '",$type,"'!\n");
        return;
    }

    if($id)
    {
        return $self->{$type}->{$id};
    }
    return $self->{$type};
}

sub image_ids :method
{
    my $self = shift;
    my ($type) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    if(!$type)
    {
        carp($subname,"(): no image type specified!\n");
        return;
    }

    if(none { $type eq $_ } IMAGETYPES)
    {
        carp($subname,"(): invalid image type '",$type,"'!\n");
        return;
    }

    return keys %{$self->{$type}};
}

sub is_1150
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    return if(!defined $self->{device});
    return 1 if($self->{device} == 2);
    return 0;
}

sub offsetelement :method
{
    my $self = shift;
    my ($offset) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    return unless($offset);
    return unless($self->{offsetelements});
    return $self->{offsetelements}->{$offset};
}

sub pack_imp_book_properties :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my $bookpropdata = pack("Z*Z*Z*Z*Z*Z*Z*",
                            $self->{identifier},
                            $self->{category},
                            $self->{subcategory},
                            $self->{title},
                            $self->{lastname},
                            $self->{middlename},
                            $self->{firstname});

    return $bookpropdata;
}

sub pack_imp_header :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my $header;
    my $filecount = scalar(keys %{$self->{resources}});
    my $resdir = $self->{resdirname};

    if(!$filecount)
    {
        carp($subname,"():\n",
             " No resources found (has a file been loaded?)\n");
        return;
    }

    if(!$resdir)
    {
        carp($subname,"():\n",
             " No resource directory name specified!\n");
        return;
    }

    if(!$self->{version})
    {
        carp($subname,"():\n",
             " No version specified (has a file been loaded?)\n");
        return;
    }
    if($self->{version} > 2)
    {
        carp($subname,"():\n",
             " invalid version ",$self->{version},"\n");
        return;
    }

    $header = pack('n',$self->{version});
    $header .= 'BOOKDOUG';
    if(! $self->{unknown0x0a}
       or length($self->{unknown0x0a}) != 8)
    {
        carp($subname,"():\n",
             " unknown data at 0x0a has incorrect length",
             " -- substituting nulls\n");
        $self->{unknown0x0a} = "\x00\x00\x00\x00\x00\x00\x00\x00";
    }
    $header .= $self->{unknown0x0a};
    $header .= pack('nn',$filecount,length($resdir));
    $header .= pack('n',$self->bookproplength + 24);
    $header .= pack('NN',$self->{unknown0x18},$self->{unknown0x1c});
    $header .= pack('NN',$self->{compression},$self->{encryption});
    $header .= pack('nC',$self->{unknown0x28},$self->{unknown0x2a});
    $header .= pack('C',$self->{device} * 16 + $self->{zoomstates});
    $header .= pack('N',$self->{unknown0x2c});

    if(length($header) != 48)
    {
        croak($subname,"():\n",
              " total header length not 48 bytes (found ",
              length($header),")\n");
    }
    return $header;
}

sub pack_imp_resource :method
{
    my $self = shift;
    my %args = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my %valid_args = (
        'name' => 1,
        'type' => 1,
        );
    foreach my $arg (keys %args)
    {
        croak($subname,"(): invalid argument '",$arg,"'")
            if(!$valid_args{$arg});
    }
    if(!$args{name} and !$args{type})
    {
        carp($subname,"():\n",
             " at least one of name or type must be specified!\n");
        return;
    }

    my $type = $args{type};
    my $resource;
    my $resdata;

    if(!($type and $self->{resources}->{$type}) and $args{name})
    {
        $type = $self->find_resource_by_name($args{name});
        if(!$type or !$self->{resources}->{$type})
        {
            carp($subname,"():\n",
                 " no resource with name '",$args{name},"' found!\n");
            return;
        }
    }
    if(!$self->{resources}->{$type})
    {
        carp($subname,"()\n",
             " no resource with type '",$args{type},"' found!\n");
        return;
    }

    $resource = $self->{resources}->{$type};
    if($self->{version} == 1)
    {
        $resdata = pack('a[4]nN',
                        $resource->{name},
                        $resource->{unknown1},
                        $resource->{size});
        $resdata .= $resource->{data};
    }
    elsif($self->{version} == 2)
    {
        $resdata = pack('a[4]NNa[4]N',
                        $resource->{name},
                        $resource->{unknown1},
                        $resource->{size},
                        $resource->{type},
                        $resource->{unknown2});
        $resdata .= $resource->{data};
    }
    else
    {
        carp($subname,"(): invalid version ",$self->{version},"!\n");
        return;
    }

    if(!$resdata)
    {
        carp($subname,"(): no resource data packed!\n");
        return;
    }

    return \$resdata;
}

sub pack_imp_rsrc_inf :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my $rsrc;

    # Data from header
    $rsrc = pack('na[8]n',1,'BOOKDOUG',$self->{resdiroffset});
    $rsrc .= pack('NNNNnCCN',
                  $self->{unknown0x18},$self->{unknown0x1c},
                  $self->{compression},$self->{encryption},
                  $self->{unknown0x28},$self->{unknown0x2a},
                  ($self->{device} * 16) + $self->{zoomstates},
                  $self->{unknown0x2c});

    # Data from book properties
    $rsrc .= pack('Z*',$self->{identifier});
    $rsrc .= pack('Z*Z*Z*',
                  $self->{category},$self->{subcategory},$self->{title});
    $rsrc .= pack('Z*Z*Z*',
                  $self->{lastname},$self->{middlename},$self->{firstname});

    if($self->{etiserverdata})
    {
        my $length = length($rsrc);
        my $padsize = length($self->{etiserverdata}->{pad});

        # Pad must result in the following record being 4-byte aligned
        if( ($length + $padsize) % 4 )
        {
            carp($subname,"():\n",
                 " ETI server data has invalid pad, regenerating it...\n");
            undef($self->{etiserverdata}->{pad});
            $padsize = $length % 4;
            if($padsize)
            {
                $padsize = 4 - $padsize;
                $self->{etiserverdata}->{pad} = pack("a[$padsize]","\0");
            }
        }

        $rsrc .= $self->{etiserverdata}->{pad};
        $rsrc .= pack('NNZ*Z*',
                      $self->{etiserverdata}->{unknown1},
                      $self->{etiserverdata}->{issuenumber},
                      $self->{etiserverdata}->{contentfeed},
                      $self->{etiserverdata}->{source});
        if($self->{etiserverdata}->{unknown2})
        {
            $rsrc .= pack('N',$self->{etiserverdata}->{unknown2});
        }
    } # if($self->{etiserverdata}

    return $rsrc;
}

sub pack_imp_toc :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my $tocdata;

    if(!$self->{version})
    {
        carp($subname,"():\n",
             " no version information found (did you load a file first?)\n");
        return;
    }
    if($self->{version} > 2)
    {
        carp($subname,"():\n",
             " invalid version ",$self->{version},"!\n");
        return;
    }

    if(!$self->{toc})
    {
        carp($subname,"(): no TOC data found!\n");
        return;
    }

    foreach my $entry (@{$self->{toc}})
    {
        if($self->{version} == 1)
        {
            $tocdata .= pack('a[4]nN',
                             $entry->{name},
                             $entry->{unknown1},
                             $entry->{size});
        }
        elsif($self->{version} == 2)
        {
            $tocdata .= pack('a[4]NNa[4]N',
                             $entry->{name},
                             $entry->{unknown1},
                             $entry->{size},
                             $entry->{type},
                             $entry->{unknown2});
        }
    }

    if(!length($tocdata))
    {
        carp($subname,"(): no valid TOC data produced!\n");
        return;
    }

    return $tocdata;
}

sub resdirbase :method
{
    my $self = shift;
    return fileparse($self->{resdirname},'\.\w+$');
}

sub resdirlength :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");
    return $self->{resdirlength};
}

sub resdirname :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");
    return $self->{resdirname};
}

sub resource :method
{
    my $self = shift;
    my ($type) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");
    return unless($type);
    return $self->{resources}->{$type};
}

sub resources :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");
    return $self->{resources};
}

sub text :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");
    return $self->{text};
}

sub title :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");
    return $self->{title};
}

sub tocentry :method
{
    my $self = shift;
    my ($index) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");
    return $self->{toc}->[$index];
}

sub version :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");
    return $self->{version};
}

sub write_images :method
{
    my $self = shift;
    my %args = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my %valid_args = (
        'dir' => 1,
        );
    foreach my $arg (keys %args)
    {
        croak($subname,"(): invalid argument '",$arg,"'")
            if(!$valid_args{$arg});
    }

    my $dirname = $args{dir} || $self->resdirbase;
    my $cwd = usedir($dirname);

    foreach my $imagetype (IMAGETYPES)
    {
        foreach my $id (keys %{$self->{$imagetype}})
        {
            my $hexid = sprintf('%04X',$id);
            my $prefix = uc($imagetype) . '_';
            my $filename = "${prefix}${hexid}.${imagetype}";
            my $fh_image;

            if(! $self->{$imagetype}->{$id})
            {
                carp($subname,"(): data for image 0x",$hexid," not found!\n");
                next;
            }

            if(!open($fh_image,'>:raw',$filename))
            {
                carp($subname,"():\n",
                     " unable to open '",$filename,"' for writing!\n");
                return;
            }
            print {*$fh_image} $self->{$imagetype}->{$id}->{data};
            if(!close($fh_image))
            {
                carp($subname,"():\n",
                     " unable to close '",$filename,"'!\n");
                return;
            }
        } # foreach my $id (keys %{$self->{$imagetype}})
    }
    chdir($cwd);
    return 1;
}

sub write_imp :method
{
    my $self = shift;
    my ($filename) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    return unless($filename);

    my $fh_imp;
    if(!open($fh_imp,'>:raw',$filename))
    {
        carp($subname,"():\n",
             " unable to open '",$filename,"' for writing!\n");
        return;
    }

    my $headerdata = $self->pack_imp_header();
    my $bookpropdata = $self->pack_imp_book_properties();
    my $tocdata = $self->pack_imp_toc;

    if(!$headerdata or length($headerdata) != 48)
    {
        carp($subname,"(): invalid header data!\n");
        return;
    }
    if(!$bookpropdata)
    {
        carp($subname,"(): invalid book properties data!\n");
        return;
    }
    if(!$tocdata)
    {
        carp($subname,"(): invalid table of contents data!\n");
        return;
    }
    if(!$self->{resdirname})
    {
        carp($subname,"(): invalid .RES directory name!\n");
        return;
    }
    if(!scalar(keys %{$self->{resources}}))
    {
        carp($subname,"(): no resources found!\n");
        return;
    }

    print {*$fh_imp} $headerdata;
    print {*$fh_imp} $bookpropdata;
    print {*$fh_imp} $self->{resdirname};
    print {*$fh_imp} $tocdata;

    foreach my $tocentry (@{$self->{toc}})
    {
        print {*$fh_imp} ${$self->pack_imp_resource(type => $tocentry->{type})};
    }

    return 1;
}

sub write_resdir :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    if(!$self->{resdirname})
    {
        carp($subname,"(): .RES directory name not known!\n");
        return;
    }

    my $cwd = getcwd();
    my $fh_resource;

    mkpath($self->{resdirname});
    if(! -d $self->{resdirname})
    {
        croak($subname,"():\n",
              " unable to create .RES directory '",$self->{resdirname},
              "'!\n");
    }
    chdir($self->{resdirname});

    $self->{'RSRC.INF'} = $self->pack_imp_rsrc_inf;

    if($self->{'RSRC.INF'})
    {
        open($fh_resource,'>:raw','RSRC.INF')
            or croak($subname,"():\n",
                     " unable to open 'RSRC.INF' for writing!\n");

        print {*$fh_resource} $self->{'RSRC.INF'};
        close($fh_resource)
            or croak($subname,"():\n",
                     " unable to close 'RSRC.INF'!\n");
    }
    else
    {
        carp($subname,"():\n",
             " WARNING: no RSRC.INF data found!\n");
    }

    foreach my $restype (keys %{$self->{resources}})
    {
        my $filename = $self->{resources}->{$restype}->{name};
        $filename = 'DATA.FRK' if($filename eq '    ');

        open($fh_resource,'>:raw',$filename)
            or croak($subname,"():\n",
                     " unable to open '",$filename,"' for writing!\n");

        print {*$fh_resource} $self->{resources}->{$restype}->{data};
        close($fh_resource)
            or croak($subname,"():\n",
                     " unable to close '",$filename,"'!\n");
    }

    chdir($cwd);
    return 1;
}

sub write_text :method
{
    my $self = shift;
    my %args = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my %valid_args = (
        'dir' => 1,
        'filename' => 1,
        );
    foreach my $arg (keys %args)
    {
        croak($subname,"(): invalid argument '",$arg,"'")
            if(!$valid_args{$arg});
    }

    if(!$self->{text})
    {
        carp($subname,"(): no text to write!\n");
        return;
    }

    my $dirname = $args{dir} || $self->resdirbase;
    my $filename = $args{filename} || $self->resdirbase . '.html';
    $filename = $dirname . '/' . $filename;
    my $fh_text;

    mkpath($dirname) if(! -d $dirname);

    if(! -d $dirname)
    {
        carp($subname,"(): unable to create directory '",$dirname,"'!\n");
        return;
    }

    if(!open($fh_text,'>:raw',$filename))
    {
        carp($subname,"(): unable to open '",$filename,"' for writing!\n");
        return;
    }
    print {*$fh_text} $self->text;
    if(!close($fh_text))
    {
        carp($subname,"(): unable to close '",$filename,"'!\n");
        return;
    }

    return 1;
}


######################################
########## MODIFIER METHODS ##########
######################################

sub create_toc_from_resources :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    $self->{toc} = ();
    return 0 unless($self->{resources});

    foreach my $type (sort keys %{$self->{resources}})
    {
        my %tocentry;
        $tocentry{name}     = $self->{resources}->{$type}->{name};
        $tocentry{type}     = $type;
        $tocentry{size}     = length($self->{resources}->{$type}->{data});
        $tocentry{unknown1} = $self->{resources}->{$type}->{unknown1};
        $tocentry{unknown2} = $self->{resources}->{$type}->{unknown2};
        push(@{$self->{toc}},\%tocentry);
    }

    $self->{filecount} = scalar($self->{toc});
    debug(2,"DEBUG: created TOC data from ",$self->{filecount}," records");
    return $self->{filecount};
}

sub parse_eti_server_data :method
{
    my $self = shift;
    my ($data) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    return 0 unless($data);

    my $proplength = $self->bookproplength;
    my $length = length($data);
    if($length < 10)
    {
        carp($subname,"():\n",
             " data is too short to contain ETI server data! [",
             $length," bytes]\n");
        return 0;
    }

    $self->{etiserverdata} = {};

    # Up to 3 bytes of padding to make sure that the following data is
    # 4-byte aligned.
    my $padlength = $proplength % 4;
    my @list;
    if($padlength)
    {
        $padlength = 4 - $padlength;
        $self->{etiserverdata}->{pad} = substr($data,0,$padlength);
        $proplength += $padlength;
    }

    @list = unpack('NNZ*Z*N',substr($data,$padlength));
    $self->{etiserverdata}->{unknown1}    = $list[0];
    $self->{etiserverdata}->{issuenumber} = $list[1];
    $self->{etiserverdata}->{contentfeed} = $list[2];
    $self->{etiserverdata}->{source}      = $list[3];
    $self->{etiserverdata}->{unknown2}    = $list[4];
    debug(2,"  pad=",hexstring($self->{etiserverdata}->{pad}))
        if($self->{etiserverdata}->{pad});
    debug(2,
          "  unknown1=",$list[0]," \t\tissuenumber=",$list[1],"\n",
          "  contentfeed='",$list[2],"' \tsource='",$list[3],"'");
    debug(2,"  unknown2=",$list[4]) if(defined $list[4]);

    return($length);
}

sub parse_imp_book_properties :method
{
    my $self = shift;
    my ($propdata) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my @properties = unpack("Z*Z*Z*Z*Z*Z*Z*",$propdata);
    if(scalar(@properties) != 7)
    {
        carp($subname,"(): WARNING: expected 7 book properties, but found ",
             scalar(@properties),"!\n");
    }

    $self->{identifier}  = $properties[0];
    $self->{category}    = $properties[1];
    $self->{subcategory} = $properties[2];
    $self->{title}       = $properties[3];
    $self->{lastname}    = $properties[4];
    $self->{middlename}  = $properties[5];
    $self->{firstname}   = $properties[6];

    debug(2,"DEBUG: found ",scalar(@properties)," properties: ");
    debug(2,"  Identifier:   ",$self->{identifier});
    debug(2,"  Category:     ",$self->{category});
    debug(2,"  Subcategory:  ",$self->{subcategory});
    debug(2,"  Title:        ",$self->{title});
    debug(2,"  Last Name:    ",$self->{lastname});
    debug(2,"  Middle Name:  ",$self->{middlename});
    debug(2,"  First Name:   ",$self->{firstname});


    # On encrypted files, there may be addtional ETI server data
    # appended
    my $proplength = $self->bookproplength;
    if($proplength < length($propdata))
    {
        debug(1,"Book properties data has extra ETI server data appended");
        $self->parse_eti_server_data(substr($propdata,$proplength));
    }
    return 1;
}

sub parse_imp_header :method
{
    my $self = shift;
    my ($headerdata) = @_;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my $length = length($headerdata);
    if($length != 48)
    {
        croak($subname,"(): expected 48 bytes, was passed ",$length,"!\n");
    }

    my $identstring = substr($headerdata,2,8);
    if($identstring ne 'BOOKDOUG')
    {
        carp($subname,"(): invalid IMP header!\n");
        return;
    }

    $self->{version} = unpack('n',$headerdata);
    if($self->{version} < 1 or $self->{version} > 2)
    {
        carp($subname,"(): Version ",$self->{version}," is not supported!\n");
        return;
    }

    $self->{unknown0x0a} = substr($headerdata,10,8);

    # Unsigned short int values
    my @list = unpack('nnn',substr($headerdata,0x12,6));
    $self->{filecount}     = $list[0];
    $self->{resdirlength}  = $list[1];
    $self->{resdiroffset}  = $list[2];
    debug(2,"DEBUG: IMP file count = ",$self->{filecount});
    debug(2,"DEBUG: IMP resdirlength = ",$self->{resdirlength});
    debug(2,"DEBUG: IMP resdir offset = ",$self->{resdiroffset});

    # Unknown long ints
    @list = unpack('NN',substr($headerdata,0x18,8));
    $self->{unknown0x18} = $list[0];
    $self->{unknown0x1c} = $list[1];
    debug(2,"DEBUG: Unknown long int at offset 0x18 = ",$self->{unknown0x18});
    debug(2,"DEBUG: Unknown long int at offset 0x1c = ",$self->{unknown0x1c});

    # Compression/Encryption/Unknown
    @list = unpack('NNnC',substr($headerdata,0x20,11));
    $self->{compression} = $list[0];
    $self->{encryption}  = $list[1];
    $self->{unknown0x28} = $list[2];
    $self->{unknown0x2a} = $list[3];
    debug(2,"DEBUG: IMP compression = ",$self->{compression});
    debug(2,"DEBUG: IMP encryption = ",$self->{encryption});
    debug(2,"DEBUG: Unknown short int at offset 0x28 = ",$self->{unknown0x28});
    debug(2,"DEBUG: Unknown byte at offset 0x2A = ",$self->{unknown0x2a});

    # Zoom State, and Unknown
    @list = unpack('CN',substr($headerdata,0x2B,5));
    $self->{device}        = $list[0] >> 4;
    $self->{zoomstates}   = $list[0] & 0x0f;
    $self->{unknown0x2c} = $list[1];

    debug(2,"DEBUG: IMP device = ",$self->{device});
    debug(2,"DEBUG: IMP zoom state = ",$self->{zoomstates});
    debug(2,"DEBUG: Unknown long int at offset 0x2c = ",$self->{unknown0x2c});

    return 1;
}

sub parse_resource_cm :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    return unless($self->{resources}->{'!!cm'});

    my @list;
    my $version;
    my $ident;          # Must be constant string '!!cm'
    my $unknown1;
    my $indexoffset;
    my $lzssdata;

    @list = unpack('na[4]NN',$self->{resources}->{'!!cm'}->{data});
    $version     = $list[0];
    $ident       = $list[1];
    $unknown1    = $list[2];
    $indexoffset = $list[3];

    if($ident ne '!!cm')
    {
        carp($subname,"():\n",
             " Invalid '!!cm' record!\n");
        return;
    }
    debug(2,"DEBUG: parsing !!cm v",$version,", index offset ",$indexoffset);
    $lzssdata = substr($self->{resources}->{'!!cm'}->{data},$indexoffset-4,4);
    @list = unpack('nn',$lzssdata);

    if($list[0] + $list[1] > 32
       or $list[0] < 2
       or $list[1] < 1)
    {
        carp($subname,"():\n",
             " invalid LZSS compression bit lengths!\n",
             "[",$list[0]," offset bits, ",
             $list[1]," length bits]\n");
        return;
    }

    $self->{lzssoffsetbits} = $list[0];
    $self->{lzsslengthbits} = $list[1];
    debug(2,"DEBUG: !!cm specifies ",$list[0]," offset bits, ",
          $list[1]," length bits");
    return 1;
}

sub parse_resource_images :method
{
    my $self = shift;
    my $subname = (caller(0))[3];
    croak($subname . "() called as a procedure!\n") unless(ref $self);
    debug(2,"DEBUG[",$subname,"]");

    my $headersize;
    my $imgdata;
    my $imgcount;
    my $total = 0;
    my @list;

    if($self->{device} == DEVICE_EBW1150) { $headersize = 14; }
    else { $headersize = 12; }

    foreach my $resource (keys %IMAGE_RESOURCE_MAP)
    {
        next unless($self->{resources}->{$resource});
        my $rsize = $self->{resources}->{$resource}->{size};
        my $itype = $IMAGE_RESOURCE_MAP{$resource};
        next if ($rsize <= 32);

        @list = unpack('na[4]NNnNNNN',$self->{resources}->{$resource}->{data});
        my $version     = $list[0];
        my $ident       = $list[1];
        my $unknown1    = $list[2];
        my $tocoffset   = $list[3];
        my $unknown2    = $list[4];
        my $unknown3    = $list[5];
        my $unknown4    = $list[6];
        my $unknown5    = $list[7];
        my $unknown6    = $list[8];

        if($ident ne $resource)
        {
            carp($subname,"():\n",
                 " Invalid '",$resource,"' record!\n");
            next;
        }

        debug(2,"DEBUG: parsing ",$resource," resource v",$version,
              ", index offset ",$tocoffset);

        $imgcount = ($rsize - $tocoffset) / $headersize;

        debug(2,"DEBUG: ",$imgcount," ",$itype," images listed in header");

        $self->{$itype} = {};
        foreach my $pos (0 .. ($imgcount - 1))
        {
            my $id;         # Image ID -- this is only unique for each imagetype
            my $hexid;      # 4-digit hexadecimal string version of $id

            $imgdata = substr($self->{resources}->{$resource}->{data},
                              $tocoffset + ($headersize * $pos),$headersize);
            if($self->{device} == DEVICE_EBW1150)
            {
                #Standard 1150 Header (14 bytes)
                @list = unpack("vvVVv",$imgdata);
                $id                               = $list[0];
                $self->{$itype}->{$id}->{unknown} = $list[1];
                $self->{$itype}->{$id}->{length}  = $list[2];
                $self->{$itype}->{$id}->{offset}  = $list[3];
                $self->{$itype}->{$id}->{const0}  = $list[4];
            }
            else
            {
                #Standard 1200 Header (12 bytes)
                @list = unpack("nNNn",$imgdata);
                $id                               = $list[0];
                $self->{$itype}->{$id}->{length}  = $list[1];
                $self->{$itype}->{$id}->{offset}  = $list[2];
                $self->{$itype}->{$id}->{const0}  = $list[3];
            }

            if($EBook::Tools::debug > 2)
            {
                printf("  id=%04X  unk1=0x%04X  length=%d  offset=%d, const0=0x%04X\n",
                       $id, $self->{$itype}->{$id}->{unknown},
                       $self->{$itype}->{$id}->{length},
                       $self->{$itype}->{$id}->{offset},
                       $self->{$itype}->{$id}->{const0});
            }

            $hexid = sprintf("%04X",$id);

            $self->{$itype}->{$id}->{data} =
                substr($self->{resources}->{$resource}->{data},
                       $self->{$itype}->{$id}->{offset},
                       $self->{$itype}->{$id}->{length});

            my ($imagex,$imagey,$imagetype) =
                imgsize(\$self->{$itype}->{$id}->{data});
            if(defined($imagex) && $imagetype)
            {
                debug(2,"  ",$itype," image ",$pos," (ID '",$hexid,"') is valid ",
                      $imagetype," image data (",$imagex," x ",$imagey,")");
            }
            else
            {
                carp($subname,"():\n",
                     " ",$itype," image ",$pos," (ID '",$id,
                     "') is not valid image data!\n");
                next;
            }
        } # foreach my $pos (0 .. ($imgcount - 1))

        my $found = scalar keys %{$self->{$itype}};
        if($found != $imgcount)
        {
            carp($subname,"()\n",
                 " resource specified ",$imgcount," images, but found ",
                 $found,"!\n");
        }
        $total += $found;
    } # foreach my $resource (keys %IMAGE_RESOURCE_MAP)

    return $total;
}