EBook-Tools

 view release on metacpan or  search on metacpan

lib/EBook/Tools/IMP.pm  view on Meta::CPAN

    keys(%rwfields),keys(%rofields),keys(%privatefields)
    );


=head1 CONSTRUCTOR AND INITIALIZATION

=head2 C<new($filename)>

Instantiates a new EBook::Tools::IMP object.  If C<$filename> is
specified, it will also immediately initialize itself via the C<load>
method.

=cut

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;
}


=head2 C<load($filename)>

Loads a .imp file, parsing it into the various object attributes.
Returns 1 on success, or undef on failure.

=cut

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

    if(not $self->{filename} and not $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;
}


=head2 C<load_resdir($dirname)>

Loads a C<.RES> resource directory, parsing it into the object
attributes.  Returns 1 on success, or undef on failure.

=cut

sub load_resdir
{
    my ($self,$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')

lib/EBook/Tools/IMP.pm  view on Meta::CPAN

    # 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;
}


=head2 C<pack_imp_toc()>

Packs the C<< $self->{toc} >> object attribute into a data string
suitable for writing into a .imp file.  The format is determined by
C<< $self->{version} >>.

Returns that string, or undef if valid version or TOC data is not
found.

=cut

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;
}


=head2 C<resdirbase()>

In scalar context, this returns the basename of C<< $self->{resdirname} >>.
In list context, it actually returns the basename, directory, and
extension as per C<fileparse> from L<File::Basename>.

=cut

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


=head2 C<resdirlength()>

Returns the length of the .RES directory name as stored in
C<< $self->{resdirlength} >>.  Note that this does NOT recompute the
length from the actual name stored in C<< $self->{resdirname} >> --
for that, use L</set_resdirlength()>.

=cut

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};
}


=head2 C<resdirname()>

Returns the .RES directory name stored in C<< $self->{resdirname} >>.

=cut

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};
}


=head2 C<resource($type)>

Returns a hashref containing the resource data for the specified
resource type, as stored in C<< $self->{resources}->{$type} >>.

Returns undef if C<$type> is not specified, or if the specified type
is not found.

lib/EBook/Tools/IMP.pm  view on Meta::CPAN

            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;
}


=head2 C<write_imp($filename)>

Takes as a sole argument the name of a file to write to, and writes a
.imp file to that filename using the object attribute data.

Returns 1 on success, or undef if required data (including the
filename) was invalid or missing, or the file could not be written.

=cut

sub write_imp :method
{
    my ($self,$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(not $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;
}


=head2 C<write_resdir()>

Writes a C<.RES> resource directory from the object attribute data,
using C<< $self->{resdirname} >> as the directory name.

=cut

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");
    }

lib/EBook/Tools/IMP.pm  view on Meta::CPAN

<head>
  <meta http-equiv="CONTENT-TYPE" content="text/html; charset=windows-1252" />
END

    $self->{text} .= "  <title>$self->{title}</title>\n";
    $self->{text} .= "</head>\n<body>\n";

    my $pos = 0;
    my %ccharmap = (
        0x0A => "\n" . '<br style="page-break-before: always" />', # supported!
        0x0B => "\n<p>",
        0x0D => "<br />\n",
        0x0E => '',             # Start of <table>, not yet supported
        0x13 => '',             # End of table cell </td>, not yet supported
        0x14 => "\n<hr />\n",
        0x8E => "&eacute;",
        0xA0 => "&nbsp;",
        0xA5 => "&bull;",
        0xA8 => "&reg;",
        0xA9 => "&copy;",
        0xAA => "&trade;",
        0xAE => "&AElig;",
        0xC7 => "&laquo;",
        0xC8 => "&raquo;",
        0xC9 => "&hellip;",
        0xD0 => "&ndash;",
        0xD1 => "&mdash;",
        0xD2 => "&ldquo;",
        0xD3 => "&rdquo;",
        0xD4 => "&lsquo;",
        0xD5 => "&rsquo;",
        0xE1 => "&middot;",
        );

    while($pos < $textlength)
    {
        my $char = substr($$textref,$pos,1);
        my $ord = ord($char);

        if($ord == 0x0F)        # Image
        {
            $self->{text} .= $self->{offsetelements}->{$pos};
        }
        elsif(defined $ccharmap{$ord})
        {
            $self->{text} .= $ccharmap{$ord};
        }
        else
        {
            $self->{text} .= $char;
        }
        $pos++;
    }
    $self->{text} .= "\n</body>\n</html>";
    $self->{text} =~ s/\x15 .*? \x15//gx;        # Kill header - comment out?
    $self->{text} =~ s/\x16 .*? \x16//gx;        # Kill footer
    return $textlength;
}


=head2 C<parse_imp_toc_v1($tocdata)>

Takes as a single argument a string containing the table of contents
data, and parses it into object attributes following the version 1
format (10 bytes per entry).

