From c4bbdec38b7d8acc8d248c7cddb7da8c7ed09205 Mon Sep 17 00:00:00 2001
From: Gurusamy Sarathy <gsar@cpan.org>
Date: Tue, 15 Feb 2000 05:42:17 +0000
Subject: update exetype.pl tool

p4raw-id: //depot/perl@5094
---
 win32/Makefile       |  1 +
 win32/bin/exetype.pl | 75 ++++++++++++++++++++++++++++++++++++++++++----------
 win32/makefile.mk    |  1 +
 3 files changed, 63 insertions(+), 14 deletions(-)

diff --git a/win32/Makefile b/win32/Makefile
index 6bf5e6ec33..774e18bd54 100644
--- a/win32/Makefile
+++ b/win32/Makefile
@@ -471,6 +471,7 @@ UTILS		=			\
 		..\pod\podselect	\
 		..\x2p\find2perl	\
 		..\x2p\s2p		\
+		bin\exetype.pl		\
 		bin\runperl.pl		\
 		bin\pl2bat.pl		\
 		bin\perlglob.pl		\
diff --git a/win32/bin/exetype.pl b/win32/bin/exetype.pl
index 5846b3ee3b..27e3b94bc8 100644
--- a/win32/bin/exetype.pl
+++ b/win32/bin/exetype.pl
@@ -1,26 +1,60 @@
 #!perl -w
 use strict;
-unless (@ARGV == 2) {
-    print "Usage: $0 exefile [CONSOLE|WINDOWS]\n";
+
+# All the IMAGE_* structures are defined in the WINNT.H file
+# of the Microsoft Platform SDK.
+
+my %subsys = (NATIVE    => 1,
+              WINDOWS   => 2,
+              CONSOLE   => 3,
+              POSIX     => 7,
+              WINDOWSCE => 9);
+
+unless (0 < @ARGV && @ARGV < 3) {
+    printf "Usage: $0 exefile [%s]\n", join '|', sort keys %subsys;
     exit;
 }
-unless ($ARGV[1] =~ /^(console|windows)$/i) {
-    print "Invalid subsystem $ARGV[1], please use CONSOLE or WINDOWS\n";
+
+$ARGV[1] = uc $ARGV[1] if $ARGV[1];
+unless (@ARGV == 1 || defined $subsys{$ARGV[1]}) {
+    (my $subsys = join(', ', sort keys %subsys)) =~ s/, (\w+)$/ or $1/;
+    print "Invalid subsystem $ARGV[1], please use $subsys\n";
     exit;
 }
-my ($record,$magic,$offset,$size);
-open EXE, "+< $ARGV[0]" or die "Cannot open $ARGV[0]: $!";
+
+my ($record,$magic,$signature,$offset,$size);
+open EXE, "+< $ARGV[0]" or die "Cannot open $ARGV[0]: $!\n";
 binmode EXE;
-read EXE, $record, 32*4;
+
+# read IMAGE_DOS_HEADER structure
+read EXE, $record, 64;
 ($magic,$offset) = unpack "Sx58L", $record;
-die "Not an MSDOS executable file" unless $magic == 0x5a4d;
+
+die "$ARGV[0] is not an MSDOS executable file.\n"
+    unless $magic == 0x5a4d; # "MZ"
+
+# read signature, IMAGE_FILE_HEADER and first WORD of IMAGE_OPTIONAL_HEADER
 seek EXE, $offset, 0;
-read EXE, $record, 24;
-($magic,$size) = unpack "Lx16S", $record;
-die "PE header not found" unless $magic == 0x4550;
-die "Optional header not in NT32 format" unless $size == 224;
-seek EXE, $offset+24+68, 0;
-print EXE pack "S", uc($ARGV[1]) eq 'CONSOLE' ? 3 : 2;
+read EXE, $record, 4+20+2;
+($signature,$size,$magic) = unpack "Lx16Sx2S", $record;
+
+die "PE header not found" unless $signature == 0x4550; # "PE\0\0"
+
+die "Optional header is neither in NT32 nor in NT64 format"
+    unless ($size == 224 && $magic == 0x10b) || # IMAGE_NT_OPTIONAL_HDR32_MAGIC
+           ($size == 240 && $magic == 0x20b);   # IMAGE_NT_OPTIONAL_HDR64_MAGIC
+
+# Offset 68 in the IMAGE_OPTIONAL_HEADER(32|64) is the 16 bit subsystem code
+seek EXE, $offset+4+20+68, 0;
+if (@ARGV == 1) {
+    read EXE, $record, 2;
+    my ($subsys) = unpack "S", $record;
+    $subsys = {reverse %subsys}->{$subsys} || "UNKNOWN($subsys)";
+    print "$ARGV[0] uses the $subsys subsystem.\n";
+}
+else {
+    print EXE pack "S", $subsys{$ARGV[1]};
+}
 close EXE;
 __END__
 
@@ -52,6 +86,19 @@ use a console supplied by the operating system.
 The WINDOWS subsystem handles an application that does not require a
 console and creates its own windows, if required.
 
+=item NATIVE
+
+The NATIVE subsystem handles a Windows NT device driver.
+
+=item WINDOWSCE
+
+The WINDOWSCE subsystem handles Windows CE consumer electronics
+applications.
+
+=item POSIX
+
+The POSIX subsystem handles a POSIX application in Windows NT.
+
 =back
 
 =head1 AUTHOR
diff --git a/win32/makefile.mk b/win32/makefile.mk
index 64f89fdbb3..5e8a3efac7 100644
--- a/win32/makefile.mk
+++ b/win32/makefile.mk
@@ -576,6 +576,7 @@ UTILS		=			\
 		..\pod\podselect	\
 		..\x2p\find2perl	\
 		..\x2p\s2p		\
+		bin\exetype.pl		\
 		bin\runperl.pl		\
 		bin\pl2bat.pl		\
 		bin\perlglob.pl		\
-- 
cgit v1.2.1