home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 Mobile / Chip_Mobile_2001.iso / palm / system / _palmemu / palmemu.exe / Scripting / Perl / EmRPC.pm < prev    next >
Text File  |  2000-01-27  |  30KB  |  1,268 lines
  1. ########################################################################
  2. #
  3. #    File:            EmRPC.pm
  4. #
  5. #    Purpose:        Low-level functions for using RPC with the Palm OS
  6. #                    Emulator.
  7. #
  8. #    Description:    This file contains base functions for using RPC:
  9. #
  10. #                    OpenConnection
  11. #                        Opens a socket to the Emulator
  12. #
  13. #                    CloseConnection
  14. #                        Closes the socket
  15. #
  16. #                    DoRPC
  17. #                        Full-service RPC packet sending and receiving,
  18. #                        including marshalling and unmarshalling of
  19. #                        parameters.
  20. #
  21. #                    ReadBlock
  22. #                        Read up to 256 bytes from the remote device's
  23. #                        memory.
  24. #
  25. #                    WriteBlock
  26. #                        Write up to 256 bytes to the remote device's
  27. #                        memory.
  28. #
  29. #                    ReadString
  30. #                        Read a C string from the remote device's memory.
  31. #
  32. #                    PrintString
  33. #                        Debugging utility.  Prints a Perl string
  34. #                        (block of arbitrary data) as a hex dump.
  35. #
  36. ########################################################################
  37.  
  38. package EmRPC;
  39.  
  40. use Exporter ();
  41. @ISA = qw(Exporter);
  42.  
  43. @EXPORT_OK = qw(
  44.     OpenConnection CloseConnection
  45.     DoRPC
  46.     ReadBlock WriteBlock
  47.     ReadString PrintString
  48. );
  49.  
  50. use IO::Socket;
  51.  
  52. use constant slkSocketDebugger        =>    0;    # Debugger Socket
  53. use constant slkSocketConsole        =>    1;    # Console Socket
  54. use constant slkSocketRemoteUI        =>    2;    # Remote UI Socket
  55. use constant slkSocketDLP            =>    3;    # Desktop Link Socket
  56. use constant slkSocketFirstDynamic    =>    4;    # first dynamic socket ID
  57. use constant slkSocketPoserRPC        => 14;
  58.  
  59. use constant slkPktTypeSystem        =>    0;    # System packets
  60. use constant slkPktTypeUnused1        =>    1;    # used to be: Connection Manager packets
  61. use constant slkPktTypePAD            =>    2;    # PAD Protocol packets
  62. use constant slkPktTypeLoopBackTest    =>    3;    # Loop-back test packets
  63.  
  64.  
  65. ########################################################################
  66. #
  67. #    FUNCTION:        OpenConnection
  68. #
  69. #    DESCRIPTION:    Open a socket-based connection to Poser.
  70. #
  71. #    PARAMETERS:        Port number to talk to (hint, try 6415).
  72. #                    IP address of computer to talk to.  Can be null
  73. #                        to use localhost.
  74. #
  75. #    RETURNED:        Nothing. Dies if fail to connect.
  76. #
  77. ########################################################################
  78.  
  79. sub OpenConnection
  80. {
  81.     ($port_number, $ip_address) = @_;
  82.  
  83.     if (not defined($sock))
  84.     {
  85.         if (defined($ip_address))
  86.         {
  87.             $remote = $ip_address;
  88.         }
  89.         else
  90.         {
  91.             $remote = "localhost";
  92.         }
  93.  
  94.         $port = $port_number;
  95.  
  96.         $sock = new IO::Socket::INET(    PeerAddr => $remote,
  97.                                         PeerPort => $port,
  98.                                         Proto => 'tcp');
  99.  
  100.         die "cannot connect to poser port. Reason: $@\n" unless $sock;
  101.     }
  102. }
  103.  
  104.  
  105. ########################################################################
  106. #
  107. #    FUNCTION:        CloseConnection
  108. #
  109. #    DESCRIPTION:    Close the socket connection to Poser.
  110. #
  111. #    PARAMETERS:        None.
  112. #
  113. #    RETURNED:        Nothing.
  114. #
  115. ########################################################################
  116.  
  117. sub CloseConnection
  118. {
  119.     close ($sock);
  120.     undef $sock;
  121. }
  122.  
  123.  
  124. ########################################################################
  125. #
  126. #    FUNCTION:        DoRPC
  127. #
  128. #    DESCRIPTION:    Performs full, round-trip RPC service.
  129. #
  130. #    PARAMETERS:        Trap word of function to call.
  131. #                    Format string describing parameters.
  132. #                    Parameters to pass in the RPC call.
  133. #
  134. #                    The format string contains a series of format
  135. #                    descriptors.  Descriptors must be seperated by
  136. #                    some sort of delimiter, which can be a space, a
  137. #                    common, a colon, or any combination of those. Each
  138. #                    descriptor has the following format:
  139. #
  140. #                        <type><optional size><optional "*">
  141. #
  142. #                    The "type" describes the parameter in the format
  143. #                    expected by the Palm OS.  The RPC routines will
  144. #                    convert the Perl variable corresponding to the
  145. #                    parameter into the described type.  The following
  146. #                    types are supported:
  147. #
  148. #                        int:        integer
  149. #                        Err:        2 byte integer
  150. #                        Coord:        2 byte integer;
  151. #                        LocalID:    4 byte integer
  152. #                        HostErr:    4 byte integer
  153. #                        string:        C string
  154. #                        rptr:        Pointer to something back on
  155. #                                    the emulated device
  156. #                        point:        Palm OS PointType
  157. #                        rect:        Palm OS RectangleType
  158. #                        block:        Block of arbitrary data
  159. #
  160. #                    Some format types can accept a size specifier
  161. #                    after them.  This size specifier is used when
  162. #                    a default parameter size cannot be implied, or
  163. #                    when you want to override the default parameter
  164. #                    size.  The following describes how the size
  165. #                    specifier is handled for each parameter type:
  166. #
  167. #                        int:
  168. #                            Length specifier must be supplied, and
  169. #                            must be one of 8, 16, or 32.
  170. #
  171. #                        string:
  172. #                            Default length is the value as returned
  173. #                            by Perl's "length" function plus one.
  174. #                            You can override this value by including
  175. #                            your own length specifier.
  176. #
  177. #                        block:
  178. #                            Default length is the value as returned
  179. #                            by Perl's "length" function.  You can
  180. #                            override this value by including your
  181. #                            own length specifier.
  182. #
  183. #                        all others:
  184. #                            Any specified size is ignored.
  185. #
  186. #                    In general, integer types are passed by value, and
  187. #                    all other types are passed by reference.  That is
  188. #                    after all the parameters are marhsalled, sent to
  189. #                    the emulator, and unmarshalled, the "pass by value"
  190. #                    parameters are pushed directly onto the emulated
  191. #                    stack, and "pass by reference" parameters have
  192. #                    their addresses pushed onto the stack.  You can
  193. #                    can change this behavior in one way: if you way
  194. #                    an integer to be passed by reference, then you
  195. #                    can append a "*" to its format specifier.
  196. #
  197. #                    Examples:
  198. #
  199. #                        "int16"
  200. #                            Pass a 2 byte integer
  201. #
  202. #                        "int32 string"
  203. #                            Pass a 4 byte integer, followed by
  204. #                            a C-string
  205. #
  206. #                        "block32"
  207. #                            Pass a 32 byte buffer, filling in
  208. #                            its contents as much as possible
  209. #                            with the given data
  210. #
  211. #                        "int16 in32 int32*"
  212. #                            Pass a 2 byte integer, followed by
  213. #                            a 4 byte integer, followed by a
  214. #                            4 byte integer passed by reference.
  215. #
  216. #    RETURNED:        List containing:
  217. #                        Register D0
  218. #                        Register A0
  219. #                        Full parameter list.  If any parameters were
  220. #                            "pass by reference", you'll receive the
  221. #                            updated parameters.  If parameters are
  222. #                            "pass by value", you'll get them back just
  223. #                            the same way you provided them.
  224. #
  225. ########################################################################
  226.  
  227. sub DoRPC
  228. {
  229.     my ($trap_word, $format, @parameters) = @_;
  230.  
  231.     my ($slkSocket)        = slkSocketPoserRPC;
  232.     my ($slkPktType)    = slkPktTypeSystem;
  233.     my ($send_body)        = EmRPC::MakeRPCBody ($trap_word, $format, @parameters);
  234.  
  235.     my ($packet) = MakePacket($slkSocket, $slkSocket, $slkPktType, $send_body);
  236.  
  237.     SendPacket($packet);
  238.  
  239.     my ($header, $body, $footer) = ReceivePacket();
  240.  
  241.     EmRPC::UnmakeRPCBody ($body, $format);
  242. }
  243.  
  244.  
  245. ########################################################################
  246. #
  247. #    FUNCTION:        ReturnValue
  248. #
  249. #    DESCRIPTION:    .
  250. #
  251. #    PARAMETERS:        .
  252. #
  253. #    RETURNED:        .
  254. #
  255. ########################################################################
  256.  
  257. sub ReturnValue
  258. {
  259.     my ($format, $D0, $A0, @parameters) = @_;
  260.  
  261.     my ($type, $size, $by_ref) = GetFormat ($format, 0);
  262.  
  263.     my ($result);
  264.  
  265.     if ($type eq "int")
  266.     {
  267.         return $D0;
  268.     }
  269.     elsif ($type eq "string")
  270.     {
  271.         return ($A0, ReadString ($A0));
  272.     }
  273.     elsif ($type eq "rptr")
  274.     {
  275.         return $A0;
  276.     }
  277.  
  278.     die "Unexpected type \"$type\" in EmRPC::ReturnValue, stopped";
  279. }
  280.  
  281.  
  282. ########################################################################
  283. #
  284. #    FUNCTION:        ReadBlock
  285. #
  286. #    DESCRIPTION:    Read a range of memory from the remote device.
  287. #
  288. #    PARAMETERS:        address of remote device to start reading from.
  289. #                    number of bytes to read (256 max).
  290. #
  291. #    RETURNED:        A Perl string containing the result.
  292. #
  293. ########################################################################
  294.  
  295. $sysPktReadMemCmd        = 0x01;
  296. $sysPktReadMemRsp        = 0x81;
  297.  
  298.     #    typedef struct SysPktReadMemCmdType {
  299.     #        _sysPktBodyCommon;                                // Common Body header
  300.     #        void*                    address;                // Address to read
  301.     #        Word                    numBytes;                // # of bytes to read
  302.     #        } SysPktReadMemCmdType;
  303.     #    typedef SysPktReadMemCmdType*    SysPktReadMemCmdPtr;
  304.     #    
  305.     #    typedef struct SysPktReadMemRspType {
  306.     #        _sysPktBodyCommon;                                // Common Body header
  307.     #        // Byte                data[?];                    // variable size
  308.     #        } SysPktReadMemRspType;
  309.     #    typedef SysPktReadMemRspType*    SysPktReadMemRspPtr;
  310.  
  311. sub ReadBlock
  312. {
  313.     my ($address, $num_bytes) = @_;
  314.  
  315.     my ($slkSocket)        = slkSocketPoserRPC;
  316.     my ($slkPktType)    = slkPktTypeSystem;
  317.     my ($send_body)        = pack ("cxNn", $sysPktReadMemCmd, $address, $num_bytes);
  318.  
  319.     my ($packet) = MakePacket($slkSocket, $slkSocket, $slkPktType, $send_body);
  320.  
  321.     SendPacket($packet);
  322.  
  323.     my ($header, $body, $footer) = ReceivePacket();
  324.  
  325.     unpack ("xx a$num_bytes", $body);
  326. }
  327.  
  328.  
  329. ########################################################################
  330. #
  331. #    FUNCTION:        WriteBlock
  332. #
  333. #    DESCRIPTION:    Write a range of bytes to the remote device.
  334. #
  335. #    PARAMETERS:        address to start writing to.
  336. #                    a Perl string containing the stuff to write.
  337. #
  338. #    RETURNED:        nothing
  339. #
  340. ########################################################################
  341.  
  342. $sysPktWriteMemCmd        = 0x02;
  343. $sysPktWriteMemRsp        = 0x82;
  344.  
  345.     #    typedef struct SysPktWriteMemCmdType {
  346.     #        _sysPktBodyCommon;                                // Common Body header
  347.     #        void*                address;                    // Address to write
  348.     #        Word                numBytes;                    // # of bytes to write
  349.     #        // Byte                data[?];                    // variable size data
  350.     #        } SysPktWriteMemCmdType;
  351.     #    typedef SysPktWriteMemCmdType*    SysPktWriteMemCmdPtr;
  352.     #    
  353.     #    typedef struct SysPktWriteMemRspType {
  354.     #        _sysPktBodyCommon;                                // Common Body header
  355.     #        } SysPktWriteMemRspType;
  356.     #    typedef SysPktWriteMemRspType*    SysPktWriteMemRspPtr;
  357.  
  358. sub WriteBlock
  359. {
  360.     my ($address, $data) = @_;
  361.  
  362.     my ($slkSocket)        = slkSocketPoserRPC;
  363.     my ($slkPktType)    = slkPktTypeSystem;
  364.     my ($send_body)        = pack ("cxNn", $sysPktWriteMemCmd, $address, length ($data)) . $data;
  365.  
  366.     my ($packet) = MakePacket($slkSocket, $slkSocket, $slkPktType, $send_body);
  367.  
  368.     SendPacket($packet);
  369.  
  370.     ReceivePacket();    # receive the results, but we don't need to do anything with them
  371. }
  372.  
  373.  
  374. ########################################################################
  375. #
  376. #    FUNCTION:        SendPacket
  377. #
  378. #    DESCRIPTION:    Send a fully-built packet to Poser.  The socket
  379. #                    connection to Poser should already have been
  380. #                    established
  381. #
  382. #    PARAMETERS:        The packet to be sent.
  383. #
  384. #    RETURNED:        Nothing.
  385. #
  386. ########################################################################
  387.  
  388. sub SendPacket
  389. {
  390.     my ($packet) = @_;
  391.  
  392.     print $sock $packet;
  393. }
  394.  
  395.  
  396. ########################################################################
  397. #
  398. #    FUNCTION:        ReceivePacket
  399. #
  400. #    DESCRIPTION:    Receive a packet from Poser.
  401. #
  402. #    PARAMETERS:        None.
  403. #
  404. #    RETURNED:        The packet header, body, and footer as an array.
  405. #
  406. ########################################################################
  407.  
  408. sub ReceivePacket
  409. {
  410.     my ($header, $body, $footer);
  411.  
  412.     my ($header_length) = 10;
  413.     sysread($sock, $header, $header_length);
  414.  
  415.     my ($body_length) = GetBodySize($header);
  416.     sysread($sock, $body, $body_length);
  417.  
  418.     my ($footer_length) = 2;
  419.     sysread($sock, $footer, $footer_length);
  420.  
  421.     ($header, $body, $footer);
  422. }
  423.  
  424.  
  425. ########################################################################
  426. #
  427. #    FUNCTION:        MakePacket
  428. #
  429. #    DESCRIPTION:    Builds up a complete packet for sending to Poser
  430. #                    including the header, body, and footer.
  431. #
  432. #    PARAMETERS:        $src - the source SLP socket.  Generally something
  433. #                        like slkSocketDebugger or slkSocketConsole.
  434. #
  435. #                    $dest - the destination SLP socket.
  436. #
  437. #                    $type - the type of packet.  Generally something
  438. #                        like slkPktTypeSystem or slkPktTypePAD.
  439. #
  440. #                    $body - the body of the packet.
  441. #
  442. #    RETURNED:        The built packet as a Perl string.  The header and
  443. #                    footer checksums will be calculated and filled in.
  444. #
  445. ########################################################################
  446.  
  447.     #    struct SlkPktHeaderType
  448.     #    {
  449.     #        Word    signature1;        // X  first 2 bytes of signature
  450.     #        Byte    signature2;        // X  3 and final byte of signature
  451.     #        Byte    dest;            // -> destination socket Id
  452.     #        Byte    src;            // -> src socket Id
  453.     #        Byte    type;            // -> packet type
  454.     #        Word    bodySize;        // X  size of body
  455.     #        Byte    transID;        // -> transaction Id
  456.     #                                //    if 0 specified, it will be replaced 
  457.     #        SlkPktHeaderChecksum    checksum;    // X  check sum of header
  458.     #    };
  459.     #
  460.     #    struct SlkPktFooterType
  461.     #    {
  462.     #        Word    crc16;            // header and body crc
  463.     #    };
  464.  
  465. $header_template = "H6CCCnCC";        # 6 Hex digits, 3 unsigned chars, a B.E. short, 2 unsigned chars
  466. $footer_template = "n";                # a B.E. short
  467.  
  468. $signature = "BEEFED";
  469.  
  470. sub MakePacket
  471. {
  472.     my ($src, $dest, $type, $body) = @_;
  473.  
  474.     if (not defined($transID))
  475.     {
  476.         $transID = 0;
  477.     }
  478.  
  479.     ++$transID;
  480.  
  481.     my ($bodySize) = length ($body);
  482.     my ($header_checksum) = CalcHeaderChecksum ($signature, $dest, $src, $type, $bodySize, $transID);
  483.  
  484.     my ($header) = pack ($header_template, $signature, $dest, $src, $type, $bodySize, $transID, $header_checksum);
  485.  
  486. #    my ($footer_checksum) = CalcFooterChecksum ($header, &body);
  487.     my ($footer_checksum) = 0;
  488.     my ($footer) = pack ($footer_template, $footer_checksum);
  489.  
  490.     $header . $body . $footer;
  491. }
  492.  
  493.  
  494. ########################################################################
  495. #
  496. #    FUNCTION:        CalcHeaderChecksum
  497. #
  498. #    DESCRIPTION:    Calculate that checksum value for the packet header.
  499. #
  500. #    PARAMETERS:        The components of the header.
  501. #
  502. #    RETURNED:        The checksum that should be placed in the SLP
  503. #                    packet header.
  504. #
  505. ########################################################################
  506.  
  507. sub CalcHeaderChecksum
  508. {
  509.     my ($signature, $dest, $src, $type, $bodySize, $transID) = @_;
  510.  
  511.     my ($checksum, $temp_buffer);
  512.  
  513.     $checksum = 0;
  514.  
  515.     $temp_buffer = pack ($header_template, $signature, $dest, $src, $type, $bodySize, $transID, 0);
  516.     @bytes = unpack("C8", $temp_buffer);
  517.     $checksum = $bytes[0] + $bytes[1] + $bytes[2] + $bytes[3] + $bytes[4] +
  518.                 $bytes[5] + $bytes[6] + $bytes[7];
  519.  
  520.     $checksum % 256;
  521. }
  522.  
  523.  
  524. ########################################################################
  525. #
  526. #    FUNCTION:        CalcFooterChecksum
  527. #
  528. #    DESCRIPTION:    Calculate the checksum value for the packet footer.
  529. #
  530. #    PARAMETERS:        The header and body.
  531. #
  532. #    RETURNED:        The checksum that should be placed in the SLP
  533. #                    packet footer.
  534. #
  535. ########################################################################
  536.  
  537. sub CalcFooterChecksum
  538. {
  539.     my ($header, $body) = @_;
  540.  
  541.     my ($checksum, $temp_buffer);
  542.  
  543.     $temp_buffer = $header . $body;
  544.  
  545.     $checksum = unpack("%16c*", $temp_buffer);    # Wrong kind of checksum!
  546. }
  547.  
  548.  
  549. ########################################################################
  550. #
  551. #    FUNCTION:        MakeRPCBody
  552. #
  553. #    DESCRIPTION:    Create the body of an RPC packet, suitable for
  554. #                    being passed off to MakePacket.
  555. #
  556. #    PARAMETERS:        The "trap word" of the trap that needs to be called
  557. #                    (as defined by the constants in SysTraps.pm) and
  558. #                    the parameters of the RPC call, as created by the
  559. #                    MakeParam function.
  560. #
  561. #    RETURNED:        The body of the packet as a string.
  562. #
  563. ########################################################################
  564.  
  565.     #    struct SysPktRPCType
  566.     #    {
  567.     #        _sysPktBodyCommon;        // Common Body header
  568.     #        Word    trapWord;        // which trap to execute
  569.     #        DWord    resultD0;        // result from D0 placed here
  570.     #        DWord    resultA0;        // result from A0 placed here
  571.     #        Word    numParams;        // how many parameters follow
  572.     #        // Following is a variable length array ofSlkRPCParamInfo's
  573.     #        SysPktRPCParamType    param[1];
  574.     #    };
  575.  
  576. $rpc_header_template    = "CxH4NNn";        # unsigned byte, filler, 4 hex digits, 2 B.E. longs, B.E. short
  577. $sysPktRPCCmd            = 0x0A;
  578. $sysPktRPCRsp            = 0x8A;
  579.  
  580. sub MakeRPCBody
  581. {
  582.     my ($trapword, $format, @param_list) = @_;
  583.  
  584.     my ($rpc_header) = pack ($rpc_header_template, $sysPktRPCCmd, $trapword, 0, 0, $#param_list + 1);
  585.     my ($rpc_body) = join ("", $rpc_header, Marshal($format, @param_list));
  586.  
  587.     $rpc_body;
  588. }
  589.  
  590. sub UnmakeRPCBody
  591. {
  592.     my ($body, $format) = @_;
  593.  
  594.     my ($cmd, $trap_word, $D0, $A0, $num_params, $packed_parms) = unpack ("$rpc_header_template a*", $body);
  595.     my (@parms) = Unmarshal($packed_parms, $format);
  596.  
  597.     return ($D0, $A0, @parms);
  598. }
  599.  
  600.  
  601. $rpc2_header_template    = "CxH4NNN";        # unsigned byte, filler, 4 hex digits, 3 B.E. longs
  602. $sysPktRPC2Cmd            = 0x20;
  603. $sysPktRPC2Rsp            = 0xA0;
  604.  
  605. sub MakeRPC2Body
  606. {
  607.     my ($trapword, $reg_list, @param_list) = @_;
  608.  
  609.     my ($rpc_header) = pack ($rpc_header_template, $sysPktRPCCmd, $trapword, 0, 0, 0);
  610.     my ($param_count) = pack ("n", $#param_list + 1);
  611.     my ($rpc_body) = join ("", $rpc_header, $reg_list, $param_count, reverse @param_list);
  612.  
  613.     $rpc_body;
  614. }
  615.  
  616.  
  617. ########################################################################
  618. #
  619. #    FUNCTION:        PackRegList
  620. #
  621. #    DESCRIPTION:    Pack a list of register values into the format
  622. #                    needed by an RPC2 packet.
  623. #
  624. #    PARAMETERS:        An associative array, where each key contains Ax
  625. #                    or Dx, and the value contains the register value.
  626. #
  627. #    RETURNED:        The packed registers as a string.
  628. #
  629. ########################################################################
  630.  
  631. sub PackRegList
  632. {
  633.     my (%reg_list) = @_;
  634.  
  635.     my ($dreg_bits, $areg_bits, $dregs, $aregs);
  636.  
  637.     $dreg_bits = 0;
  638.     $areg_bits = 0;
  639.     $dregs = "";
  640.     $aregs = "";
  641.  
  642.     foreach $key (sort keys %reg_list)
  643.     {
  644.         my($reg_space) = substr($key, 0, 1);
  645.         my($bit_to_set) = (1 << (ord(substr($key, 1, 1)) - ord("0")));
  646.         my($value) = $reg_list{$key};
  647.  
  648.         if ($reg_space eq "D")
  649.         {
  650.             $dreg_bits |= $bit_to_set;
  651.             $dregs .= pack ("N", $value);
  652.         }
  653.         else
  654.         {
  655.             $areg_bits |= $bit_to_set;
  656.             $aregs .= pack ("N", $value);
  657.         }
  658.     }
  659.  
  660.     my ($result) = join ("", pack("CC", $dreg_bits, $areg_bits), $dregs, $aregs);
  661. }
  662.  
  663.  
  664. ########################################################################
  665. #
  666. #    FUNCTION:        MakeParam
  667. #
  668. #    DESCRIPTION:    Create a parameter array element, suitable for being
  669. #                    added to other parameter array elements and --
  670. #                    eventually -- to an RPC packet body.
  671. #
  672. #    PARAMETERS:        $data - the data to be added.
  673. #                    $data_len - the length of the data to be added.  If
  674. #                        greater than zero, then we assume $data to be
  675. #                        an integer.  If equal to zero, then we assume
  676. #                        data to be a string where the length of the
  677. #                        string is determined by the length () function.
  678. #                        If less than zero, then data is assumed to be
  679. #                        a buffer with a length of -$data.
  680. #                    $by_ref - zero if the parameter is to be treated as
  681. #                        pass-by-value.  Non-zero if it's pass-by-ref.
  682. #
  683. #    RETURNED:        A parameter string that can be appended to a longer
  684. #                    string of parameters.  If the length of the string
  685. #                    would otherwise be odd, a padding byte is added.
  686. #
  687. ########################################################################
  688.  
  689.     #    struct SysPktRPCParamInfo
  690.     #    {
  691.     #        Byte     byRef;            // true if param is by reference
  692.     #        Byte    size;            // # of Bytes of paramData    (must be even)            
  693.     #        Word    data[1];        // variable length array of paramData
  694.     #    };
  695.  
  696. sub ToParamBlock
  697. {
  698.     my ($data, $data_len) = @_;
  699.  
  700.     die "Undefined \$data, stopped" unless defined($data);
  701.     die "\$data_len is negative, stopped" if ($data_len < 0);
  702.  
  703.     ## If data_len == 0, determine the length using the length () function.
  704.     ## Else, use the given length.
  705.  
  706.     if ($data_len == 0)
  707.     {
  708.         $data_len = length ($data);
  709.     }
  710.     else
  711.     {
  712.         $data = pack ("a$data_len", $data);
  713.     }
  714.  
  715.     ## Pack up the data.
  716.  
  717.     my ($param) = pack ("CC", 1, $data_len) . $data;
  718.  
  719.     ## Make sure the packed data is an even number of bytes long.
  720.  
  721.     if (($data_len % 2) != 0)
  722.     {
  723.         $param .= "\0";
  724.     }
  725.  
  726.     $param;
  727. }
  728.  
  729.  
  730. sub FromParamBlock
  731. {
  732.     my ($param, $data_len) = @_;
  733.  
  734.     die "Undefined \$param, stopped" unless defined($param);
  735.     die "\$data_len is negative, stopped" if ($data_len < 0);
  736.  
  737.     ## Just ignore the $data_len and use what's in the parameter block.
  738.  
  739.     $data_len = unpack ("xC", $param);
  740.  
  741.     unpack ("xxa$data_len", $param);
  742. }
  743.  
  744.  
  745. sub ToParamInt
  746. {
  747.     my ($data, $data_len, $by_ref) = @_;
  748.  
  749.     die "Undefined \$data, stopped" unless defined($data);
  750.  
  751.     my ($format);
  752.  
  753.     if ($data_len == 8)
  754.     {
  755.         $format = ("CCCx");
  756.         $data_len = 1;
  757.     }
  758.     elsif ($data_len == 16 || $data_len == 0)
  759.     {
  760.         $format = ("CCn");
  761.         $data_len = 2;
  762.     }
  763.     elsif ($data_len == 32)
  764.     {
  765.         $format = ("CCN");
  766.         $data_len = 4;
  767.     }
  768.     else
  769.     {
  770.         die "\$data_len not 8, 16, or 32, stopped";
  771.     }
  772.  
  773.     ## Pack up the data.
  774.  
  775.     pack ($format, $by_ref, $data_len, $data);
  776. }
  777.  
  778.  
  779. sub FromParamInt
  780. {
  781.     my ($param, $data_len) = @_;
  782.  
  783.     die "Undefined \$param, stopped" unless defined($param);
  784.  
  785.     my ($format);
  786.  
  787.     if ($data_len == 8)
  788.     {
  789.         $format = ("xxCx");
  790.     }
  791.     elsif ($data_len == 16 || $data_len == 0)
  792.     {
  793.         $format = ("xxn");
  794.     }
  795.     elsif ($data_len == 32)
  796.     {
  797.         $format = ("xxN");
  798.     }
  799.     else
  800.     {
  801.         die "\$data_len not 8, 16, or 32, stopped";
  802.     }
  803.  
  804.     unpack ($format, $param);
  805. }
  806.  
  807.  
  808. sub ToParamPoint
  809. {
  810.     my ($point) = @_;
  811.     my ($param);
  812.  
  813.     if (defined $point->{x})
  814.     {
  815.         $param = pack ("CCnn", 1, 4, $point->{x}, $point->{y});
  816.     }
  817.     else
  818.     {
  819.         $param = pack ("CCxxxx", 1, 4);
  820.     }
  821.  
  822.     $param;
  823. }
  824.  
  825.  
  826. sub FromParamPoint
  827. {
  828.     my ($param) = @_;
  829.  
  830.     die "Undefined \$param, stopped" unless defined($param);
  831.  
  832.     my (@coords) = unpack ("xxnn", $param);
  833.  
  834.     {x    => $coords[0],
  835.      y    => $coords[1]};
  836. }
  837.  
  838.  
  839. sub ToParamRect
  840. {
  841.     my ($rect) = @_;
  842.     my ($param);
  843.  
  844.     if (defined $rect->{height})
  845.     {
  846.         $param = pack ("CCnnnn", 1, 8, $rect->{left}, $rect->{top}, $rect->{width}, $rect->{height});
  847.     }
  848.     elsif (defined $rect->{bottom})
  849.     {
  850.         $param = pack ("CCnnnn", 1, 8, $rect->{left}, $rect->{top}, $rect->{right} - $rect->{left}, $rect->{bottom} - $rect->{top});
  851.     }
  852.     else
  853.     {
  854.         $param = pack ("CCxxxxxxxx", 1, 8);
  855.     }
  856.  
  857.     $param;
  858. }
  859.  
  860.  
  861. sub FromParamRect
  862. {
  863.     my ($param) = @_;
  864.  
  865.     die "Undefined \$param, stopped" unless defined($param);
  866.  
  867.     my (@coords) = unpack ("xxnnnn", $param);
  868.  
  869.     {left    => $coords[0],
  870.      top    => $coords[1],
  871.      width    => $coords[2],
  872.      height    => $coords[3],
  873.      right    => $coords[0] + $coords[2],
  874.      bottom    => $coords[1] + $coords[3]};
  875. }
  876.  
  877.  
  878. sub ToParamString
  879. {
  880.     my ($data, $data_len) = @_;
  881.  
  882.     die "Undefined \$data, stopped" unless defined($data);
  883.     die "\$data_len is negative, stopped" if ($data_len < 0);
  884.  
  885.     ## If $data_len == 0, determine the length using the length () function.
  886.  
  887.     if ($data_len == 0)
  888.     {
  889.         $data_len = length ($data) + 1;    # Add 1 to get 1 byte of NULL padding
  890.     }
  891.  
  892.     ## Pack up the data.
  893.  
  894.     my ($param) = pack ("CCa$data_len", 1, $data_len, $data);
  895.  
  896.     ## Make sure the packed data is an even number of bytes long.
  897.  
  898.     if (($data_len % 2) != 0)
  899.     {
  900.         $param .= "\0";
  901.     }
  902.  
  903.     $param;
  904. }
  905.  
  906.  
  907. sub FromParamString
  908. {
  909.     my ($param) = @_;
  910.  
  911.     unpack ("xxA*", $param);
  912. }
  913.  
  914.  
  915. ########################################################################
  916. #
  917. #    FUNCTION:        UnpackHeader
  918. #
  919. #    DESCRIPTION:    Disassemble a packet header into its consituent
  920. #                    parts.
  921. #
  922. #    PARAMETERS:        The packet header as received from Poser
  923. #
  924. #    RETURNED:        The signature, destination port, source port,
  925. #                    packet type, body size, transaction ID, and
  926. #                    checksum as an array.
  927. #
  928. ########################################################################
  929.  
  930. sub UnpackHeader
  931. {
  932.     my($header) = @_;
  933.  
  934.     my ($signature, $dest, $src, $type, $bodySize, $transID, $checksum)
  935.         = unpack ($header_template, $header);
  936.  
  937.     ($signature, $dest, $src, $type, $bodySize, $transID, $checksum);
  938. }
  939.  
  940.  
  941. ########################################################################
  942. #
  943. #    FUNCTION:        GetBodySize
  944. #
  945. #    DESCRIPTION:    Utility function to extract the packet body size
  946. #                    field from the packet header.
  947. #
  948. #    PARAMETERS:        The packet header as received from Poser.
  949. #
  950. #    RETURNED:        The size of the body following the header.
  951. #
  952. ########################################################################
  953.  
  954. sub GetBodySize
  955. {
  956.     my($header) = @_;
  957.  
  958.     my ($signature, $dest, $srs, $type, $bodySize, $transID, $checksum)
  959.         = UnpackHeader ($header);
  960.  
  961.     $bodySize;
  962. }
  963.     
  964.  
  965. sub SkipWhite
  966. {
  967.     my ($format, $format_index) = @_;
  968.  
  969.     while ()
  970.     {
  971.         last if ($format_index >= length ($format));
  972.  
  973.         my ($char) = substr ($format, $format_index, 1);
  974.         last unless ($char eq " " || $char eq "," || $char eq ":");
  975.  
  976.         $format_index += 1;
  977.     }
  978.  
  979.     $format_index
  980. }
  981.  
  982.  
  983. sub GetType
  984. {
  985.     my ($format, $format_index) = @_;
  986.     my ($type) = "";
  987.  
  988.     $format_index = SkipWhite ($format, $format_index);
  989.  
  990.     while ()
  991.     {
  992.         last if ($format_index >= length ($format));
  993.  
  994.         my ($char) = substr ($format, $format_index, 1);
  995.         last if (($char lt "a" || $char gt "z") && ($char lt "A" || $char gt "Z"));
  996.  
  997.         $type .= $char;
  998.         $format_index += 1;
  999.     }
  1000.  
  1001.     die "Unknown type (\"$type\" @ $format_index), stopped"
  1002.         unless ($type eq "int" ||
  1003.                 $type eq "Err" ||
  1004.                 $type eq "Coord" ||
  1005.                 $type eq "LocalID" ||
  1006.                 $type eq "HostErr" ||
  1007.                 $type eq "string" ||
  1008.                 $type eq "rptr" ||
  1009.                 $type eq "point" ||
  1010.                 $type eq "rect" ||
  1011.                 $type eq "block");
  1012.  
  1013.     return ($type, $format_index);
  1014. }
  1015.  
  1016.  
  1017. sub GetSize
  1018. {
  1019.     my ($format, $format_index) = @_;
  1020.     my ($size) = 0;
  1021.  
  1022.     while ()
  1023.     {
  1024.         last if ($format_index >= length ($format));
  1025.  
  1026.         my ($char) = substr ($format, $format_index, 1);
  1027.         last if ($char lt "0" || $char gt "9");
  1028.  
  1029.         $size = $size * 10 + $char;
  1030.         $format_index += 1;
  1031.     }
  1032.  
  1033.     return ($size, $format_index);
  1034. }
  1035.  
  1036.  
  1037. sub GetByRef
  1038. {
  1039.     my ($format, $format_index) = @_;
  1040.     my ($by_ref) = 0;
  1041.     
  1042.     if (substr ($format, $format_index, 1) eq "*")
  1043.     {
  1044.         $by_ref = 1;
  1045.     }
  1046.  
  1047.     if ($by_ref)
  1048.     {
  1049.         $format_index += 1;
  1050.     }
  1051.  
  1052.     return ($by_ref, $format_index);
  1053. }
  1054.  
  1055.  
  1056. sub GetFormat
  1057. {
  1058.     my ($format, $format_index) = @_;
  1059.     my ($type, $size, $by_ref) = (" ", 0, 0);
  1060.  
  1061.     ($type, $format_index) = GetType ($format, $format_index);
  1062.     ($size, $format_index) = GetSize ($format, $format_index);
  1063.     ($by_ref, $format_index) = GetByRef ($format, $format_index);
  1064.  
  1065.     ## Deal with aliases
  1066.  
  1067.     if ($type eq "LocalID" or $type eq "HostErr")
  1068.     {
  1069.         $type = "int";
  1070.         $size = 32;
  1071.     }
  1072.     elsif ($type eq "Err" or $type eq "Coord")
  1073.     {
  1074.         $type = "int";
  1075.         $size = 16;
  1076.     }
  1077.  
  1078.     return ($type, $size, $by_ref, $format_index);
  1079. }
  1080.  
  1081.  
  1082. sub Marshal
  1083. {
  1084.     my ($format, @parameters) = @_;
  1085.     my (@result);
  1086.  
  1087.     my ($format_index) = 0;
  1088.     my ($parameter_index) = 0;
  1089.  
  1090.     while ($format_index < length ($format))
  1091.     {
  1092.         my ($parm);
  1093.  
  1094.         my ($type, $size);
  1095.         ($type, $size, $by_ref, $format_index) = GetFormat ($format, $format_index);
  1096.  
  1097.         if ($type eq "int")
  1098.         {
  1099.             $parm = EmRPC::ToParamInt($parameters[$parameter_index], $size, $by_ref);
  1100.         }
  1101.         elsif ($type eq "rptr")
  1102.         {
  1103.             $parm = EmRPC::ToParamInt($parameters[$parameter_index], 32, 0);
  1104.         }
  1105.         elsif ($type eq "point")
  1106.         {
  1107.             $parm = EmRPC::ToParamPoint($parameters[$parameter_index], $size);
  1108.         }
  1109.         elsif ($type eq "rect")
  1110.         {
  1111.             $parm = EmRPC::ToParamRect($parameters[$parameter_index], $size);
  1112.         }
  1113.         elsif ($type eq "string")
  1114.         {
  1115.             $parm = EmRPC::ToParamString($parameters[$parameter_index], $size);
  1116.         }
  1117.         elsif ($type eq "block")
  1118.         {
  1119.             $parm = EmRPC::ToParamBlock($parameters[$parameter_index], $size);
  1120.         }
  1121.         else
  1122.         {
  1123.             die "Unexpected type \"$type\" in EmRPC::Marshal, stopped";
  1124.         }
  1125.  
  1126.         push (@result, $parm);
  1127.  
  1128.         $parameter_index += 1;
  1129.     }
  1130.  
  1131.     return join ("", reverse @result);
  1132. }
  1133.  
  1134.  
  1135. sub BreakApartParameters
  1136. {
  1137.     my ($packed_parms) = @_;
  1138.     my (@result) = 0;
  1139.  
  1140.     my ($offset) = 0;
  1141.  
  1142.     while ($offset < length ($packed_parms))
  1143.     {
  1144.         # Get the size field.
  1145.  
  1146.         my ($size) = unpack ("x$offset" . "xC", $packed_parms);
  1147.  
  1148.         # Add in the lengths of the byRef and size fields.
  1149.  
  1150.         $size += 2;
  1151.  
  1152.         # Make sure the field is word-aligned.
  1153.  
  1154.         if (($size % 2) != 0)
  1155.         {
  1156.             $size += 1;
  1157.         }
  1158.  
  1159.         # Get the SysPktRPCParamInfo.
  1160.  
  1161.         my ($parm) = unpack ("x$offset a$size", $packed_parms);
  1162.  
  1163.         push (@result, $parm);
  1164.  
  1165.         $offset += $size;
  1166.     }
  1167.  
  1168.     return @result;
  1169. }
  1170.  
  1171.  
  1172. sub Unmarshal
  1173. {
  1174.     my ($packed_parms, $format) = @_;
  1175.     my (@result);
  1176.  
  1177.     my ($format_index) = 0;
  1178.     my ($parameter_index) = 0;
  1179.  
  1180.     my (@parameters) = reverse BreakApartParameters($packed_parms);
  1181.  
  1182.     while ($format_index < length ($format))
  1183.     {
  1184.         my ($parm);
  1185.  
  1186.         my ($type, $size);
  1187.         ($type, $size, $by_ref, $format_index) = GetFormat ($format, $format_index);
  1188.  
  1189.         if ($type eq "int")
  1190.         {
  1191.             $parm = EmRPC::FromParamInt($parameters[$parameter_index], $size);
  1192.         }
  1193.         elsif ($type eq "rptr")
  1194.         {
  1195.             $parm = EmRPC::FromParamInt($parameters[$parameter_index], 32);
  1196.         }
  1197.         elsif ($type eq "point")
  1198.         {
  1199.             $parm = EmRPC::FromParamPoint($parameters[$parameter_index]);
  1200.         }
  1201.         elsif ($type eq "rect")
  1202.         {
  1203.             $parm = EmRPC::FromParamRect($parameters[$parameter_index]);
  1204.         }
  1205.         elsif ($type eq "string")
  1206.         {
  1207.             $parm = EmRPC::FromParamString($parameters[$parameter_index]);
  1208.         }
  1209.         elsif ($type eq "block")
  1210.         {
  1211.             $parm = EmRPC::FromParamBlock($parameters[$parameter_index], $size);
  1212.         }
  1213.         else
  1214.         {
  1215.             die "Unexpected type \"$type\" in EmRPC::Unmarshal, stopped";
  1216.         }
  1217.  
  1218.         push (@result, $parm);
  1219.  
  1220.         $parameter_index += 1;
  1221.     }
  1222.  
  1223.     return @result;
  1224. }
  1225.  
  1226.  
  1227. sub ReadString
  1228. {
  1229.     my ($address) = @_;
  1230.  
  1231.     my ($block) = EmRPC::ReadBlock($address, 128);
  1232.  
  1233.     my ($string, $ch);
  1234.  
  1235.     foreach $ii (0..length ($block) - 1)
  1236.     {
  1237.         $ch = substr($block, $ii, 1);
  1238.         last if (ord($ch) == 0);
  1239.         $string .= $ch;
  1240.     }
  1241.  
  1242.     $string;
  1243. }
  1244.  
  1245.  
  1246. sub PrintString
  1247. {
  1248.     my($string) = @_;
  1249.  
  1250.     foreach $ii (0..length ($string) - 1)
  1251.     {
  1252.         my($ch) = substr($string, $ii, 1);
  1253.  
  1254.         printf "0x%02X, ", ord($ch);
  1255.  
  1256.         if ($ii % 8 == 7)
  1257.         {
  1258.             print "\n";
  1259.         }
  1260.     }
  1261.  
  1262.     printf "\n";
  1263.  
  1264.     $string;
  1265. }
  1266.  
  1267. 1;
  1268.