view release on metacpan or  search on metacpan

perl.pm.PL  view on Meta::CPAN

                reserved parenthesis taint closure semicolon);
#use warnings qw(FATAL closed threads internal debugging pack substr malloc unopened portable prototype
#                inplace io pipe unpack regexp deprecated exiting glob digit printf
#                utf8 layer reserved parenthesis taint closure semicolon);
no  warnings qw(exec newline);

use feature ();

BEGIN {
	if ($^V >= 5.011) {
		feature->import( qw(say state switch unicode_strings) );
	} else {
		feature->import( qw(say state switch) );
	}
}

use utf8;
use open qw(:utf8 :std);
use mro 'c3';

BEGIN {
	$HINTS = $^H              & ~$HINTS;
	$WARNS = ${^WARNING_BITS} & ~( $WARNS // ("\0" x length ${^WARNING_BITS}) );
	my %h = %{^H};
	delete @h{ keys %HINTS };
	%HINTS = %h;
}

sub dumper($) {
	require Data::Dumper;
	my $s = Data::Dumper->new([@_])
			->Terse(1)
			->Indent(1)
			->Purity(0)
			->Useqq(1)
			->Quotekeys(0)
			->Dump;
	$s =~ s{\n+$}{}s;
	$s;
}

while (<DATA>) {
	if (/^SELFBEGIN/) {
		printf '	defined ${^WARNING_BITS}'."\n".
			'		?	${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "%s"'."\n".
			'		:	${^WARNING_BITS} = "%s"'.";\n"
			,
			(join('', map "\\x$_", unpack "(H2)*", $WARNS))x2;
		printf "	\$^H |= 0x%x;\n\n", $HINTS;
	}
	elsif (/^IMPORT/) {
		print  "	# use warnings\n";
		printf '	${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "%s";'."\n\n",
			join '', map "\\x$_", unpack "(H2)*", $WARNS;
		
		print  "	# use strict, utf8, open, 5.010, ...\n";
		printf "	\$^H |= 0x%x;\n\n", $HINTS;
		
		print  "	# use feature qw(@{[ keys %HINTS ]})\n";
		for (keys %HINTS) {
			print "	\$^H{'$_'} = ".dumper( $HINTS{$_}).";\n";
		}
		print "\n";
	}
	elsif (/^UNIMPORT/) {
		# TODO
		print  "	# no warnings\n";
		printf '	${^WARNING_BITS} = "%s";'."\n\n",
			join '', map "\\x$_", unpack "(H2)*", $NOWARNS;
		
		print  "	# no strict, utf8, open, 5.010, ...\n";
		printf "	\$^H &= ~0x%x;\n\n", $HINTS;
		
		print  "	# no feature qw(@{[ keys %HINTS ]})\n";
		for (keys %HINTS) {
			print "	delete \$^H{'$_'};\n";
		}
		print "\n";
	}
	else {
		print;
	}
}

close STDOUT;
rename "$ARGV[0]~", $ARGV[0];

__DATA__
package uni::perl;

our $VERSION = '0.92';

BEGIN {
SELFBEGIN
}
m{
use strict;
use warnings;
}x;
use mro ();

# paste this into perl to find bitmask

# no warnings;
# use warnings qw(FATAL closed threads internal debugging pack substr malloc unopened portable prototype
#                 inplace io pipe unpack regexp deprecated exiting glob digit printf
#                 utf8 layer reserved parenthesis taint closure semicolon);
# no warnings qw(exec newline);
# BEGIN { warn join "", map "\\x$_", unpack "(H2)*", ${^WARNING_BITS}; exit 0 };

BEGIN {
	for my $sub (qw(carp croak confess)) {
		no strict 'refs';
		*$sub = sub {
			my $caller = caller;
			local *__ANON__ = $caller .'::'. $sub;
			require Carp;
			*{ $caller.'::'.$sub } = \&{ 'Carp::'.$sub };
			goto &{ 'Carp::'.$sub };
		};
	}