File Coverage

blib/lib/GBK.pm

Criterion	Covered	Total	%
statement	68	134	50.7
branch	24	74	32.4
condition	0	3	0.0
subroutine	11	13	84.6
pod	0	2	0.0
total	103	226	45.5

package GBK;
use strict;
BEGIN { $INC{'warnings.pm'} = '' if $] < 5.006 } use warnings;
######################################################################
#
# GBK - Source code filter to escape GBK script
#
# http://search.cpan.org/dist/Char-GBK/
#
# Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
######################################################################

use 5.00503;    # Galapagos Consensus 1998 for primetools
# use 5.008001; # Lancaster Consensus 2013 for toolchains

# 12.3. Delaying use Until Runtime
# in Chapter 12. Packages, Libraries, and Modules
# of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
# (and so on)

# Version numbers should be boring
# http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
# For the impatient, the disinterested or those who just want to follow
# a recipe, my advice for all modules is this:
# our $VERSION = "0.001"; # or "0.001_001" for a dev release
# $VERSION = CORE::eval $VERSION; # No!! because '1.10' makes '1.1'

use vars qw($VERSION);
$VERSION = '1.22';
$VERSION = $VERSION;

BEGIN {
    if ($^X =~ / jperl /oxmsi) {
        die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
    }
    if (CORE::ord('A') == 193) {
        die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
    }
    if (CORE::ord('A') != 0x41) {
        die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
    }
}

BEGIN {
    (my $dirname = __FILE__) =~ s{^(.+)/[^/]*$}{$1};
    unshift @INC, $dirname;
    CORE::require Egbk;
}

# instead of Symbol.pm
BEGIN {
    sub gensym () {
        if ($] < 5.006) {
            return \do { local *_ };
        }
        else {
            return undef;
        }
    }
}

# P.714 29.2.39. flock
# in Chapter 29: Functions
# of ISBN 0-596-00027-8 Programming Perl Third Edition.

# P.863 flock
# in Chapter 27: Functions
# of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.

# P.228 Inlining Constant Functions
# in Chapter 6: Subroutines
# of ISBN 0-596-00027-8 Programming Perl Third Edition.

# P.331 Inlining Constant Functions
# in Chapter 7: Subroutines
# of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.

sub LOCK_SH() {1}
sub LOCK_EX() {2}
sub LOCK_UN() {8}
sub LOCK_NB() {4}

sub unimport {}
sub GBK::escape_script;

# 6.18. Matching Multiple-Byte Characters
# in Chapter 6. Pattern Matching
# of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
# (and so on)

# regexp of character
my $qq_char   = qr/(?> \\c[\x40-\x5F] | \\? (?:[\x81-\xFE][\x00-\xFF] | [\x00-\xFF]) )/oxms;
my  $q_char   = qr/(?> [\x81-\xFE][\x00-\xFF] | [\x00-\xFF] )/oxms;

# when this script is main program
if ($0 eq __FILE__) {

    # show usage
    unless (@ARGV) {
        die <
$0: usage

perl $0 GBK_script.pl > Escaped_script.pl.e
END
    }

    print GBK::escape_script($ARGV[0]);
    exit 0;
}

my($package,$filename,$line,$subroutine,$hasargs,$wantarray,$evaltext,$is_require,$hints,$bitmask) = caller 0;

# called any package not main
if ($package ne 'main') {
    die <
@{[__FILE__]}: escape by manually command '$^X @{[__FILE__]} "$filename" > "@{[__PACKAGE__]}::$filename"'
and rewrite "use $package;" to "use @{[__PACKAGE__]}::$package;" of script "$0".
END
}

# P.302 Module Privacy and the Exporter
# in Chapter 11: Modules
# of ISBN 0-596-00027-8 Programming Perl Third Edition.
#
# A module can do anything it jolly well pleases when it's used, since use just
# calls the ordinary import method for the module, and you can define that
# method to do anything you like.

# P.406 Module Privacy and the Exporter
# in Chapter 11: Modules
# of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
#
# A module can do anything it jolly well pleases when it's used, since use just
# calls the ordinary import method for the module, and you can define that
# method to do anything you like.

