home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / Module.pm < prev    next >
Text File  |  1998-07-26  |  24KB  |  958 lines
  1. package RISCOS::Module::Command;
  2.  
  3. sub new {
  4.     my $proto = shift;
  5.     my $class = ref($proto) || $proto;
  6.     my $self  = {};
  7.     my ($module, $offset) = @_;
  8.  
  9.     $self->{'__NAME'} = RISCOS::Module::getmodtext ($module, $offset);
  10.     return wantarray ? () : undef
  11.       unless defined ($self->{'__NAME'}) && length $self->{'__NAME'};
  12.  
  13.     # This is now fileswitch proof:
  14.     $offset = ($offset + length ($self->{'__NAME'}) + 4) & ~3;
  15.     my ($code, $min, $gs, $max, $flags, $syntax, $help)
  16.       = unpack 'ICaC2I2', substr $module, $offset;
  17.  
  18.     return undef unless defined $help;
  19.  
  20.     $self->{'__MIN'} = $min;
  21.     $self->{'__MAX'} = $max;
  22.     $self->{'__GS'} = $gs;
  23.  
  24.     $self->{'__CODE'} = $code
  25.       if (RISCOS::Module::isvalid_not_zero (length ($module), $code) & 7) == 1;
  26.     $syntax = RISCOS::Module::getmodtext ($module, $syntax);
  27.     $self->{'__SYNTAX'} = $syntax if defined $syntax;
  28.     
  29.     my $_flags = [];
  30.     push @$_flags, 'filing system command' if ($flags & 0x80);
  31.     push @$_flags, 'status command' if ($flags & 0x40);
  32.     if ($flags & 0x20) {
  33.     push @$_flags, 'help is code';
  34.     $self->{'__HELP'} = $help
  35.       if (RISCOS::Module::isvalid_not_zero (length ($module), $help) & 7)
  36.            == 1;
  37.     } else {
  38.     $help = RISCOS::Module::getmodtext ($module, $help);
  39.     $self->{'__HELP'} = $help if defined $help;
  40.     }
  41.     
  42.     $self->{'__FLAGS'} = $_flags if @$_flags;
  43.       
  44.     bless ($self, $class);
  45.     return $self unless wantarray;
  46.     ($self, $offset + 16, $self->{'__NAME'})
  47. }
  48.  
  49. sub Name {
  50.     my $self = shift;
  51.     $self->{'__NAME'};
  52. }
  53.  
  54. sub Min {
  55.     my $self = shift;
  56.     $self->{'__MIN'};
  57. }
  58.  
  59. sub Max {
  60.     my $self = shift;
  61.     $self->{'__MAX'};
  62. }
  63.  
  64. sub GS_Flags {
  65.     my $self = shift;
  66.     return $self->{'__GS'} unless wantarray;
  67.     split //, unpack 'b*', $self->{'__GS'};
  68. }
  69.  
  70. sub Code {
  71.     my $self = shift;
  72.     $self->{'__CODE'};
  73. }
  74.  
  75. sub Syntax {
  76.     my $self = shift;
  77.     $self->{'__SYNTAX'};
  78. }
  79.  
  80. sub Help {
  81.     my $self = shift;
  82.     $self->{'__HELP'};
  83. }
  84.  
  85. sub Flags {
  86.     my $self = shift;
  87.     return wantarray ? () : undef
  88.       unless defined $self->{'__FLAGS'};
  89.     return @{$self->{'__FLAGS'}} if wantarray;
  90.     join ', ', @{$self->{'__FLAGS'}};
  91. }
  92.  
  93. sub Dump {
  94.     my $self = shift;
  95.     my @lines = ("Name:\t\t" . $self->Name()
  96.          . ($self->Flags() ? "\t(" . $self->Flags() . ')' : ''));
  97.     push @lines, "Syntax:\t\t" . $self->Syntax if defined $self->Syntax;
  98.     push @lines, "Help:\t\t" . $self->Help if defined $self->Help;
  99.     push @lines, "Parameters:\t" . (($self->Min == $self->Max)
  100.                      ? $self->Min
  101.                      : $self->Min . ' - ' . $self->Max);
  102.     push @lines, "GS Trans map:\t" . join ' ', $self->GS_Flags if $self->Max;
  103.     return @lines if wantarray;
  104.     join "\n", @lines, '';
  105. }
  106.  
  107. package RISCOS::Module;
  108.  
  109. use RISCOS::SWI;
  110. use RISCOS::ValidateAddr;
  111. use RISCOS::File 0.02;
  112. require Exporter;
  113. #use SelfLoader;
  114. use Carp;
  115. use strict;
  116. use vars qw (@ISA @EXPORT_OK $VERSION $os_mods $code_mask $work_mask
  117. $unsqueeze_code @offsets);
  118.  
  119. @ISA = qw(Exporter);
  120. @EXPORT_OK = qw(rm_private_word rm_workspace rm_code_addr rm_grab
  121. rmensure rm_unsqueeze split_help_string modules modules_only);
  122. $VERSION = 0.02;
  123.  
  124. $code_mask = ®mask([0,1],[3]);
  125. $work_mask = ®mask([0,1],[4]);
  126.  
  127. # Hmm. Magic numbers
  128. # Bits 0,1
  129. # 0 is invalid
  130. # 1 is in module
  131. # 2 is exactly at end
  132. # 3 is in module but top bit set
  133. # Bit 4 => Not word aligned
  134.  
  135. @offsets = (    # 1 (word aligned in module) is always valid.
  136.   ['start',     0, \&start_valid],
  137.   ['init',     4],    # Not [1,2] as we are checking after unsqueeze
  138.   ['final',     8, [3,7]],
  139.   ['service',     12],
  140.   ['title',     16, [5]],
  141.   ['help',     20, [0,4,5]],
  142.   ['command',     24, [5]],    # fileswitch has a non-word aligned table !!
  143.   ['SWIchunk',     28, \&swichunk_valid],        # Not a pointer :-)
  144.   ['SWIhandler', 32, [0,1,4]],
  145.   ['SWItable',     36, [0,1,4,5]],
  146.   ['SWIdecode',  40, [0,1,4]],
  147.   ['tokenfile',     44, [0,1,4,5]]
  148. );
  149.  
  150.  
  151. $unsqueeze_code = # A little bit of raw ARM code never hurt anyone
  152.  
  153. '8-) û ã?Îãå,Oâ?‘è
  154.  @à    ‘Jà€⇨à⇨o•âVá` ± ⇧àqŷà
  155. P á@ ã  á0àã°[â)ºÕä
  156. QâªQã
  157. ÕäÕä€áÕä€áTãÕ €0◰à0ŷäíÿÿê°Kà°⇧â0◰â0ŷäQâûÿÿÊæÿÿê\Qã0◰°0ŷ´âÿÿº®QâºÕäŴáÕä€á0◰à0ŷäÙÿÿê\QâÕäŴá0◰à0ŷäÓÿÿêTã ° áÀ á  á@ ãÊÿÿê° áP•âMo•â@ áµè§èUáûÿÿºð á‘⇨à€Hâ    Zá5Ú`zå0â    SâºzåŴáA†çêSâºzåŴáœçzåDŴáê@°á
  158. zåzå€ázå€ázåL€á&2 á    SâºzåŴáQ†ç0(éÜÿÿêSâºzåŴáœçzåTŴá0(éÓÿÿêP°á0(    Ðÿÿ
  159. zåzå€ázå€ázå\€á0(éÇÿÿê]ãÚ`Ià‘ á ⇨à¶è§èÐ]âûÿÿʽÿÿêð árcc 4.00
  160.       ';
  161.  
  162. $os_mods = SWINumberFromString('XOS_Module');
  163. #__DATA__
  164.  
  165. sub new {
  166.     my $proto = shift;
  167.     my $class = ref($proto) || $proto;
  168.     return undef unless my $code = rm_unsqueeze (shift);
  169.  
  170.     my $self  = {};
  171.     my $length = length $code;
  172.     my $skip = 0;
  173.  
  174.     foreach my $entry (@offsets)
  175.     {
  176.     my $offset = $$entry[1];
  177.  
  178.     if ($skip) {
  179.         $offset = 0;
  180.     } else {
  181.         # Translate the offset in the header into an offset in the module
  182.         $offset = getmodoffset ($code, $offset);
  183.  
  184.         my @acceptable = ();
  185.         my $status;
  186.  
  187.         if (ref $$entry[2] eq 'CODE')
  188.         {
  189.         # Only the SWI chunk ends up in here
  190.         @acceptable = (0,1);
  191.         $status = &{$$entry[2]} ($offset);
  192.         }
  193.         else
  194.         {
  195.         if (ref $$entry[2] eq 'ARRAY')
  196.         {
  197.             @acceptable = @{$$entry[2]};
  198.         }
  199.         $status = isvalid ($length, $offset);
  200.         }
  201.  
  202.         if ($status != 1)
  203.         {
  204.         my $fail = 1;
  205.         foreach (@acceptable) {
  206.             $fail = 0 if ($_ == $status)
  207.         }
  208.         if ($fail) {
  209.             carp sprintf "Invalid $$entry[0] module entry point of &%X",
  210.               $offset if $^W;
  211.             return undef;
  212.         }
  213.         }
  214.         if (($status & 3) == 0)
  215.         {
  216.         $offset = undef;
  217.         $skip = 1;    # Skip rest of module headers
  218.         }
  219.     }
  220.  
  221.     $self->{"___$$entry[0]"} = $offset;
  222.     }
  223.     $self->{'__TITLE'} = getmodtext ($code, $self->{'___title'});
  224.  
  225.     ($self->{'__NAME'}, $self->{'__VERSION'}, $self->{'__DATE'},
  226.       $self->{'__COMMENT'})
  227.       = split_help_string (getmodtext ($code, $self->{'___help'}));
  228.     delete $self->{'__COMMENT'} unless length $self->{'__COMMENT'};
  229.     
  230.     if (my $swi_off = $self->{'___SWItable'}) {
  231.     my $length = length ($self->{'__SWI_PREFIX'} =
  232.                        getmodtext ($code, $swi_off));
  233.     my @swis;
  234.     my $swi;
  235.     while ($length =
  236.          length ($swi = getmodtext ($code, $swi_off += $length + 1)))
  237.     {
  238.         push @swis, $swi;
  239.     }
  240.     $self->{'__SWIS'} = [@swis];
  241.     }
  242.  
  243.     if (my $command_off = $self->{'___command'}) {
  244.     my ($commands, $command_hash, $command, $name) = ([], {});
  245.     while (($command, $command_off, $name)
  246.     # Don't know why RISCOS::Module::Command->new( $code, $command_off)) {
  247.     # is SelfLoader-unfriendly
  248.     #  = RISCOS::Module::Command::new('RISCOS::Module::Command', $code, $command_off)) {
  249.        = RISCOS::Module::Command->new($code, $command_off)) {
  250.         push @$commands, $command;
  251.         $command_hash->{$name} = $command;
  252.     }
  253.     $self->{'__COMMANDS'} = $commands;
  254.     $self->{'__COMMAND_INDEX'} = $command_hash;
  255.     }
  256.  
  257.    my $token = getmodtext ($code, $self->{'___tokenfile'});
  258.     $self->{'__TOKEN'} = $token if $token;
  259.  
  260.     $self->{'__LENGTH'} = $length;
  261.     
  262.     bless ($self, $class);
  263.  
  264.     return ($self, $code) if wantarray;
  265.     $self;
  266. }
  267.  
  268. sub grab_from_os_heap ($) {
  269.     # This relies on the private word pointing at an OS_Heap block, and
  270.     # Acorn not re-writing OS_Heap. But apperntly a dodgy API means that it is
  271.     # virtually impossible for them _not_ to have the block length at addr-4
  272.     return undef unless defined (my $addr = shift);
  273.     return '' unless $addr;    # Private word == 0 means no workspace
  274.  
  275.     return '' unless validate_addr ($addr-4, $addr);
  276.     # Hey, this beauty worked first time!
  277.     my $pointer = pack 'I', $addr - 4;
  278.     my $len = (unpack 'I', unpack 'P4', $pointer) - 4;
  279.     # Validate that we can read the word before, and then read it!
  280.  
  281.     return '' unless validate_addr ($addr, $addr + $len);
  282.  
  283.     $pointer = pack 'I', $addr;
  284.  
  285.     unpack "P$len", $pointer;    # Who said perl was safe?
  286. }
  287.  
  288. sub rm_private_word ($) {
  289.     return undef unless my $name = shift;
  290.     my $addr = 'x'x4;
  291.  
  292.     return undef unless swix ($os_mods, $work_mask, 18, $name, $addr);
  293.  
  294.     return unpack 'I', $addr;
  295. }
  296.  
  297. sub rm_code_addr ($) {
  298.     return undef unless my $name = shift;
  299.     my $addr = 'x'x4;
  300.  
  301.     return undef unless swix ($os_mods, $code_mask, 18, $name, $addr);
  302.  
  303.     return unpack 'I', $addr;
  304. }
  305.  
  306. sub rm_workspace ($) { grab_from_os_heap (&rm_private_word) }
  307. sub rm_grab ($) { grab_from_os_heap (&rm_code_addr) }
  308.  
  309. sub start_valid {
  310.     1;    # It's always valid (treated as an ARM instruction if not an offset)
  311. }
  312.  
  313. sub swichunk_valid {
  314.     !($_[0] & 0xFF00003F)    # Is it a multiple of 64 ?
  315. }
  316.  
  317. sub isvalid ($;@) {
  318.     return undef unless defined (my $length = shift);
  319.     my @result;
  320.  
  321.     foreach (@_)
  322.     {
  323.     my $result;
  324.     if (defined)
  325.     {
  326.         $result = 0;
  327.         my $top = ($_ & 0x80000000);
  328.         $_ &= 0x7FFFFFFF if $top;
  329.         if ($_ >= 0 && $_ < $length)
  330.         {
  331.         $result = $top ? 3 : 1;    # Inside module.
  332.         }
  333.         elsif ($top && $_ == $length)
  334.         {
  335.         $result = 2;        # At end of module.
  336.         }
  337.         $result |= 4 if $_ & 3;    # Not a multiple of 4
  338.     }
  339.     push @result, $result;
  340.     }
  341.     return $result[0] unless wantarray;
  342.     @result;
  343. }
  344.  
  345. sub isvalid_not_zero ($;@) {
  346.     return undef unless defined (my $length = shift);
  347.     my @result = @_;
  348.  
  349.     foreach (@result) {
  350.     $_-- unless $_;        # 0 -> -1;
  351.     }
  352.     
  353.     isvalid ($length, @result);
  354. }
  355.     
  356.  
  357. sub grab {
  358.     my $proto = shift;
  359.     new ($proto, &rm_grab);    # Pass on parameter
  360. }
  361.  
  362. sub load {
  363.     my ($proto, $file) = @_;
  364.  
  365.     my $code = RISCOS::File::load ($file);
  366.     unless (defined $code) {
  367.       carp "Could not load file '$file'" if $^W;
  368.       return undef;
  369.     }
  370.     new ($proto, $code);
  371. }
  372.  
  373. sub getmodoffset ($$) {
  374.     my ($module, $offset) = @_;
  375.     return undef unless defined $offset;
  376.     unpack 'I', substr $module, $offset, 4;
  377. }
  378.  
  379. sub getmodtext ($$) {
  380.     my ($module, $offset) = @_;
  381.     # Must be inside module
  382.     return undef unless defined $module and defined $offset
  383.             and (isvalid_not_zero (length ($module), $offset) & 3) 
  384.                   == 1;
  385.     (substr $module, $offset) =~ /^([^\0]*)/s;
  386.     $1;
  387. }
  388.  
  389. sub Title {
  390.     my $self = shift;
  391.     $self->{'__TITLE'};
  392. }
  393.  
  394. sub Name {
  395.     my $self = shift;
  396.     $self->{'__NAME'};
  397. }
  398. sub Version {
  399.     my $self = shift;
  400.     $self->{'__VERSION'};
  401. }
  402. sub Date {
  403.     my $self = shift;
  404.     $self->{'__DATE'};
  405. }
  406. sub Comment {
  407.     my $self = shift;
  408.     $self->{'__COMMENT'};
  409. }
  410.  
  411. sub Length {
  412.     my $self = shift;
  413.     $self->{'__LENGTH'};
  414. }
  415.  
  416. sub Start {
  417.     my $self = shift;
  418.     my $offset = $self->{'___start'};
  419.     return undef unless $offset;
  420.     return $offset if (isvalid ($self->{'__LENGTH'}, $offset) & 7) == 1;
  421.     require ARM;
  422.     return ARM::disassemble ($offset) if defined \&ARM::disassemble;
  423.     sprintf "&%08X", $offset;    # Failed to get disassembler.
  424. }
  425.  
  426. sub Init {
  427.     my $self = shift;
  428.     $self->{'___init'} ? $self->{'___init'} : undef;
  429. }
  430. sub Final {
  431.     my $self = shift;
  432.     $self->{'___final'} ? $self->{'___final'} : undef;
  433. }
  434. sub Service {
  435.     my $self = shift;
  436.     $self->{'___service'} ? $self->{'___service'} : undef;
  437. }
  438. sub SWIchunk {
  439.     my $self = shift;      
  440.     $self->{'___SWIchunk'} ? $self->{'___SWIchunk'} : undef;
  441. }
  442. sub SWIhandler {
  443.     my $self = shift;
  444.     $self->{'___SWIhandler'} ? $self->{'___SWIhandler'} : undef;
  445. }
  446. sub SWIdecode {
  447.     my $self = shift;
  448.     $self->{'___SWIdecode'} ? $self->{'___SWIdecode'} : undef;
  449. }
  450.  
  451. sub TokenFile {
  452.     my $self = shift;
  453.     $self->{'__TOKEN'};
  454. }
  455.  
  456. sub CommandTable {
  457.     my $self = shift;
  458.     $self->{'__COMMANDS'};
  459. }
  460. sub CommandHash {
  461.     my $self = shift;
  462.     $self->{'__COMMAND_INDEX'};
  463. }
  464. sub Command {
  465.     my $self = shift;
  466.     defined ($self->{'__COMMAND_INDEX'}) ? $self->{'__COMMAND_INDEX'}->{$_[0]}
  467.                      : undef;
  468. }
  469.  
  470. sub SWIPrefix {
  471.     my $self = shift;
  472.     $self->{'__SWI_PREFIX'};
  473. }
  474. sub SWITable {
  475.     my $self = shift;
  476.     $self->{'__SWIS'};
  477. }
  478.  
  479. sub Dump {
  480.     my $self = shift;
  481.     my @lines;
  482.     
  483.     foreach my $thing (qw(Title Version Date Comment Start Init Final Service
  484.     TokenFile SWIhandler SWIdecode)) {
  485.     my $value;
  486.     if (eval "defined (\$value = \$self->$thing)") {
  487.         my $line = "$thing:\t";
  488.         $line .= "\t" if length $line < 8;
  489.         push @lines, "$line$value";
  490.     }
  491.     }
  492.     push @lines, '';
  493.     my $table;
  494.     if ($table = $self->SWITable and @$table) {
  495.     my $prefix = $self->SWIPrefix;
  496.     my $swi = $self->SWIchunk;
  497.     push @lines, "SWIs:";
  498.     foreach (@$table) {
  499.         push @lines, sprintf "&%06X: ${prefix}_$_", $swi++;
  500.     }
  501.     push @lines, '';
  502.     }
  503.     if ($table = $self->CommandTable and @$table) {
  504.     foreach (@$table) {
  505.         push @lines, $_->Dump, '';
  506.     }
  507.     }
  508.     return join "\n", @lines unless wantarray;
  509.     pop @lines;    # Loose final ''
  510.     @lines;
  511. }
  512.  
  513. sub split_help_string ($) {
  514.     $_[0] =~ /([\S ]*)\t+([0-9.a-zß]+)\s*\((.*?)\)\s*(.*)/;
  515.     ($1, $2, $3, $4);
  516. }
  517.  
  518. sub rmensure ($;$$) {
  519.     my ($name, $path, $version) = @_;
  520.     $version += 0;    # Default version is 0
  521.     $path = "System:Modules.$name" unless defined $path;
  522.  
  523.     my $word = 'xxxx';
  524.     # Hack to get the address of the xxxx
  525.     my $addr = unpack 'I', pack 'p', $word;
  526.     my $command = "RMEnsure $name $version RMLoad $path";
  527.     kernelswi ('OS_CLI', $command);
  528.  
  529.     # Darren Salt's truely evil rmensure idea...
  530.     $command = "RMEnsure $name $version MemoryA 10_$addr 0 { > Null: }";
  531.     # Execute the MemoryA command if RMEnsure fails, to alter the flag
  532.  
  533.     return undef unless defined kernelswi ('OS_CLI', $command);
  534.     ('xxxx' eq $word) ? 1 : 0;
  535. }
  536.  
  537. sub rm_unsqueeze ($) {
  538.     my $module = shift;
  539.     return undef unless defined $module;
  540.     my $result;
  541.     my $init = getmodoffset ($module, 4);
  542.     my $length = length $module;
  543.     my $status = isvalid ($length, $init);
  544.  
  545.     return $module if ($status == 1);    # It's not squeezed
  546.     return undef unless $status == 2;    # Check - is it exactly at end?
  547.  
  548.     my ($present, $place);
  549.  
  550.     foreach $place (undef, 'Patch:Modules.Unsqueeze',
  551.             'ADFS::4.$.Utilities.Patches.!Patch.Modules.UnSqueeze')
  552.     {
  553.     $present = rmensure ('Unsqueeze', $place, 1.23);
  554.         croak "Unexpected error when checking for UnSqueeze module: $^E"
  555.     unless (defined $present);
  556.     last if $present;
  557.     }
  558.  
  559.     unless ($present)
  560.     {
  561.     my $error = 'Could not load the UnSqueeze module, which is needed to '
  562.             . 'unsqueeze compressed modules. A copy of this module '
  563.             . 'is found in the !Patch application supplied by Acorn.';
  564.     my $patch = $ENV{'Patch$Path'};
  565.     if (defined $patch)
  566.     {
  567.         $patch =~ s/\.$//;
  568.         $error .= " That's strange. Patch seems to be $patch but the module"
  569.               . ' UnSqueeze could not be loaded from its Modules '
  570.               . "subdirectory. Most odd.\n";
  571.     }
  572.     die $error
  573.     }
  574.  
  575.     # Righto. Got the Unsqueeze module.
  576.     my $convert = RISCOS::Filespec::convert();
  577.     RISCOS::Filespec::convert_on();
  578.     my $tmpfile = 'mod000';
  579.     my $text = ' temporary file to unsqueeze module: ';
  580.     ++$tmpfile while -f "/tmp/$tmpfile";
  581.     my $tmpout = $tmpfile;
  582.     ++$tmpout;    # Move beyond input file
  583.     ++$tmpout while -f "/tmp/$tmpout";
  584.     $tmpfile = "/tmp/$tmpfile";
  585.     $tmpout = "/tmp/$tmpout";
  586.     open MOD, ">$tmpfile"
  587.       or croak "Couldn't open$text$!";
  588.  
  589.     local $\;    # Don't want output record separator.
  590.     undef $\;    # N has a nasty habit of setting this to "\n" with -l flag
  591.     my $offset = getmodoffset ($module, 20);
  592.     $offset += (length (getmodtext ($module, $offset)) + 8) & -4;
  593.     $length -= $offset;
  594.     substr ($unsqueeze_code, 0, 4)
  595.       = (getmodoffset ($module, 16) != 52)
  596.     ? pack 'I', 0x180 # increase this if it fails to unsqueeze large modules
  597.     : substr ($module, 48, 4);
  598.  
  599.     print MOD pack ('I', (0xEA000000 | (($length + 15) >> 2))),
  600.           substr ($module, $offset), $unsqueeze_code
  601.       or warn "Couldn't write$text$!";
  602.  
  603.     close MOD
  604.       or croak "Couldn't close$text$!";
  605.  
  606.     RISCOS::File::settype (0xFF8, $tmpfile)
  607.       or croak "Couldn't settype$text$!";
  608.  
  609.     if (system 'UnSqueeze ' . RISCOS::Filespec::riscosify ($tmpfile) . ' '
  610.            . RISCOS::Filespec::riscosify ($tmpout))
  611.     {
  612.       warn "Failed to run unsqueeze command\n";
  613.     }
  614.     else
  615.     {
  616.     if (open MOD, "<$tmpout")
  617.     {
  618.         local $/; undef $/; $result = <MOD>;
  619.         close MOD
  620.     }
  621.     else
  622.     {
  623.         warn "Couldn't open unsqueeze output file: $!";
  624.     }
  625.     }
  626.  
  627.     unlink $tmpfile, $tmpout;
  628.     RISCOS::Filespec::convert($convert);
  629.     $result;
  630. }
  631.  
  632. sub modules {
  633.     my ($previous, $mod, $inst) = (-1, 0, 0);
  634.     my ($postfix, $with, $without) = '';
  635.     my @result;
  636.     
  637.     while (defined $postfix) {
  638.     my $base;
  639.     
  640.     my $result = kernelswi ($os_mods, 12, $mod, $inst);
  641.     if (defined $result) {
  642.         ($mod, $inst, $base, $postfix) = unpack 'x4I3x4p', $result;
  643.     
  644.         my $module = grab_from_os_heap ($base);
  645.     
  646.         push @result, ($mod == $previous) ? $with : $without
  647.           if defined $with;
  648.         $without = getmodtext ($module, getmodoffset ($module, 16));
  649.         $with = "$without%$postfix";
  650.         $without = $with if $inst;
  651.         $previous = $mod;
  652.     } else {
  653.         $mod++; $inst = 0; undef $postfix;
  654.         push @result, $without;
  655.     }
  656.    }
  657.    
  658.    @result;
  659. }
  660.  
  661. sub modules_only {
  662.     my $mod = 0;
  663.     my (@result, $base, $result);
  664.     
  665.     while (defined ($result = kernelswi ($os_mods, 12, $mod++, 0))) {
  666.     $base = unpack 'x12I', $result;
  667.     
  668.     my $module = grab_from_os_heap ($base);
  669.     
  670.     push @result, getmodtext ($module, getmodoffset ($module, 16));
  671.     }
  672.     
  673.     @result;
  674. }
  675.  
  676. $os_mods;
  677. __END__
  678.  
  679. =head1 NAME
  680.  
  681. RISCOS::Module -- manipulate relocatable modules
  682.  
  683. =head1 SYNOPSIS
  684.  
  685.     use RISCOS::Module;
  686.  
  687.     $mod = grab RISCOS::Module $mod;
  688.     print scalar $mod->Dump if $mod;
  689.  
  690.     $cooked = rm_unsqueeze $raw;
  691.  
  692.     $code    = rm_grab $mod;
  693.     $workspace    = rm_workspace $mod;
  694.  
  695. =head1 DESCRIPTION
  696.  
  697. C<RISCOS::Module> provides a class to hold details about a relocatable module,
  698. and a variety of subroutines to manipulate entire relocatable modules and their
  699. workspace from disc and the C<RMA>.
  700.  
  701. =head2 Subroutines
  702.  
  703. =over 4
  704.  
  705. =item rm_private_word <module_name>
  706.  
  707. Returns the contents of a module's private word. Typically this points to the
  708. modules workspace.
  709.  
  710. =item rm_workspace <module_name>
  711.  
  712. Returns the contents of the module workspace (by assuming that the module's
  713. private word points to an area of workspace in the RMA, where the length of
  714. workspace is stored in the preceding word)
  715.  
  716. =item rm_code_addr <module_name>
  717.  
  718. Returns the address of the module's code.
  719.  
  720. =item rm_grab <module_name>
  721.  
  722. Returns the module's code.
  723.  
  724. =item rmensure <module> [, <path> [,<version>]]
  725.  
  726. Emulates the C<RMEnsure> command. If a copy of I<module> of version I<version>
  727. or higher is not present will attempt to C<RMLoad> a module from I<path>.
  728. I<version> defaults to 0, I<path> defaults to 'C<System:Modules.I<module>>'.
  729.  
  730. Returns undefined if an error occurs, 0 if the module is still absent after the
  731. C<RMLoad> command, 1 if the module is present (before or after the command is
  732. run).
  733.  
  734. The method used is a perl conversion of an idea by Darren Salt 
  735. <F<arcsalt@spuddy.mew.co.uk>>.
  736.  
  737. =item rm_unsqueeze <module>
  738.  
  739. Returns the "unsqeezed" version of the B<module> passed in. The entire module
  740. code should be in the scalar, not the name of a module. "unsqeezing" requires
  741. the 'C<UNSqeeze>' module and use of a disc file. (The 'C<UNSqueeze>' module
  742. found in C<!Patch> - C<rm_unsqueeze> will look there and in C<!System.Modules>
  743. for this module).
  744.  
  745. =item split_help_string <string>
  746.  
  747. Splits a module help string into I<Name>, I<Version>, I<Date> and I<Comment>.
  748. Returns an array with these four elements.
  749.  
  750. =item modules
  751.  
  752. Unlike C<modules_only> this will include multiply instantiated modules multiple
  753. times - I<i.e.>: 
  754.  
  755.     FileCore%ADFS
  756.     FileCore%Base
  757.  
  758. =item modules_only
  759.  
  760. Returns a list of the names of all modules in the C<RMA>. Multiply instantiated
  761. modules are only returned once in the list.
  762.  
  763. =back
  764.  
  765. =head2 Methods
  766.  
  767. The C<RISCOS::Module> class provides the following methods:
  768.  
  769. =over 4
  770.  
  771. =item new <module>
  772.  
  773. Creates a new C<RISCOS::Module> object from the module B<code> passed in. C<new>
  774. automatically calls C<rm_unsqueeze>. Returns the object.
  775.  
  776. =item grab <module_name>
  777.  
  778. Grabs the named module from the C<RMA> and calls C<new> with it.
  779.  
  780. =item load <filename>
  781.  
  782. Loads the file using C<RISCOS::File::load> and calls C<new>. Hence I<filename>
  783. can be a filename, a reference to a filehandle, or a reference to a scalar which
  784. is used as the file's contents.
  785.  
  786.  
  787. =item Title
  788.  
  789. Returns the module's title (as found from the C<title> offset).
  790.  
  791. =item Name
  792.  
  793. Returns the module's name (obtained by splitting the help string).
  794.  
  795. =item Version
  796.  
  797. Returns the module's version.
  798.  
  799. =item Date
  800.  
  801. Returns the module's date.
  802.  
  803. =item Comment
  804.  
  805. Returns the module's comment (any text in the help string after the date).
  806.  
  807. =item Length
  808.  
  809. Returns the module's length.
  810.  
  811. =item Start
  812.  
  813. Returns the module's start offset. If the start offset is non-zero but invalid
  814. (not a multiple of four within the module) it is disassembled and the
  815. instruction returned. Returns undefined if the start offset is zero.
  816.  
  817. =item Init
  818.  
  819. Returns the module's initialisation code offset, or undefined if there is no
  820. initialisation code.
  821.  
  822. =item Final
  823.  
  824. Returns the module's finalisation code offset, or undefined if there is no
  825. finalisation code.
  826.  
  827. =item Service
  828.  
  829. Returns the module's service call handler offset, or undefined if there is no
  830. service call code.
  831.  
  832. =item TokenFile
  833.  
  834. Returns the name of the textfile containing tokens used in the module's command
  835. text.
  836.  
  837. =item CommandTable
  838.  
  839. Returns a reference to an array of C<RISCOS::Module::Command> objects (see
  840. below) that describe the C<*> commands provided by the module. If the module
  841. provides no commands, C<CommandTable> returns undefined.
  842.  
  843. =item CommandHash
  844.  
  845. Returns a reference to an array of C<RISCOS::Module::Command> objects, keyed by
  846. command name.  If the module provides no commands, C<CommandHash> returns
  847. undefined.
  848.  
  849. =item Command <name>
  850.  
  851. Looks up I<name> in the hash of C<*> commands provided by the module. Returns a
  852. C<RISCOS::Module::Command> object if found, else undefined.
  853.  
  854. =item SWIchunk
  855.  
  856. Returns the module's C<SWI> chunk number, or undefined if the module does not
  857. provide C<SWI>s (using the module header entries).
  858.  
  859. =item SWIhandler
  860.  
  861. Returns the module's C<SWI> handler code offset, or undefined if there is no
  862. C<SWI> handler code.
  863.  
  864. =item SWIdecode
  865.  
  866. Returns the module's C<SWI> decoding code offset, or undefined if there is no
  867. C<SWI> decoding code.
  868.  
  869. =item SWIPrefix
  870.  
  871. Returns the module's C<SWI> prefix, or undefined if the module does not provide
  872. C<SWI>s. 
  873.  
  874. =item SWITable
  875.  
  876. Returns a reference to an array of C<SWI> names provided by the module. These
  877. are not prefixed by the C<SWI> prefix - for example the WindowManager will
  878. return
  879.  
  880.     ['Initialise', 'CreateWindow', 'CreateIcon',
  881.  
  882. I<etc.>
  883.  
  884. =item Dump
  885.  
  886. Returns a text dump of the module. In array context returns a list of lines. In
  887. scalar context joins these with "\n";
  888.  
  889. =back
  890.  
  891. =head2 RISCOS::Module::Command
  892.  
  893. The C<RISCOS::Module::Command> class provides the following methods:
  894.  
  895. =over 4
  896.  
  897. =item new <module_data>, <offset>
  898.  
  899. Creates a new Command object from the command table entry stored at I<offset> in
  900. the module data supplied. Returns this object in scalar context - in list
  901. context returns C<(object, new-offset, name).
  902.  
  903. =item Name
  904.  
  905. Returns the command's name.
  906.  
  907. =item Min
  908.  
  909. Returns the minimum number of parameters to the command.
  910.  
  911. =item Max
  912.  
  913.  
  914. Returns the maximum number of parameters to the command.
  915.  
  916.  
  917. =item GS_Flags
  918.  
  919. Returns the command's C<GSTrans> flags. In scalar context returns a byte
  920. corresponding to the byte in the command table. For any bit set that number
  921. parameter will be passed to C<GSTrans> before the command is called. In array
  922. context expands this byte and returns a list with 8 elements, each either 0 or
  923. 1. Element 0 refers to parameter 0.
  924.  
  925. =item Code
  926.  
  927. Returns the offset to the command's code.
  928.  
  929. =item Syntax
  930.  
  931. Returns the command's syntax text.
  932.  
  933. =item Help
  934.  
  935. Returns the command's help text, or the offset to the command's help code.
  936.  
  937. =item Flags
  938.  
  939. Returns the command's flags. In array context returns a list of text strings.
  940. In scalar context joins these with ', '
  941.  
  942. =item Dump
  943.  
  944. Returns a text dump of the command. In array context returns a list of lines. In
  945. scalar context joins these with "\n";
  946.  
  947. =back
  948.  
  949. =head1 BUGS
  950.  
  951. None known. However, running C<new> on all modules in my C<RMA> found a couple
  952. that I fixed (I<e.g.> C<Fileswitch> has a non-word aligned command table, which
  953. is legal, but caught me out), so there may still be some.
  954.  
  955. =head1 AUTHOR
  956.  
  957. Nicholas Clark <F<nick@unfortu.net>>
  958.