Merging upstream version 2.9.1.

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 568 insertions, 0 deletions

diff --git a/samples/mhtml-tool b/samples/mhtml-tool
new file mode 100755
index 0000000..aaf7f70
--- /dev/null
+++ b/samples/mhtml-tool
@@ -0,0 +1,568 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+$| = 1;
+
+=pod
+
+=head1 NAME
+
+B<mhtml-tool> - Unpack a MIME HTML archive
+
+
+=head1 SYNOPSIS
+
+B<mhtml-tool> unpacks MIME HTML archives that some browsers (such as Opera)
+save by default.  The file extensions of such archives are ".mht" or ".mhtml".
+
+The first HTML file in the archive is taken to be the primary web page, the
+other contained files for "page requisites" such as images or frames.  The
+primary web page is written to the output directory (the current directory by
+default), the requisites to a subdirectory named after the primary HTML file
+name without extension, with "_files" appended.  Link URLs in all HTML
+files referring to requisites are rewritten to point to the saved files.
+
+
+=head1 OPTIONS
+
+=over
+
+=item B<-e> program
+
+=item B<--exec> program
+
+Unpack the archive into a temporary directory and execute the given program
+in that directory, passing the primary HTML (first text/html entry) of the
+archive as a parameter.
+
+If B<-o> is given, use that directory location with the program.
+
+If the program is "lynx" or "(e)links(2)", this script uses the "-force-html"
+option to help when the entrypoint lacks a ".html" file-suffix.
+
+=item B<-h>
+
+=item B<-?>
+
+=item B<--help>
+
+Print a brief usage summary.
+
+=item B<-l>
+
+=item B<--list>
+
+List archive contents instead of unpacking.  Four columns are output: file
+name, MIME type, size and URL.  Unavailable entries are replaced by "(?)".
+
+=item B<-o> I<directory/ or name>
+
+=item B<--output> I<directory/ or name>
+
+If the argument ends in a slash or is an existing directory, unpack to that
+directory instead of current directory.  Otherwise the argument is taken as a
+path to the file name to write the primary HTML file to.  If the output
+directory does not exist, it is created.
+
+=back
+
+
+=head1 SEE ALSO
+
+https://github.com/ThomasDickey/mhtml-tool
+
+https://github.com/clapautius/mhtml-tool
+
+http://www.volkerschatz.com/unix/uware/unmht.html
+
+=head1 COPYLEFT
+
+B<unmht> is Copyright (c) 2012 Volker Schatz.  It may be copied and/or
+modified under the same terms as Perl.
+
+B<mhtml-tool> is Copyright (c) 2018 Tudor M. Pristavu. It may be copied and/or
+modified under the same terms as Perl.
+
+B<mhtml-tool> is Copyright (c) 2024 Thomas E. Dickey. It may be copied and/or
+modified under the same terms as Perl.
+
+=cut
+
+use Cwd;
+use File::Path;
+use File::Copy;
+use File::Glob;
+use File::Temp qw/ tempdir /;
+use URI;
+use MIME::Base64;
+use MIME::QuotedPrint;
+use HTML::PullParser;
+use HTML::Tagset;
+use Getopt::Long;
+
+our $path_limit = 255;
+our %shorten_path;
+
+# RFC 7230 (obsoletes RFC 2616) indicates that URI length is limited by the
+# server line-length, which it suggests should be at least 8000 octets.  The
+# problem is that components of pathnames might be limited to 255 bytes, while
+# the URI components can be much longer.  As an additional complication, the
+# too-long components can be both directory- and file-names, and truncating
+# the components can produce collisions.
+sub shorten_path {
+    my $actual = $_[0];
+    if ( not defined $shorten_path{$actual} ) {
+        my @parts = split /\//, $actual;
+        for my $n ( 0 .. $#parts ) {
+            $parts[$n] = substr( $parts[$n], 0, $path_limit );
+        }
+        $shorten_path{$actual} = join "/", @parts;
+    }
+    return $shorten_path{$actual};
+}
+
+# URLs can include "&" and other characters which require quoting to use in
+# a shell command.  We use system() rather than exec() to allow the temporary
+# directory to be cleaned up after running lynx.
+sub quoted {
+    my $param = $_[0];
+    $param =~ s/'/'\"'\"'/g;
+    return sprintf( "'%s'", $param );
+}
+
+# Add approriate ordinal suffix to a number.
+# -> Number
+# <- String of number with ordinal suffix
+sub ordinal {
+    return $_[0] . "th" if $_[0] > 3 && $_[0] < 20;
+    my $unitdig = $_[0] % 10;
+    return $_[0] . "st" if $unitdig == 1;
+    return $_[0] . "nd" if $unitdig == 2;
+    return $_[0] . "rd" if $unitdig == 3;
+    return $_[0] . "th";
+}
+
+{
+    my %taken;
+
+ # Find unique file name.
+ # -> Preferred file name, or undef
+ #    MHT archive name (as a fallback if no name given)
+ # <- File name not conflicting with names returned by previous calls, but which
+ #    may exist!
+    sub unique_name {
+        my ( $fname, $mhtname ) = @_;
+        my ( $trunc, $ext );
+
+        if ( defined $fname ) {
+            $fname =~ s/^\s+//;
+            $fname =~ s/\s+$//;
+            $taken{$fname} = 1, return $fname unless $taken{$fname};
+            ( $trunc, $ext ) = $fname =~ /^(.*?)(\.\w+)?$/;
+            $ext //= "";
+        }
+        else {
+            $trunc = $mhtname || "unpack";
+            $trunc =~ s/\.mht(?:ml?)?$//i;
+            $ext = "";
+        }
+        for my $suff ( 1 .. 9999 ) {
+            $fname = "${trunc}_$suff$ext";
+            $taken{$fname} = 1, return $fname unless $taken{$fname};
+            ++$suff;
+        }
+        return undef;
+    }
+
+}
+
+# Output error message and exit with return value 1.
+sub abort {
+    print STDERR "$_[0]\n";
+    exit 1;
+}
+
+# Generate output file directories and primary HTML file name depending on
+# --output option and primary HTML file name from archive.  In case the primary
+# HTML file is not the first file in the archive, the secondary files directory
+# is renamed or the files moved on the second call, when the primary HTML file
+# name is known.
+# -> Value of --output option (or  undef)
+#    Primary HTML file name from MHT archive
+#    Flag indicating if .._files subdirectory should be created
+#    Hash reference to store resulting paths to
+sub mkfiledir {
+    my ( $outputopt, $firsthtmlname, $needfilesdir, $out ) = @_;
+
+    my $prevfilespath = $$out{filespath};
+    $firsthtmlname = "unpackmht-$$" unless defined $firsthtmlname;
+    if ( !defined $outputopt ) {
+        $$out{toppath} = ".";
+    }
+    elsif ( -d $outputopt || $outputopt =~ m!/$! ) {
+        $$out{toppath} = $outputopt;
+    }
+    else {
+        ( $$out{toppath}, $firsthtmlname ) = $outputopt =~ m!^(.*/)?([^/]+)$!;
+        abort "Empty output file name." unless defined $firsthtmlname;
+        $firsthtmlname .= ".html"       unless $firsthtmlname =~ /\./;
+        $$out{toppath} = "."            unless defined $$out{toppath};
+    }
+    $$out{toppath} =~ s!/$!!;
+    $$out{firstout} = "$$out{toppath}/$firsthtmlname";
+    $$out{filesdir} = $firsthtmlname;
+    $$out{filesdir} =~ s/\.[^.]+$//;
+    $$out{filesdir} = substr( $$out{filesdir}, 0, $path_limit - 6 );
+    $$out{filesdir} .= "_files";
+    $$out{filespath} = "$$out{toppath}/$$out{filesdir}";
+
+    if ( defined $prevfilespath ) {
+        return unless $prevfilespath ne $$out{filespath};
+        return unless -d $prevfilespath;
+        if ( !-d $$out{filespath} ) {
+            File::Copy::move( $prevfilespath, $$out{filespath} )
+              or abort "Could not rename secondary files directory.";
+        }
+        else {
+            for ( File::Glob::bsd_glob("$prevfilespath/*") ) {
+                File::Copy::move( $_, $$out{filespath} )
+                  or abort "Could not move secondary files.";
+            }
+        }
+    }
+    else {
+        my $createall = $needfilesdir ? $$out{filespath} : $$out{toppath};
+        if ( !-d $createall ) {
+            File::Path::make_path($createall)
+              or abort "Could not create output directory $createall.";
+        }
+    }
+}
+
+my %opt;
+my @optdescr = ( 'exec|e=s', 'output|o=s', 'list|l!', 'help|h|?!', 'debug|d!' );
+my %config;
+
+my $status = GetOptions( \%opt, @optdescr );
+
+if ( !$status || $opt{help} ) {
+    print <<EOF;
+Usage: mhtml-tool [options] <MHT file>
+
+By default, mhtml-tool unpacks an MHT archive (an archive type saved by some
+browsers) to the current directory.  The first HTML file in the archive is
+taken for the primary web page, and all other contained files are written to a
+directory named after that HTML file.
+
+Options:
+-e, --exec    Execute the given program on a temporarily-unpacked archive
+-l, --list    List archive contents (file name, MIME type, size and URL)
+-o, --output  Unpack to directory <dir/> or to file <name>.html
+
+Use the command "pod2man mhtml-tool > mhtml-tool.1" or
+"pod2html mhtml-tool > mhtml-tool.html" to extract the manual.
+EOF
+    exit !$status;
+}
+
+my $origin  = getcwd;
+my $tempdir = "";
+if ( $opt{exec} and not defined $opt{output} ) {
+    $tempdir = tempdir( CLEANUP => 1 );
+    $opt{output} = $tempdir . "/";
+}
+
+my $orig_sep  = $/;
+my $crlf_file = 0;
+
+# Print a message to stdout (if debug is enabled).
+sub debug_msg {
+    if ( $opt{debug} ) {
+        print ":debug: $_[0]\n";
+    }
+}
+
+# Read next line. Remove line endings (both unix & windows style).
+sub read_next_line {
+    my $cur_line = <>;
+    chomp $cur_line;
+    if ( $cur_line =~ /\r$/ ) {
+        debug_msg("It's a CRLF file") if ( $crlf_file == 0 );
+        $crlf_file++;
+    }
+    $cur_line =~ s/\r//;
+    return $cur_line;
+}
+
+# Parse headers.
+# Handle multi-line headers (lines starting with spaces are part of a
+# multi-line header).
+# Read data from <> until the first empty line.
+# Set $crlf_file to 1 if it's a CRLF (windoze) file.
+sub parse_headers {
+    my %headers;
+    my $sep = $/;
+    $/ = $orig_sep;
+    my $cur_line  = read_next_line;
+    my $full_line = $cur_line;
+
+    while ( not( $cur_line =~ /^$/ ) ) {
+        if ( $cur_line =~ /;$/ ) {    # if a continued line...
+            while ( ( $cur_line = read_next_line ) =~ /^\h+/ ) {
+                $cur_line =~ s/^\h+//;
+                $full_line = $full_line . " " . $cur_line;
+            }
+            if ( $full_line =~ s/^([-\w]+): (.*)$// ) {
+                $headers{$1} = $2;
+                debug_msg("(1) New header $1 with value $2");
+            }
+        }
+        else {
+            if ( $full_line =~ s/^([-\w]+): (.*)$// ) {
+                $headers{$1} = $2;
+                debug_msg("(2) New header $1 with value $2");
+            }
+        }
+        $cur_line  = read_next_line;
+        $full_line = $cur_line;
+    }
+    $/ = $sep;
+    return %headers;
+}
+
+my %global_headers = parse_headers();
+
+abort "Can't find Content-Type header - not a MIME HTML file?"
+  if ( !defined( $global_headers{'Content-Type'} ) );
+debug_msg("Global Content-Type: $global_headers{'Content-Type'}");
+
+my $boundary = '';
+my $endcode  = '';
+
+# FIXME: - add other possible mime types
+# Types implemented so far are:
+#   Content-Type: multipart/related; boundary="----=_NextPart_01D8BCC9.47C2B260"
+#   Content-Type: text/html; charset="utf-8"
+if ( $global_headers{'Content-Type'} =~
+    m!multipart/related;.*\h+boundary="?([^"]*)"?$! )
+{
+    $endcode = $boundary = $1;
+    $endcode =~ s/\s+$//;
+    if ($crlf_file) {
+        $/ = "\r\n--$boundary\r\n";
+    }
+    else {
+        $/ = "\n--$boundary\n";
+    }
+    debug_msg("Boundary: $boundary");
+}
+elsif ( $global_headers{'Content-Type'} =~ m!text/html! ) {
+    $/ = '';
+}
+else {
+    die "Error: Unknown Content-Type: $global_headers{'Content-Type'}\n";
+}
+
+my %by_url;
+my @htmlfiles;
+my $fh;
+
+{
+    my $fileind = 1;
+    my $leading = "--$boundary\n";
+    while ( defined( my $data = <> ) ) {
+        chomp $data;
+        $data =~ s/\R/\n/g;   # handle various other line-endings (windows, mac)
+        while ( index( $data, $leading ) == 0 ) {
+            $data = substr( $data, length($leading) );
+        }
+        my %headers;
+        while ( $data =~ s/^([-\w]+): (.*)\n// ) {
+            $headers{$1} = $2;
+            debug_msg("New header $1 with value $2");
+
+          # read (and ignore atm) lines starting with space (multi-line headers)
+            while ( $data =~ s/^\h+.*\n// ) {
+                debug_msg("empty line");
+            }
+        }
+        if ( scalar(%headers) == 0 ) {
+            %headers = %global_headers
+              ;   # fallback to the global headers as needed, usually for "text"
+        }
+        $data =~ s/^\n//;
+        $data =~ s/\n--$endcode--\r?\n$/\n/s;
+        my ( $type, $origname );
+        if ( defined( $headers{"Content-Type"} ) ) {
+            ($type) = $headers{"Content-Type"} =~ /^(\w+\/\w+)\b/;
+            debug_msg("type=$type");
+        }
+        else {
+            print "Error: No Content-Type found, skipping chunk\n";
+
+        # we could print the bad chunk here...
+        # but it's probably just a "warning" about
+        #   "if you see this your software isn't recognizing a web archive file"
+            next;
+        }
+        if ( defined( $headers{"Content-Type"} )
+            && $headers{"Content-Type"} =~ /\bname=([^;]*)/ )
+        {
+            $origname = $1;
+            ($type) = $headers{"Content-Type"} =~ /^(\w+\/\w+)\b/;
+            $type //= "";
+        }
+        elsif ( defined( $headers{"Content-Disposition"} )
+            && $headers{"Content-Disposition"} =~ /\bfilename=([^;]*)/ )
+        {
+            $origname = $1;
+            if ( !defined($type) ) {
+                $type = $origname =~ /\.html?$/i ? "text/html" : "";
+            }
+        }
+        elsif ( defined( $headers{"Content-Location"} ) ) {
+            $origname = $headers{"Content-Location"};
+
+            # for unknown reasons, files generated by IE11 may contain some
+            # local paths with '\' instead of '/'
+            if ( $origname =~ m!^file://.*\\! ) {
+                debug_msg("Windows-style path detected: $origname");
+                $origname =~ s!^.*\\!!;
+            }
+            $origname =~ s!^.*/!!;
+            if ( !defined($type) ) {
+                $type = "";
+            }
+        }
+
+        $origname = "noname" unless defined $origname;
+        $origname = "noname" if ( $origname eq "" );
+        my $fname = unique_name( $origname, $ARGV[0] );
+        if ( !defined( $headers{"Content-Transfer-Encoding"} ) ) {
+            print STDERR "Info: Encoding of ", ordinal($fileind),
+              " file not found - leaving as-is.\n";
+        }
+        elsif ( $headers{"Content-Transfer-Encoding"} =~ /\bbase64\b/i ) {
+            $data = MIME::Base64::decode($data);
+        }
+        elsif (
+            $headers{"Content-Transfer-Encoding"} =~ /\bquoted-printable\b/i )
+        {
+            $data = MIME::QuotedPrint::decode($data);
+        }
+        debug_msg("origname=$origname; fname=$fname; type=$type");
+        debug_msg( "Content-Type: " . $headers{"Content-Type"} );
+        debug_msg( "Data size: " . length($data) );
+        if ( $opt{list} ) {
+            $origname =~ s/\s+$// if defined $origname;
+            my $size = length($data);
+            print $fname // "(?)", "\t", $type || "(?)", "\t$size\t",
+              $headers{"Content-Location"} // "(?)", "\n";
+            next;
+        }
+        $headers{fname} = $fname;
+        if ( $headers{"Content-Location"} ) {
+            $headers{url} = $headers{"Content-Location"};
+            $headers{url} =~ s/\s+$//;
+            $by_url{ $headers{url} } = \%headers;
+            debug_msg("Content-Location: $headers{url}");
+        }
+        else {
+            debug_msg("?? no location");
+        }
+        if ( $type eq "text/html" ) {
+            $headers{data} = $data;
+            if ( scalar @htmlfiles == 0 ) {   # first html file must have a name
+                if ( !$headers{fname} ) {
+                    $headers{fname} = "index.html";
+                }
+            }
+            push @htmlfiles, \%headers;
+            debug_msg("New html file in list: $headers{fname}");
+        }
+        else {
+            mkfiledir( $opt{output}, $htmlfiles[0]->{fname}, 1, \%config );
+            $fname = shorten_path "$config{filespath}/$fname";
+            open $fh, ">$fname" or abort "Could not create file $fname.";
+            print $fh $data;
+            close $fh;
+        }
+    }
+    continue {
+        debug_msg("");
+        ++$fileind;
+    }
+}
+
+if ( $opt{list} ) {
+    exit(0);
+}
+
+mkfiledir( $opt{output}, $htmlfiles[0]->{fname}, 0, \%config );
+
+my $entrypoint  = ".";
+my $filesprefix = $config{filesdir} . "/";
+my $outname     = $config{firstout};
+print "primary html output name: $outname\n";
+
+for my $html (@htmlfiles) {
+    my $linksubst = "";
+    my $p         = HTML::PullParser->new(
+        doc     => \$html->{data},
+        "start" => 'text, attr, tagname',
+        "text"  => 'text',
+        "end"   => 'text'
+    );
+    while ( defined( my $tok = $p->get_token() ) ) {
+        my $linkary;
+        my @linkattrs;
+        if (   ref( $tok->[1] )
+            && ( $linkary   = $HTML::Tagset::linkElements{ $tok->[2] } )
+            && ( @linkattrs = grep $tok->[1]->{$_}, @$linkary ) )
+        {
+            for my $attr (@linkattrs) {
+                my $uri = URI->new( $tok->[1]->{$attr} );
+                next unless defined $uri;
+                next unless defined $html->{url};
+                $uri = $uri->abs( $html->{url} );
+                $tok->[1]->{$attr} =
+                  "$filesprefix" . $by_url{ $uri->as_string() }->{fname}
+                  if $by_url{ $uri->as_string() };
+            }
+            delete $tok->[1]->{"/"};
+            $linksubst .=
+              "<$tok->[2] "
+              . join( " ",
+                map( "$_=\"$tok->[1]->{$_}\"", keys %{ $tok->[1] } ) )
+              . ">";
+        }
+        else {
+            $linksubst .= $tok->[0];
+        }
+    }
+    $outname = "$config{filespath}/$html->{fname}" unless defined $outname;
+    $outname = shorten_path $outname;
+    open $fh, ">$outname" or abort "Could not create file $outname.";
+    print $fh $linksubst;
+    close $fh;
+    $entrypoint = $outname if ( $entrypoint eq "." );
+
+    # for all except the first HTML file:
+    $filesprefix = "";
+    $outname     = undef;
+}
+
+if ( $tempdir ne "" ) {
+    chdir $tempdir;
+    my $enforce = "";
+    $enforce = "-force-html"
+      if (  $entrypoint ne "."
+        and $entrypoint !~ /\.htm(l)?$/
+        and $opt{exec}  =~ /(lynx|((e)?links(2)?))/ );
+    system( sprintf( "%s %s %s", $opt{exec}, $enforce, quoted $entrypoint ) );
+    chdir $origin;
+}
+
+1;