new script dosepsbin (11nov11)

git-svn-id: svn://tug.org/texlive/trunk@24759 c570f23f-e606-0410-a88d-b1316a301751

3 files changed, 443 insertions, 0 deletions

diff --git a/Build/source/texk/texlive/linked_scripts/Makefile.am b/Build/source/texk/texlive/linked_scripts/Makefile.am
index 5af2eb066af..908fb66b193 100644
--- a/Build/source/texk/texlive/linked_scripts/Makefile.am
+++ b/Build/source/texk/texlive/linked_scripts/Makefile.am
@@ -79,6 +79,7 @@ texmf_dist_other_scripts = \
 	ctanify/ctanify \
 	ctanupload/ctanupload.pl \
 	de-macro/de-macro \
+	dosepsbin/dosepsbin.pl \
 	dviasm/dviasm.py \
 	ebong/ebong.py \
 	epspdf/epspdf.rb \
diff --git a/Build/source/texk/texlive/linked_scripts/Makefile.in b/Build/source/texk/texlive/linked_scripts/Makefile.in
index 802b831c5f0..7a952627353 100644
--- a/Build/source/texk/texlive/linked_scripts/Makefile.in
+++ b/Build/source/texk/texlive/linked_scripts/Makefile.in
@@ -234,6 +234,7 @@ texmf_dist_other_scripts = \
 	ctanify/ctanify \
 	ctanupload/ctanupload.pl \
 	de-macro/de-macro \
+	dosepsbin/dosepsbin.pl \
 	dviasm/dviasm.py \
 	ebong/ebong.py \
 	epspdf/epspdf.rb \
