lib/Devel/PeekPoke.pm

   1 package Devel::PeekPoke;
   2 use strict;
   3 use warnings;
   4
   5 our $VERSION = '0.01';
   6
   7 use Carp;
   8 use Devel::PeekPoke::Constants qw/PTR_SIZE PTR_PACK_TYPE BIG_ENDIAN/;
   9
  10 if (
  11   $ENV{DEVEL_PEEK_POKE_USE_PP}
  12     or
  13   # when someone writes the XS this should just work
  14   ! eval { require XSLoader; XSLoader::load( __PACKAGE__, $VERSION ) }
  15 ) {
  16   require Devel::PeekPoke::PP;
  17   *peek = \&Devel::PeekPoke::PP::peek;
  18   *poke = \&Devel::PeekPoke::PP::poke;
  19
  20   # sanity checks an address value before packing it
  21   *_pack_address = \&Devel::PeekPoke::PP::_pack_address;
  22 }
  23
  24 use base 'Exporter';
  25 our @EXPORT = qw/peek poke/;
  26 our @EXPORT_OK = qw/peek poke peek_address poke_address peek_verbose describe_bytestring/;
  27
  28 =head1 NAME
  29
  30 Devel::PeekPoke - All your bytes are belong to us
  31
  32 =head1 DESCRIPTION
  33
  34 This module provides a toolset for raw memory manipulation (both reading and
  35 writing), together with some tools making it easier to examine memory chunks.
  36
  37 All provided routines expect memory addresses as regular integers (not as their
  38 packed representations). Note that you can only manipulate memory of your
  39 current perl process, this is B<not> a general memory access tool.
  40
  41 =head1 PORTABILITY
  42
  43 The implementation is very portable, and is expected to work on all
  44 architectures and operating systems supported by perl itself. Moreover no
  45 compiler toolchain is required to install this module (in fact currently no
  46 XS version is available).
  47
  48 In order to interpret the results, you may need to know the details of the
  49 underlying system architecture. See L<Devel::PeekPoke::Constants> for some
  50 useful constants related to the current system.
  51
  52 =head1 USE RESPONSIBLY
  53
  54 It is apparent with the least amount of imagination that this module can be
  55 used for great evil and general mischief. On the other hand there are some
  56 legitimate uses, if nothing else as a learning/debugging tool. Hence this
  57 tool is provided ( L<with Larry Wall's blessing!
  58 |http://groups.google.com/group/alt.hackers/msg/8ce9ba2e5554e8e6>)
  59 in the interest of free speech and all. The authors expect a user of this
  60 module to exercise maximum common sense.
  61
  62
  63 =head1 EXPORTABLE FUNCTIONS
  64
  65 The following functions are provided, with L</peek> and L</poke> being
  66 exported by default.
  67
  68 =head2 peek
  69
  70   my $byte_string = peek( $address, $size );
  71
  72 Reads and returns C<$size> B<bytes> from the supplied address. Expects
  73 C<$address> to be specified as an integer.
  74
  75 =head2 poke
  76
  77   my $bytes_written = poke( $address, $bytes );
  78
  79 Writes the contents of C<$bytes> to the memory location C<$address>. Returns
  80 the amount of bytes written. Expects C<$bytes> to be a raw byte string, throws
  81 an exception when (possible) characters are detected.
  82
  83 =cut
  84
  85 # peek and poke come either from Devel::PeekPoke::PP or the XS implementation
  86
  87 =head2 peek_address
  88
  89   my $address = peek_address( $pointer_address );
  90
  91 A convenience function to retrieve an address from a known location of a
  92 pointer. The address is returned as an integer. Equivalent to:
  93
  94   unpack (
  95     Devel::PeekPoke::Constants::PTR_PACK_TYPE,
  96     peek( $pointer_address, Devel::PeekPoke::Constants::PTR_SIZE ),
  97   )
  98
  99 =cut
 100
 101 sub peek_address {
 102   #my($location) = @_;
 103   croak "Peek address where?" unless defined $_[0];
 104   unpack PTR_PACK_TYPE, peek($_[0], PTR_SIZE);
 105 }
 106
 107 =head2 poke_address
 108
 109   my $addr_size = poke_address( $pointer_address, $address_value );
 110
 111 A convenience function to set a pointer to an arbitrary address an address
 112 (you need to ensure that C<$pointer_address> is in fact a pointer).
 113 Equivalent to:
 114
 115   poke( $pointer_address, pack (
 116     Devel::PeekPoke::Constants::PTR_PACK_TYPE,
 117     $address_value,
 118   ));
 119
 120 =cut
 121
 122 sub poke_address {
 123   #my($location, $addr) = @_;
 124   croak "Poke address where and to what?"
 125     unless (defined $_[0]) and (defined $_[1]);
 126   poke( $_[0], _pack_address( $_[1]) );
 127 }
 128
 129 =head2 peek_verbose
 130
 131   peek_verbose( $address, $size )
 132
 133 A convenience wrapper around L</describe_bytestring>. Equivalent to:
 134
 135   print STDERR describe_bytestring( peek($address, $size), $address);
 136
 137 =cut
 138
 139 sub peek_verbose {
 140   #my($location, $len) = @_;
 141   my $out = describe_bytestring( peek(@_), $_[0]);
 142
 143   print STDERR "$out\n";
 144 }
 145
 146 =head2 describe_bytestring
 147
 148   my $desc = describe_bytestring( $bytes, $start_address )
 149
 150 A convenience aid for examination of random bytestrings. Useful for those of
 151 us who are not skilled enough to read hex dumps directly. For example:
 152
 153   describe_bytestring( "Har har\t\x13\x37\xb0\x0b\x1e\x55 !!!", 46685601519 )
 154
 155  returns the following on a little-endian system (regardless of pointer size):
 156
 157               Hex  Dec  Oct    Bin     ASCII      32      32+2          64
 158              --------------------------------  -------- -------- ----------------
 159  0xadeadbeef   48   72  110  01001000    H     20726148          0972616820726148
 160  0xadeadbef0   61   97  141  01100001    a     ___/              _______/
 161  0xadeadbef1   72  114  162  01110010    r     __/      61682072 ______/
 162  0xadeadbef2   20   32   40  00100000  (SP)    _/       ___/     _____/
 163  0xadeadbef3   68  104  150  01101000    h     09726168 __/      ____/
 164  0xadeadbef4   61   97  141  01100001    a     ___/     _/       ___/
 165  0xadeadbef5   72  114  162  01110010    r     __/      37130972 __/
 166  0xadeadbef6   09    9   11  00001001  (HT)    _/       ___/     _/
 167  0xadeadbef7   13   19   23  00010011  (DC3)   0BB03713 __/      2120551E0BB03713
 168  0xadeadbef8   37   55   67  00110111    7     ___/     _/       _______/
 169  0xadeadbef9   B0  176  260  10110000  "\260"  __/      551E0BB0 ______/
 170  0xadeadbefa   0B   11   13  00001011  (VT)    _/       ___/     _____/
 171  0xadeadbefb   1E   30   36  00011110  (RS)    2120551E __/      ____/
 172  0xadeadbefc   55   85  125  01010101    U     ___/     _/       ___/
 173  0xadeadbefd   20   32   40  00100000  (SP)    __/      21212120 __/
 174  0xadeadbefe   21   33   41  00100001    !     _/       ___/     _/
 175  0xadeadbeff   21   33   41  00100001    !              __/
 176  0xadeadbf00   21   33   41  00100001    !              _/
 177
 178 =cut
 179
 180 # compile a list of short C0 code names (why doesn't charnames.pm provide me with this?)
 181 my $ctrl_names;
 182 for (qw/
 183   NUL SOH STX ETX EOT ENQ ACK BEL BS HT LF VT FF CR SO SI DLE DC1 DC2 DC3 DC4 NAK SYN ETB CAN EM SUB ESC FS GS RS US SP
 184 /) {
 185   $ctrl_names->{scalar keys %$ctrl_names} = $_;
 186 };
 187 $ctrl_names->{127} = 'DEL';
 188 for (values %$ctrl_names) {
 189   $_ = "($_)" . ( ' ' x (4 - length $_) );
 190 }
 191
 192 sub describe_bytestring {
 193   my ($bytes, $start_addr) = @_;
 194   $start_addr ||= 0;
 195
 196   my $len = length($bytes);
 197
 198   my $max_addr_hexsize = length (sprintf ('%x', $start_addr + $len));
 199   $max_addr_hexsize = 7 if $max_addr_hexsize < 7; # to match perl itself
 200   my $addr_hdr_pad = ' ' x ($max_addr_hexsize + 3);
 201
 202   my @out = (
 203     "$addr_hdr_pad Hex  Dec  Oct    Bin     ASCII  ",
 204     "$addr_hdr_pad-------------------------------- ",
 205   );
 206
 207   if ($len > 3) {
 208     $out[0] .= '    32   ';
 209     $out[1] .= ' --------';
 210   }
 211
 212   if ($len > 5) {
 213     $out[0] .= '   32+2  ';
 214     $out[1] .= ' --------';
 215   }
 216
 217   if ($len > 7) {
 218     $out[0] .= '        64       ';
 219     $out[1] .= ' ----------------';
 220   }
 221
 222   for my $off (0 .. $len - 1) {
 223     my $byte = substr $bytes, $off, 1;
 224     my ($val) = unpack ('C', $byte);
 225     push @out, sprintf( "0x%0${max_addr_hexsize}x   %02X % 4d % 4o  %s  %s",
 226       $start_addr + $off,
 227       ($val) x 3,
 228       unpack('B8', $byte),
 229       $ctrl_names->{$val} || ( $val > 127 ? sprintf('"\%o"', $val) : "  $byte   " ),
 230     );
 231
 232     my @ints;
 233     for my $col_32 (0,2) {
 234       my $start_off_32 = ($off - $col_32) % 4;
 235
 236       if ( ($off < $col_32) or ($len - $off + $start_off_32) < 4 ) {
 237         push @ints, (' ' x 8);
 238       }
 239       else {
 240         push @ints,
 241             $start_off_32 == 0 ? sprintf '%08X', unpack('L', substr $bytes, $off - $start_off_32, 4)
 242           : sprintf '%s/%s', '_' x (4 - $start_off_32), ' ' x ($start_off_32 + 3)
 243         ;
 244       }
 245     }
 246
 247     # print as two successive 32bit values, based on the determined endianness
 248     # since the machine may very well not have unpack('Q',...)
 249     my $start_off_64 = $off % 8;
 250     if ( ($len - $off + $start_off_64) >= 8) {
 251       push @ints,
 252           $start_off_64 == 0 ? sprintf '%08X%08X', unpack('LL', BIG_ENDIAN
 253             ? substr( $bytes, $off, 8 )
 254             : substr( $bytes, $off + 4, 4 ) . substr( $bytes, $off, 4 )
 255           )
 256         : sprintf '%s/%s', '_' x (8 - $start_off_64), ' ' x ($start_off_64 + 7)
 257       ;
 258     }
 259
 260     $out[-1] .= join ' ', ' ', @ints
 261       if @ints;
 262   }
 263
 264   join "\n", @out;
 265 }
 266
 267 =head1 AUTHOR
 268
 269 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
 270
 271 =head1 CONTRIBUTORS
 272
 273 None as of yet
 274
 275 =head1 COPYRIGHT
 276
 277 Copyright (c) 2011 the Devel::PeekPoke L</AUTHOR> and L</CONTRIBUTORS>
 278 as listed above.
 279
 280 =head1 LICENSE
 281
 282 This library is free software and may be distributed under the same terms
 283 as perl itself.
 284
 285 =cut
 286
 287 1;