=head3 Format

=over

=item * Offset 0x00 [4 bytes, text]

Resource name.  Stored in hash key C<name>.  In the case of the
'DATA.FRK' text resource, this will be four spaces (C<'    '>).

=item * Offset 0x04 [2 bytes, big-endian unsigned short int]

Unknown, but always zero or one.  Stored in hash key C<unknown1>.

=item * Offset 0x08 [4 bytes, big-endian unsigned long int]

Size of the resource data in bytes.  Stored in hash key C<size>.

=back

=cut

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

    my $length = length($tocdata);
    my $lengthexpected = 10 * $self->{filecount};
    my $tocentrydata;
    my $offset = 0;

    if($self->{version} != 1)
    {
        carp($subname,"(): attempting to parse a version 1 TOC,",
             " but the file appears to be version ",$self->{version},"!\n");
    }

    if($length != $lengthexpected)
    {
        carp($subname,"(): expected ",$lengthexpected," bytes, but received ",
             $length," -- aborting!\n");
        return;
    }

    $self->{toc} = ();
    foreach my $index (0 .. $self->{filecount} - 1)
    {
        my %tocentry;
        my @list;
        $tocentrydata = substr($tocdata,$offset,10);
        @list = unpack('a[4]nN',$tocentrydata);

        $tocentry{name}     = $list[0];
        $tocentry{unknown1} = $list[1];
        $tocentry{size}     = $list[2];

        debug(3,"DEBUG: found toc entry '",$tocentry{name},
              "', type '",$tocentry{type},"' [",$tocentry{size}," bytes]");
        push(@{$self->{toc}}, \%tocentry);
        $offset += 10;
    }

    return 1;
}


=head2 C<parse_imp_toc_v2($tocdata)>

Takes as a single argument a string containing the table of contents
data, and parses it into object attributes following the version 2
format (20 bytes per entry).

=head3 Format

=over

=item * Offset 0x00 [4 bytes, text]

Resource name.  Stored in C<name>.  In the case of the 'DATA.FRK' text
resource, this will be four spaces (C<'   '>).

=item * Offset 0x04 [4 bytes, big-endian unsigned long int]

Unknown, but always zero.  Stored in C<unknown1>.

=item * Offset 0x08 [4 bytes, big-endian unsigned long int]

Size of the resource data in bytes.  Stored in C<size>.

=item * Offset 0x0C [4 bytes, text]

Resource type.  Stored in C<type>, and used as the key for the stored
resource hash.

=item * Offset 0x10 [4 bytes, big-endian unsigned long int]

Unknown, but always either zero or one.  Stored in C<unknown2>.

=back

=cut

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

    my $length = length($tocdata);
    my $lengthexpected = 20 * $self->{filecount};
    my $template;
    my $tocentrydata;
    my $offset = 0;

    if($self->{version} != 2)
    {
        carp($subname,"(): attempting to parse a version 2 TOC,",
             " but the file appears to be version ",$self->{version},"!\n");
    }

    if($length != $lengthexpected)
    {
        carp($subname,"(): expected ",$lengthexpected," bytes, but received ",
             $length," -- aborting!\n");
        return;
    }

    $self->{toc} = ();
    foreach my $index (0 .. $self->{filecount} - 1)
    {
        my %tocentry;
        my @list;
        $tocentrydata = substr($tocdata,$offset,20);
        @list = unpack('a[4]NNa[4]N',$tocentrydata);

        $tocentry{name}     = $list[0];
        $tocentry{unknown1} = $list[1];
        $tocentry{size}     = $list[2];
        $tocentry{type}     = $list[3];
        $tocentry{unknown2} = $list[4];

        debug(3,"DEBUG: found toc entry '",$tocentry{name},
              "', type '",$tocentry{type},"' [",$tocentry{size}," bytes,",
              " unk1=",$tocentry{unknown1}," unk2=",$tocentry{unknown2},"]");
        push(@{$self->{toc}}, \%tocentry);
        $offset += 20;
    }

    return 1;
}


=head2 C<set_book_properties(%args)>

Sets the specified book properties.  Returns 1 on success, or undef if
no properties were specified.

=head3 Arguments

=over

=item * C<identifier>

The book identifier, as might be provided as an OPF C<< <dc:identifier> >>
element.

=item * C<category>

The main book category, as might be provided as an OPF C<< <dc:subject> >>
element.

=item * C<subcategory>

The subcategory, generally a set of search arguments for the ETI
website.

=item * C<title>

The book title, as might be provided as an OPF C<< <dc:title> >>
element.

=item * C<lastname>

The primary author's last name, but see the entry for C<firstname>
before deciding how to handle name storage.

=item * C<middlename>

The primary author's middle name, but see the entry for C<firstname>
before deciding how to handle name storage.

=item * C<firstname>