Initial Commit

database/perl/vendor/lib/Win32/Exe/Section/Code.pm

@@ -0,0 +1,8 @@
+# Copyright 2004 by Audrey Tang <cpan@audreyt.org>
+
+package Win32::Exe::Section::Code;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;

database/perl/vendor/lib/Win32/Exe/Section/Data.pm

@@ -0,0 +1,8 @@
+# Copyright 2004 by Audrey Tang <cpan@audreyt.org>
+
+package Win32::Exe::Section::Data;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;

database/perl/vendor/lib/Win32/Exe/Section/Debug.pm

@@ -0,0 +1,8 @@
+# Copyright 2004 by Audrey Tang <cpan@audreyt.org>
+
+package Win32::Exe::Section::Debug;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;

database/perl/vendor/lib/Win32/Exe/Section/Exports.pm

@@ -0,0 +1,8 @@
+# Copyright 2004 by Audrey Tang <cpan@audreyt.org>
+
+package Win32::Exe::Section::Exports;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;

database/perl/vendor/lib/Win32/Exe/Section/Imports.pm

@@ -0,0 +1,8 @@
+# Copyright 2004 by Audrey Tang <cpan@audreyt.org>
+
+package Win32::Exe::Section::Imports;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;

database/perl/vendor/lib/Win32/Exe/Section/Resources.pm