sub import {

    if (Egbk::e("$filename.e")) {
        if (exists $ENV{'CHAR_DEBUG'}) {
            Egbk::unlink "$filename.e";
        }
        elsif (Egbk::z("$filename.e")) {
            Egbk::unlink "$filename.e";
        }
        else {

            #----------------------------------------------------
            #  older >
            #  newer >>>>>
            #----------------------------------------------------
            # Filter >
            # Source >>>>>
            # Escape >>>   needs re-escape (Source was changed)
            #
            # Filter >>>
            # Source >>>>>
            # Escape >     needs re-escape (Source was changed)
            #
            # Filter >>>>>
            # Source >>>
            # Escape >     needs re-escape (Source was changed)
            #
            # Filter >>>>>
            # Source >
            # Escape >>>   needs re-escape (Filter was changed)
            #
            # Filter >
            # Source >>>
            # Escape >>>>> executable without re-escape
            #
            # Filter >>>
            # Source >
            # Escape >>>>> executable without re-escape
            #----------------------------------------------------

            my $mtime_filter = (Egbk::stat(__FILE__     ))[9];
            my $mtime_source = (Egbk::stat($filename    ))[9];
            my $mtime_escape = (Egbk::stat("$filename.e"))[9];
            if (($mtime_escape < $mtime_source) or ($mtime_escape < $mtime_filter)) {
                Egbk::unlink "$filename.e";
            }
        }
    }

    if (not Egbk::e("$filename.e")) {
        my $fh = gensym();
        Egbk::_open_a($fh, "$filename.e") or die __FILE__, ": Can't write open file: $filename.e\n";

        # 7.19. Flushing Output
        # in Chapter 7. File Access
        # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.

        select((select($fh), $|=1)[0]);

        if (0) {
        }
        elsif (exists $ENV{'CHAR_NONBLOCK'}) {

            # P.419 File Locking
            # in Chapter 16: Interprocess Communication
            # of ISBN 0-596-00027-8 Programming Perl Third Edition.

            # P.524 File Locking
            # in Chapter 15: Interprocess Communication
            # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.

            # P.571 Handling Race Conditions
            # in Chapter 23: Security
            # of ISBN 0-596-00027-8 Programming Perl Third Edition.

            # P.663 Handling Race Conditions
            # in Chapter 20: Security
            # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.

            # (and so on)

            CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
            if ($@) {
                die __FILE__, ": Can't immediately write-lock the file: $filename.e\n";
            }
        }
        else {
            CORE::eval q{ flock($fh, LOCK_EX) };
        }

        CORE::eval q{ truncate($fh, 0) };
        seek($fh, 0, 0) or die __FILE__, ": Can't seek file: $filename.e\n";

        my $e_script = GBK::escape_script($filename);
        print {$fh} $e_script;

        my $mode = (Egbk::stat($filename))[2] & 0777;
        chmod $mode, "$filename.e";

        close($fh) or die "Can't close file: $filename.e: $!";
    }

    my $fh = gensym();
    Egbk::_open_r($fh, "$filename.e") or die __FILE__, ": Can't read open file: $filename.e\n";

    if (0) {
    }
    elsif (exists $ENV{'CHAR_NONBLOCK'}) {
        CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
        if ($@) {
            die __FILE__, ": Can't immediately read-lock the file: $filename.e\n";
        }
    }
    else {
        CORE::eval q{ flock($fh, LOCK_SH) };
    }

    my @switch = ();
    if ($^W) {
        push @switch, '-w';
    }
    if (defined $^I) {
        push @switch, '-i' . $^I;
        undef $^I;
    }

    # P.707 29.2.33. exec
    # in Chapter 29: Functions
    # of ISBN 0-596-00027-8 Programming Perl Third Edition.
    #
    # If there is more than one argument in LIST, or if LIST is an array with more
    # than one value, the system shell will never be used. This also bypasses any
    # shell processing of the command. The presence or absence of metacharacters in
    # the arguments doesn't affect this list-triggered behavior, which makes it the
    # preferred from in security-conscious programs that do not with to expose
    # themselves to potential shell escapes.
    # Environment variable PERL5SHELL(Microsoft ports only) will never be used, too.

    # P.855 exec
    # in Chapter 27: Functions
    # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
    #
    # If there is more than one argument in LIST, or if LIST is an array with more
    # than one value, the system shell will never be used. This also bypasses any
    # shell processing of the command. The presence or absence of metacharacters in
    # the arguments doesn't affect this list-triggered behavior, which makes it the
    # preferred from in security-conscious programs that do not wish to expose
    # themselves to injection attacks via shell escapes.
    # Environment variable PERL5SHELL(Microsoft ports only) will never be used, too.

    # P.489 #! and Quoting on Non-Unix Systems
    # in Chapter 19: The Command-Line Interface
    # of ISBN 0-596-00027-8 Programming Perl Third Edition.

    # P.578 #! and Quoting on Non-Unix Systems
    # in Chapter 17: The Command-Line Interface
    # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.

    my $system = 0;

    # DOS-like system
    if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
        $system = Egbk::_systemx(
            _escapeshellcmd_MSWin32($^X),

        # -I switch can not treat space included path
        #   (map { '-I' . _escapeshellcmd_MSWin32($_) } @INC),
            (map { '-I' .                         $_  } @INC),

            @switch,
            '--',
            map { _escapeshellcmd_MSWin32($_) } "$filename.e", @ARGV
        );
    }

    # UNIX-like system
    else {
        $system = Egbk::_systemx(
            _escapeshellcmd($^X),
            (map { '-I' . _escapeshellcmd($_) } @INC),
            @switch,
            '--',
            map { _escapeshellcmd($_) } "$filename.e", @ARGV
        );
    }

    # exit with actual exit value
    exit($system >> 8);
}

