File Coverage

blib/lib/ELF/Writer.pm
Criterion Covered Total %
statement 146 204 71.5
branch 50 138 36.2
condition 13 43 30.2
subroutine 29 33 87.8
pod 0 14 0.0
total 238 432 55.0


line stmt bran cond sub pod time code
1             package ELF::Writer;
2 1     1   38398 use Moo 2;
  1         10636  
  1         6  
3 1     1   1068 use Carp;
  1         2  
  1         42  
4 1     1   398 use IO::File;
  1         6624  
  1         101  
5             BEGIN {
6             # Check if we need a wrapper for 'pack'
7             eval "use ELF::Writer::PackWrapper 'pack'"
8 1 50   1   1 unless eval{ pack('Q<',1) };
  1         17  
9             }
10 1     1   437 use namespace::clean;
  1         7676  
  1         5  
11              
12             our $VERSION= '0.011';
13              
14             # ABSTRACT: Encode elf files with pure-perl
15              
16              
17             sub _init_enum {
18 7     7   20 my ($to_sym, $from_sym, @name_to_num)= @_;
19 7         36 %$from_sym= @name_to_num;
20 7         39 %$to_sym= reverse @name_to_num;
21             }
22              
23              
24             our (%class_to_sym, %class_from_sym);
25             _init_enum(\%class_to_sym, \%class_from_sym,
26             '32bit' => 1,
27             '64bit' => 2,
28             );
29              
30             has class => ( is => 'rw', coerce => sub {
31             my $x= $class_from_sym{$_[0]};
32             defined $x? $x
33             : (int($_[0]) == $_[0])? $_[0]
34             : croak "$_[0] is not a valid 'class'"
35             });
36              
37             sub class_sym {
38 2     2 0 9 my $self= shift;
39 2 50       5 $self->class($_[0]) if @_;
40 2         28 my $v= $self->class;
41 2 50       20 $class_to_sym{$v} || $v
42             }
43              
44              
45             our (%data_to_sym, %data_from_sym);
46             _init_enum(\%data_to_sym, \%data_from_sym,
47             '2LSB' => 1,
48             '2MSB' => 2,
49             );
50              
51             has data => ( is => 'rw', coerce => sub {
52             my $x= $data_from_sym{$_[0]};
53             defined $x? $x
54             : (int($_[0]) == $_[0])? $_[0]
55             : croak "$_[0] is not a valid 'data'"
56             });
57              
58             sub data_sym {
59 2     2 0 8 my $self= shift;
60 2 50       5 $self->data($_[0]) if @_;
61 2         27 my $v= $self->data;
62 2 50       16 $data_to_sym{$v} || $v
63             }
64              
65              
66             has header_version => ( is => 'rw', default => sub { 1 } );
67              
68              
69             our (%osabi_to_sym, %osabi_from_sym);
70             _init_enum(\%osabi_to_sym, \%osabi_from_sym,
71             'SystemV' => 0,
72             'HP-UX' => 1,
73             'NetBSD' => 2,
74             'Linux' => 3,
75             'Solaris' => 6,
76             'AIX' => 7,
77             'IRIX' => 8,
78             'FreeBSD' => 9,
79             'OpenBSD' => 0x0C,
80             'OpenVMS' => 0x0D,
81             );
82              
83             has osabi => ( is => 'rw', coerce => sub {
84             my $x= $osabi_from_sym{$_[0]};
85             defined $x? $x
86             : (int($_[0]) == $_[0])? $_[0]
87             : croak "$_[0] is not a valid 'osabi'"
88             });
89              
90             sub osabi_sym {
91 2     2 0 7 my $self= shift;
92 2 50       7 $self->osabi($_[0]) if @_;
93 2         27 my $v= $self->osabi;
94 2 50       17 $osabi_to_sym{$v} || $v
95             }
96              
97              
98             has osabi_version => ( is => 'rw', default => sub { 0 } );
99              
100             our (%type_to_sym, %type_from_sym);
101             _init_enum(\%type_to_sym, \%type_from_sym,
102             'none' => 0,
103             'relocatable' => 1,
104             'executable' => 2,
105             'shared' => 3,
106             'core' => 4,
107             );
108              
109             has type => ( is => 'rw', coerce => sub {
110             my $x= $type_from_sym{$_[0]};
111             defined $x? $x
112             : (int($_[0]) == $_[0])? $_[0]
113             : croak "$_[0] is not a valid 'type'"
114             });
115              
116             sub type_sym {
117 5     5 0 271 my $self= shift;
118 5 50       11 $self->type($_[0]) if @_;
119 5         69 my $v= $self->type;
120 5 100       44 $type_to_sym{$v} || $v
121             }
122              
123              
124             our (%machine_to_sym, %machine_from_sym);
125             _init_enum(\%machine_to_sym, \%machine_from_sym,
126             'SPARC' => 0x02,
127             'i386' => 0x03,
128             'Motorola68K' => 0x04,
129             'Motorola88K' => 0x05,
130             'i860' => 0x07,
131             'MIPS-RS3000' => 0x08,
132             'MIPS-RS4000' => 0xA0,
133             'PowerPC' => 0x14,
134             'ARM' => 0x28,
135             'SuperH' => 0x2A,
136             'IA-64' => 0x32,
137             'x86-64' => 0x3E,
138             'AArch64' => 0xB7,
139             );
140              
141             has machine => ( is => 'rw', coerce => sub {
142             my $x= $machine_from_sym{$_[0]};
143             defined $x? $x
144             : (int($_[0]) == $_[0])? $_[0]
145             : croak "$_[0] is not a valid 'machine'"
146             });
147              
148             sub machine_sym {
149 1     1 0 5 my $self= shift;
150 1 50       4 $self->machine($_[0]) if @_;
151 1         16 my $v= $self->machine;
152 1 50       12 $machine_to_sym{$v} || $v
153             }
154              
155              
156             has version => ( is => 'rw', default => sub { 1 } );
157              
158             has flags => ( is => 'rw', default => sub { 0 } );
159              
160             has entry_point => ( is => 'rw' );
161              
162              
163             our $Magic= "\x7fELF";
164              
165             sub elf_header_len {
166 10     10 0 289 my $class= shift->class;
167 10 50       56 return $class == 1? 52
    100          
168             : $class == 2? 64
169             : croak "Don't know structs for elf class $class";
170             }
171             our @Elf_Header_Pack= (
172             'a4 C C C C C a7 v v V V V V V v v v v v v', # 32-bit LE
173             'a4 C C C C C a7 n n N N N N N n n n n n n', # 32-bit BE
174             'a4 C C C C C a7 v v V Q< Q< Q< V v v v v v v', # 64-bit LE
175             'a4 C C C C C a7 n n N Q> Q> Q> N n n n n n n', # 64-bit BE
176             );
177             sub _elf_header_packstr {
178 2     2   2 my ($self, $encoding)= @_;
179 2 50       5 $encoding= $self->_encoding unless defined $encoding;
180 2         25 $Elf_Header_Pack[ $encoding ];
181             }
182              
183             sub segment_header_elem_len {
184 4     4 0 47 my $class= shift->class;
185 4 50       25 return $class == 1? 32
    100          
186             : $class == 2? 56
187             : croak "Don't know structs for elf class $class";
188             }
189             # Note! there is also a field swap between 32bit and 64bit
190             our @Segment_Header_Pack= (
191             'V V V V V V V V',
192             'N N N N N N N N',
193             'V V Q< Q< Q< Q< Q< Q<',
194             'N N Q> Q> Q> Q> Q> Q>',
195             );
196             sub _segment_header_packstr {
197 2     2   3 my ($self, $encoding)= @_;
198 2 50       5 $encoding= $self->_encoding unless defined $encoding;
199 2         40 $Segment_Header_Pack[ $encoding ];
200             }
201              
202             sub section_header_elem_len {
203 2     2 0 35 my $class= shift->class;
204 2 50       15 return $class == 1? 40
    100          
205             : $class == 2? 64
206             : croak "Don't know structs for elf class $class";
207             }
208             our @Section_Header_Pack= (
209             'V V V V V V V V V V',
210             'N N N N N N N N N N',
211             'V V Q< Q< Q< Q< V V Q< Q<',
212             'N N Q> Q> Q> Q> N N Q> Q>',
213             );
214             sub _section_header_packstr {
215 0     0   0 my ($self, $encoding)= @_;
216 0 0       0 $encoding= $self->_encoding unless defined $encoding;
217 0         0 $Section_Header_Pack[ $encoding ];
218             }
219              
220             # Returns a number 0..3 used by the various routines when packing binary data
221             sub _encoding {
222 6     6   7 my $self= shift;
223 6         83 my $endian= $self->data;
224 6         80 my $bits= $self->class;
225 6 50 33     43 defined $endian && $endian > 0 && $endian < 3 or croak "Can't encode for data=$endian";
      33        
226 6 50 33     27 defined $bits && $bits > 0 && $bits < 3 or croak "Can't encode for class=$bits";
      33        
227 6         22 return ($bits-1)*2 + ($endian-1);
228             }
229              
230              
231             has segments => ( is => 'rw', coerce => \&_coerce_segments, default => sub { [] } );
232 2     2 0 2 sub segment_count { scalar @{ shift->segments } }
  2         26  
