-
Notifications
You must be signed in to change notification settings - Fork 138
/
pbc_header.pl
executable file
·192 lines (157 loc) · 5.22 KB
/
pbc_header.pl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
#! perl
# Copyright (C) 2004-2012, Parrot Foundation.
use strict;
use warnings;
use 5.008;
=head1 NAME
pbc_header.pl - PBC header info and manipulation
=head1 SYNOPSIS
perl pbc_header.pl files ...
perl pbc_header.pl --update-fingerprint files ...
=head1 DESCRIPTION
The F<PBC_COMPAT> file is used to maintain Parrot bytecode
compatibility. During release preparation (and other changes to
PBC_COMPAT) the fingerprint of existing bytecode files is invalidated.
This utility updates the version and fingerprint information in the bytecode,
but can of course not assure that it will run correctly, when incompatible
changes were done.
If no options are given, a summary of the PBC header is printed to STDOUT.
=head1 SEE ALSO
The C<pbc_dump -h> utility does a much more thorough job of showing bytecode file
headers, but fails with version-incompatible pbc files.
=cut
use Getopt::Long;
use Digest::MD5 qw(md5);
my %opt;
my $word_size = 4;
main();
sub get_version {
my $version_file = 'VERSION';
open my $IN, '<', $version_file or die "Can't read $version_file";
my $v = <$IN>;
close $IN;
$v =~ /^(\d+)\.(\d+).?(\d+)?/;
my ($major, $minor, $patch) = ($1, $2, $3 ? $3 : 0);
die "Can't read $version_file" unless defined $major;
return ( $major, $minor, $patch );
}
sub update_fp {
my (@args) = @_;
my ( $major, $minor, $patch ) = get_version();
for my $f (@args) {
my $b;
open my $F, "+<", "$f" or die "Can't open $f: $!";
binmode $F;
# magic8, wordsize byteorder floattype
# parrot_major parrot_minor parrot_patch
# bc_major bc_minor uuid_type uuid_size
seek $F, 11, 0; # pos 11: major, minor, patch
print $F pack "ccc", $major, $minor, $patch;
goto SKIP; # disabled
# stamp with the fingerprint UUID
# uuid_type = 1, uuid_size = 12, uuid_data = $fp
seek $F, 16, 0;
read $F, $b, 8;
my ($type, $uuid_len) = unpack "cc", $b;
# copy the tail first
my $leftover = (18 + $uuid_len) % 16;
my $n = $leftover == 0 ? 0 : 16 - $leftover;
my $dirstart = 18 + $uuid_len + $n;
seek $F, $dirstart, 0; # Fw to dir
my $size = -s $F;
read $F, $b, $size - $dirstart; # read rest of the file
my $fp = md5($b);
my $fp_len = length $fp;
$leftover = (18 + $fp_len) % 16;
$n = $leftover == 0 ? 0 : 16 - $leftover;
$dirstart = 18 + $fp_len + $n;
seek $F, $dirstart, 0; # Back to new dir
print $F $b; # print tail
SEEK:
seek $F, 16, 0; # back to pos 16: uuid_type, uuid_size
print $F pack "cc", 1, $fp_len;
print $F $fp;
SKIP:
close $F;
}
return;
}
my @pbc_header_type_names;
BEGIN {
@pbc_header_type_names = qw( directory default fixup constant
bytecode annotations pic dependencies );
}
sub pbc_info {
my @args = @_;
for my $f (@args) {
my $b;
open my $F, "+<", "$f" or die "Can't open $f: $!";
binmode $F;
print "$f:\n";
show_pbc_file_info($F);
close $F;
}
}
sub show_pbc_file_info {
my $F = shift;
# [bad assumption? -- rgr, 10-Feb-08.
# No, header format is the same also for 64bit - rurban 2009-02-19]
my $word_unpack = 'V';
my $packfile_offset = 0;
my $read_pbc_words = sub {
my ($n_words) = @_;
my @result;
my $bytes;
read $F, $bytes, $n_words*$word_size;
for my $i (0 .. $n_words-1) {
my $word = substr $bytes, $word_size*$i, $word_size;
push(@result, unpack $word_unpack, $word);
}
@result;
};
# Display single_byte fields.
my @byte_fields = qw( wordsize byteorder floattype
parrot_major parrot_minor parrot_patch
bc_major bc_minor
uuid_type uuid_size );
my $n_byte_fields = @byte_fields;
my $header;
read $F, $header, $n_byte_fields+8;
$packfile_offset += ($n_byte_fields+8)/$word_size;
for my $i ( 0 .. $n_byte_fields-1 ) {
my $c = substr $header, $i+8, 1;
$c = unpack 'c', $c;
printf "\t%-14s= %3d\n", $byte_fields[$i], $c;
}
# Show the UUID, if any, followed by the header padding.
my $uuid_type = ord substr $header, $n_byte_fields+6;
my $uuid_len = ord substr $header, $n_byte_fields+7;
my $leftover = (18+$uuid_len) % 16;
my $n = $leftover == 0 ? 0 : 16 - $leftover;
my $uuid;
read $F, $uuid, $uuid_len+$n;
$packfile_offset += ($uuid_len+$n)/$word_size;
if ($uuid_type) {
printf "\t%-14s= '%s'\n", 'UUID', unpack "H$uuid_len", $uuid;
}
printf "\t%-14s= %3d\n", 'pad', $n;
# Show the directory format header.
printf "\t%-14s= %d, %d, %d, %d\n", 'dir_format', $read_pbc_words->(4);
$packfile_offset += 4;
}
sub main {
my ( $result, $upd_fp );
$result = GetOptions( "update-fingerprint" => \$upd_fp, );
my (@args) = $^O eq 'MSWin32' ? <@ARGV> : @ARGV;
$upd_fp and do {
update_fp(@args);
exit;
};
return pbc_info(@args);
}
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4: