home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / BookFile.pm < prev    next >
Text File  |  1998-07-12  |  8KB  |  342 lines
  1. package RISCOS::BookFile::ResetPos;
  2. use IO::File;
  3. use strict;
  4. sub new ($$) {
  5.     my $proto = shift;
  6.     my $class = ref($proto) || $proto;
  7.     my $bookfile = shift;
  8.     my $self = [];
  9.     $$self[0] = $bookfile->{__HANDLE};
  10.  
  11.     return undef unless defined ($$self[1] = $$self[0]->tell);
  12.     bless ($self, $class);
  13. }
  14.  
  15. sub DESTROY {
  16.     my $self = shift;
  17.     $$self[0]->seek ($$self[1], &SEEK_SET);
  18. }
  19.  
  20. package RISCOS::BookFile;
  21.  
  22. require RISCOS::DrawFile;
  23. use RISCOS::DrawFile::Container 'split_drawobjs';
  24. $RISCOS::DrawFile::TextArea::Parser::cack = 1;
  25. require RISCOS::DrawFile::TextArea::Parser;
  26.  
  27. use IO::File;
  28. use RISCOS::Units qw(draw2inch);
  29. # require Exporter;
  30. use Carp;
  31. use strict;
  32. use vars qw (@ISA $VERSION $AUTOLOAD);
  33.  
  34.  
  35. # @ISA = qw(Exporter);
  36. $VERSION = 0.01;
  37.  
  38. sub open_file ($) {
  39.     return undef unless my $file = shift;
  40.     # If passed ref to scalar assume that we have been given the file's contents
  41.     return undef if ref($file) eq 'SCALAR' or ref($file) eq 'LVALUE';
  42.  
  43.     if (ref($file) ? (ref($file) eq 'GLOB'
  44.               || UNIVERSAL::isa($file, 'GLOB')
  45.               || UNIVERSAL::isa($file, 'IO::Handle'))
  46.            : (ref(\$file) eq 'GLOB'))
  47.     {
  48.     return $file;
  49.     }
  50.  
  51.     my $handle = new IO::File;
  52.     $handle->open ("<$file") or return undef;
  53.     return $handle;
  54. }
  55.  
  56. # Manual Name
  57. sub do_10000000 ($$) {
  58.     my $self = shift;
  59.     ($self->{__NAME}) = $_[0] =~ /^([^\0]*)/;
  60.     0;    # Keep going
  61. }
  62. # Page text
  63. sub do_10000001 ($$) {
  64.     1;    # Stop
  65. }
  66. # Page index
  67. sub do_10000002 ($$) {
  68.     my $self = shift;
  69.     ($self->{__PAGEINDEX}) = shift;
  70.     0;    # Keep going
  71. }
  72. # Graphic index
  73. sub do_10000003 ($$) {
  74.     my $self = shift;
  75.     ($self->{__GRAPHINDEX}) = shift;
  76.     0;    # Keep going
  77. }
  78. sub do_10000004 ($$) {
  79.     warn "\aGot a 10000004, length " . length $_[1];
  80.     1;
  81. }
  82. sub do_10000005 ($$) {
  83.     warn "\aGot a 10000005, length " . length $_[1];
  84.     1;
  85. }
  86. sub do_10000006 ($$) {
  87.     warn "\aGot a 10000006, length " . length $_[1];
  88.     1;
  89. }
  90. # Copyright
  91. sub do_10000007 ($$) {
  92.     my $self = shift;
  93.     ($self->{__COPY}) = $_[0] =~ /^([^\0]*)/;
  94.     0;    # Keep going
  95. }
  96. sub do_10000008 ($$) {
  97.     warn "\aGot a 10000008, length " . length $_[1];
  98.     1;
  99. }
  100. # Section indexes
  101. sub do_10000009 ($$) {
  102.     my $self = shift;
  103.     @{$self->{__SECTIONINDEXES}} = unpack 'I*', shift;
  104.     0;    # Keep going
  105. }
  106. sub do_00000006 ($$) {
  107.     1;    # Stop
  108. }
  109. sub do_00000005 ($$) {
  110.     1;    # Stop
  111. }
  112.  
  113. sub new ($$) {
  114.     my $proto = shift;
  115.     my $class = ref($proto) || $proto;
  116.     my $self  = {};
  117.     my $name = shift;
  118.     my $handle;
  119.     return undef
  120.       unless defined ($self->{__HANDLE} = $handle = open_file ($name));
  121.  
  122.     $self->{__FILENAME} = $name;
  123.  
  124.     my $temp;
  125.     return undef unless 40 == $handle->read($temp, 40);
  126.  
  127.     my ($id, $zero);
  128. #    $self->{__BBOX} = [];
  129.  
  130.     ($id, $self->{__MAJOR}, $self->{__MINOR}, $self->{__PAGEINDEX},
  131.      $self->{__GRAPHINDEX}, $zero, @{$self->{__BBOX}})    # @{} is crucial
  132.      = unpack 'A4V9', $temp;
  133.  
  134.     unless ($id eq 'Book') {
  135.     warn "ID '$id' not Book" if $^W;
  136.     return undef;
  137.     }
  138.  
  139.     if ($zero) {
  140.     warn "First zero word is actually $zero" if $^W;
  141.     return undef;
  142.     }
  143.  
  144.     warn "Version number $self->{__MAJOR} != 201"
  145.       unless $self->{__MAJOR} == 201;
  146.  
  147.     my $restore = new RISCOS::BookFile::ResetPos $self;
  148.     # Restore file position when we leave this routine
  149.  
  150.     while (!$self->{__HANDLE}->eof) {
  151.     my ($tag, $length, $data) = Object ($self);
  152.     last if eval sprintf "&do_%08X (\$self, \$data)", $tag;
  153.     }
  154.     bless ($self, $class);
  155. }
  156.  
  157. sub Name ($) {
  158.     my $self = shift;
  159.     $self->{__NAME};
  160. }
  161.  
  162. sub Copy ($) {
  163.     my $self = shift;
  164.     $self->{__COPY};
  165. }
  166.  
  167. sub Major ($) {
  168.     my $self = shift;
  169.     $self->{__MAJOR};
  170. }
  171.  
  172. sub Minor ($) {
  173.     my $self = shift;
  174.     $self->{__MAJOR};
  175. }
  176.  
  177. sub PageIndex ($) {
  178.     my $self = shift;
  179.     $self->{__PAGEINDEX}
  180. }
  181.  
  182. sub GraphIndex ($) {
  183.     my $self = shift;
  184.     $self->{__GRAPHINDEX}
  185. }
  186.  
  187. sub Object ($) {
  188.     my $self = shift;
  189.     my ($where, $tag, $length, $data, $handle);
  190.     $handle = $self->{__HANDLE};
  191.     return wantarray ? () : undef unless defined ($where = $handle->tell);
  192.  
  193.     unless (8 == $handle->read ($data, 8)) {
  194.     $handle->seek ($where, &SEEK_SET);
  195.     return wantarray ? () : undef;
  196.     }
  197.  
  198.     ($tag, $length) = unpack 'I2', $data;
  199.  
  200.     unless (($length - 8) == $handle->read ($data, ($length - 8))) {
  201.     $handle->seek ($where, &SEEK_SET);
  202.     return wantarray ? () : undef;
  203.     }
  204.  
  205.     return wantarray ? ($tag, $length, $data) : $tag . $length . $data;
  206. }
  207.  
  208. sub Dump ($) {
  209.     my $self = shift;
  210.     my @result = (
  211.       $self->{__NAME},
  212.       $self->{__COPY},
  213.       "Major: $self->{__MAJOR}\t\tMinor: $self->{__MINOR}",
  214.       "Page index at:\t\t$self->{__PAGEINDEX}",
  215.       "Graphic index at:\t$self->{__GRAPHINDEX}",
  216.       draw2inch ($self->{__BBOX}->[0]) . "\"\t" .
  217.       draw2inch ($self->{__BBOX}->[1]) . "\"\t" .
  218.       draw2inch ($self->{__BBOX}->[2]) . "\"\t" .
  219.       draw2inch ($self->{__BBOX}->[3]) . '"'
  220.     );
  221.     return @result if wantarray;
  222.     join "\n", @result, '';
  223. }
  224.  
  225. sub __decode_index ($$$$$) {
  226.     my ($name_index, $pos_index, $data, $length, $position) = @_;
  227.     my ($ofs, $datalen, $blk) = unpack "i3", substr $$data, $position;
  228.  
  229.     warn "$ofs != $position" unless $ofs == $position;
  230.  
  231.     my $end = $position + $datalen;
  232.     $position += 12;    # What we have read already
  233.  
  234.     __decode_index ($name_index, $pos_index, $data, $length, $blk)
  235.     unless ($blk == -1);
  236.     while ($position <= $end) {
  237.     ($blk, $ofs) = unpack "i2", substr $$data, $position;
  238.     __decode_index ($name_index, $pos_index, $data, $length, $blk)
  239.         unless ($blk == -1);
  240.     $position += 8;
  241.     my ($text) = substr ($$data, $position) =~ /([^\0]+)/;
  242.     $name_index->{$text} = $ofs;
  243.     $pos_index->{$ofs} = $text if defined $pos_index;
  244.     $position += 4+ length ($text) & ~3;
  245.     }
  246. }
  247.  
  248. sub DecodeIndex ($$) {
  249.     my $self = shift;
  250.     my $restore = new RISCOS::BookFile::ResetPos $self;
  251.     # Restore file position when we leave this routine
  252.  
  253.     my $handle = $self->{__HANDLE};
  254.  
  255.     unless ($handle->seek (4 + $_[0], &SEEK_SET)) {
  256.     return wantarray ? () : undef;
  257.     }
  258.  
  259.     my $data;
  260.     unless (4 == $handle->read ($data, 4)) {
  261.     return wantarray ? () : undef;
  262.     }
  263.  
  264.     my $length = unpack 'I', $data;
  265.  
  266.     unless ($length == $handle->read ($data, $length)) {
  267.     return wantarray ? () : undef;
  268.     }
  269.  
  270.     my ($name, $pos) = ({}, {});
  271.     undef $pos unless wantarray;
  272.     __decode_index ($name ,$pos, \$data, length ($data), 0);
  273.  
  274.     return wantarray ? ($name, $pos) : $name;
  275. }
  276.  
  277.  
  278. sub DecodePage ($) {
  279.     my $self = shift;
  280.     my $restore = new RISCOS::BookFile::ResetPos $self;
  281.     # Restore file position when we leave this routine
  282.  
  283.     my $handle = $self->{__HANDLE};
  284.  
  285.     unless ($handle->seek ($_[0], &SEEK_SET)) {
  286.     return wantarray ? () : undef;
  287.     }
  288.  
  289.     my $data;
  290.     unless (8 == $handle->read ($data, 8)) {
  291.     return wantarray ? () : undef;
  292.     }
  293.  
  294.     my ($type, $length) = unpack 'I2', $data;
  295.  
  296.     unless ($type == 0x10000001) {
  297.     warn sprintf "Unknown object type in page data (%08X)\n", $type;
  298.     return wantarray ? () : undef;
  299.     }
  300.  
  301.     print "Decoding $length bytes at offset $_[0]\n";
  302.     $length -= 12;
  303.  
  304.     unless (4 == $handle->read ($data, 4)) {
  305.     return wantarray ? () : undef;
  306.     }
  307.  
  308.     printf "Dummy (%08X)\n", unpack 'I', $data;
  309.  
  310.     unless ($length == read $handle, $data, $length) {
  311.     return wantarray ? () : undef;
  312.     }
  313.     my $split = RISCOS::DrawFile::Container->Objfunc();
  314.     $split->{9} = sub { RISCOS::DrawFile::TextArea::Parser->new (@_) };
  315.     split_drawobjs (undef, \$data, undef, undef, $split );
  316. }
  317.  
  318. sub bbox ($) {
  319.     my $data;
  320.     my $handle = shift;
  321.     unless (16 == $handle->read ($data, 16)) {
  322.     return ();
  323.     }
  324.     unpack 'I4', $data;
  325. }
  326.  
  327. sub scan_objects ($) {
  328.     my $book = shift;
  329.     my %skip = ( 0x10000001 => 'text', 5 => 'sprite', 6 => 'group' );
  330.     $! = 0;
  331.     while (!$book->{__HANDLE}->eof) {
  332.     my ($tag, $length) = Object ($book);
  333.     printf "Tag %08X, length %d\n", $tag, $length
  334.       if defined $tag and not $skip{$tag};
  335.     if ($!) {
  336.         warn $!;
  337.         $! = 0;
  338.     }
  339.     }
  340. }
  341. 1;
  342.