diff --git a/Build/source/texk/texlive/linked_scripts/dosepsbin/dosepsbin.pl b/Build/source/texk/texlive/linked_scripts/dosepsbin/dosepsbin.pl
new file mode 100755
index 00000000000..b87bd25af54
--- /dev/null
+++ b/Build/source/texk/texlive/linked_scripts/dosepsbin/dosepsbin.pl
@@ -0,0 +1,441 @@
+#!/usr/bin/env perl
+#
+use strict;
+$^W=1;
+
+my $prj = 'dosepsbin';
+my $version = '1.0';
+my $date = '2011/11/10';
+my $author = 'Heiko Oberdiek';
+my $copyright = "Copyright 2011 $author";
+
+my $verbose = 0;
+my $quiet = 0;
+my $inputfile = '';
+my $file_eps = '';
+my $file_wmf= '';
+my $file_tiff = '';
+my $buf_size = 0x1000000;
+
+my $title = "\U$prj\E $date v$version, $copyright\n";
+
+sub die_error ($;$) {
+    my $msg = shift;
+    $msg = "\n!!! Error: $msg!\n";
+    if (@_) {
+        my $ref = shift;
+        foreach my $key (sort keys %$ref) {
+            my $value = $$ref{$key};
+            $key =~ s/ /_/g;
+            $key =~ s/^\d+_?//;
+            $msg .= "    [$key: $value]\n";
+        }
+    }
+    die $msg;
+}
+
+sub warning ($) {
+    my $msg = shift;
+    print "!!! Warning: $msg!\n";
+}
+
+sub verbose (@) {
+    return unless $verbose;
+    my @msg = @_;
+    print "* @msg\n";
+}
+
+sub verbose_kv ($$) {
+    return unless $verbose;
+    my $key = shift;
+    my $value = shift;
+    $key =~ s/ /_/g;
+    print "    [$key: $value]\n";
+}
+
+sub die_usage {
+    my $msg = $_[0];
+    pod2usage(
+        -exitstatus => 2,
+        -msg        => "\n==> $msg!\n");
+}
+
+use Getopt::Long;
+use Pod::Usage;
+
+GetOptions(
+    'verbose'         => sub {
+        $verbose = 1;
+        $quiet = 0;
+    },
+    'quiet'           => sub {
+        $quiet = 1;
+        $verbose = 0;
+    },
+    'help|?'          => sub {
+        print $title;
+        pod2usage(1);
+    },
+    'man'             => sub {
+        pod2usage(-exitstatus => 0, -verbose => 2);
+    },
+    'version'         => sub {
+        print "$prj $date v$version\n";
+        exit(0);
+    },
+    'inputfile=s'     => \$inputfile,
+    'eps-file=s'       => \$file_eps,
+    'wmf-file=s'       => \$file_wmf,
+    'tiff-file=s'      => \$file_tiff,
+) or die_usage('Unknown option');
+
+print $title unless $quiet;
+
+verbose_kv 'program name', $0;
+verbose_kv 'osname', $^O;
+verbose_kv 'perl version', $^V ? sprintf('v%vd', $^V) : $];
+
+$inputfile = shift @ARGV if not $inputfile and @ARGV;
+$inputfile or die_error "Missing input file";
+
+# If input file does not exist, try with extension ".eps"
+if (not -f $inputfile) {
+    my $file = "$inputfile.eps";
+    $inputfile = $file if -f $file;
+}
+-f $inputfile or
+        die_error "Input file not found", {
+            'input file' => $inputfile
+        };
+verbose_kv 'input file', $inputfile;
+
+# Get file size of input file
+my @tmp = stat $inputfile;
+@tmp or die_error "Getting size of Input file `$inputfile' failed";
+my $inputfile_size = $tmp[7];
+$inputfile_size > 30 or
+        die_error "Input file size is too small", {
+            '1 input file' => $inputfile,
+            '2 file size' => $inputfile_size,
+        };
+verbose_kv 'input file size', $inputfile_size;
+
+# Open input file
+open(IN, '<', $inputfile) or # die_error "Input file `$inputfile' not found";
+        die_error "Cannot open input file", {
+            '1 input file' => $inputfile,
+            '2 os error' => $!,
+        };
+binmode(IN);
+
+# Read header
+my $header;
+read IN, $header, 30 or
+        die_error "Reading the header of the input file failed", {
+            'file' => $inputfile,
+            'os error' => $!,
+        };
+# Check ASCII PS header
+if ('%!' eq substr $header, 0, 2) {
+    $header =~ m/^(%![A-Za-z0-9\.\- \t]+)/;
+    my $first_line = $1;
+    die_error "Input file seems to be an ASCII PostScript file", {
+        '1 input file' => $inputfile,
+        '2 file header' => $first_line,
+    }
+}
+my ($id,
+    $offset_ps, $length_ps,
+    $offset_wmf, $length_wmf,
+    $offset_tiff, $length_tiff,
+    $checksum) = unpack 'NV6n', $header;
+
+my $id_hex = unpack 'H8', pack 'N', $id;
+$id_hex = "0x\U$id_hex\E";
+verbose_kv 'header id', $id_hex;
+$id eq 0xC5D0D3C6 or
+        die_error "Input file is not a `DOS EPS binary file'", {
+            '1 input file' => $inputfile,
+            '2 file header id' => $id_hex,
+        };
+
+# Check checksum
+if ($checksum == 0xFFFF) {
+    verbose_kv 'checksum', '0xFFFF (ignored)';
+}
+else {
+    my $cs = 0;
+    map { $cs ^= $_ } unpack 'n14', $header;
+    if ($cs != $checksum) {
+        my $cs_hex = unpack 'H4', pack 'n', $cs;
+        $cs_hex = "0x\U$cs_hex\E";
+        my $cs_found = unpack 'H4', pack 'n', $checksum;
+        $cs_found = "0x\U$cs_found\E";
+        die_error "Checksum mismatch", {
+                '1 input file' => $inputfile,
+                '2 checksum found' => $cs_found,
+                '3 checksum expected' => $cs_hex,
+        };
+    }
+}
+
+verbose_kv 'offset of PS section', $offset_ps;
+verbose_kv 'length of PS section', $length_ps;
+verbose_kv 'offset of WMF section', $offset_wmf;
+verbose_kv 'length of WMF section', $length_wmf;
+verbose_kv 'offset of TIFF section', $offset_tiff;
+verbose_kv 'length of TIFF section', $length_tiff;
+
+{
+    my %check_positions;
+    sub check_section ($$$) {
+        my $type = shift;
+        my $ref_off = shift;
+        my $ref_len = shift;
+        if ($$ref_off == 0 and $$ref_len == 0) {
+            print "--> $type section is not available.\n" unless $quiet;
+            return '<not present>';
+        }
+        $$ref_off >= 32 and $$ref_off < $inputfile_size or
+                die_error "Invalid offset of PS section", {
+                    '1 input file' => $inputfile,
+                    "2 offset of $type section" => $$ref_off,
+                    "3 length of $type section" => $$ref_len,
+                };
+        $$ref_len >= 0 and $$ref_off + $$ref_len <= $inputfile_size or
+                die_error "Invalid length of PS section", {
+                    '1 input file' => $inputfile,
+                    "2 offset of $type section" => $$ref_off,
+                    "3 length of $type section" => $$ref_len,
+                };
+        $check_positions{$$ref_off} = $$ref_off + $$ref_len;
+        print "--> $type section with $$ref_len bytes.\n" unless $quiet;
+        return sprintf '%d..%d', $$ref_off, $$ref_off + $$ref_len - 1;
+    }
+    my $sec_ps   = check_section 'PS', \$offset_ps, \$length_ps;
+    verbose_kv 'position of PS section', $sec_ps;
+    my $sec_wmf  = check_section 'WMF', \$offset_wmf, \$length_wmf;
+    verbose_kv 'position of WMF section', $sec_wmf;
+    my $sec_tiff = check_section 'TIFF', \$offset_tiff, \$length_tiff;
+    verbose_kv 'position of TIFF section', $sec_tiff;
+    my $pos = 30;
+    foreach my $beg (sort keys %check_positions) {
+        $check_positions{$beg} >= $pos or
+                die_error "Section overlap detected", {
+                    '1 input file' => $inputfile,
+                    '2 position of header' => "0..29",
+                    '3 position of PS section' => $sec_ps,
+                    '4 position of WMF section' => $sec_wmf,
+                    '5 position of TIFF section' => $sec_tiff,
+                };
+    }
+}
+
+sub write_file ($$$$) {
+    my $type = shift;
+    my $file = shift;
+    my $off = shift;
+    my $len = shift;
+    my $org_len = $len;
+    return unless $file;
+    verbose_kv "$type file", $file;
+    if ($off <= 0 or $len <= 0) {
+        warning "No $type section found";
+        return;
+    }
+    my $position = $off;
+    seek IN, $off, 0 or
+            die_error "Moving to $type section offset failed", {
+                '1 input file' => $inputfile,
+                '2 position' => $off,
+                '3 os error' => $!,
+            };
+    open(OUT, '>', $file) or
+            die_error "Opening $type file for writing failed", {
+                "1 $type file" => $file,
+                '2 os error' => $!,
+            };
+    binmode(OUT);
+    while ($len > 0) {
+        my $read_len = ($len > $buf_size) ? $buf_size : $len;
+        my $buf;
+        my $read_count = read IN, $buf, $read_len;
+        $read_count > 0 or
+                die_error "Reading file failed", {
+                    '1 input file' => $inputfile,
+                    "2 $type file" => $file,
+                    '3 offset' => $position,
+                    '4 length' => $read_len,
+                    '5 os error' => $!,
+                };
+        $position += $read_count;
+        print OUT $buf or
+                die_error "Writing $type file failed", {
+                    "1 $type file" => $file,
+                    '2 offset' => $org_len - $len,
+                    '3 length' => $read_count,
+                    '4 os error' => $!,
+                };
+        $len -= $read_count;
+    }
+    close(OUT);
+    print "==> $type file written: [$file]\n" unless $quiet;
+}
+
+write_file 'TIFF', $file_tiff, $offset_tiff, $length_tiff;
+write_file 'WMF', $file_wmf, $offset_wmf, $length_wmf;
+write_file 'EPS', $file_eps, $offset_ps, $length_ps;
+
+close(IN);
+
+1;
+
+__DATA__
+
+=head1 NAME
+
+dosepsbin -- Extract PS/WMF/TIFF sections from DOS EPS binary files
+
+=head1 VERSION
+
+2011-11-10 v1.0
+
+=head1 SYNOPSIS
+
+The progam B<dosepsbin> analyses an EPS file that is not
+a plain ASCII PostScript file but given as DOS EPS binary file.
+
+    dosepsbin [options] <input file>
+
+First it analyzes the I<input file>, validates its header
+and summarizes the available sections. Depending on the
+given options, the sections are then written to files.
+
+Options:
+
+    --eps-file <file>      Write PS section to <file>.
+    --wmf-file <file>      Write WMF section to <file>.
+    --tiff-file <file>      Write WMF section to <file>.
+    --inputfile <file>     The name of the input file.
+    --verbose              Verbose output.
+    --quiet                Only errors and warnings are printed.
+    --help                 Brief help message.
+    --man                  Full documentation.
+    --version              Print version identification.
+
+The files for output must be different from the input file.
+
+=head1 DESCRIPTION
+
+=head2 DOS EPS Binary File Format
+
+A Encapsulated PostScript (EPS) file can also given in a special
+binary format to support the inclusion of a thumbnail. The file
+format starts with a binary header that contains the positions of
+the possible sections:
+
+=over
+
+=item * Postscript (PS)
+
+=item * Windows Metafile Format (WMF)
+
+=item * Tag Image File Format (TIFF)
+
+=back
+
+The PS section must be present and either the WMF file or the TIFF
+file should be given.
+
+=head1 OPTIONS
+
+=over
+
+=item B<->B<-eps-file>=<I<file>>
+
+The PS section is written to <I<file>>. The output file must
+be different from the input file.
+
+=item B<->B<-wmf-file>=<I<file>>
+
+The WMF section is written to <I<file>> if present. The output
+file must be different from the input file.
+
+=item B<->B<-tiff-file>=<I<file>>
+
+The TIFF section is written to <I<file>> if present. The output
+file must be different from the input file.
+
+=item B<->B<-inputfile>=<I<file>>
+
+The input file can also be given directly on the command line.
+If the file does not exist, then the file with extension `.eps'
+is tried.
+
+=item B<->B<-verbose>
+
+Verbose messages.
+
+=item B<->B<-quiet>
+
+No messages are printed except for errors and warnings.
+
+=item B<->B<-help>
+
+Display help screen.
+
+=item B<->B<-man>
+
+Prints manual page.
+
+=item B<->B<-version>
+
+Print version identification and exit.
+
+=back
+
+=head1 EXAMPLES
+
+The following command extracts the PS section from file F<test.eps>
+and stores the result in file F<test-ps.eps>:
+
+    dosepsbin --eps-file test-ps.eps test.eps
+
+=head1 AUTHOR
+
+Heiko Oberdiek, email: heiko.oberdiek at googlemail.com
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2011 by Heiko Oberdiek.
+
+This library is free software; you may redistribute it and/or
+modify it under the same terms as Perl itself
+(Perl Artistic License/GNU General Public License, version 2).
+
+=head1 SEE ALSO
+
+The DOS EPS binary file format is described
+in section "5.2 Windows Metafile or TIFF":
+
+    Adobe Developer Support,
+    Encapsulated PostScript File Format Specification,
+    Version 3.0,
+    1992-05-01,
+    http://partners.adobe.com/public/developer/en/ps/5002.EPSF_Spec.pdf
+
+=head1 HISTORY
+
+=over 2
+
+=item B<2011/11/10 v1.0>
+
+=over 2
+
+=item * First version.
+
+=back
+
+=back
+
+=cut