1use Config; 2$file = @ARGV ? shift : 'examples/convert.pl'; 3open OUT, ">$file" or die "Can't create $file: $!"; 4print OUT <<"!GROK!THIS!"; 5$Config{startperl} -w 6!GROK!THIS! 7print OUT <<'!NO!SUBS!'; 8################################################################################ 9# 10# Copyright (c) 2002-2020 Marcus Holland-Moritz. All rights reserved. 11# This program is free software; you can redistribute it and/or modify 12# it under the same terms as Perl itself. 13# 14################################################################################ 15 16#=============================================================================== 17# 18# Parse a C struct and use 'pack', 'unpack', 'sizeof' and 'offsetof'. 19# 20#=============================================================================== 21 22use Convert::Binary::C; 23use Data::Dumper; 24use strict; 25 26#-------------------------------------------------------------- 27# Create an object, configure it, and parse some embedded code. 28#-------------------------------------------------------------- 29 30my $c = Convert::Binary::C->new( LongSize => 4, ShortSize => 2 ) 31 ->Alignment( 4 ) 32 ->ByteOrder( 'BigEndian' ) 33 ->parse( <<'ENDC' ); 34 35typedef signed long i_32; 36typedef unsigned long u_32; 37typedef signed short i_16; 38typedef unsigned short u_16; 39typedef signed char i_8; 40typedef unsigned char u_8; 41 42struct convert { 43 i_8 byte; 44 i_16 word[2]; 45 i_32 dword; 46 union { 47 u_32 dword; 48 u_8 bytes[ sizeof( u_32 ) ]; 49 } c32; 50}; 51 52ENDC 53 54#----------------------------------------------------------- 55# Print the offsets and sizes of some of the struct members. 56#----------------------------------------------------------- 57 58for( qw( byte word dword ) ) { 59 print "offsetof( 'convert', '$_' ) = ", $c->offsetof( 'convert', $_ ); 60 print ", sizeof( 'convert.$_' ) = ", $c->sizeof( "convert.$_" ), "\n"; 61} 62 63#------------------------------------------------- 64# Pack a Perl data structure into a binary string. 65# Note that not all members need to be specified. 66#------------------------------------------------- 67 68my $binary = $c->pack( 'convert', { 69 word => [-30000, 4711], 70 c32 => { dword => 0x01020304 } 71} ); 72 73#------------------------------------------------------- 74# Just a demonstration that pack does the right thing... 75#------------------------------------------------------- 76 77if( $c->sizeof( 'convert' ) == length $binary ) { 78 print "\nYup, the size matches!\n"; 79} 80 81#------------------------------------------------------- 82# Hexdump the binary string. 83# Note that all padding regions are initialized to zero. 84#------------------------------------------------------- 85 86print "\nBinary: ", hexdump( $binary ), "\n\n"; 87 88#--------------------------------------------------------------- 89# Unpack the binary string and dump the returned data structure. 90#--------------------------------------------------------------- 91 92my $data = $c->unpack( 'convert', $binary ); 93print Data::Dumper->Dump( [$data], ['data'] ); 94 95#------------------------------------------------------ 96# You can modify selected elements in the binary string 97# using the 3-argument version of 'pack'. 98#------------------------------------------------------ 99 100# only 'dword' will be modified 101$c->pack( 'convert', { dword => -559038737 }, $binary ); 102print "\nBinary: ", hexdump( $binary ), "\n\n"; 103print Dumper( $c->unpack( 'convert', $binary ) ); 104 105#-------------------------------------------------- 106# You can also use pack/unpack on compound members. 107#-------------------------------------------------- 108 109my $array = $c->unpack( 'convert.c32.bytes', 'ABCD' ); 110print "\n\$array = [ @$array ]\n"; 111 112#========================================================== 113# SUBROUTINES 114#========================================================== 115 116sub hexdump 117{ 118 join ' ', map { sprintf "%02X", $_ } unpack "C*", $_[0]; 119} 120!NO!SUBS! 121 122close OUT or die "Can't close $file: $!"; 123chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; 124 125