# escape shell command line on DOS-like system
sub _escapeshellcmd_MSWin32 {
    my($word) = @_;
    if ($word =~ / [ ] /oxms) {
        return qq{"$word"};
    }
    else {
        return $word;
    }
}

# escape shell command line on UNIX-like system
sub _escapeshellcmd {
    my($word) = @_;
    return $word;
}

# P.619 Source Filters
# in Chapter 24: Common Practices
# of ISBN 0-596-00027-8 Programming Perl Third Edition.

# P.718 Source Filters
# in Chapter 21: Common Practices
# of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.

# escape GBK script
sub GBK::escape_script {
    my($script) = @_;
    my $e_script = '';

    # read GBK script
    my $fh = gensym();
    Egbk::_open_r($fh, $script) or die __FILE__, ": Can't open file: $script\n";
    local $/ = undef; # slurp mode
    $_ = <$fh>;
    close($fh) or die "Can't close file: $script: $!";

    if (/^ use Egbk(?:(?>\s+)(?>[0-9\.]*))?(?>\s*); $/oxms) {
        return $_;
    }
    else {

        # #! shebang line
        if (s/\A(#!.+?\n)//oms) {
            my $head = $1;
            $head =~ s/\bjperl\b/perl/gi;
            $e_script .= $head;
        }

        # DOS-like system header
        if (s/\A(\@rem(?>\s*)=(?>\s*)'.*?'(?>\s*);\s*\n)//oms) {
            my $head = $1;
            $head =~ s/\bjperl\b/perl/gi;
            $e_script .= $head;
        }

        # P.618 Generating Perl in Other Languages
        # in Chapter 24: Common Practices
        # of ISBN 0-596-00027-8 Programming Perl Third Edition.

        # P.717 Generating Perl in Other Languages
        # in Chapter 21: Common Practices
        # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.

        if (s/(.*^#(?>\s*)line(?>\s+)(?>[0-9]+)(?:(?>\s+)"(?:$q_char)+?")?\s*\n)//oms) {
            my $head = $1;
            $head =~ s/\bjperl\b/perl/gi;
            $e_script .= $head;
        }

        # P.210 5.10.3.3. Match-time code evaluation
        # in Chapter 5: Pattern Matching
        # of ISBN 0-596-00027-8 Programming Perl Third Edition.

        # P.255 Match-time code evaluation
        # in Chapter 5: Pattern Matching
        # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.

        # '...' quote to avoid "Octal number in vector unsupported" on perl 5.6

        $e_script .= sprintf("use Egbk '%s.0'; # 'quote' for perl5.6\n", $GBK::VERSION); # require run-time routines version

        # use GBK version qw(ord reverse getc);
        if (s/^ (?>\s*) use (?>\s+) (?: Char | GBK ) (?>\s*) ([^\x81-\xFE;]*) ; \s* \n? $//oxms) {

            # require version
            my $list = $1;
            if ($list =~ s/\A ((?>[0-9]+)\.(?>[0-9]+)) \.0 (?>\s*) //oxms) {
                my $version = $1;
                if ($version ne $GBK::VERSION) {
                    my @file = grep -e, map {qq{$_/GBK.pm}} @INC;
                    my %file = map { $_ => 1 } @file;
                    if (scalar(keys %file) >= 2) {
                        my $file = join "\n", sort keys %file;
                        warn <
****************************************************
                   C A U T I O N

              CONFLICT GBK.pm FILE

$file
****************************************************

END
                    }
                    die "Script $0 expects GBK.pm $version, but @{[__FILE__]} is version $GBK::VERSION\n";
                }
                $e_script .= qq{die "Script \$0 expects Egbk.pm $version, but \\\$Egbk::VERSION is \$Egbk::VERSION" if \$Egbk::VERSION ne '$version';\n};
            }
            elsif ($list =~ s/\A ((?>[0-9]+)(?>\.[0-9]*)) (?>\s*) //oxms) {
                my $version = $1;
                if ($version > $GBK::VERSION) {
                    die "Script $0 required GBK.pm $version, but @{[__FILE__]} is only version $GBK::VERSION\n";
                }
            }

            # demand ord, reverse, and getc
            if ($list !~ /\A (?>\s*) \z/oxms) {
                local $@;
                my @list = CORE::eval $list;
                for (@list) {
                    $Egbk::function_ord     = 'GBK::ord'     if /\A ord \z/oxms;
                    $Egbk::function_ord_    = 'GBK::ord_'    if /\A ord \z/oxms;
                    $Egbk::function_reverse = 'GBK::reverse' if /\A reverse \z/oxms;
                    $Egbk::function_getc    = 'GBK::getc'    if /\A getc \z/oxms;

                    # avoid: used only once: possible typo at ...
                    $Egbk::function_ord     = $Egbk::function_ord;
                    $Egbk::function_ord_    = $Egbk::function_ord_;
                    $Egbk::function_reverse = $Egbk::function_reverse;
                    $Egbk::function_getc    = $Egbk::function_getc;
                }
            }
        }
    }

    $e_script .= GBK::escape();

    return $e_script;
}

1;

__END__