@@ -0,0 +1,259 @@
+# Copyright 2004 by Audrey Tang <cpan@audreyt.org>
+
+package Win32::Exe::Section::Resources;
+
+use strict;
+use base 'Win32::Exe::Section';
+use constant DELEGATE_SUBS => (
+    'ResourceEntry' => [ 'high_bit' ],
+    'ResourceEntry::Id' => [ 'rt_to_id', 'id_to_rt' ],
+);
+
+sub initialize {
+    my $self = shift;
+    $self->make_table(0);
+    return $self;
+}
+
+sub table {
+    my $self = shift;
+    return $self->{table};
+}
+
+sub make_table {
+    my ($self, $offset, @path) = @_;
+    my $image = $self->substr($offset);
+    my $table = $self->require_class('ResourceTable')->new(
+    \$image, {
+        parent  => $self,
+        path    => \@path
+    },
+    );
+
+    foreach my $entry ($table->members) {
+    if ($entry->IsDirectory) {
+        $self->make_table($entry->VirtualAddress, @path, $entry->Name);
+    }
+    else {
+        $self->{table}{$entry->PathName} = $entry;
+    }
+    }
+}
+
+sub names {
+    my ($self) = @_;
+    my @rv = sort keys %{$self->{table}};
+    wantarray ? @rv : \@rv;
+}
+
+sub resources {
+    my ($self, $name) = @_;
+    my @rv = map $self->{table}{$_}, $self->names;
+    wantarray ? @rv : \@rv;
+}
+
+sub remove {
+    my ($self, $name) = @_;
+    delete $self->{table}{$_} for grep /^\Q$name\E/, $self->names;
+}
+
+sub insert {
+    my ($self, $name, $res) = @_;
+    $self->{table}{$name} = $res;
+}
+
+sub res {
+    my ($self, $name) = @_;
+    return $self->{table}{$name};
+}
+
+sub res_data {
+    my ($self, $name) = @_;
+    my $res = $self->res($name) or return;
+    return $res->Data;
+}
+
+sub res_codepage {
+    my ($self, $name) = @_;
+    my $res = $self->res($name) or return;
+    return $res->CodePage;
+}
+
+sub res_object {
+    my ($self, $name) = @_;
+    my $res = $self->res($name) or return;
+    return $res->object;
+}
+
+sub res_image {
+    my ($self, $name) = @_;
+    my $res = $self->res($name) or return;
+    my $object = $res->object or return $res->Data;
+    return $object->dump;
+}
+
+sub first_object {
+    my ($self, $type) = @_;
+    foreach my $object (grep $_, map $_->object, $self->resources) {
+    return $object if !$type or $object->is_type($type);
+    }
+    return undef;
+}
+
+sub objects {
+    my ($self, $type) = @_;
+    return grep { $type ? $_->is_type($type) : 1 }
+       grep { $_ } map { $_->object } $self->resources;
+}
+
+sub refresh {
+    my $self = shift;
+
+    my $res_num = @{$self->resources} or return pack('V*', (0) x 4);
+    my $entry_size = $self->entry_size(scalar $self->names);
+    my $data_entry_size = 16 * $res_num;
+
+    my %str_addr;
+    my $str_image  = '';
+    my $str_offset = $entry_size + $data_entry_size;
+
+    foreach my $name ($self->names) {
+    $name =~ s!^/!!;
+    foreach my $chunk (split("/", $name, -1)) {
+        $chunk =~ /^#/ and next;
+        $chunk =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+        next if exists $str_addr{$chunk};
+
+        die "String too long" if length($chunk) > 0xFFFF;
+
+        my $addr = length($str_image);
+        my $str = $self->encode_ucs2($chunk);
+        $str_image .= pack('v', length($str) / 2) . $str;
+
+        $str_addr{$chunk} = $addr + $str_offset;
+    }
+    }
+    $str_image .= $self->pad($str_image, 8);
+
+    my %data_entry_addr;
+    my $data_entry_image = '';
+    my $data_image       = '';
+    my $data_offset      = $str_offset + length($str_image);
+
+    foreach my $name ($self->names) {
+    $data_entry_addr{$name} = $entry_size + length($data_entry_image);
+
+    my $data_addr = $data_offset + length($data_image) + $self->VirtualAddress;
+    $data_entry_image .= pack(
+        'V4',
+        $data_addr,
+        length($self->res_data($name)),
+        $self->res_codepage($name),
+        0,
+    );
+    $data_image .= $self->res_data($name);
+    $data_image .= $self->pad($data_image, 8);
+    }
+
+    my $entry_image = '';
+    $self->make_entry(
+    \$entry_image,
+    '',
+    [$self->names],
+    \%str_addr,
+    \%data_entry_addr,
+    );
+
+    length($entry_image) == $entry_size or die "Wrong size";
+
+    $self->SetData(
+    join('', $entry_image, $data_entry_image, $str_image, $data_image)
+    );
+}
+
+sub entry_size {
+    my ($self, $names) = @_;
+
+    my %entries;
+    foreach my $name (grep length, @$names) {
+    $name =~ m!^/([^/]*)(.*)! or next;
+    push(@{ $entries{$1} }, $2);
+    }
+
+    my $count = keys %entries or return 0;
+    my $size = 8 * ($count + 2);
+    $size += $self->entry_size($_) for values %entries;
+    return $size;
+}
+
+sub make_entry {
+    my ($self, $image_ref, $prefix, $names, $str_addr, $data_entry_addr) = @_;
+
+    if (@$names == 1 and !length($names->[0])) {
+    return $data_entry_addr->{$prefix};
+    }
+
+    my %entries;
+    foreach my $name (@$names) {
+    $name =~ m!^/([^/]*)(.*)! or next;
+    my ($path, $name) = ($1, $2);
+    my $type = ($path =~ /^#/) ? 'id' : 'name';
+    push(@{ $entries{$type}{$path} }, $name);
+    }
+
+    my $addr = length($$image_ref);
+    my $num_name = keys %{ $entries{name} };
+    my $num_id   = keys %{ $entries{id} };
+    $$image_ref .= pack('V3vv', 0, 0, 0, $num_name, $num_id);
+
+    my $entry_offset = length($$image_ref);
+    $$image_ref .= pack('V*', (0) x (($num_name + $num_id) * 2));
+
+    foreach my $entry ($self->sort_entry(\%entries)) {
+    my ($type, $name) = @$entry;
+    my $id;
+    if ($type eq 'id') {
+        $id = $name;
+        $id =~ s/^#//;
+        $id = $self->rt_to_id($id);
+    }
+    else {
+        (my $n = $name) =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+        $id = $str_addr->{$n} | $self->high_bit;
+    }
+
+    my $rva = $self->make_entry(
+        $image_ref,
+        "$prefix/$name",
+        $entries{$type}{$name},
+        $str_addr,
+        $data_entry_addr,
+    );
+
+    substr($$image_ref, $entry_offset, 8) = pack('VV', $id, $rva);
+    $entry_offset += 8;
+    }
+
+    return ($addr | $self->high_bit);
+}
+
+sub sort_entry {
+    my ($self, $entries) = @_;
+
+    my @names = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map {
+    my $name = lc($_);
+    $name =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+    [ $name => $_ ];
+    } keys %{ $entries->{name} };
+
+    my @ids = map "#$_", sort {
+    $self->rt_to_id($a) <=> $self->rt_to_id($b)
+    } map substr($_, 1), keys %{ $entries->{id} };
+
+    return(
+    (map [ name => $_ ], @names),
+    (map [ id   => $_ ], @ids),
+    );
+}
+
+1;