233 2     2 0 2 sub segment_list { @{ shift->segments } }
  2         26  
234              
235              
236             has sections => ( is => 'rw', coerce => \&_coerce_sections, default => sub { [] } );
237 2     2 0 3 sub section_count { scalar @{ shift->sections } }
  2         24  
238 2     2 0 3 sub section_list { @{ shift->sections } }
  2         33  
239              
240             has section_name_string_table_idx => ( is => 'rw' );
241              
242              
243             sub serialize {
244 2     2 0 81 my $self= shift;
245            
246             # Faster than checking bit lengths on every field ourself
247 1     1   1682 use warnings FATAL => 'pack';
  1         1  
  1         893  
248            
249             # Make sure all required attributes are defined
250             defined($self->$_) || croak "Attribute $_ is not defined"
251 2   50     29 for qw( class data osabi type machine header_version osabi_version version entry_point );
252            
253             # Clone the segments and sections so that our changes don't affect the
254             # configuration the user built.
255 2         174 my @segments= map { $_->clone } $self->segment_list;
  2         11  
256 2         13 my @sections= map { $_->clone } $self->section_list;
  0         0  
257 2         11 my $segment_table;
258             my $section_table;
259            
260             # Now apply defaults and set numbering for diagostics of errors
261 2         2 my $i= 0;
262 2         3 for (@segments) {
263 2         6 $_->_index($i++);
264 2         7 $self->_apply_segment_defaults($_);
265            
266             # There can be one segment which loads the segment table itself
267             # into the program's address space. If used, we track the pointer
268             # to that segment. We also clear it's 'data' and set it's 'size'
269             # to keep from confusing the code below.
270 2 50       35 if ($_->type == 6) {
271 0 0       0 croak "There can be only one segment of type 'phdr'"
272             if defined $segment_table;
273 0         0 $segment_table= $_;
274 0         0 $segment_table->data(undef);
275 0         0 $segment_table->size($self->segment_header_len * @segments);
276             }
277             }
278 2         13 $i= 0;
279 2         3 for (@sections) {
280 0         0 $_->_index($i++);
281 0         0 $self->_apply_section_defaults($_);
282             }
283            
284             # Build a list of every defined range of data in the file,
285             # and a list of every segment/section which needs automatically placed.
286 2         3 my @defined_ranges;
287             my @auto_offset;
288 2         3 for (@segments, @sections) {
289             # size is guaranteed to be defined by "_apply...defaults()"
290             # Data might not be defined if the user just wanted to point the
291             # segment at something, and offset might not be defined if the user
292             # just wants it appended wherever.
293 2 50       7 if (!defined $_->offset) {
294 0         0 push @auto_offset, $_;
295             }
296             else {
297 2 50       6 $_->offset >= 0 or croak $_->_name." offset cannot be negative";
298 2 50 33     14 push @defined_ranges, $_
299             if defined $_->data && length $_->data;
300             }
301             }
302            
303 2 50       3 if (@sections) {
304             # First section must always be the NULL section. If the user forgot this
305             # then their indicies might be off.
306 0 0       0 $sections[0]->type == 0
307             or croak "Section 0 must be type NULL";
308             # Sections may not overlap, regardless of whether the user attached data to them
309 0         0 my $prev_end= 0;
310 0         0 my $prev;
311 0         0 for (sort { $a->offset <=> $b->offset } $self->section_list) {
  0         0  
312 0 0       0 croak 'Section overlap between '.$_->_name.' and '.$prev->_name
313             if $_->offset < $prev_end;
314 0         0 $prev_end= $_->offset + $_->size;
315             }
316             }
317            
318             # Each segment and section can define data to be written to the file,
319             # but segments can overlap sections. Make sure their defined data doesn't
320             # conflict, or we wouldn't know which to write.
321 2         3 my $prev;
322 2         4 my $prev_end= $self->elf_header_len;
323 2         1 my $first_data;
324 2         3 @defined_ranges= sort { $a->data_offset <=> $b->data_offset } @defined_ranges;
  0         0  
325 2         4 for (@defined_ranges) {
326 2 0       6 croak 'Data overlap between '.$_->_name.' and '.($prev? $prev->_name : 'ELF header')
    50          
327             if $_->data_offset < $prev_end;
328 2         3 $prev= $_;
329 2         6 $prev_end= $_->data_offset + $_->size;
330             }
331            
332             # For each segment or section that needs an offset assigned, append to
333             # end of file.
334 2         3 for (@auto_offset) {
335 0         0 my $align= $_->_required_file_alignment;
336 0         0 $prev_end= int(($prev_end + $align - 1) / $align) * $align;
337 0         0 $_->offset($prev_end);
338 0 0 0     0 push @defined_ranges, $_ if defined $_->data && length $_->data;
339 0         0 $prev_end += $_->size;
340             }
341            
342             # Now, every segment and section have an offset and a length.
343             # We can now encode the tables.
344 2         2 my @insert;
345 2 50       3 if (@segments) {
346 2         3 my $segment_table_data= '';
347             $segment_table_data .= $self->_serialize_segment_header($_)
348 2         10 for @segments;
349             # The user might have defined this segment on their own.
350             # Otherwise we just create a dummy to use below.
351 2 50       36 if (!defined $segment_table) {
352 2 100       26 $segment_table= ELF::Writer::Segment->new(
353             align => ($self->class == 2? 8 : 4),
354             filesize => length($segment_table_data),
355             data => $segment_table_data,
356             );
357 2         4 push @insert, $segment_table;
358             } else {
359 0         0 $segment_table->data($segment_table_data);
360             }
361             }
362 2 50       5 if (@sections) {
363 0         0 my $section_table_data= '';
364             $section_table_data .= $self->_serialize_section_header($_)
365 0         0 for @sections;
366            
367 0 0       0 $section_table= ELF::Writer::Segment->new(
368             align => ($self->class == 2? 8 : 4),
369             filesize => length($section_table_data),
370             data => $section_table_data,
371             );
372 0         0 push @insert, $section_table;
373             }
374            
375             # Find a spot for the segment and/or section tables.
376             # Due to alignment, there is probably room to squeeze the table(s) inbetween
377             # other defined ranges. Else, put them at the end.
378 2         5 $prev_end= $self->elf_header_len;
379 2   66     11 for (my $i= 0; @insert and $i <= @defined_ranges; ++$i) {
380 2         6 my $align= $insert[0]->_required_file_alignment;
381 2         5 $prev_end= int(($prev_end + $align-1) / $align) * $align;
382 2 50 33     9 if ($i == @defined_ranges
383             or $prev_end + $insert[0]->size <= $defined_ranges[$i]->data_offset
384             ) {
385 2         3 $insert[0]->offset($prev_end);
386 2         6 splice @defined_ranges, $i, 0, shift @insert;
387             }
388             }
389            
390             # Now, we can finally encode the ELF header.
391 2 50 50     15 my $header= pack($self->_elf_header_packstr,
    50          
392             $Magic, $self->class, $self->data, $self->header_version,
393             $self->osabi, $self->osabi_version, '',
394             $self->type, $self->machine, $self->version, $self->entry_point,
395             ($segment_table? $segment_table->offset : 0),
396             ($section_table? $section_table->offset : 0),
397             $self->flags, $self->elf_header_len,
398             $self->segment_header_elem_len, $self->segment_count,
399             $self->section_header_elem_len, $self->section_count,
400             $self->section_name_string_table_idx || 0,
401             );
402             # sanity check
403 2 50       28 length($header) == $self->elf_header_len
404             or croak "Elf header len mismatch";
405            
406             # Write out the header and each range of defined bytes, padded with NULs as needed.
407 2         2 my $data= $header;
408 2         4 for (@defined_ranges) {
409 4         8 my $pad= $_->data_offset - length($data);
410 4 50       6 $data .= "\0" x $pad if $pad;
411 4         8 $data .= $_->data;
412             }
413 2         11 return $data;
414             }
415              
416             sub _serialize_segment_header {
417 2     2   3 my ($self, $seg)= @_;
418            
419             # Faster than checking bit lengths on every field ourself
420 1     1   5 use warnings FATAL => 'pack';
  1         5  
  1         205  
421            
422             # Make sure all required attributes are defined
423             defined $seg->$_ or croak "Attribute $_ is not defined"
424 2   50     28 for qw( type offset virt_addr align );
425            
426 2         20 my $filesize= $seg->filesize;
427 2 50       4 $filesize= length($seg->data) + $seg->data_offset
428             unless defined $filesize;
429            
430 2         3 my $align= $seg->align;
431 2         3 my $memsize= $seg->memsize;
432 2 50       3 $memsize= int(($filesize + $align - 1) / $align) * $align
433             unless defined $memsize;
434            
435             # 'flags' moves depending on 32 vs 64 bit, so changing the pack string isn't enough
436 2 100 50     7 return $self->_encoding < 2?
      50        
437             pack($self->_segment_header_packstr,
438             $seg->type, $seg->offset, $seg->virt_addr, $seg->phys_addr || 0,
439             $filesize, $memsize, $seg->flags, $seg->align
440             )
441             : pack($self->_segment_header_packstr,
442             $seg->type, $seg->flags, $seg->offset, $seg->virt_addr,
443             $seg->phys_addr || 0, $filesize, $memsize, $seg->align
444             );
445             }
446              
447             sub _serialize_section_header {
448 0     0   0 my ($self, $sec)= @_;
449            
450             # Make sure all required attributes are defined
451             defined $sec->$_ or croak "Attribute $_ is not defined"
452 0   0     0 for qw( type name flags addr offset size link info addralign entsize );
453            
454             # Faster than checking bit lengths on every field ourself
455 1     1   5 use warnings FATAL => 'pack';
  1         1  
  1         509  
456            
457 0         0 return pack($self->_section_header_packstr,
458             $sec->name, $sec->type, $sec->flags, $sec->addr, $sec->offset,
459             $sec->size, $sec->link, $sec->info, $sec->align, $sec->entry_size
460             );
461             }
462              
463              
464             sub write_file {
465 0     0 0 0 my ($self, $filename, $mode)= @_;
466 0 0       0 $mode= 0755 unless defined $mode;
467 0         0 require File::Temp;
468 0         0 my ($fh, $tmpname)= File::Temp::tempfile( $filename.'-XXXXXX' );
469 0 0       0 print $fh $self->serialize or croak "write: $!";
470 0 0       0 close $fh or croak "close: $!";
471 0 0       0 chmod($mode, $tmpname) or croak "chmod: $!";
472 0 0       0 rename($tmpname, $filename) or croak "rename: $!";
473             }
474              
475             # coerce arrayref of hashrefs into arrayref of objects
476             sub _coerce_segments {
477 14     14   30 my $spec= shift;
478 14         161 return [ map { (__PACKAGE__.'::Segment')->coerce($_) } @$spec ];
  2         10  
479             }
480              
481             # coerce arrayref of hashrefs into arrayref of objects
482             sub _coerce_sections {
483 14     14   9 my $spec= shift;
484 14         176 return [ map { (__PACKAGE__.'::Section')->coerce($_) } @$spec ];
  0         0  
485             }
486              
487             # Overridden by subclasses for machine-specific defaults
488             sub _apply_section_defaults {
489 0     0   0 my ($self, $sec)= @_;
490             # Undef type is "null" type 0
491 0         0 my $type= $sec->type;
492 0 0       0 defined $type
493             or $sec->type($type= 0);
494 0         0 my $offset= $sec->offset;
495 0         0 my $size= $sec->size;
496            
497 0 0       0 if ($type == 0) { # 'null'
    0          
498             # Ensure length and offset are zero
499 0 0       0 $size= $sec->size(0) unless defined $size;
500 0 0       0 $offset= $sec->offset(0) unless defined $offset;
501 0 0 0     0 croak "null section should have offset=0 and size=0"
502             if $offset || $size;
503             }
504             elsif ($type == 8) { # 'nobits'
505             # Offset can be set but ensure size is zero
506 0 0       0 $size= $sec->size(0) unless defined $size;
507 0 0       0 croak "nobits section should have size=0"
508             if $size;
509            
510             }
511             else {
512             # 'size' is required, but can be computed from 'data' and 'data_offset'.
513 0 0       0 if (!defined $size) {
514 0 0       0 defined $sec->data or croak "Section must define 'size' or 'data'";
515 0         0 $sec->size($sec->data_start + length($sec->data));
516             }
517             }
518             }
519              
520             # Overridden by subclasses for machine-specific defaults
521             sub _apply_segment_defaults {
522 2     2   3 my ($self, $seg)= @_;
523             # Undef type is "null" type 0
524 2         31 my $type= $seg->type;
525 2 50       11 defined $type
526             or $seg->type($type= 0);
527 2         5 my $offset= $seg->offset;
528 2         3 my $filesize= $seg->filesize;
529            
530 2 50       5 if ($type == 0) { # 'null'
531             # Ensure length and offset are zero
532 0 0       0 $filesize= $seg->filesize(0) unless defined $filesize;
533 0 0       0 $offset= $seg->offset(0) unless defined $offset;
534 0 0 0     0 croak "null segment should have offset=0 and filesize=0"
535             if $offset || $filesize;
536             }
537             else {
538             # 'filesize' is required, but can be computed from 'data' and 'data_offset'
539 2 50       4 if (!defined $filesize) {
540 2 50       10 defined $seg->data or croak "Segment must define 'filesize' or 'data'";
541 2         10 $filesize= $seg->filesize($seg->data_start + length($seg->data));
542             }
543             # Default memsize to filesize
544 2 50       8 $seg->memsize($filesize) unless defined $seg->memsize;
545             }
546             }
547              
548             # Loaded last, to make sure all data in this module is initialized
549             require ELF::Writer::Segment;
550             require ELF::Writer::Section;
551              
552             1;
553              
554             __END__