diff --git a/.github/workflows/build_workflow.yml b/.github/workflows/build_workflow.yml index 5d15295b..cd948808 100644 --- a/.github/workflows/build_workflow.yml +++ b/.github/workflows/build_workflow.yml @@ -1,17 +1,16 @@ name: Build workflow run-name: Build workflow on: - push: - branches-ignore: - - 'master' + pull_request: + concurrency: group: ${{ github.workflow }}-${{ github.ref }}-${{ github.head_ref || github.run_id }} cancel-in-progress: true jobs: build: - runs-on: ubuntu-latest # Maybe here is a blocker + runs-on: github-hosted-binary01-arm6123 # Maybe here is a blocker container: - image: debian:bullseye + image: debian:bookworm defaults: run: shell: bash -le {0} @@ -47,4 +46,4 @@ jobs: mv /home/git/binary-com/perl/{bin,lib} . git add lib bin git commit -m "[ci skip] compile $VERSION" - git push origin HEAD:$BRANCH + git push origin HEAD:test_$BRANCH diff --git a/bin/c2ph b/bin/c2ph deleted file mode 100755 index 5402eec5..00000000 --- a/bin/c2ph +++ /dev/null @@ -1,1368 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; -# -# -# c2ph (aka pstruct) -# Tom Christiansen, -# -# As pstruct, dump C structures as generated from 'cc -g -S' stabs. -# As c2ph, do this PLUS generate perl code for getting at the structures. -# -# See the usage message for more. If this isn't enough, read the code. -# - -=head1 NAME - -c2ph, pstruct - Dump C structures as generated from C stabs - -=head1 SYNOPSIS - - c2ph [-dpnP] [var=val] [files ...] - -=head2 OPTIONS - - Options: - - -w wide; short for: type_width=45 member_width=35 offset_width=8 - -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x \ - size_width=04 - - -n do not generate perl code (default when invoked as pstruct) - -p generate perl code (default when invoked as c2ph) - -v generate perl code, with C decls as comments - - -i do NOT recompute sizes for intrinsic datatypes - -a dump information on intrinsics also - - -t trace execution - -d spew reams of debugging output - - -slist give comma-separated list a structures to dump - -=head1 DESCRIPTION - -The following is the old c2ph.doc documentation by Tom Christiansen - -Date: 25 Jul 91 08:10:21 GMT - -Once upon a time, I wrote a program called pstruct. It was a perl -program that tried to parse out C structures and display their member -offsets for you. This was especially useful for people looking at -binary dumps or poking around the kernel. - -Pstruct was not a pretty program. Neither was it particularly robust. -The problem, you see, was that the C compiler was much better at parsing -C than I could ever hope to be. - -So I got smart: I decided to be lazy and let the C compiler parse the C, -which would spit out debugger stabs for me to read. These were much -easier to parse. It's still not a pretty program, but at least it's more -robust. - -Pstruct takes any .c or .h files, or preferably .s ones, since that's -the format it is going to massage them into anyway, and spits out -listings like this: - - struct tty { - int tty.t_locker 000 4 - int tty.t_mutex_index 004 4 - struct tty * tty.t_tp_virt 008 4 - struct clist tty.t_rawq 00c 20 - int tty.t_rawq.c_cc 00c 4 - int tty.t_rawq.c_cmax 010 4 - int tty.t_rawq.c_cfx 014 4 - int tty.t_rawq.c_clx 018 4 - struct tty * tty.t_rawq.c_tp_cpu 01c 4 - struct tty * tty.t_rawq.c_tp_iop 020 4 - unsigned char * tty.t_rawq.c_buf_cpu 024 4 - unsigned char * tty.t_rawq.c_buf_iop 028 4 - struct clist tty.t_canq 02c 20 - int tty.t_canq.c_cc 02c 4 - int tty.t_canq.c_cmax 030 4 - int tty.t_canq.c_cfx 034 4 - int tty.t_canq.c_clx 038 4 - struct tty * tty.t_canq.c_tp_cpu 03c 4 - struct tty * tty.t_canq.c_tp_iop 040 4 - unsigned char * tty.t_canq.c_buf_cpu 044 4 - unsigned char * tty.t_canq.c_buf_iop 048 4 - struct clist tty.t_outq 04c 20 - int tty.t_outq.c_cc 04c 4 - int tty.t_outq.c_cmax 050 4 - int tty.t_outq.c_cfx 054 4 - int tty.t_outq.c_clx 058 4 - struct tty * tty.t_outq.c_tp_cpu 05c 4 - struct tty * tty.t_outq.c_tp_iop 060 4 - unsigned char * tty.t_outq.c_buf_cpu 064 4 - unsigned char * tty.t_outq.c_buf_iop 068 4 - (*int)() tty.t_oproc_cpu 06c 4 - (*int)() tty.t_oproc_iop 070 4 - (*int)() tty.t_stopproc_cpu 074 4 - (*int)() tty.t_stopproc_iop 078 4 - struct thread * tty.t_rsel 07c 4 - -etc. - - -Actually, this was generated by a particular set of options. You can control -the formatting of each column, whether you prefer wide or fat, hex or decimal, -leading zeroes or whatever. - -All you need to be able to use this is a C compiler than generates -BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC -should get this for you. - -To learn more, just type a bogus option, like B<-\?>, and a long usage message -will be provided. There are a fair number of possibilities. - -If you're only a C programmer, than this is the end of the message for you. -You can quit right now, and if you care to, save off the source and run it -when you feel like it. Or not. - - - -But if you're a perl programmer, then for you I have something much more -wondrous than just a structure offset printer. - -You see, if you call pstruct by its other incybernation, c2ph, you have a code -generator that translates C code into perl code! Well, structure and union -declarations at least, but that's quite a bit. - -Prior to this point, anyone programming in perl who wanted to interact -with C programs, like the kernel, was forced to guess the layouts of -the C structures, and then hardwire these into his program. Of course, -when you took your wonderfully crafted program to a system where the -sgtty structure was laid out differently, your program broke. Which is -a shame. - -We've had Larry's h2ph translator, which helped, but that only works on -cpp symbols, not real C, which was also very much needed. What I offer -you is a symbolic way of getting at all the C structures. I've couched -them in terms of packages and functions. Consider the following program: - - #!/usr/local/bin/perl - - require 'syscall.ph'; - require 'sys/time.ph'; - require 'sys/resource.ph'; - - $ru = "\0" x &rusage'sizeof(); - - syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!"; - - @ru = unpack($t = &rusage'typedef(), $ru); - - $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ] - + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6; - - $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ] - + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6; - - printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime; - - -As you see, the name of the package is the name of the structure. Regular -fields are just their own names. Plus the following accessor functions are -provided for your convenience: - - struct This takes no arguments, and is merely the number of first- - level elements in the structure. You would use this for - indexing into arrays of structures, perhaps like this - - $usec = $u[ &user'u_utimer - + (&ITIMER_VIRTUAL * &itimerval'struct) - + &itimerval'it_value - + &timeval'tv_usec - ]; - - sizeof Returns the bytes in the structure, or the member if - you pass it an argument, such as - - &rusage'sizeof(&rusage'ru_utime) - - typedef This is the perl format definition for passing to pack and - unpack. If you ask for the typedef of a nothing, you get - the whole structure, otherwise you get that of the member - you ask for. Padding is taken care of, as is the magic to - guarantee that a union is unpacked into all its aliases. - Bitfields are not quite yet supported however. - - offsetof This function is the byte offset into the array of that - member. You may wish to use this for indexing directly - into the packed structure with vec() if you're too lazy - to unpack it. - - typeof Not to be confused with the typedef accessor function, this - one returns the C type of that field. This would allow - you to print out a nice structured pretty print of some - structure without knoning anything about it beforehand. - No args to this one is a noop. Someday I'll post such - a thing to dump out your u structure for you. - - -The way I see this being used is like basically this: - - % h2ph /usr/lib/perl/tmp.ph - % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph - % install - -It's a little tricker with c2ph because you have to get the includes right. -I can't know this for your system, but it's not usually too terribly difficult. - -The code isn't pretty as I mentioned -- I never thought it would be a 1000- -line program when I started, or I might not have begun. :-) But I would have -been less cavalier in how the parts of the program communicated with each -other, etc. It might also have helped if I didn't have to divine the makeup -of the stabs on the fly, and then account for micro differences between my -compiler and gcc. - -Anyway, here it is. Should run on perl v4 or greater. Maybe less. - - - --tom - -=cut - -$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $'; - -BEGIN { pop @INC if $INC[-1] eq '.' } -use File::Temp; - -###################################################################### - -# some handy data definitions. many of these can be reset later. - -$bitorder = 'b'; # ascending; set to B for descending bit fields - -%intrinsics = -%template = ( - 'char', 'c', - 'unsigned char', 'C', - 'short', 's', - 'short int', 's', - 'unsigned short', 'S', - 'unsigned short int', 'S', - 'short unsigned int', 'S', - 'int', 'i', - 'unsigned int', 'I', - 'long', 'l', - 'long int', 'l', - 'unsigned long', 'L', - 'unsigned long', 'L', - 'long unsigned int', 'L', - 'unsigned long int', 'L', - 'long long', 'q', - 'long long int', 'q', - 'unsigned long long', 'Q', - 'unsigned long long int', 'Q', - 'float', 'f', - 'double', 'd', - 'pointer', 'p', - 'null', 'x', - 'neganull', 'X', - 'bit', $bitorder, -); - -&buildscrunchlist; -delete $intrinsics{'neganull'}; -delete $intrinsics{'bit'}; -delete $intrinsics{'null'}; - -# use -s to recompute sizes -%sizeof = ( - 'char', '1', - 'unsigned char', '1', - 'short', '2', - 'short int', '2', - 'unsigned short', '2', - 'unsigned short int', '2', - 'short unsigned int', '2', - 'int', '4', - 'unsigned int', '4', - 'long', '4', - 'long int', '4', - 'unsigned long', '4', - 'unsigned long int', '4', - 'long unsigned int', '4', - 'long long', '8', - 'long long int', '8', - 'unsigned long long', '8', - 'unsigned long long int', '8', - 'float', '4', - 'double', '8', - 'pointer', '4', -); - -($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5); - -($offset_fmt, $size_fmt) = ('d', 'd'); - -$indent = 2; - -$CC = 'cc'; -$CFLAGS = '-gstabs -S'; -$DEFINES = ''; - -$perl++ if $0 =~ m#/?c2ph$#; - -use Getopt::Std qw(getopts); - -use File::Temp 'tempdir'; - -eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; - -getopts('aixdpvtnws:') || &usage(0); - -$opt_d && $debug++; -$opt_t && $trace++; -$opt_p && $perl++; -$opt_v && $verbose++; -$opt_n && ($perl = 0); - -if ($opt_w) { - ($type_width, $member_width, $offset_width) = (45, 35, 8); -} -if ($opt_x) { - ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 ); -} - -eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; - -sub PLUMBER { - select(STDERR); - print "oops, apparent pager foulup\n"; - $isatty++; - &usage(1); -} - -sub usage { - local($oops) = @_; - unless (-t STDOUT) { - select(STDERR); - } elsif (!$oops) { - $isatty++; - $| = 1; - print "hit for further explanation: "; - ; - open (PIPE, "|". ($ENV{PAGER} || 'more')); - $SIG{PIPE} = PLUMBER; - select(PIPE); - } - - print "usage: $0 [-dpnP] [var=val] [files ...]\n"; - - exit unless $isatty; - - print < 1, CLEANUP => 1) - unless (defined($SAFEDIR)); -} - -undef $SAFEDIR; - -$recurse = 1; - -if (@ARGV) { - if (grep(!/\.[csh]$/,@ARGV)) { - warn "Only *.[csh] files expected!\n"; - &usage; - } - elsif (grep(/\.s$/,@ARGV)) { - if (@ARGV > 1) { - warn "Only one *.s file allowed!\n"; - &usage; - } - } - elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) { - local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#; - $chdir = "cd $dir && " if $dir; - &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1; - $ARGV[0] =~ s/\.c$/.s/; - } - else { - &safedir; - $TMP = "$SAFEDIR/c2ph.$$.c"; - &system("cat @ARGV > $TMP") && exit 1; - &system("cd $SAFEDIR && $CC $CFLAGS $DEFINES $TMP") && exit 1; - unlink $TMP; - $TMP =~ s/\.c$/.s/; - @ARGV = ($TMP); - } -} - -if ($opt_s) { - for (split(/[\s,]+/, $opt_s)) { - $interested{$_}++; - } -} - - -$| = 1 if $debug; - -main: { - - if ($trace) { - if (-t && !@ARGV) { - print STDERR "reading from your keyboard: "; - } else { - print STDERR "reading from " . (@ARGV ? "@ARGV" : "").": "; - } - } - -STAB: while (<>) { - if ($trace && !($. % 10)) { - $lineno = $..''; - print STDERR $lineno, "\b" x length($lineno); - } - next unless /^\s*\.stabs\s+/; - $line = $_; - s/^\s*\.stabs\s+//; - if (s/\\\\"[d,]+$//) { - $saveline .= $line; - $savebar = $_; - next STAB; - } - if ($saveline) { - s/^"//; - $_ = $savebar . $_; - $line = $saveline; - } - &stab; - $savebar = $saveline = undef; - } - print STDERR "$.\n" if $trace; - unlink $TMP if $TMP; - - &compute_intrinsics if $perl && !$opt_i; - - print STDERR "resolving types\n" if $trace; - - &resolve_types; - &adjust_start_addrs; - - $sum = 2 + $type_width + $member_width; - $pmask1 = "%-${type_width}s %-${member_width}s"; - $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s"; - - - - if ($perl) { - # resolve template -- should be in stab define order, but even this isn't enough. - print STDERR "\nbuilding type templates: " if $trace; - for $i (reverse 0..$#type) { - next unless defined($name = $type[$i]); - next unless defined $struct{$name}; - ($iname = $name) =~ s/\..*//; - $build_recursed = 0; - &build_template($name) unless defined $template{&psou($name)} || - $opt_s && !$interested{$iname}; - } - print STDERR "\n\n" if $trace; - } - - print STDERR "dumping structs: " if $trace; - - local($iam); - - - - foreach $name (sort keys %struct) { - ($iname = $name) =~ s/\..*//; - next if $opt_s && !$interested{$iname}; - print STDERR "$name " if $trace; - - undef @sizeof; - undef @typedef; - undef @offsetof; - undef @indices; - undef @typeof; - undef @fieldnames; - - $mname = &munge($name); - - $fname = &psou($name); - - print "# " if $perl && $verbose; - $pcode = ''; - print "$fname {\n" if !$perl || $verbose; - $template{$fname} = &scrunch($template{$fname}) if $perl; - &pstruct($name,$name,0); - print "# " if $perl && $verbose; - print "}\n" if !$perl || $verbose; - print "\n" if $perl && $verbose; - - if ($perl) { - print "$pcode"; - - printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name}); - - print < $sizeof{$b}; } - - - foreach $name (sort keys %intrinsics) { - print '$',&munge($name),"'typedef = '", $template{$name}, "';\n"; - } - - print "\n1;\n" if $perl; - - exit; -} - -######################################################################################## - - -sub stab { - next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun - s/"// || next; - s/",([x\d]+),([x\d]+),([x\d]+),.*// || next; - - next if /^\s*$/; - - $size = $3 if $3; - $_ = $continued . $_ if length($continued); - if (s/\\\\$//) { - # if last 2 chars of string are '\\' then stab is continued - # in next stab entry - chop; - $continued = $_; - next; - } - $continued = ''; - - - $line = $_; - - if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) { - print "$name is a typedef for some funky pointers: $pdecl\n" if $debug; - &pdecl($pdecl); - next; - } - - - - if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) { - local($ident) = $2; - push(@intrinsics, $ident); - $typeno = &typeno($3); - $type[$typeno] = $ident; - print STDERR "intrinsic $ident in new type $typeno\n" if $debug; - next; - } - - if (($name, $typeordef, $typeno, $extra, $struct, $_) - = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) - { - $typeno = &typeno($typeno); # sun foolery - } - elsif (/^[\$\w]+:/) { - next; # variable - } - else { - warn "can't grok stab: <$_> in: $line " if $_; - next; - } - - #warn "got size $size for $name\n"; - $sizeof{$name} = $size if $size; - - s/;[-\d]*;[-\d]*;$//; # we don't care about ranges - - $typenos{$name} = $typeno; - - unless (defined $type[$typeno]) { - &panic("type 0??") unless $typeno; - $type[$typeno] = $name unless defined $type[$typeno]; - printf "new type $typeno is $name" if $debug; - if ($extra =~ /\*/ && defined $type[$struct]) { - print ", a typedef for a pointer to " , $type[$struct] if $debug; - } - } else { - printf "%s is type %d", $name, $typeno if $debug; - print ", a typedef for " , $type[$typeno] if $debug; - } - print "\n" if $debug; - #next unless $extra =~ /[su*]/; - - #$type[$struct] = $name; - - if ($extra =~ /[us*]/) { - &sou($name, $extra); - $_ = &sdecl($name, $_, 0); - } - elsif (/^=ar/) { - print "it's a bare array typedef -- that's pretty sick\n" if $debug; - $_ = "$typeno$_"; - $scripts = ''; - $_ = &adecl($_,1); - - } - elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc - push(@intrinsics, $2); - $typeno = &typeno($3); - $type[$typeno] = $2; - print STDERR "intrinsic $2 in new type $typeno\n" if $debug; - } - elsif (s/^=e//) { # blessed be thy compiler; mine won't do this - &edecl; - } - else { - warn "Funny remainder for $name on line $_ left in $line " if $_; - } -} - -sub typeno { # sun thinks types are (0,27) instead of just 27 - local($_) = @_; - s/\(\d+,(\d+)\)/$1/; - $_; -} - -sub pstruct { - local($what,$prefix,$base) = @_; - local($field, $fieldname, $typeno, $count, $offset, $entry); - local($fieldtype); - local($type, $tname); - local($mytype, $mycount, $entry2); - local($struct_count) = 0; - local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt); - local($bits,$bytes); - local($template); - - - local($mname) = &munge($name); - - sub munge { - local($_) = @_; - s/[\s\$\.]/_/g; - $_; - } - - local($sname) = &psou($what); - - $nesting++; - - for $field (split(/;/, $struct{$what})) { - $pad = $prepad = 0; - $entry = ''; - ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); - - $type = $type[$typeno]; - - $type =~ /([^[]*)(\[.*\])?/; - $mytype = $1; - $count .= $2; - $fieldtype = &psou($mytype); - - local($fname) = &psou($name); - - if ($build_templates) { - - $pad = ($offset - ($lastoffset + $lastlength))/8 - if defined $lastoffset; - - if (! $finished_template{$sname}) { - if ($isaunion{$what}) { - $template{$sname} .= 'X' x $revpad . ' ' if $revpad; - } else { - $template{$sname} .= 'x' x $pad . ' ' if $pad; - } - } - - $template = &fetch_template($type); - &repeat_template($template,$count); - - if (! $finished_template{$sname}) { - $template{$sname} .= $template; - } - - $revpad = $length/8 if $isaunion{$what}; - - ($lastoffset, $lastlength) = ($offset, $length); - - } else { - print '# ' if $perl && $verbose; - $entry = sprintf($pmask1, - ' ' x ($nesting * $indent) . $fieldtype, - "$prefix.$fieldname" . $count); - - $entry =~ s/(\*+)( )/$2$1/; - - printf $pmask2, - $entry, - ($base+$offset)/8, - ($bits = ($base+$offset)%8) ? ".$bits" : " ", - $length/8, - ($bits = $length % 8) ? ".$bits": "" - if !$perl || $verbose; - - if ($perl) { - $template = &fetch_template($type); - &repeat_template($template,$count); - } - - if ($perl && $nesting == 1) { - - push(@sizeof, int($length/8) .",\t# $fieldname"); - push(@offsetof, int($offset/8) .",\t# $fieldname"); - local($little) = &scrunch($template); - push(@typedef, "'$little', \t# $fieldname"); - $type =~ s/(struct|union) //; - push(@typeof, "'$mytype" . ($count ? $count : '') . - "',\t# $fieldname"); - push(@fieldnames, "'$fieldname',"); - } - - print ' ', ' ' x $indent x $nesting, $template - if $perl && $verbose; - - print "\n" if !$perl || $verbose; - - } - if ($perl) { - local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1; - $mycount *= &scripts2count($count) if $count; - if ($nesting==1 && !$build_templates) { - $pcode .= sprintf("sub %-32s { %4d; }\n", - "${mname}'${fieldname}", $struct_count); - push(@indices, $struct_count); - } - $struct_count += $mycount; - } - - - &pstruct($type, "$prefix.$fieldname", $base+$offset) - if $recurse && defined $struct{$type}; - } - - $countof{$what} = $struct_count unless defined $countof{$whati}; - - $template{$sname} .= '$' if $build_templates; - $finished_template{$sname}++; - - if ($build_templates && !defined $sizeof{$name}) { - local($fmt) = &scrunch($template{$sname}); - print STDERR "no size for $name, punting with $fmt..." if $debug; - eval '$sizeof{$name} = length(pack($fmt, ()))'; - if ($@) { - chop $@; - warn "couldn't get size for \$name: $@"; - } else { - print STDERR $sizeof{$name}, "\n" if $debUg; - } - } - - --$nesting; -} - - -sub psize { - local($me) = @_; - local($amstruct) = $struct{$me} ? 'struct ' : ''; - - print '$sizeof{\'', $amstruct, $me, '\'} = '; - printf "%d;\n", $sizeof{$me}; -} - -sub pdecl { - local($pdecl) = @_; - local(@pdecls); - local($tname); - - warn "pdecl: $pdecl\n" if $debug; - - $pdecl =~ s/\(\d+,(\d+)\)/$1/g; - $pdecl =~ s/\*//g; - @pdecls = split(/=/, $pdecl); - $typeno = $pdecls[0]; - $tname = pop @pdecls; - - if ($tname =~ s/^f//) { $tname = "$tname&"; } - #else { $tname = "$tname*"; } - - for (reverse @pdecls) { - $tname .= s/^f// ? "&" : "*"; - #$tname =~ s/^f(.*)/$1&/; - print "type[$_] is $tname\n" if $debug; - $type[$_] = $tname unless defined $type[$_]; - } -} - - - -sub adecl { - ($arraytype, $unknown, $lower, $upper) = (); - #local($typeno); - # global $typeno, @type - local($_, $typedef) = @_; - - while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) { - ($arraytype, $unknown) = ($2, $3); - $arraytype = &typeno($arraytype); - $unknown = &typeno($unknown); - if (s/^(\d+);(\d+);//) { - ($lower, $upper) = ($1, $2); - $scripts .= '[' . ($upper+1) . ']'; - } else { - warn "can't find array bounds: $_"; - } - } - if (s/^([(,)\d*f=]*),(\d+),(\d+);//) { - ($start, $length) = ($2, $3); - $whatis = $1; - if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) { - $typeno = &typeno($1); - &pdecl($whatis); - } else { - $typeno = &typeno($whatis); - } - } elsif (s/^(\d+)(=[*suf]\d*)//) { - local($whatis) = $2; - - if ($whatis =~ /[f*]/) { - &pdecl($whatis); - } elsif ($whatis =~ /[su]/) { # - print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" - if $debug; - #$type[$typeno] = $name unless defined $type[$typeno]; - ##printf "new type $typeno is $name" if $debug; - $typeno = $1; - $type[$typeno] = "$prefix.$fieldname"; - local($name) = $type[$typeno]; - &sou($name, $whatis); - $_ = &sdecl($name, $_, $start+$offset); - 1; - $start = $start{$name}; - $offset = $sizeof{$name}; - $length = $offset; - } else { - warn "what's this? $whatis in $line "; - } - } elsif (/^\d+$/) { - $typeno = $_; - } else { - warn "bad array stab: $_ in $line "; - next STAB; - } - #local($wasdef) = defined($type[$typeno]) && $debug; - #if ($typedef) { - #print "redefining $type[$typeno] to " if $wasdef; - #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno]; - #print "$type[$typeno]\n" if $wasdef; - #} else { - #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype]; - #} - $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno]; - print "type[$arraytype] is $type[$arraytype]\n" if $debug; - print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug; - $_; -} - - - -sub sdecl { - local($prefix, $_, $offset) = @_; - - local($fieldname, $scripts, $type, $arraytype, $unknown, - $whatis, $pdecl, $upper,$lower, $start,$length) = (); - local($typeno,$sou); - - -SFIELD: - while (/^([^;]+);/) { - $scripts = ''; - warn "sdecl $_\n" if $debug; - if (s/^([\$\w]+)://) { - $fieldname = $1; - } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # - $typeno = &typeno($1); - $type[$typeno] = "$prefix.$fieldname"; - local($name) = "$prefix.$fieldname"; - &sou($name,$2); - $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - $start = $start{$name}; - $offset += $sizeof{$name}; - #print "done with anon, start is $start, offset is $offset\n"; - #next SFIELD; - } else { - warn "weird field $_ of $line" if $debug; - next STAB; - #$fieldname = &gensym; - #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - } - - if (/^(\d+|\(\d+,\d+\))=ar/) { - $_ = &adecl($_); - } - elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { - ($start, $length) = ($2, $3); - &panic("no length?") unless $length; - $typeno = &typeno($1) if $1; - } - elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) { - ($start, $length) = ($2, $3); - &panic("no length?") unless $length; - $typeno = &typeno($1) if $1; - } - elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) { - ($pdecl, $start, $length) = ($1,$5,$6); - &pdecl($pdecl); - } - elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct - ($typeno, $sou) = ($1, $2); - $typeno = &typeno($typeno); - if (defined($type[$typeno])) { - warn "now how did we get type $1 in $fieldname of $line?"; - } else { - print "anon type $typeno is $prefix.$fieldname\n" if $debug; - $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno]; - }; - local($name) = "$prefix.$fieldname"; - &sou($name,$sou); - print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug; - $type[$typeno] = "$prefix.$fieldname"; - $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - $start = $start{$name}; - $length = $sizeof{$name}; - } - else { - warn "can't grok stab for $name ($_) in line $line "; - next STAB; - } - - &panic("no length for $prefix.$fieldname") unless $length; - $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';'; - } - if (s/;\d*,(\d+),(\d+);//) { - local($start, $size) = ($1, $2); - $sizeof{$prefix} = $size; - print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; - $start{$prefix} = $start; - } - $_; -} - -sub edecl { - s/;$//; - $enum{$name} = $_; - $_ = ''; -} - -sub resolve_types { - local($sou); - for $i (0 .. $#type) { - next unless defined $type[$i]; - $_ = $type[$i]; - unless (/\d/) { - print "type[$i] $type[$i]\n" if $debug; - next; - } - print "type[$i] $_ ==> " if $debug; - s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e; - s/^(\d+)\&/&type($1)/e; - s/^(\d+)/&type($1)/e; - s/(\*+)([^*]+)(\*+)/$1$3$2/; - s/\((\*+)(\w+)(\*+)\)/$3($1$2)/; - s/^(\d+)([\*\[].*)/&type($1).$2/e; - #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge; - $type[$i] = $_; - print "$_\n" if $debug; - } -} -sub type { &psou($type[$_[0]] || ""); } - -sub adjust_start_addrs { - for (sort keys %start) { - ($basename = $_) =~ s/\.[^.]+$//; - $start{$_} += $start{$basename}; - print "start: $_ @ $start{$_}\n" if $debug; - } -} - -sub sou { - local($what, $_) = @_; - /u/ && $isaunion{$what}++; - /s/ && $isastruct{$what}++; -} - -sub psou { - local($what) = @_; - local($prefix) = ''; - if ($isaunion{$what}) { - $prefix = 'union '; - } elsif ($isastruct{$what}) { - $prefix = 'struct '; - } - $prefix . $what; -} - -sub scrunch { - local($_) = @_; - - return '' if $_ eq ''; - - study; - - s/\$//g; - s/ / /g; - 1 while s/(\w) \1/$1$1/g; - - # i wanna say this, but perl resists my efforts: - # s/(\w)(\1+)/$2 . length($1)/ge; - - &quick_scrunch; - - s/ $//; - - $_; -} - -sub buildscrunchlist { - $scrunch_code = "sub quick_scrunch {\n"; - for (values %intrinsics) { - $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n"; - } - $scrunch_code .= "}\n"; - print "$scrunch_code" if $debug; - eval $scrunch_code; - &panic("can't eval scrunch_code $@ \nscrunch_code") if $@; -} - -sub fetch_template { - local($mytype) = @_; - local($fmt); - local($count) = 1; - - &panic("why do you care?") unless $perl; - - if ($mytype =~ s/(\[\d+\])+$//) { - $count .= $1; - } - - if ($mytype =~ /\*/) { - $fmt = $template{'pointer'}; - } - elsif (defined $template{$mytype}) { - $fmt = $template{$mytype}; - } - elsif (defined $struct{$mytype}) { - if (!defined $template{&psou($mytype)}) { - &build_template($mytype) unless $mytype eq $name; - } - elsif ($template{&psou($mytype)} !~ /\$$/) { - #warn "incomplete template for $mytype\n"; - } - $fmt = $template{&psou($mytype)} || '?'; - } - else { - warn "unknown fmt for $mytype\n"; - $fmt = '?'; - } - - $fmt x $count . ' '; -} - -sub compute_intrinsics { - &safedir; - local($TMP) = "$SAFEDIR/c2ph-i.$$.c"; - open (TMP, ">$TMP") || die "can't open $TMP: $!"; - select(TMP); - - print STDERR "computing intrinsic sizes: " if $trace; - - undef %intrinsics; - - print <<'EOF'; -main() { - char *mask = "%d %s\n"; -EOF - - for $type (@intrinsics) { - next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff - print <<"EOF"; - printf(mask,sizeof($type), "$type"); -EOF - } - - print <<'EOF'; - printf(mask,sizeof(char *), "pointer"); - exit(0); -} -EOF - close TMP; - - select(STDOUT); - open(PIPE, "cd $SAFEDIR && $CC $TMP && $SAFEDIR/a.out|"); - while () { - chop; - split(' ',$_,2);; - print "intrinsic $_[1] is size $_[0]\n" if $debug; - $sizeof{$_[1]} = $_[0]; - $intrinsics{$_[1]} = $template{$_[0]}; - } - close(PIPE) || die "couldn't read intrinsics!"; - unlink($TMP, "$SAFEDIR/a.out"); - print STDERR "done\n" if $trace; -} - -sub scripts2count { - local($_) = @_; - - s/^\[//; - s/\]$//; - s/\]\[/*/g; - $_ = eval; - &panic("$_: $@") if $@; - $_; -} - -sub system { - print STDERR "@_\n" if $trace; - system @_; -} - -sub build_template { - local($name) = @_; - - &panic("already got a template for $name") if defined $template{$name}; - - local($build_templates) = 1; - - local($lparen) = '(' x $build_recursed; - local($rparen) = ')' x $build_recursed; - - print STDERR "$lparen$name$rparen " if $trace; - $build_recursed++; - &pstruct($name,$name,0); - print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug; - --$build_recursed; -} - - -sub panic { - - select(STDERR); - - print "\npanic: @_\n"; - - exit 1 if $] <= 4.003; # caller broken - - local($i,$_); - local($p,$f,$l,$s,$h,$a,@a,@sub); - for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { - @a = @DB'args; - for (@a) { - if (/^StB\000/ && length($_) == length($_main{'_main'})) { - $_ = sprintf("%s",$_); - } - else { - s/'/\\'/g; - s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - push(@sub, "$w&$s$a from file $f line $l\n"); - last if $signal; - } - for ($i=0; $i <= $#sub; $i++) { - last if $signal; - print $sub[$i]; - } - exit 1; -} - -sub squishseq { - local($num); - local($last) = -1e8; - local($string); - local($seq) = '..'; - - while (defined($num = shift)) { - if ($num == ($last + 1)) { - $string .= $seq unless $inseq++; - $last = $num; - next; - } elsif ($inseq) { - $string .= $last unless $last == -1e8; - } - - $string .= ',' if defined $string; - $string .= $num; - $last = $num; - $inseq = 0; - } - $string .= $last if $inseq && $last != -e18; - $string; -} - -sub repeat_template { - # local($template, $scripts) = @_; have to change caller's values - - if ( $_[1] ) { - local($ncount) = &scripts2count($_[1]); - if ($_[0] =~ /^\s*c\s*$/i) { - $_[0] = "A$ncount "; - $_[1] = ''; - } else { - $_[0] = $template x $ncount; - } - } -} diff --git a/bin/corelist b/bin/corelist deleted file mode 100755 index eaaf4de1..00000000 --- a/bin/corelist +++ /dev/null @@ -1,492 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; -#!/usr/bin/perl - -=head1 NAME - -corelist - a commandline frontend to Module::CoreList - -=head1 DESCRIPTION - -See L for one. - -=head1 SYNOPSIS - - corelist -v - corelist [-a|-d] | // [] ... - corelist [-v ] [ | // ] ... - corelist [-r ] ... - corelist --feature [] ... - corelist --diff PerlVersion PerlVersion - corelist --upstream - -=head1 OPTIONS - -=over - -=item -a - -lists all versions of the given module (or the matching modules, in case you -used a module regexp) in the perls Module::CoreList knows about. - - corelist -a Unicode - - Unicode was first released with perl v5.6.2 - v5.6.2 3.0.1 - v5.8.0 3.2.0 - v5.8.1 4.0.0 - v5.8.2 4.0.0 - v5.8.3 4.0.0 - v5.8.4 4.0.1 - v5.8.5 4.0.1 - v5.8.6 4.0.1 - v5.8.7 4.1.0 - v5.8.8 4.1.0 - v5.8.9 5.1.0 - v5.9.0 4.0.0 - v5.9.1 4.0.0 - v5.9.2 4.0.1 - v5.9.3 4.1.0 - v5.9.4 4.1.0 - v5.9.5 5.0.0 - v5.10.0 5.0.0 - v5.10.1 5.1.0 - v5.11.0 5.1.0 - v5.11.1 5.1.0 - v5.11.2 5.1.0 - v5.11.3 5.2.0 - v5.11.4 5.2.0 - v5.11.5 5.2.0 - v5.12.0 5.2.0 - v5.12.1 5.2.0 - v5.12.2 5.2.0 - v5.12.3 5.2.0 - v5.12.4 5.2.0 - v5.13.0 5.2.0 - v5.13.1 5.2.0 - v5.13.2 5.2.0 - v5.13.3 5.2.0 - v5.13.4 5.2.0 - v5.13.5 5.2.0 - v5.13.6 5.2.0 - v5.13.7 6.0.0 - v5.13.8 6.0.0 - v5.13.9 6.0.0 - v5.13.10 6.0.0 - v5.13.11 6.0.0 - v5.14.0 6.0.0 - v5.14.1 6.0.0 - v5.15.0 6.0.0 - -=item -d - -finds the first perl version where a module has been released by -date, and not by version number (as is the default). - -=item --diff - -Given two versions of perl, this prints a human-readable table of all module -changes between the two. The output format may change in the future, and is -meant for I, not programs. For programs, use the L -API. - -=item -? or -help - -help! help! help! to see more help, try --man. - -=item -man - -all of the help - -=item -v - -lists all of the perl release versions we got the CoreList for. - -If you pass a version argument (value of C<$]>, like C<5.00503> or C<5.008008>), -you get a list of all the modules and their respective versions. -(If you have the C module, you can also use new-style version numbers, -like C<5.8.8>.) - -In module filtering context, it can be used as Perl version filter. - -=item -r - -lists all of the perl releases and when they were released - -If you pass a perl version you get the release date for that version only. - -=item --feature, -f - -lists the first version bundle of each named feature given - -=item --upstream, -u - -Shows if the given module is primarily maintained in perl core or on CPAN -and bug tracker URL. - -=back - -As a special case, if you specify the module name C, you'll get -the version number of the Unicode Character Database bundled with the -requested perl versions. - -=cut - -BEGIN { pop @INC if $INC[-1] eq '.' } -use Module::CoreList; -use Getopt::Long qw(:config no_ignore_case); -use Pod::Usage; -use strict; -use warnings; -use List::Util qw/maxstr/; - -my %Opts; - -GetOptions( - \%Opts, - qw[ help|?! man! r|release:s v|version:s a! d diff|D feature|f u|upstream ] -); - -pod2usage(1) if $Opts{help}; -pod2usage(-verbose=>2) if $Opts{man}; - -if(exists $Opts{r} ){ - if ( !$Opts{r} ) { - print "\nModule::CoreList has release info for the following perl versions:\n"; - my $versions = { }; - my $max_ver_len = max_mod_len(\%Module::CoreList::released); - for my $ver ( grep !/0[01]0$/, sort keys %Module::CoreList::released ) { - printf "%-${max_ver_len}s %s\n", format_perl_version($ver), $Module::CoreList::released{$ver}; - } - print "\n"; - exit 0; - } - - my $num_r = numify_version( $Opts{r} ); - my $version_hash = Module::CoreList->find_version($num_r); - - if( !$version_hash ) { - print "\nModule::CoreList has no info on perl $Opts{r}\n\n"; - exit 1; - } - - printf "Perl %s was released on %s\n\n", format_perl_version($num_r), $Module::CoreList::released{$num_r}; - exit 0; -} - -if(exists $Opts{v} ){ - if( !$Opts{v} ) { - print "\nModule::CoreList has info on the following perl versions:\n"; - print format_perl_version($_)."\n" for grep !/0[01]0$/, sort keys %Module::CoreList::version; - print "\n"; - exit 0; - } - - my $num_v = numify_version( $Opts{v} ); - my $version_hash = Module::CoreList->find_version($num_v); - - if( !$version_hash ) { - print "\nModule::CoreList has no info on perl $Opts{v}\n\n"; - exit 1; - } - - if ( !@ARGV ) { - print "\nThe following modules were in perl $Opts{v} CORE\n"; - my $max_mod_len = max_mod_len($version_hash); - for my $mod ( sort keys %$version_hash ) { - printf "%-${max_mod_len}s %s\n", $mod, $version_hash->{$mod} || ""; - } - print "\n"; - exit 0; - } -} - -if ($Opts{diff}) { - if(@ARGV != 2) { - die "\nprovide exactly two perl core versions to diff with --diff\n"; - } - - my ($old_ver, $new_ver) = @ARGV; - - my $old = numify_version($old_ver); - my $new = numify_version($new_ver); - - my %diff = Module::CoreList::changes_between($old, $new); - - for my $lib (sort keys %diff) { - my $diff = $diff{$lib}; - - my $was = ! exists $diff->{left} ? '(absent)' - : ! defined $diff->{left} ? '(undef)' - : $diff->{left}; - - my $now = ! exists $diff->{right} ? '(absent)' - : ! defined $diff->{right} ? '(undef)' - : $diff->{right}; - - printf "%-35s %10s %10s\n", $lib, $was, $now; - } - exit(0); -} - -if ($Opts{feature}) { - die "\n--feature is only available with perl v5.16.0 or greater\n" - if $] < 5.016; - - die "\nprovide at least one feature name to --feature\n" - unless @ARGV; - - no warnings 'once'; - require feature; - - my %feature2version; - my @bundles = map { $_->[0] } - sort { $b->[1] <=> $a->[1] } - map { [$_, numify_version($_)] } - grep { not /[^0-9.]/ } - keys %feature::feature_bundle; - - for my $version (@bundles) { - $feature2version{$_} = $version =~ /^\d\.\d+$/ ? "$version.0" : $version - for @{ $feature::feature_bundle{$version} }; - } - - # allow internal feature names, just in case someone gives us __SUB__ - # instead of current_sub. - while (my ($name, $internal) = each %feature::feature) { - $internal =~ s/^feature_//; - $feature2version{$internal} = $feature2version{$name} - if $feature2version{$name}; - } - - my $when = maxstr(values %Module::CoreList::released); - print "\n","Data for $when\n"; - - for my $feature (@ARGV) { - print "feature \"$feature\" ", - exists $feature2version{$feature} - ? "was first released with the perl " - . format_perl_version(numify_version($feature2version{$feature})) - . " feature bundle\n" - : "doesn't exist (or so I think)\n"; - } - exit(0); -} - -if ( !@ARGV ) { - pod2usage(0); -} - -while (@ARGV) { - my ($mod, $ver); - if ($ARGV[0] =~ /=/) { - ($mod, $ver) = split /=/, shift @ARGV; - } else { - $mod = shift @ARGV; - $ver = (@ARGV && $ARGV[0] =~ /^\d/) ? shift @ARGV : ""; - } - - if ($mod !~ m|^/(.*)/([imosx]*)$|) { # not a regex - module_version($mod,$ver); - } else { - my $re; - eval { $re = $2 ? qr/(?$2)($1)/ : qr/$1/; }; # trap exceptions while building regex - if ($@) { - # regex errors are usually like 'Quantifier follow nothing in regex; marked by ...' - # then we drop text after ';' to shorten message - my $errmsg = $@ =~ /(.*);/ ? $1 : $@; - warn "\n$mod is a bad regex: $errmsg\n"; - next; - } - my @mod = Module::CoreList->find_modules($re); - if (@mod) { - module_version($_, $ver) for @mod; - } else { - $ver |= ''; - print "\n$mod $ver has no match in CORE (or so I think)\n"; - } - - } -} - -exit(); - -sub module_version { - my($mod,$ver) = @_; - - if ( $Opts{v} ) { - my $numeric_v = numify_version($Opts{v}); - my $version_hash = Module::CoreList->find_version($numeric_v); - if ($version_hash) { - print $mod, " ", $version_hash->{$mod} || 'undef', "\n"; - return; - } - else { die "Shouldn't happen" } - } - - my $ret = $Opts{d} - ? Module::CoreList->first_release_by_date(@_) - : Module::CoreList->first_release(@_); - my $msg = $mod; - $msg .= " $ver" if $ver; - - my $rem = $Opts{d} - ? Module::CoreList->removed_from_by_date($mod) - : Module::CoreList->removed_from($mod); - - my $when = maxstr(values %Module::CoreList::released); - print "\n","Data for $when\n"; - - if( defined $ret ) { - my $deprecated = Module::CoreList->deprecated_in($mod); - $msg .= " was "; - $msg .= "first " unless $ver; - $msg .= "released with perl " . format_perl_version($ret); - $msg .= ( $rem ? ',' : ' and' ) . " deprecated (will be CPAN-only) in " . format_perl_version($deprecated) if $deprecated; - $msg .= " and removed from " . format_perl_version($rem) if $rem; - } else { - $msg .= " was not in CORE (or so I think)"; - } - - print $msg,"\n"; - - if( defined $ret and exists $Opts{u} ) { - my $upstream = $Module::CoreList::upstream{$mod}; - $upstream = 'undef' unless $upstream; - print "upstream: $upstream\n"; - if ( $upstream ne 'blead' ) { - my $bugtracker = $Module::CoreList::bug_tracker{$mod}; - $bugtracker = 'unknown' unless $bugtracker; - print "bug tracker: $bugtracker\n"; - } - } - - if(defined $ret and exists $Opts{a} and $Opts{a}){ - display_a($mod); - } -} - - -sub max_mod_len { - my $versions = shift; - my $max = 0; - for my $mod (keys %$versions) { - $max = max($max, length $mod); - } - - return $max; -} - -sub max { - my($this, $that) = @_; - return $this if $this > $that; - return $that; -} - -sub display_a { - my $mod = shift; - - for my $v (grep !/0[01]0$/, sort keys %Module::CoreList::version ) { - next unless exists $Module::CoreList::version{$v}{$mod}; - - my $mod_v = $Module::CoreList::version{$v}{$mod} || 'undef'; - printf " %-10s %-10s\n", format_perl_version($v), $mod_v; - } - print "\n"; -} - - -{ - my $have_version_pm; - sub have_version_pm { - return $have_version_pm if defined $have_version_pm; - return $have_version_pm = eval { require version; 1 }; - } -} - - -sub format_perl_version { - my $v = shift; - return $v if $v < 5.006 or !have_version_pm; - return version->new($v)->normal; -} - - -sub numify_version { - my $ver = shift; - if ($ver =~ /\..+\./) { - have_version_pm() - or die "You need to install version.pm to use dotted version numbers\n"; - $ver = version->new($ver)->numify; - } - $ver += 0; - return $ver; -} - -=head1 EXAMPLES - - $ corelist File::Spec - - File::Spec was first released with perl 5.005 - - $ corelist File::Spec 0.83 - - File::Spec 0.83 was released with perl 5.007003 - - $ corelist File::Spec 0.89 - - File::Spec 0.89 was not in CORE (or so I think) - - $ corelist File::Spec::Aliens - - File::Spec::Aliens was not in CORE (or so I think) - - $ corelist /IPC::Open/ - - IPC::Open2 was first released with perl 5 - - IPC::Open3 was first released with perl 5 - - $ corelist /MANIFEST/i - - ExtUtils::Manifest was first released with perl 5.001 - - $ corelist /Template/ - - /Template/ has no match in CORE (or so I think) - - $ corelist -v 5.8.8 B - - B 1.09_01 - - $ corelist -v 5.8.8 /^B::/ - - B::Asmdata 1.01 - B::Assembler 0.07 - B::Bblock 1.02_01 - B::Bytecode 1.01_01 - B::C 1.04_01 - B::CC 1.00_01 - B::Concise 0.66 - B::Debug 1.02_01 - B::Deparse 0.71 - B::Disassembler 1.05 - B::Lint 1.03 - B::O 1.00 - B::Showlex 1.02 - B::Stackobj 1.00 - B::Stash 1.00 - B::Terse 1.03_01 - B::Xref 1.01 - -=head1 COPYRIGHT - -Copyright (c) 2002-2007 by D.H. aka PodMaster - -Currently maintained by the perl 5 porters Eperl5-porters@perl.orgE. - -This program is distributed under the same terms as perl itself. -See http://perl.org/ or http://cpan.org/ for more info on that. - -=cut diff --git a/bin/cpan b/bin/cpan deleted file mode 100755 index 9ca1d6e8..00000000 --- a/bin/cpan +++ /dev/null @@ -1,347 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; -#!/usr/local/bin/perl - -BEGIN { pop @INC if $INC[-1] eq '.' } -use strict; -use vars qw($VERSION); - -use App::Cpan '1.64'; -$VERSION = '1.64'; - -my $rc = App::Cpan->run( @ARGV ); - -# will this work under Strawberry Perl? -exit( $rc || 0 ); - -=head1 NAME - -cpan - easily interact with CPAN from the command line - -=head1 SYNOPSIS - - # with arguments and no switches, installs specified modules - cpan module_name [ module_name ... ] - - # with switches, installs modules with extra behavior - cpan [-cfFimtTw] module_name [ module_name ... ] - - # use local::lib - cpan -I module_name [ module_name ... ] - - # one time mirror override for faster mirrors - cpan -p ... - - # with just the dot, install from the distribution in the - # current directory - cpan . - - # without arguments, starts CPAN.pm shell - cpan - - # without arguments, but some switches - cpan [-ahpruvACDLOPX] - -=head1 DESCRIPTION - -This script provides a command interface (not a shell) to CPAN. At the -moment it uses CPAN.pm to do the work, but it is not a one-shot command -runner for CPAN.pm. - -=head2 Options - -=over 4 - -=item -a - -Creates a CPAN.pm autobundle with CPAN::Shell->autobundle. - -=item -A module [ module ... ] - -Shows the primary maintainers for the specified modules. - -=item -c module - -Runs a `make clean` in the specified module's directories. - -=item -C module [ module ... ] - -Show the F files for the specified modules - -=item -D module [ module ... ] - -Show the module details. This prints one line for each out-of-date module -(meaning, modules locally installed but have newer versions on CPAN). -Each line has three columns: module name, local version, and CPAN -version. - -=item -f - -Force the specified action, when it normally would have failed. Use this -to install a module even if its tests fail. When you use this option, --i is not optional for installing a module when you need to force it: - - % cpan -f -i Module::Foo - -=item -F - -Turn off CPAN.pm's attempts to lock anything. You should be careful with -this since you might end up with multiple scripts trying to muck in the -same directory. This isn't so much of a concern if you're loading a special -config with C<-j>, and that config sets up its own work directories. - -=item -g module [ module ... ] - -Downloads to the current directory the latest distribution of the module. - -=item -G module [ module ... ] - -UNIMPLEMENTED - -Download to the current directory the latest distribution of the -modules, unpack each distribution, and create a git repository for each -distribution. - -If you want this feature, check out Yanick Champoux's C -distribution. - -=item -h - -Print a help message and exit. When you specify C<-h>, it ignores all -of the other options and arguments. - -=item -i module [ module ... ] - -Install the specified modules. With no other switches, this switch -is implied. - -=item -I - -Load C (think like C<-I> for loading lib paths). Too bad -C<-l> was already taken. - -=item -j Config.pm - -Load the file that has the CPAN configuration data. This should have the -same format as the standard F file, which defines -C<$CPAN::Config> as an anonymous hash. - -=item -J - -Dump the configuration in the same format that CPAN.pm uses. This is useful -for checking the configuration as well as using the dump as a starting point -for a new, custom configuration. - -=item -l - -List all installed modules with their versions - -=item -L author [ author ... ] - -List the modules by the specified authors. - -=item -m - -Make the specified modules. - -=item -M mirror1,mirror2,... - -A comma-separated list of mirrors to use for just this run. The C<-P> -option can find them for you automatically. - -=item -n - -Do a dry run, but don't actually install anything. (unimplemented) - -=item -O - -Show the out-of-date modules. - -=item -p - -Ping the configured mirrors and print a report - -=item -P - -Find the best mirrors you could be using and use them for the current -session. - -=item -r - -Recompiles dynamically loaded modules with CPAN::Shell->recompile. - -=item -s - -Drop in the CPAN.pm shell. This command does this automatically if you don't -specify any arguments. - -=item -t module [ module ... ] - -Run a `make test` on the specified modules. - -=item -T - -Do not test modules. Simply install them. - -=item -u - -Upgrade all installed modules. Blindly doing this can really break things, -so keep a backup. - -=item -v - -Print the script version and CPAN.pm version then exit. - -=item -V - -Print detailed information about the cpan client. - -=item -w - -UNIMPLEMENTED - -Turn on cpan warnings. This checks various things, like directory permissions, -and tells you about problems you might have. - -=item -x module [ module ... ] - -Find close matches to the named modules that you think you might have -mistyped. This requires the optional installation of Text::Levenshtein or -Text::Levenshtein::Damerau. - -=item -X - -Dump all the namespaces to standard output. - -=back - -=head2 Examples - - # print a help message - cpan -h - - # print the version numbers - cpan -v - - # create an autobundle - cpan -a - - # recompile modules - cpan -r - - # upgrade all installed modules - cpan -u - - # install modules ( sole -i is optional ) - cpan -i Netscape::Booksmarks Business::ISBN - - # force install modules ( must use -i ) - cpan -fi CGI::Minimal URI - - # install modules but without testing them - cpan -Ti CGI::Minimal URI - -=head2 Environment variables - -There are several components in CPAN.pm that use environment variables. -The build tools, L and L use some, -while others matter to the levels above them. Some of these are specified -by the Perl Toolchain Gang: - -Lancaster Concensus: L - -Oslo Concensus: L - -=over 4 - -=item NONINTERACTIVE_TESTING - -Assume no one is paying attention and skips prompts for distributions -that do that correctly. C sets this to C<1> unless it already -has a value (even if that value is false). - -=item PERL_MM_USE_DEFAULT - -Use the default answer for a prompted questions. C sets this -to C<1> unless it already has a value (even if that value is false). - -=item CPAN_OPTS - -As with C, a string of additional C options to -add to those you specify on the command line. - -=item CPANSCRIPT_LOGLEVEL - -The log level to use, with either the embedded, minimal logger or -L if it is installed. Possible values are the same as -the C levels: C, C, C, C, -C, and C. The default is C. - -=item GIT_COMMAND - -The path to the C binary to use for the Git features. The default -is C. - -=back - -=head1 EXIT VALUES - -The script exits with zero if it thinks that everything worked, or a -positive number if it thinks that something failed. Note, however, that -in some cases it has to divine a failure by the output of things it does -not control. For now, the exit codes are vague: - - 1 An unknown error - - 2 The was an external problem - - 4 There was an internal problem with the script - - 8 A module failed to install - -=head1 TO DO - -* one shot configuration values from the command line - -=head1 BUGS - -* none noted - -=head1 SEE ALSO - -Most behaviour, including environment variables and configuration, -comes directly from CPAN.pm. - -=head1 SOURCE AVAILABILITY - -This code is in Github in the CPAN.pm repository: - - https://github.com/andk/cpanpm - -The source used to be tracked separately in another GitHub repo, -but the canonical source is now in the above repo. - -=head1 CREDITS - -Japheth Cleaver added the bits to allow a forced install (-f). - -Jim Brandt suggest and provided the initial implementation for the -up-to-date and Changes features. - -Adam Kennedy pointed out that exit() causes problems on Windows -where this script ends up with a .bat extension - -=head1 AUTHOR - -brian d foy, C<< >> - -=head1 COPYRIGHT - -Copyright (c) 2001-2015, brian d foy, All Rights Reserved. - -You may redistribute this under the same terms as Perl itself. - -=cut - -1; diff --git a/bin/cpanm b/bin/cpanm deleted file mode 100755 index 072e601d..00000000 --- a/bin/cpanm +++ /dev/null @@ -1,1075 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl -# -# This is a pre-compiled source code for the cpanm (cpanminus) program. -# For more details about how to install cpanm, go to the following URL: -# -# https://github.com/miyagawa/cpanminus -# -# Quickstart: Run the following command and it will install itself for -# you. You might want to run it as a root with sudo if you want to install -# to places like /usr/local/bin. -# -# % curl -L https://cpanmin.us | perl - App::cpanminus -# -# If you don't have curl but wget, replace `curl -L` with `wget -O -`. - -# DO NOT EDIT -- this is an auto generated file - -# This chunk of stuff was generated by App::FatPacker. To find the original -# file's code, look for the end of this BEGIN block or the string 'FATPACK' -BEGIN { -my %fatpacked; - -$fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS'; - package App::cpanminus;our$VERSION="1.7044";1; -APP_CPANMINUS - -$fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_DEPENDENCY'; - package App::cpanminus::Dependency;use strict;use CPAN::Meta::Requirements;sub from_prereqs {my($class,$prereqs,$phases,$types)=@_;my@deps;for my$type (@$types){push@deps,$class->from_versions($prereqs->merged_requirements($phases,[$type])->as_string_hash,$type,)}return@deps}sub from_versions {my($class,$versions,$type)=@_;my@deps;while (my($module,$version)=each %$versions){push@deps,$class->new($module,$version,$type)}@deps}sub merge_with {my($self,$requirements)=@_;$self->{original_version}=$self->version;eval {$requirements->add_string_requirement($self->module,$self->version)};if ($@ =~ /illegal requirements/){warn sprintf("Can't merge requirements for %s: '%s' and '%s'",$self->module,$self->version,$requirements->requirements_for_module($self->module))}$self->{version}=$requirements->requirements_for_module($self->module)}sub new {my($class,$module,$version,$type)=@_;bless {module=>$module,version=>$version,type=>$type || 'requires',},$class}sub module {$_[0]->{module}}sub version {$_[0]->{version}}sub type {$_[0]->{type}}sub requires_version {my$self=shift;if (defined$self->{original_version}){return$self->{original_version}}$self->version}sub is_requirement {$_[0]->{type}eq 'requires'}1; -APP_CPANMINUS_DEPENDENCY - -$fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_SCRIPT'; - package App::cpanminus::script;use strict;use Config;use Cwd ();use App::cpanminus;use App::cpanminus::Dependency;use File::Basename ();use File::Find ();use File::Path ();use File::Spec ();use File::Copy ();use File::Temp ();use Getopt::Long ();use Symbol ();use String::ShellQuote ();use version ();use constant WIN32=>$^O eq 'MSWin32';use constant BAD_TAR=>($^O eq 'solaris' || $^O eq 'hpux');use constant CAN_SYMLINK=>eval {symlink("","");1};our$VERSION=$App::cpanminus::VERSION;if ($INC{"App/FatPacker/Trace.pm"}){require version::vpp}my$quote=WIN32 ? q/"/ : q/'/;sub agent {my$self=shift;my$agent="cpanminus/$VERSION";$agent .= " perl/$]" if$self->{report_perl_version};$agent}sub determine_home {my$class=shift;my$homedir=$ENV{HOME}|| eval {require File::HomeDir;File::HomeDir->my_home}|| join('',@ENV{qw(HOMEDRIVE HOMEPATH)});if (WIN32){require Win32;$homedir=Win32::GetShortPathName($homedir)}return "$homedir/.cpanm"}sub new {my$class=shift;bless {home=>$class->determine_home,cmd=>'install',seen=>{},notest=>undef,test_only=>undef,installdeps=>undef,force=>undef,sudo=>undef,make=>undef,verbose=>undef,quiet=>undef,interactive=>undef,log=>undef,mirrors=>[],mirror_only=>undef,mirror_index=>undef,cpanmetadb=>"http://cpanmetadb.plackperl.org/v1.0/",perl=>$^X,argv=>[],local_lib=>undef,self_contained=>undef,exclude_vendor=>undef,prompt_timeout=>0,prompt=>undef,configure_timeout=>60,build_timeout=>3600,test_timeout=>1800,try_lwp=>1,try_wget=>1,try_curl=>1,uninstall_shadows=>($] < 5.012),skip_installed=>1,skip_satisfied=>0,auto_cleanup=>7,pod2man=>1,installed_dists=>0,install_types=>['requires'],with_develop=>0,with_configure=>0,showdeps=>0,scandeps=>0,scandeps_tree=>[],format=>'tree',save_dists=>undef,skip_configure=>0,verify=>0,report_perl_version=>!$class->maybe_ci,build_args=>{},features=>{},pure_perl=>0,cpanfile_path=>'cpanfile',@_,},$class}sub env {my($self,$key)=@_;$ENV{"PERL_CPANM_" .$key}}sub maybe_ci {my$class=shift;grep$ENV{$_},qw(TRAVIS CI AUTOMATED_TESTING AUTHOR_TESTING)}sub install_type_handlers {my$self=shift;my@handlers;for my$type (qw(recommends suggests)){push@handlers,"with-$type"=>sub {my%uniq;$self->{install_types}=[grep!$uniq{$_}++,@{$self->{install_types}},$type ]};push@handlers,"without-$type"=>sub {$self->{install_types}=[grep $_ ne $type,@{$self->{install_types}}]}}@handlers}sub build_args_handlers {my$self=shift;my@handlers;for my$phase (qw(configure build test install)){push@handlers,"$phase-args=s"=>\($self->{build_args}{$phase})}@handlers}sub parse_options {my$self=shift;local@ARGV=@{$self->{argv}};push@ARGV,grep length,split /\s+/,$self->env('OPT');push@ARGV,@_;Getopt::Long::Configure("bundling");Getopt::Long::GetOptions('f|force'=>sub {$self->{skip_installed}=0;$self->{force}=1},'n|notest!'=>\$self->{notest},'test-only'=>sub {$self->{notest}=0;$self->{skip_installed}=0;$self->{test_only}=1},'S|sudo!'=>\$self->{sudo},'v|verbose'=>\$self->{verbose},'verify!'=>\$self->{verify},'q|quiet!'=>\$self->{quiet},'h|help'=>sub {$self->{action}='show_help'},'V|version'=>sub {$self->{action}='show_version'},'perl=s'=>sub {$self->diag("--perl is deprecated since it's known to be fragile in figuring out dependencies. Run `$_[1] -S cpanm` instead.\n",1);$self->{perl}=$_[1]},'l|local-lib=s'=>sub {$self->{local_lib}=$self->maybe_abs($_[1])},'L|local-lib-contained=s'=>sub {$self->{local_lib}=$self->maybe_abs($_[1]);$self->{self_contained}=1;$self->{pod2man}=undef},'self-contained!'=>\$self->{self_contained},'exclude-vendor!'=>\$self->{exclude_vendor},'mirror=s@'=>$self->{mirrors},'mirror-only!'=>\$self->{mirror_only},'mirror-index=s'=>sub {$self->{mirror_index}=$self->maybe_abs($_[1])},'M|from=s'=>sub {$self->{mirrors}=[$_[1]];$self->{mirror_only}=1},'cpanmetadb=s'=>\$self->{cpanmetadb},'cascade-search!'=>\$self->{cascade_search},'prompt!'=>\$self->{prompt},'installdeps'=>\$self->{installdeps},'skip-installed!'=>\$self->{skip_installed},'skip-satisfied!'=>\$self->{skip_satisfied},'reinstall'=>sub {$self->{skip_installed}=0},'interactive!'=>\$self->{interactive},'i|install'=>sub {$self->{cmd}='install'},'info'=>sub {$self->{cmd}='info'},'look'=>sub {$self->{cmd}='look';$self->{skip_installed}=0},'U|uninstall'=>sub {$self->{cmd}='uninstall'},'self-upgrade'=>sub {$self->{action}='self_upgrade'},'uninst-shadows!'=>\$self->{uninstall_shadows},'lwp!'=>\$self->{try_lwp},'wget!'=>\$self->{try_wget},'curl!'=>\$self->{try_curl},'auto-cleanup=s'=>\$self->{auto_cleanup},'man-pages!'=>\$self->{pod2man},'scandeps'=>\$self->{scandeps},'showdeps'=>sub {$self->{showdeps}=1;$self->{skip_installed}=0},'format=s'=>\$self->{format},'save-dists=s'=>sub {$self->{save_dists}=$self->maybe_abs($_[1])},'skip-configure!'=>\$self->{skip_configure},'dev!'=>\$self->{dev_release},'metacpan!'=>\$self->{metacpan},'report-perl-version!'=>\$self->{report_perl_version},'configure-timeout=i'=>\$self->{configure_timeout},'build-timeout=i'=>\$self->{build_timeout},'test-timeout=i'=>\$self->{test_timeout},'with-develop'=>\$self->{with_develop},'without-develop'=>sub {$self->{with_develop}=0},'with-configure'=>\$self->{with_configure},'without-configure'=>sub {$self->{with_configure}=0},'with-feature=s'=>sub {$self->{features}{$_[1]}=1},'without-feature=s'=>sub {$self->{features}{$_[1]}=0},'with-all-features'=>sub {$self->{features}{__all}=1},'pp|pureperl!'=>\$self->{pure_perl},"cpanfile=s"=>\$self->{cpanfile_path},$self->install_type_handlers,$self->build_args_handlers,);if (!@ARGV && $0 ne '-' &&!-t STDIN){push@ARGV,$self->load_argv_from_fh(\*STDIN);$self->{load_from_stdin}=1}$self->{argv}=\@ARGV}sub check_upgrade {my$self=shift;my$install_base=$ENV{PERL_LOCAL_LIB_ROOT}? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}): $Config{installsitebin};if ($0 eq '-'){return}elsif ($0 !~ /^$install_base/){if ($0 =~ m!perlbrew/bin!){die <{_checked}++;$self->bootstrap_local_lib}sub setup_verify {my$self=shift;my$has_modules=eval {require Module::Signature;require Digest::SHA;1};$self->{cpansign}=$self->which('cpansign');unless ($has_modules && $self->{cpansign}){warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";$self->{verify}=0}}sub parse_module_args {my($self,$module)=@_;$module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;if ($module =~ /\~[v\d\._,\!<>= ]+$/){return split /\~/,$module,2}else {return$module,undef}}sub doit {my$self=shift;my$code;eval {$code=($self->_doit==0)};if (my$e=$@){warn$e;$code=1}return$code}sub _doit {my$self=shift;$self->setup_home;$self->init_tools;$self->setup_verify if$self->{verify};if (my$action=$self->{action}){$self->$action()and return 1}return$self->show_help(1)unless @{$self->{argv}}or $self->{load_from_stdin};$self->configure_mirrors;my$cwd=Cwd::cwd;my@fail;for my$module (@{$self->{argv}}){if ($module =~ s/\.pm$//i){my ($volume,$dirs,$file)=File::Spec->splitpath($module);$module=join '::',grep {$_}File::Spec->splitdir($dirs),$file}($module,my$version)=$self->parse_module_args($module);$self->chdir($cwd);if ($self->{cmd}eq 'uninstall'){$self->uninstall_module($module)or push@fail,$module}else {$self->install_module($module,0,$version)or push@fail,$module}}if ($self->{base}&& $self->{auto_cleanup}){$self->cleanup_workdirs}if ($self->{installed_dists}){my$dists=$self->{installed_dists}> 1 ? "distributions" : "distribution";$self->diag("$self->{installed_dists} $dists installed\n",1)}if ($self->{scandeps}){$self->dump_scandeps()}$self->chdir($cwd);return!@fail}sub setup_home {my$self=shift;$self->{home}=$self->env('HOME')if$self->env('HOME');unless (_writable($self->{home})){die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n"}$self->{base}="$self->{home}/work/" .time .".$$";File::Path::mkpath([$self->{base}],0,0777);$self->{log}=File::Spec->catfile($self->{base},"build.log");my$final_log="$self->{home}/build.log";{open my$out,">$self->{log}" or die "$self->{log}: $!"}if (CAN_SYMLINK){my$build_link="$self->{home}/latest-build";unlink$build_link;symlink$self->{base},$build_link;unlink$final_log;symlink$self->{log},$final_log}else {my$log=$self->{log};my$home=$self->{home};$self->{at_exit}=sub {my$self=shift;my$temp_log="$home/build.log." .time .".$$";File::Copy::copy($log,$temp_log)&& unlink($final_log);rename($temp_log,$final_log)}}$self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" ."Work directory is $self->{base}\n")}sub package_index_for {my ($self,$mirror)=@_;return$self->source_for($mirror)."/02packages.details.txt"}sub generate_mirror_index {my ($self,$mirror)=@_;my$file=$self->package_index_for($mirror);my$gz_file=$file .'.gz';my$index_mtime=(stat$gz_file)[9];unless (-e $file && (stat$file)[9]>= $index_mtime){$self->chat("Uncompressing index file...\n");if (eval {require Compress::Zlib}){my$gz=Compress::Zlib::gzopen($gz_file,"rb")or do {$self->diag_fail("$Compress::Zlib::gzerrno opening compressed index");return};open my$fh,'>',$file or do {$self->diag_fail("$! opening uncompressed index for write");return};my$buffer;while (my$status=$gz->gzread($buffer)){if ($status < 0){$self->diag_fail($gz->gzerror ." reading compressed index");return}print$fh $buffer}}else {if (system("gunzip -c $gz_file > $file")){$self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");return}}utime$index_mtime,$index_mtime,$file}return 1}sub search_mirror_index {my ($self,$mirror,$module,$version)=@_;$self->search_mirror_index_file($self->package_index_for($mirror),$module,$version)}sub search_mirror_index_file {my($self,$file,$module,$version)=@_;open my$fh,'<',$file or return;my$found;while (<$fh>){if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m){$found=$self->cpan_module($module,$2,$1);last}}return$found unless$self->{cascade_search};if ($found){if ($self->satisfy_version($module,$found->{module_version},$version)){return$found}else {$self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n")}}return}sub with_version_range {my($self,$version)=@_;defined($version)&& $version =~ /(?:<|!=|==)/}sub encode_json {my($self,$data)=@_;require JSON::PP;my$json=JSON::PP::encode_json($data);$self->uri_escape($json)}sub decode_json {my($self,$json)=@_;require JSON::PP;JSON::PP::decode_json($json)}sub uri_escape {my($self,$fragment)=@_;$fragment =~ s/([^A-Za-z0-9\-\._~])/uc sprintf("%%%02X", ord($1))/eg;$fragment}sub uri_params {my($self,@params)=@_;my@param_strings;while (my$key=shift@params){my$value=shift@params;push@param_strings,join '=',map$self->uri_escape($_),$key,$value}return join '&',@param_strings}sub numify_ver {my($self,$ver)=@_;eval version->new($ver)->numify}sub search_metacpan {my($self,$module,$version,$dev_release)=@_;my$metacpan_uri='http://fastapi.metacpan.org/v1/download_url/';my$url=$metacpan_uri .$module;my$query=$self->uri_params(($version ? (version=>$version): ()),($dev_release ? (dev=>1): ()),);$url .= '?' .$query if length$query;my$dist_json=$self->get($url);my$dist_meta=eval {$self->decode_json($dist_json)};if ($dist_meta && $dist_meta->{download_url}){(my$distfile=$dist_meta->{download_url})=~ s!.+/authors/id/!!;local$self->{mirrors}=$self->{mirrors};$self->{mirrors}=['http://cpan.metacpan.org' ];return$self->cpan_module($module,$distfile,$dist_meta->{version})}$self->chat("! Could not find a release matching $module".($version?" ($version)":'')." on MetaCPAN.\n");return}sub search_database {my($self,$module,$version)=@_;my$found;if ($self->{dev_release}or $self->{metacpan}){$found=$self->search_metacpan($module,$version,$self->{dev_release})and return$found;$found=$self->search_cpanmetadb($module,$version,$self->{dev_release})and return$found}else {$found=$self->search_cpanmetadb($module,$version)and return$found;$found=$self->search_metacpan($module,$version)and return$found}}sub search_cpanmetadb {my($self,$module,$version,$dev_release)=@_;$self->chat("Searching $module ($version) on cpanmetadb ...\n");if ($self->with_version_range($version)){return$self->search_cpanmetadb_history($module,$version,$dev_release)}else {return$self->search_cpanmetadb_package($module,$version,$dev_release)}}sub search_cpanmetadb_package {my($self,$module,$version,$dev_release)=@_;require CPAN::Meta::YAML;(my$uri=$self->{cpanmetadb})=~ s{/?$}{/package/$module};my$yaml=$self->get($uri);my$meta=eval {CPAN::Meta::YAML::Load($yaml)};if ($meta && $meta->{distfile}){return$self->cpan_module($module,$meta->{distfile},$meta->{version})}$self->diag_fail("Finding $module on cpanmetadb failed.");return}sub search_cpanmetadb_history {my($self,$module,$version)=@_;(my$uri=$self->{cpanmetadb})=~ s{/?$}{/history/$module};my$content=$self->get($uri)or return;my@found;for my$line (split /\r?\n/,$content){if ($line =~ /^$module\s+(\S+)\s+(\S+)$/){push@found,{version=>$1,version_obj=>version::->parse($1),distfile=>$2,}}}return unless@found;$found[-1]->{latest}=1;my$match;for my$try (sort {$b->{version_obj}cmp $a->{version_obj}}@found){if ($self->satisfy_version($module,$try->{version_obj},$version)){local$self->{mirrors}=$self->{mirrors};unshift @{$self->{mirrors}},'http://backpan.perl.org' unless$try->{latest};return$self->cpan_module($module,$try->{distfile},$try->{version})}}$self->diag_fail("Finding $module ($version) on cpanmetadb failed.");return}sub search_module {my($self,$module,$version)=@_;if ($self->{mirror_index}){$self->mask_output(chat=>"Searching $module on mirror index $self->{mirror_index} ...\n");my$pkg=$self->search_mirror_index_file($self->{mirror_index},$module,$version);return$pkg if$pkg;unless ($self->{cascade_search}){$self->mask_output(diag_fail=>"Finding $module ($version) on mirror index $self->{mirror_index} failed.");return}}unless ($self->{mirror_only}){my$found=$self->search_database($module,$version);return$found if$found}MIRROR: for my$mirror (@{$self->{mirrors}}){$self->mask_output(chat=>"Searching $module on mirror $mirror ...\n");my$name='02packages.details.txt.gz';my$uri="$mirror/modules/$name";my$gz_file=$self->package_index_for($mirror).'.gz';unless ($self->{pkgs}{$uri}){$self->mask_output(chat=>"Downloading index file $uri ...\n");$self->mirror($uri,$gz_file);$self->generate_mirror_index($mirror)or next MIRROR;$self->{pkgs}{$uri}="!!retrieved!!"}my$pkg=$self->search_mirror_index($mirror,$module,$version);return$pkg if$pkg;$self->mask_output(diag_fail=>"Finding $module ($version) on mirror $mirror failed.")}return}sub source_for {my($self,$mirror)=@_;$mirror =~ s/[^\w\.\-]+/%/g;my$dir="$self->{home}/sources/$mirror";File::Path::mkpath([$dir ],0,0777);return$dir}sub load_argv_from_fh {my($self,$fh)=@_;my@argv;while(defined(my$line=<$fh>)){chomp$line;$line =~ s/#.+$//;$line =~ s/^\s+//;$line =~ s/\s+$//;push@argv,split ' ',$line if$line}return@argv}sub show_version {my$self=shift;print "cpanm (App::cpanminus) version $VERSION ($0)\n";print "perl version $] ($^X)\n\n";print " \%Config:\n";for my$key (qw(archname installsitelib installsitebin installman1dir installman3dir sitearchexp sitelibexp vendorarch vendorlibexp archlibexp privlibexp)){print " $key=$Config{$key}\n" if$Config{$key}}print " \%ENV:\n";for my$key (grep /^PERL/,sort keys%ENV){print " $key=$ENV{$key}\n"}print " \@INC:\n";for my$inc (@INC){print " $inc\n" unless ref($inc)eq 'CODE'}return 1}sub show_help {my$self=shift;if ($_[0]){print <splitdir($dir);while (@dir){$dir=File::Spec->catdir(@dir);if (-e $dir){return -w _}pop@dir}return}sub maybe_abs {my($self,$lib)=@_;if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)){return$lib}else {return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(),$lib))}}sub local_lib_target {my($self,$root)=@_;(grep {$_ ne ''}split /\Q$Config{path_sep}/,$root)[0]}sub bootstrap_local_lib {my$self=shift;if ($self->{local_lib}){return$self->setup_local_lib($self->{local_lib})}if ($ENV{PERL_LOCAL_LIB_ROOT}&& $ENV{PERL_MM_OPT}){return$self->setup_local_lib($self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}),1)}return if$self->{sudo}or (_writable($Config{installsitelib})and _writable($Config{installsitebin}));if ($ENV{PERL_MM_OPT}and ($ENV{MODULEBUILDRC}or $ENV{PERL_MB_OPT})){return}$self->setup_local_lib;$self->diag(<module=>$_}@$config_deps;my$reqs=CPAN::Meta::Requirements->from_string_hash({'Module::Build'=>'0.38','ExtUtils::MakeMaker'=>'6.58','ExtUtils::Install'=>'1.46',});if ($deps{"ExtUtils::MakeMaker"}){$deps{"ExtUtils::MakeMaker"}->merge_with($reqs)}elsif ($deps{"Module::Build"}){$deps{"Module::Build"}->merge_with($reqs);$deps{"ExtUtils::Install"}||= App::cpanminus::Dependency->new("ExtUtils::Install",0,'configure');$deps{"ExtUtils::Install"}->merge_with($reqs)}@$config_deps=values%deps}sub _core_only_inc {my($self,$base)=@_;require local::lib;(local::lib->resolve_path(local::lib->install_base_arch_path($base)),local::lib->resolve_path(local::lib->install_base_perl_path($base)),(!$self->{exclude_vendor}? grep {$_}@Config{qw(vendorarch vendorlibexp)}: ()),@Config{qw(archlibexp privlibexp)},)}sub _diff {my($self,$old,$new)=@_;my@diff;my%old=map {$_=>1}@$old;for my$n (@$new){push@diff,$n unless exists$old{$n}}@diff}sub _setup_local_lib_env {my($self,$base)=@_;$self->diag(<setup_env_hash_for($base,0)}sub setup_local_lib {my($self,$base,$no_env)=@_;$base=undef if$base eq '_';require local::lib;{local $0='cpanm';$base ||= "~/perl5";$base=local::lib->resolve_path($base);if ($self->{self_contained}){my@inc=$self->_core_only_inc($base);$self->{search_inc}=[@inc ]}else {$self->{search_inc}=[local::lib->install_base_arch_path($base),local::lib->install_base_perl_path($base),@INC,]}$self->_setup_local_lib_env($base)unless$no_env;$self->{local_lib}=$base}}sub prompt_bool {my($self,$mess,$def)=@_;my$val=$self->prompt($mess,$def);return lc$val eq 'y'}sub prompt {my($self,$mess,$def)=@_;my$isa_tty=-t STDIN && (-t STDOUT ||!(-f STDOUT || -c STDOUT));my$dispdef=defined$def ? "[$def] " : " ";$def=defined$def ? $def : "";if (!$self->{prompt}|| (!$isa_tty && eof STDIN)){return$def}local $|=1;local $\;my$ans;eval {local$SIG{ALRM}=sub {undef$ans;die "alarm\n"};print STDOUT "$mess $dispdef";alarm$self->{prompt_timeout}if$self->{prompt_timeout};$ans=;alarm 0};if (defined$ans){chomp$ans}else {print STDOUT "\n"}return (!defined$ans || $ans eq '')? $def : $ans}sub diag_ok {my($self,$msg)=@_;chomp$msg;$msg ||= "OK";if ($self->{in_progress}){$self->_diag("$msg\n");$self->{in_progress}=0}$self->log("-> $msg\n")}sub diag_fail {my($self,$msg,$always)=@_;chomp$msg;if ($self->{in_progress}){$self->_diag("FAIL\n");$self->{in_progress}=0}if ($msg){$self->_diag("! $msg\n",$always,1);$self->log("-> FAIL $msg\n")}}sub diag_progress {my($self,$msg)=@_;chomp$msg;$self->{in_progress}=1;$self->_diag("$msg ... ");$self->log("$msg\n")}sub _diag {my($self,$msg,$always,$error)=@_;my$fh=$error ? *STDERR : *STDOUT;print {$fh}$msg if$always or $self->{verbose}or!$self->{quiet}}sub diag {my($self,$msg,$always)=@_;$self->_diag($msg,$always);$self->log($msg)}sub chat {my$self=shift;print STDERR @_ if$self->{verbose};$self->log(@_)}sub mask_output {my$self=shift;my$method=shift;$self->$method($self->mask_uri_passwords(@_))}sub log {my$self=shift;open my$out,">>$self->{log}";print$out @_}sub run {my($self,$cmd)=@_;if (WIN32){$cmd=$self->shell_quote(@$cmd)if ref$cmd eq 'ARRAY';unless ($self->{verbose}){$cmd .= " >> " .$self->shell_quote($self->{log})." 2>&1"}!system$cmd}else {my$pid=fork;if ($pid){waitpid$pid,0;return!$?}else {$self->run_exec($cmd)}}}sub run_exec {my($self,$cmd)=@_;if (ref$cmd eq 'ARRAY'){unless ($self->{verbose}){open my$logfh,">>",$self->{log};open STDERR,'>&',$logfh;open STDOUT,'>&',$logfh;close$logfh}exec @$cmd}else {unless ($self->{verbose}){$cmd .= " >> " .$self->shell_quote($self->{log})." 2>&1"}exec$cmd}}sub run_timeout {my($self,$cmd,$timeout)=@_;return$self->run($cmd)if WIN32 || $self->{verbose}||!$timeout;my$pid=fork;if ($pid){eval {local$SIG{ALRM}=sub {die "alarm\n"};alarm$timeout;waitpid$pid,0;alarm 0};if ($@ && $@ eq "alarm\n"){$self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry.");local$SIG{TERM}='IGNORE';kill TERM=>0;waitpid$pid,0;return}return!$?}elsif ($pid==0){$self->run_exec($cmd)}else {$self->chat("! fork failed: falling back to system()\n");$self->run($cmd)}}sub append_args {my($self,$cmd,$phase)=@_;if (my$args=$self->{build_args}{$phase}){$cmd=join ' ',$self->shell_quote(@$cmd),$args}$cmd}sub configure {my($self,$cmd,$depth)=@_;local$ENV{PERL5_CPAN_IS_RUNNING}=local$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$;local$ENV{PERL5_CPANM_IS_RUNNING}=$$;my$use_default=!$self->{interactive};local$ENV{PERL_MM_USE_DEFAULT}=$use_default;local$ENV{PERL_MM_OPT}=$ENV{PERL_MM_OPT};local$ENV{PERL_MB_OPT}=$ENV{PERL_MB_OPT};unless ($self->{pod2man}){$ENV{PERL_MM_OPT}.= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";$ENV{PERL_MB_OPT}.= " --config installman1dir= --config installsiteman1dir= --config installman3dir= --config installsiteman3dir="}if ($self->{pure_perl}){$ENV{PERL_MM_OPT}.= " PUREPERL_ONLY=1";$ENV{PERL_MB_OPT}.= " --pureperl-only"}local$ENV{PERL_USE_UNSAFE_INC}=1 unless exists$ENV{PERL_USE_UNSAFE_INC};$cmd=$self->append_args($cmd,'configure')if$depth==0;local$self->{verbose}=$self->{verbose}|| $self->{interactive};$self->run_timeout($cmd,$self->{configure_timeout})}sub build {my($self,$cmd,$distname,$depth)=@_;local$ENV{PERL_MM_USE_DEFAULT}=!$self->{interactive};local$ENV{PERL_USE_UNSAFE_INC}=1 unless exists$ENV{PERL_USE_UNSAFE_INC};$cmd=$self->append_args($cmd,'build')if$depth==0;return 1 if$self->run_timeout($cmd,$self->{build_timeout});while (1){my$ans=lc$self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?","s");return if$ans eq 's';return$self->build($cmd,$distname,$depth)if$ans eq 'r';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}sub test {my($self,$cmd,$distname,$depth)=@_;return 1 if$self->{notest};local$ENV{PERL_MM_USE_DEFAULT}=!$self->{interactive};local$ENV{NONINTERACTIVE_TESTING}=!$self->{interactive};$cmd=$self->append_args($cmd,'test')if$depth==0;local$ENV{PERL_USE_UNSAFE_INC}=1 unless exists$ENV{PERL_USE_UNSAFE_INC};return 1 if$self->run_timeout($cmd,$self->{test_timeout});if ($self->{force}){$self->diag_fail("Testing $distname failed but installing it anyway.");return 1}else {$self->diag_fail;while (1){my$ans=lc$self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install, e)xamine build log, or l)ook ?","s");return if$ans eq 's';return$self->test($cmd,$distname,$depth)if$ans eq 'r';return 1 if$ans eq 'f';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}}sub install {my($self,$cmd,$uninst_opts,$depth)=@_;if ($depth==0 && $self->{test_only}){return 1}local$ENV{PERL_USE_UNSAFE_INC}=1 unless exists$ENV{PERL_USE_UNSAFE_INC};if ($self->{sudo}){unshift @$cmd,"sudo"}if ($self->{uninstall_shadows}&&!$ENV{PERL_MM_OPT}){push @$cmd,@$uninst_opts}$cmd=$self->append_args($cmd,'install')if$depth==0;$self->run($cmd)}sub look {my$self=shift;my$shell=$ENV{SHELL};$shell ||= $ENV{COMSPEC}if WIN32;if ($shell){my$cwd=Cwd::cwd;$self->diag("Entering $cwd with $shell\n");system$shell}else {$self->diag_fail("You don't seem to have a SHELL :/")}}sub show_build_log {my$self=shift;my@pagers=($ENV{PAGER},(WIN32 ? (): ('less')),'more');my$pager;while (@pagers){$pager=shift@pagers;next unless$pager;$pager=$self->which($pager);next unless$pager;last}if ($pager){system("$pager < $self->{log}")}else {$self->diag_fail("You don't seem to have a PAGER :/")}}sub chdir {my$self=shift;Cwd::chdir(File::Spec->canonpath($_[0]))or die "$_[0]: $!"}sub configure_mirrors {my$self=shift;unless (@{$self->{mirrors}}){$self->{mirrors}=['http://www.cpan.org' ]}for (@{$self->{mirrors}}){s!^/!file:///!;s!/$!!}}sub self_upgrade {my$self=shift;$self->check_upgrade;$self->{argv}=['App::cpanminus' ];return}sub install_module {my($self,$module,$depth,$version)=@_;$self->check_libs;if ($self->{seen}{$module}++){$self->chat("Already tried $module. Skipping.\n");return 1}if ($self->{skip_satisfied}){my($ok,$local)=$self->check_module($module,$version || 0);if ($ok){$self->diag("You have $module ($local)\n",1);return 1}}my$dist=$self->resolve_name($module,$version);unless ($dist){my$what=$module .($version ? " ($version)" : "");$self->diag_fail("Couldn't find module or a distribution $what",1);return}if ($dist->{distvname}&& $self->{seen}{$dist->{distvname}}++){$self->chat("Already tried $dist->{distvname}. Skipping.\n");return 1}if ($self->{cmd}eq 'info'){print$self->format_dist($dist),"\n";return 1}$dist->{depth}=$depth;if ($dist->{module}){unless ($self->satisfy_version($dist->{module},$dist->{module_version},$version)){$self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n",1);return}my$cmp=$version ? "==" : "";my$requirement=$dist->{module_version}? "$cmp$dist->{module_version}" : 0;my($ok,$local)=$self->check_module($dist->{module},$requirement);if ($self->{skip_installed}&& $ok){$self->diag("$dist->{module} is up to date. ($local)\n",1);return 1}}if ($dist->{dist}eq 'perl'){$self->diag("skipping $dist->{pathname}\n");return 1}$self->diag("--> Working on $module\n");$dist->{dir}||= $self->fetch_module($dist);unless ($dist->{dir}){$self->diag_fail("Failed to fetch distribution $dist->{distvname}",1);return}$self->chat("Entering $dist->{dir}\n");$self->chdir($self->{base});$self->chdir($dist->{dir});if ($self->{cmd}eq 'look'){$self->look;return 1}return$self->build_stuff($module,$dist,$depth)}sub uninstall_search_path {my$self=shift;$self->{local_lib}? (local::lib->install_base_arch_path($self->{local_lib}),local::lib->install_base_perl_path($self->{local_lib})): @Config{qw(installsitearch installsitelib)}}sub uninstall_module {my ($self,$module)=@_;$self->check_libs;my@inc=$self->uninstall_search_path;my($metadata,$packlist)=$self->packlists_containing($module,\@inc);unless ($packlist){$self->diag_fail(<uninstall_target($metadata,$packlist);$self->ask_permission($module,\@uninst_files)or return;$self->uninstall_files(@uninst_files,$packlist);$self->diag("Successfully uninstalled $module\n",1);return 1}sub packlists_containing {my($self,$module,$inc)=@_;require Module::Metadata;my$metadata=Module::Metadata->new_from_module($module,inc=>$inc)or return;my$packlist;my$wanted=sub {return unless $_ eq '.packlist' && -f $_;for my$file ($self->unpack_packlist($File::Find::name)){$packlist ||= $File::Find::name if$file eq $metadata->filename}};{require File::pushd;my$pushd=File::pushd::pushd();my@search=grep -d $_,map File::Spec->catdir($_,'auto'),@$inc;File::Find::find($wanted,@search)}return$metadata,$packlist}sub uninstall_target {my($self,$metadata,$packlist)=@_;if ($self->has_shadow_install($metadata)or $self->{local_lib}){grep$self->should_unlink($_),$self->unpack_packlist($packlist)}else {$self->unpack_packlist($packlist)}}sub has_shadow_install {my($self,$metadata)=@_;my@shadow=grep defined,map Module::Metadata->new_from_module($metadata->name,inc=>[$_]),@INC;@shadow >= 2}sub should_unlink {my($self,$file)=@_;if ($self->{local_lib}){$file =~ /^\Q$self->{local_lib}\E/}else {!(grep$file =~ /^\Q$_\E/,@Config{qw(installbin installscript installman1dir installman3dir)})}}sub ask_permission {my ($self,$module,$files)=@_;$self->diag("$module contains the following files:\n\n");for my$file (@$files){$self->diag(" $file\n")}$self->diag("\n");return 'force uninstall' if$self->{force};local$self->{prompt}=1;return$self->prompt_bool("Are you sure you want to uninstall $module?",'y')}sub unpack_packlist {my ($self,$packlist)=@_;open my$fh,'<',$packlist or die "$packlist: $!";map {chomp;$_}<$fh>}sub uninstall_files {my ($self,@files)=@_;$self->diag("\n");for my$file (@files){$self->diag("Unlink: $file\n");unlink$file or $self->diag_fail("$!: $file")}$self->diag("\n");return 1}sub format_dist {my($self,$dist)=@_;return "$dist->{cpanid}/$dist->{filename}"}sub trim {local $_=shift;tr/\n/ /d;s/^\s*|\s*$//g;$_}sub fetch_module {my($self,$dist)=@_;$self->chdir($self->{base});for my$uri (@{$dist->{uris}}){$self->mask_output(diag_progress=>"Fetching $uri");my$filename=$dist->{filename}|| $uri;my$name=File::Basename::basename($filename);my$cancelled;my$fetch=sub {my$file;eval {local$SIG{INT}=sub {$cancelled=1;die "SIGINT\n"};$self->mirror($uri,$name);$file=$name if -e $name};$self->diag("ERROR: " .trim("$@")."\n",1)if $@ && $@ ne "SIGINT\n";return$file};my($try,$file);while ($try++ < 3){$file=$fetch->();last if$cancelled or $file;$self->mask_output(diag_fail=>"Download $uri failed. Retrying ... ")}if ($cancelled){$self->diag_fail("Download cancelled.");return}unless ($file){$self->mask_output(diag_fail=>"Failed to download $uri");next}$self->diag_ok;$dist->{local_path}=File::Spec->rel2abs($name);my$dir=$self->unpack($file,$uri,$dist);next unless$dir;if (my$save=$self->{save_dists}){my$path=$dist->{pathname}? "$save/authors/id/$dist->{pathname}" : "$save/vendor/$file";$self->chat("Copying $name to $path\n");File::Path::mkpath([File::Basename::dirname($path)],0,0777);File::Copy::copy($file,$path)or warn $!}return$dist,$dir}}sub unpack {my($self,$file,$uri,$dist)=@_;if ($self->{verify}){$self->verify_archive($file,$uri,$dist)or return}$self->chat("Unpacking $file\n");my$dir=$file =~ /\.zip/i ? $self->unzip($file): $self->untar($file);unless ($dir){$self->diag_fail("Failed to unpack $file: no directory")}return$dir}sub verify_checksums_signature {my($self,$chk_file)=@_;require Module::Signature;$self->chat("Verifying the signature of CHECKSUMS\n");my$rv=eval {local$SIG{__WARN__}=sub {};my$v=Module::Signature::_verify($chk_file);$v==Module::Signature::SIGNATURE_OK()};if ($rv){$self->chat("Verified OK!\n")}else {$self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n");return}return 1}sub verify_archive {my($self,$file,$uri,$dist)=@_;unless ($dist->{cpanid}){$self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n");return 1}(my$mirror=$uri)=~ s!/authors/id.*$!!;(my$chksum_uri=$uri)=~ s!/[^/]*$!/CHECKSUMS!;my$chk_file=$self->source_for($mirror)."/$dist->{cpanid}.CHECKSUMS";$self->mask_output(diag_progress=>"Fetching $chksum_uri");$self->mirror($chksum_uri,$chk_file);unless (-e $chk_file){$self->diag_fail("Fetching $chksum_uri failed.\n");return}$self->diag_ok;$self->verify_checksums_signature($chk_file)or return;$self->verify_checksum($file,$chk_file)}sub verify_checksum {my($self,$file,$chk_file)=@_;$self->chat("Verifying the SHA1 for $file\n");open my$fh,"<$chk_file" or die "$chk_file: $!";my$data=join '',<$fh>;$data =~ s/\015?\012/\n/g;require Safe;my$chksum=Safe->new->reval($data);if (!ref$chksum or ref$chksum ne 'HASH'){$self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");return}if (my$sha=$chksum->{$file}{sha256}){my$hex=$self->sha1_for($file);if ($hex eq $sha){$self->chat("Checksum for $file: Verified!\n")}else {$self->diag_fail("Checksum mismatch for $file\n");return}}else {$self->chat("Checksum for $file not found in CHECKSUMS.\n");return}}sub sha1_for {my($self,$file)=@_;require Digest::SHA;open my$fh,"<",$file or die "$file: $!";my$dg=Digest::SHA->new(256);my($data);while (read($fh,$data,4096)){$dg->add($data)}return$dg->hexdigest}sub verify_signature {my($self,$dist)=@_;$self->diag_progress("Verifying the SIGNATURE file");my$out=`$self->{cpansign} -v --skip 2>&1`;$self->log($out);if ($out =~ /Signature verified OK/){$self->diag_ok("Verified OK");return 1}else {$self->diag_fail("SIGNATURE verification for $dist->{filename} failed\n");return}}sub resolve_name {my($self,$module,$version)=@_;if ($module =~ /(?:^git:|\.git(?:@.+)?$)/){return$self->git_uri($module)}if ($module =~ /^(ftp|https?|file):/){if ($module =~ m!authors/id/(.*)!){return$self->cpan_dist($1,$module)}else {return {uris=>[$module ]}}}if ($module =~ m!^[\./]! && -d $module){return {source=>'local',dir=>Cwd::abs_path($module),}}if (-f $module){return {source=>'local',uris=>["file://" .Cwd::abs_path($module)],}}if ($module =~ s!^cpan:///distfile/!!){return$self->cpan_dist($module)}if ($module =~ m!^(?:[A-Z]/[A-Z]{2}/)?([A-Z]{2}[\-A-Z0-9]*/.*)$!){return$self->cpan_dist($1)}return$self->search_module($module,$version)}sub cpan_module {my($self,$module,$dist_file,$version)=@_;my$dist=$self->cpan_dist($dist_file);$dist->{module}=$module;$dist->{module_version}=$version if$version && $version ne 'undef';return$dist}sub cpan_dist {my($self,$dist,$url)=@_;$dist =~ s!^([A-Z]{2})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;require CPAN::DistnameInfo;my$d=CPAN::DistnameInfo->new($dist);if ($url){$url=[$url ]unless ref$url eq 'ARRAY'}else {my$id=$d->cpanid;my$fn=substr($id,0,1)."/" .substr($id,0,2)."/" .$id ."/" .$d->filename;my@mirrors=@{$self->{mirrors}};my@urls=map "$_/authors/id/$fn",@mirrors;$url=\@urls,}return {$d->properties,source=>'cpan',uris=>$url,}}sub git_uri {my ($self,$uri)=@_;($uri,my$commitish)=split /(?<=\.git)@/i,$uri,2;my$dir=File::Temp::tempdir(CLEANUP=>1);$self->mask_output(diag_progress=>"Cloning $uri");$self->run(['git','clone',$uri,$dir ]);unless (-e "$dir/.git"){$self->diag_fail("Failed cloning git repository $uri",1);return}if ($commitish){require File::pushd;my$dir=File::pushd::pushd($dir);unless ($self->run(['git','checkout',$commitish ])){$self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");return}}$self->diag_ok;return {source=>'local',dir=>$dir,}}sub setup_module_build_patch {my$self=shift;open my$out,">$self->{base}/ModuleBuildSkipMan.pm" or die $!;print$out <{search_inc}||= do {if (defined$::Bin){[grep!/^\Q$::Bin\E\/..\/(?:fat)?lib$/,@INC]}else {[@INC]}}}sub check_module {my($self,$mod,$want_ver)=@_;require Module::Metadata;my$meta=Module::Metadata->new_from_module($mod,inc=>$self->search_inc)or return 0,undef;my$version=$meta->version;if ($self->{self_contained}&& $self->loaded_from_perl_lib($meta)){$version=$self->core_version_for($mod);return 0,undef if$version && $version==-1}$self->{local_versions}{$mod}=$version;if ($self->is_deprecated($meta)){return 0,$version}elsif ($self->satisfy_version($mod,$version,$want_ver)){return 1,($version || 'undef')}else {return 0,$version}}sub satisfy_version {my($self,$mod,$version,$want_ver)=@_;$want_ver='0' unless defined($want_ver)&& length($want_ver);require CPAN::Meta::Requirements;my$requirements=CPAN::Meta::Requirements->new;$requirements->add_string_requirement($mod,$want_ver);$requirements->accepts_module($mod,$version)}sub unsatisfy_how {my($self,$ver,$want_ver)=@_;if ($want_ver =~ /^[v0-9\.\_]+$/){return "$ver < $want_ver"}else {return "$ver doesn't satisfy $want_ver"}}sub is_deprecated {my($self,$meta)=@_;my$deprecated=eval {require Module::CoreList;Module::CoreList::is_deprecated($meta->{module})};return$deprecated && $self->loaded_from_perl_lib($meta)}sub loaded_from_perl_lib {my($self,$meta)=@_;require Config;my@dirs=qw(archlibexp privlibexp);if ($self->{self_contained}&&!$self->{exclude_vendor}&& $Config{vendorarch}){unshift@dirs,qw(vendorarch vendorlibexp)}for my$dir (@dirs){my$confdir=$Config{$dir};if ($confdir eq substr($meta->filename,0,length($confdir))){return 1}}return}sub should_install {my($self,$mod,$ver)=@_;$self->chat("Checking if you have $mod $ver ... ");my($ok,$local)=$self->check_module($mod,$ver);if ($ok){$self->chat("Yes ($local)\n")}elsif ($local){$self->chat("No (" .$self->unsatisfy_how($local,$ver).")\n")}else {$self->chat("No\n")}return$mod unless$ok;return}sub check_perl_version {my($self,$version)=@_;require CPAN::Meta::Requirements;my$req=CPAN::Meta::Requirements->from_string_hash({perl=>$version });$req->accepts_module(perl=>$])}sub install_deps {my($self,$dir,$depth,@deps)=@_;my(@install,%seen,@fail);for my$dep (@deps){next if$seen{$dep->module};if ($dep->module eq 'perl'){if ($dep->is_requirement &&!$self->check_perl_version($dep->version)){$self->diag("Needs perl @{[$dep->version]}, you have $]\n");push@fail,'perl'}}elsif ($self->should_install($dep->module,$dep->version)){push@install,$dep;$seen{$dep->module}=1}}if (@install){$self->diag("==> Found dependencies: " .join(", ",map $_->module,@install)."\n")}for my$dep (@install){$self->install_module($dep->module,$depth + 1,$dep->version)}$self->chdir($self->{base});$self->chdir($dir)if$dir;if ($self->{scandeps}){return 1}my@not_ok=$self->unsatisfied_deps(@deps);if (@not_ok){return 0,\@not_ok}else {return 1}}sub unsatisfied_deps {my($self,@deps)=@_;require CPAN::Meta::Check;require CPAN::Meta::Requirements;my$reqs=CPAN::Meta::Requirements->new;for my$dep (grep $_->is_requirement,@deps){$reqs->add_string_requirement($dep->module=>$dep->requires_version || '0')}my$ret=CPAN::Meta::Check::check_requirements($reqs,'requires',$self->{search_inc});grep defined,values %$ret}sub install_deps_bailout {my($self,$target,$dir,$depth,@deps)=@_;my($ok,$fail)=$self->install_deps($dir,$depth,@deps);if (!$ok){$self->diag_fail("Installing the dependencies failed: " .join(", ",@$fail),1);unless ($self->prompt_bool("Do you want to continue building $target anyway?","n")){$self->diag_fail("Bailing out the installation for $target.",1);return}}return 1}sub build_stuff {my($self,$stuff,$dist,$depth)=@_;if ($self->{verify}&& -e 'SIGNATURE'){$self->verify_signature($dist)or return}require CPAN::Meta;my($meta_file)=grep -f,qw(META.json META.yml);if ($meta_file){$self->chat("Checking configure dependencies from $meta_file\n");$dist->{cpanmeta}=eval {CPAN::Meta->load_file($meta_file)}}elsif ($dist->{dist}&& $dist->{version}){$self->chat("META.yml/json not found. Creating skeleton for it.\n");$dist->{cpanmeta}=CPAN::Meta->new({name=>$dist->{dist},version=>$dist->{version}})}$dist->{meta}=$dist->{cpanmeta}? $dist->{cpanmeta}->as_struct : {};my@config_deps;if ($dist->{cpanmeta}){push@config_deps,App::cpanminus::Dependency->from_prereqs($dist->{cpanmeta}->effective_prereqs,['configure'],$self->{install_types},)}if (-e 'Build.PL' &&!$self->should_use_mm($dist->{dist})&&!@config_deps){push@config_deps,App::cpanminus::Dependency->from_versions({'Module::Build'=>'0.38' },'configure',)}$self->merge_with_cpanfile($dist,\@config_deps);$self->upgrade_toolchain(\@config_deps);my$target=$dist->{meta}{name}? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};{$self->install_deps_bailout($target,$dist->{dir},$depth,@config_deps)or return}$self->diag_progress("Configuring $target");my$configure_state=$self->configure_this($dist,$depth);$self->diag_ok($configure_state->{configured_ok}? "OK" : "N/A");if ($dist->{cpanmeta}&& $dist->{source}eq 'cpan'){$dist->{provides}=$dist->{cpanmeta}{provides}|| $self->extract_packages($dist->{cpanmeta},".")}my$root_target=(($self->{installdeps}or $self->{showdeps})and $depth==0);$dist->{want_phases}=$self->{notest}&&!$root_target ? [qw(build runtime)]: [qw(build test runtime)];push @{$dist->{want_phases}},'develop' if$self->{with_develop}&& $depth==0;push @{$dist->{want_phases}},'configure' if$self->{with_configure}&& $depth==0;my@deps=$self->find_prereqs($dist);my$module_name=$self->find_module_name($configure_state)|| $dist->{meta}{name};$module_name =~ s/-/::/g;if ($self->{showdeps}){for my$dep (@config_deps,@deps){print$dep->module,($dep->version ? ("~".$dep->version): ""),"\n"}return 1}my$distname=$dist->{meta}{name}? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;my$walkup;if ($self->{scandeps}){$walkup=$self->scandeps_append_child($dist)}$self->install_deps_bailout($distname,$dist->{dir},$depth,@deps)or return;if ($self->{scandeps}){unless ($configure_state->{configured_ok}){my$diag=<{scandeps_tree}};$diag .= "!\n" .join("",map "! * $_->[0]{module}\n",@tree[0..$#tree-1])if@tree}$self->diag("!\n$diag!\n",1)}$walkup->();return 1}if ($self->{installdeps}&& $depth==0){if ($configure_state->{configured_ok}){$self->diag("<== Installed dependencies for $stuff. Finishing.\n");return 1}else {$self->diag("! Configuring $distname failed. See $self->{log} for details.\n",1);return}}my$installed;if ($configure_state->{use_module_build}&& -e 'Build' && -f _){$self->diag_progress("Building " .($self->{notest}? "" : "and testing ").$distname);$self->build([$self->{perl},"./Build" ],$distname,$depth)&& $self->test([$self->{perl},"./Build","test" ],$distname,$depth)&& $self->install([$self->{perl},"./Build","install" ],["--uninst",1 ],$depth)&& $installed++}elsif ($self->{make}&& -e 'Makefile'){$self->diag_progress("Building " .($self->{notest}? "" : "and testing ").$distname);$self->build([$self->{make}],$distname,$depth)&& $self->test([$self->{make},"test" ],$distname,$depth)&& $self->install([$self->{make},"install" ],["UNINST=1" ],$depth)&& $installed++}else {my$why;my$configure_failed=$configure_state->{configured}&&!$configure_state->{configured_ok};if ($configure_failed){$why="Configure failed for $distname."}elsif ($self->{make}){$why="The distribution doesn't have a proper Makefile.PL/Build.PL"}else {$why="Can't configure the distribution. You probably need to have 'make'."}$self->diag_fail("$why See $self->{log} for details.",1);return}if ($installed && $self->{test_only}){$self->diag_ok;$self->diag("Successfully tested $distname\n",1)}elsif ($installed){my$local=$self->{local_versions}{$dist->{module}|| ''};my$version=$dist->{module_version}|| $dist->{meta}{version}|| $dist->{version};my$reinstall=$local && ($local eq $version);my$action=$local &&!$reinstall ? $self->numify_ver($version)< $self->numify_ver($local)? "downgraded" : "upgraded" : undef;my$how=$reinstall ? "reinstalled $distname" : $local ? "installed $distname ($action from $local)" : "installed $distname" ;my$msg="Successfully $how";$self->diag_ok;$self->diag("$msg\n",1);$self->{installed_dists}++;$self->save_meta($stuff,$dist,$module_name,\@config_deps,\@deps);return 1}else {my$what=$self->{test_only}? "Testing" : "Installing";$self->diag_fail("$what $stuff failed. See $self->{log} for details. Retry with --force to force install it.",1);return}}sub perl_requirements {my($self,@requires)=@_;my@perl;for my$requires (grep defined,@requires){if (exists$requires->{perl}){push@perl,App::cpanminus::Dependency->new(perl=>$requires->{perl})}}return@perl}sub should_use_mm {my($self,$dist)=@_;my%should_use_mm=map {$_=>1}qw(version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest);$should_use_mm{$dist}}sub configure_this {my($self,$dist,$depth)=@_;if (-e $self->{cpanfile_path}&& $self->{installdeps}&& $depth==0){require Module::CPANfile;$dist->{cpanfile}=eval {Module::CPANfile->load($self->{cpanfile_path})};$self->diag_fail($@,1)if $@;return {configured=>1,configured_ok=>!!$dist->{cpanfile},use_module_build=>0,}}if ($self->{skip_configure}){my$eumm=-e 'Makefile';my$mb=-e 'Build' && -f _;return {configured=>1,configured_ok=>$eumm || $mb,use_module_build=>$mb,}}my$state={};my$try_eumm=sub {if (-e 'Makefile.PL'){$self->chat("Running Makefile.PL\n");if ($self->configure([$self->{perl},"Makefile.PL" ],$depth)){$state->{configured_ok}=-e 'Makefile'}$state->{configured}++}};my$try_mb=sub {if (-e 'Build.PL'){$self->chat("Running Build.PL\n");if ($self->configure([$self->{perl},"Build.PL" ],$depth)){$state->{configured_ok}=-e 'Build' && -f _}$state->{use_module_build}++;$state->{configured}++}};my@try;if ($dist->{dist}&& $self->should_use_mm($dist->{dist})){@try=($try_eumm,$try_mb)}else {@try=($try_mb,$try_eumm)}for my$try (@try){$try->();last if$state->{configured_ok}}unless ($state->{configured_ok}){while (1){my$ans=lc$self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?","s");last if$ans eq 's';return$self->configure_this($dist,$depth)if$ans eq 'r';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}return$state}sub find_module_name {my($self,$state)=@_;return unless$state->{configured_ok};if ($state->{use_module_build}&& -e "_build/build_params"){my$params=do {open my$in,"_build/build_params";$self->safe_eval(join "",<$in>)};return eval {$params->[2]{module_name}}|| undef}elsif (-e "Makefile"){open my$mf,"Makefile";while (<$mf>){if (/^\#\s+NAME\s+=>\s+(.*)/){return$self->safe_eval($1)}}}return}sub list_files {my$self=shift;if (-e 'MANIFEST'){require ExtUtils::Manifest;my$manifest=eval {ExtUtils::Manifest::manifind()}|| {};return sort {lc$a cmp lc$b}keys %$manifest}else {require File::Find;my@files;my$finder=sub {my$name=$File::Find::name;$name =~ s!\.[/\\]!!;push@files,$name};File::Find::find($finder,".");return sort {lc$a cmp lc$b}@files}}sub extract_packages {my($self,$meta,$dir)=@_;my$try=sub {my$file=shift;return 0 if$file =~ m!^(?:x?t|inc|local|perl5|fatlib|_build)/!;return 1 unless$meta->{no_index};return 0 if grep {$file =~ m!^$_/!}@{$meta->{no_index}{directory}|| []};return 0 if grep {$file eq $_}@{$meta->{no_index}{file}|| []};return 1};require Parse::PMFile;my@files=grep {/\.pm(?:\.PL)?$/ && $try->($_)}$self->list_files;my$provides={};for my$file (@files){my$parser=Parse::PMFile->new($meta,{UNSAFE=>1,ALLOW_DEV_VERSION=>1 });my$packages=$parser->parse($file);while (my($package,$meta)=each %$packages){$provides->{$package}||= {file=>$meta->{infile},($meta->{version}eq 'undef')? (): (version=>$meta->{version}),}}}return$provides}sub save_meta {my($self,$module,$dist,$module_name,$config_deps,$build_deps)=@_;return unless$dist->{distvname}&& $dist->{source}eq 'cpan';my$base=($ENV{PERL_MM_OPT}|| '')=~ /INSTALL_BASE=/ ? ($self->install_base($ENV{PERL_MM_OPT})."/lib/perl5"): $Config{sitelibexp};my$provides=$dist->{provides};File::Path::mkpath("blib/meta",0,0777);my$local={name=>$module_name,target=>$module,version=>exists$provides->{$module_name}? ($provides->{$module_name}{version}|| $dist->{version}): $dist->{version},dist=>$dist->{distvname},pathname=>$dist->{pathname},provides=>$provides,};require JSON::PP;open my$fh,">","blib/meta/install.json" or die $!;print$fh JSON::PP::encode_json($local);if (-e "MYMETA.json"){File::Copy::copy("MYMETA.json","blib/meta/MYMETA.json")}my@cmd=(($self->{sudo}? 'sudo' : ()),$^X,'-MExtUtils::Install=install','-e',qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],);$self->run(\@cmd)}sub _merge_hashref {my($self,@hashrefs)=@_;my%hash;for my$h (@hashrefs){%hash=(%hash,%$h)}return \%hash}sub install_base {my($self,$mm_opt)=@_;$mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;die "Your PERL_MM_OPT doesn't contain INSTALL_BASE"}sub safe_eval {my($self,$code)=@_;eval$code}sub configure_features {my($self,$dist,@features)=@_;map $_->identifier,grep {$self->effective_feature($dist,$_)}@features}sub effective_feature {my($self,$dist,$feature)=@_;if ($dist->{depth}==0){my$value=$self->{features}{$feature->identifier};return$value if defined$value;return 1 if$self->{features}{__all}}if ($self->{interactive}){require CPAN::Meta::Requirements;$self->diag("[@{[ $feature->description ]}]\n",1);my$req=CPAN::Meta::Requirements->new;for my$phase (@{$dist->{want_phases}}){for my$type (@{$self->{install_types}}){$req->add_requirements($feature->prereqs->requirements_for($phase,$type))}}my$reqs=$req->as_string_hash;my@missing;for my$module (keys %$reqs){if ($self->should_install($module,$req->{$module})){push@missing,$module}}if (@missing){my$howmany=@missing;$self->diag("==> Found missing dependencies: " .join(", ",@missing)."\n",1);local$self->{prompt}=1;return$self->prompt_bool("Install the $howmany optional module(s)?","y")}}return}sub find_prereqs {my($self,$dist)=@_;my@deps=$self->extract_meta_prereqs($dist);if ($dist->{module}=~ /^Bundle::/i){push@deps,$self->bundle_deps($dist)}$self->merge_with_cpanfile($dist,\@deps);return@deps}sub merge_with_cpanfile {my($self,$dist,$deps)=@_;if ($self->{cpanfile_requirements}&&!$dist->{cpanfile}){for my$dep (@$deps){$dep->merge_with($self->{cpanfile_requirements})}}}sub extract_meta_prereqs {my($self,$dist)=@_;if ($dist->{cpanfile}){my@features=$self->configure_features($dist,$dist->{cpanfile}->features);my$prereqs=$dist->{cpanfile}->prereqs_with(@features);$self->{cpanfile_requirements}=$prereqs->merged_requirements($dist->{want_phases},['requires']);return App::cpanminus::Dependency->from_prereqs($prereqs,$dist->{want_phases},$self->{install_types})}require CPAN::Meta;my@deps;my($meta_file)=grep -f,qw(MYMETA.json MYMETA.yml);if ($meta_file){$self->chat("Checking dependencies from $meta_file ...\n");my$mymeta=eval {CPAN::Meta->load_file($meta_file,{lazy_validation=>1 })};if ($mymeta){$dist->{meta}{name}=$mymeta->name;$dist->{meta}{version}=$mymeta->version;return$self->extract_prereqs($mymeta,$dist)}}if (-e '_build/prereqs'){$self->chat("Checking dependencies from _build/prereqs ...\n");my$prereqs=do {open my$in,"_build/prereqs";$self->safe_eval(join "",<$in>)};my$meta=CPAN::Meta->new({name=>$dist->{meta}{name},version=>$dist->{meta}{version},%$prereqs },{lazy_validation=>1 },);@deps=$self->extract_prereqs($meta,$dist)}elsif (-e 'Makefile'){$self->chat("Finding PREREQ from Makefile ...\n");open my$mf,"Makefile";while (<$mf>){if (/^\#\s+PREREQ_PM => \{\s*(.*?)\s*\}/){my@all;my@pairs=split ', ',$1;for (@pairs){my ($pkg,$v)=split '=>',$_;push@all,[$pkg,$v ]}my$list=join ", ",map {"'$_->[0]' => $_->[1]"}@all;my$prereq=$self->safe_eval("no strict; +{ $list }");push@deps,App::cpanminus::Dependency->from_versions($prereq)if$prereq;last}}}return@deps}sub bundle_deps {my($self,$dist)=@_;my$match;if ($dist->{module}){$match=sub {my$meta=Module::Metadata->new_from_file($_[0]);$meta && ($meta->name eq $dist->{module})}}else {$match=sub {1}}my@files;File::Find::find({wanted=>sub {push@files,File::Spec->rel2abs($_)if /\.pm$/i && $match->($_)},no_chdir=>1,},'.');my@deps;for my$file (@files){open my$pod,"<",$file or next;my$in_contents;while (<$pod>){if (/^=head\d\s+CONTENTS/){$in_contents=1}elsif (/^=/){$in_contents=0}elsif ($in_contents){/^(\S+)\s*(\S+)?/ and push@deps,App::cpanminus::Dependency->new($1,$self->maybe_version($2))}}}return@deps}sub maybe_version {my($self,$string)=@_;return$string && $string =~ /^\.?\d/ ? $string : undef}sub extract_prereqs {my($self,$meta,$dist)=@_;my@features=$self->configure_features($dist,$meta->features);my$prereqs=$self->soften_makemaker_prereqs($meta->effective_prereqs(\@features)->clone);return App::cpanminus::Dependency->from_prereqs($prereqs,$dist->{want_phases},$self->{install_types})}sub soften_makemaker_prereqs {my($self,$prereqs)=@_;return$prereqs unless -e "inc/Module/Install.pm";for my$phase (qw(build test runtime)){my$reqs=$prereqs->requirements_for($phase,'requires');if ($reqs->requirements_for_module('ExtUtils::MakeMaker')){$reqs->clear_requirement('ExtUtils::MakeMaker');$reqs->add_minimum('ExtUtils::MakeMaker'=>0)}}$prereqs}sub cleanup_workdirs {my$self=shift;my$expire=time - 24 * 60 * 60 * $self->{auto_cleanup};my@targets;opendir my$dh,"$self->{home}/work";while (my$e=readdir$dh){next if$e !~ /^(\d+)\.\d+$/;my$time=$1;if ($time < $expire){push@targets,"$self->{home}/work/$e"}}if (@targets){if (@targets >= 64){$self->diag("Expiring " .scalar(@targets)." work directories. This might take a while...\n")}else {$self->chat("Expiring " .scalar(@targets)." work directories.\n")}File::Path::rmtree(\@targets,0,0)}}sub scandeps_append_child {my($self,$dist)=@_;my$new_node=[$dist,[]];my$curr_node=$self->{scandeps_current}|| [undef,$self->{scandeps_tree}];push @{$curr_node->[1]},$new_node;$self->{scandeps_current}=$new_node;return sub {$self->{scandeps_current}=$curr_node}}sub dump_scandeps {my$self=shift;if ($self->{format}eq 'tree'){$self->walk_down(sub {my($dist,$depth)=@_;if ($depth==0){print "$dist->{distvname}\n"}else {print " " x ($depth - 1);print "\\_ $dist->{distvname}\n"}},1)}elsif ($self->{format}=~ /^dists?$/){$self->walk_down(sub {my($dist,$depth)=@_;print$self->format_dist($dist),"\n"},0)}elsif ($self->{format}eq 'json'){require JSON::PP;print JSON::PP::encode_json($self->{scandeps_tree})}elsif ($self->{format}eq 'yaml'){require YAML;print YAML::Dump($self->{scandeps_tree})}else {$self->diag("Unknown format: $self->{format}\n")}}sub walk_down {my($self,$cb,$pre)=@_;$self->_do_walk_down($self->{scandeps_tree},$cb,0,$pre)}sub _do_walk_down {my($self,$children,$cb,$depth,$pre)=@_;for my$node (@$children){$cb->($node->[0],$depth)if$pre;$self->_do_walk_down($node->[1],$cb,$depth + 1,$pre);$cb->($node->[0],$depth)unless$pre}}sub DESTROY {my$self=shift;$self->{at_exit}->($self)if$self->{at_exit}}sub shell_quote {my($self,@stuff)=@_;if (WIN32){join ' ',map {/^${quote}.+${quote}$/ ? $_ : ($quote .$_ .$quote)}@stuff}else {String::ShellQuote::shell_quote_best_effort(@stuff)}}sub which {my($self,$name)=@_;if (File::Spec->file_name_is_absolute($name)){if (-x $name &&!-d _){return$name}}my$exe_ext=$Config{_exe};for my$dir (File::Spec->path){my$fullpath=File::Spec->catfile($dir,$name);if ((-x $fullpath || -x ($fullpath .= $exe_ext))&&!-d _){if ($fullpath =~ /\s/){$fullpath=$self->shell_quote($fullpath)}return$fullpath}}return}sub get {my($self,$uri)=@_;if ($uri =~ /^file:/){$self->file_get($uri)}else {$self->{_backends}{get}->(@_)}}sub mirror {my($self,$uri,$local)=@_;if ($uri =~ /^file:/){$self->file_mirror($uri,$local)}else {$self->{_backends}{mirror}->(@_)}}sub untar {$_[0]->{_backends}{untar}->(@_)};sub unzip {$_[0]->{_backends}{unzip}->(@_)};sub uri_to_file {my($self,$uri)=@_;if ($uri =~ s!file:/+!!){$uri="/$uri" unless$uri =~ m![a-zA-Z]:!}return$uri}sub file_get {my($self,$uri)=@_;my$file=$self->uri_to_file($uri);open my$fh,"<$file" or return;join '',<$fh>}sub file_mirror {my($self,$uri,$path)=@_;my$file=$self->uri_to_file($uri);my$source_mtime=(stat$file)[9];return 1 if -e $path && (stat$path)[9]>= $source_mtime;File::Copy::copy($file,$path);utime$source_mtime,$source_mtime,$path}sub has_working_lwp {my($self,$mirrors)=@_;my$https=grep /^https:/,@$mirrors;eval {require LWP::UserAgent;LWP::UserAgent->VERSION(5.802);require LWP::Protocol::https if$https;1}}sub init_tools {my$self=shift;return if$self->{initialized}++;if ($self->{make}=$self->which($Config{make})){$self->chat("You have make $self->{make}\n")}if ($self->{try_lwp}&& $self->has_working_lwp($self->{mirrors})){$self->chat("You have LWP $LWP::VERSION\n");my$ua=sub {LWP::UserAgent->new(parse_head=>0,env_proxy=>1,agent=>$self->agent,timeout=>30,@_,)};$self->{_backends}{get}=sub {my$self=shift;my$res=$ua->()->request(HTTP::Request->new(GET=>$_[0]));return unless$res->is_success;return$res->decoded_content};$self->{_backends}{mirror}=sub {my$self=shift;my$res=$ua->()->mirror(@_);die$res->content if$res->code==501;$res->code}}elsif ($self->{try_wget}and my$wget=$self->which('wget')){$self->chat("You have $wget\n");my@common=('--user-agent',$self->agent,'--retry-connrefused',($self->{verbose}? (): ('-q')),);$self->{_backends}{get}=sub {my($self,$uri)=@_;$self->safeexec(my$fh,$wget,$uri,@common,'-O','-')or die "wget $uri: $!";local $/;<$fh>};$self->{_backends}{mirror}=sub {my($self,$uri,$path)=@_;$self->safeexec(my$fh,$wget,$uri,@common,'-O',$path)or die "wget $uri: $!";local $/;<$fh>}}elsif ($self->{try_curl}and my$curl=$self->which('curl')){$self->chat("You have $curl\n");my@common=('--location','--user-agent',$self->agent,($self->{verbose}? (): '-s'),);$self->{_backends}{get}=sub {my($self,$uri)=@_;$self->safeexec(my$fh,$curl,@common,$uri)or die "curl $uri: $!";local $/;<$fh>};$self->{_backends}{mirror}=sub {my($self,$uri,$path)=@_;$self->safeexec(my$fh,$curl,@common,$uri,'-#','-o',$path)or die "curl $uri: $!";local $/;<$fh>}}else {require HTTP::Tiny;$self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");my%common=(agent=>$self->agent,);$self->{_backends}{get}=sub {my$self=shift;my$res=HTTP::Tiny->new(%common)->get($_[0]);return unless$res->{success};return$res->{content}};$self->{_backends}{mirror}=sub {my$self=shift;my$res=HTTP::Tiny->new(%common)->mirror(@_);return$res->{status}}}my$tar=$self->which('tar');my$tar_ver;my$maybe_bad_tar=sub {WIN32 || BAD_TAR || (($tar_ver=`$tar --version 2>/dev/null`)=~ /GNU.*1\.13/i)};if ($tar &&!$maybe_bad_tar->()){chomp$tar_ver;$self->chat("You have $tar: $tar_ver\n");$self->{_backends}{untar}=sub {my($self,$tarfile)=@_;my$xf=($self->{verbose}? 'v' : '')."xf";my$ar=$tarfile =~ /bz2$/ ? 'j' : 'z';my($root,@others)=`$tar ${ar}tf $tarfile` or return undef;FILE: {chomp$root;$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}system "$tar $ar$xf $tarfile";return$root if -d $root;$self->diag_fail("Bad archive: $tarfile");return undef}}elsif ($tar and my$gzip=$self->which('gzip')and my$bzip2=$self->which('bzip2')){$self->chat("You have $tar, $gzip and $bzip2\n");$self->{_backends}{untar}=sub {my($self,$tarfile)=@_;my$x="x" .($self->{verbose}? 'v' : '')."f -";my$ar=$tarfile =~ /bz2$/ ? $bzip2 : $gzip;my($root,@others)=`$ar -dc $tarfile | $tar tf -` or return undef;FILE: {chomp$root;$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}system "$ar -dc $tarfile | $tar $x";return$root if -d $root;$self->diag_fail("Bad archive: $tarfile");return undef}}elsif (eval {require Archive::Tar}){$self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");$self->{_backends}{untar}=sub {my$self=shift;my$t=Archive::Tar->new($_[0]);my($root,@others)=$t->list_files;FILE: {$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}$t->extract;return -d $root ? $root : undef}}else {$self->{_backends}{untar}=sub {die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n"}}if (my$unzip=$self->which('unzip')){$self->chat("You have $unzip\n");$self->{_backends}{unzip}=sub {my($self,$zipfile)=@_;my$opt=$self->{verbose}? '' : '-q';my(undef,$root,@others)=`$unzip -t $zipfile` or return undef;FILE: {chomp$root;if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}){$root=shift(@others);redo FILE if$root}}system "$unzip $opt $zipfile";return$root if -d $root;$self->diag_fail("Bad archive: [$root] $zipfile");return undef}}else {$self->{_backends}{unzip}=sub {eval {require Archive::Zip}or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";my($self,$file)=@_;my$zip=Archive::Zip->new();my$status;$status=$zip->read($file);$self->diag_fail("Read of file[$file] failed")if$status!=Archive::Zip::AZ_OK();my@members=$zip->members();for my$member (@members){my$af=$member->fileName();next if ($af =~ m!^(/|\.\./)!);$status=$member->extractToFileNamed($af);$self->diag_fail("Extracting of file[$af] from zipfile[$file failed")if$status!=Archive::Zip::AZ_OK()}my ($root)=$zip->membersMatching(qr<^[^/]+/$>);$root &&= $root->fileName;return -d $root ? $root : undef}}}sub safeexec {my$self=shift;my$rdr=$_[0]||= Symbol::gensym();if (WIN32){my$cmd=$self->shell_quote(@_[1..$#_]);return open($rdr,"$cmd |")}if (my$pid=open($rdr,'-|')){return$pid}elsif (defined$pid){exec(@_[1 .. $#_ ]);exit 1}else {return}}sub mask_uri_passwords {my($self,@strings)=@_;s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:********@}gx for@strings;return@strings}1; - It appears your cpanm executable was installed via `perlbrew install-cpanm`. - cpanm --self-upgrade won't upgrade the version of cpanm you're running. - - Run the following command to get it upgraded. - - perlbrew install-cpanm - - DIE - You are running cpanm from the path where your current perl won't install executables to. - Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running. - - cpanm path : $0 - Install path : $Config{installsitebin} - - It means you either installed cpanm globally with system perl, or use distro packages such - as rpm or apt-get, and you have to use them again to upgrade cpanm. - DIE - Usage: cpanm [options] Module [...] - - Try `cpanm --help` or `man cpanm` for more options. - USAGE - Usage: cpanm [options] Module [...] - - Options: - -v,--verbose Turns on chatty output - -q,--quiet Turns off the most output - --interactive Turns on interactive configure (required for Task:: modules) - -f,--force force install - -n,--notest Do not run unit tests - --test-only Run tests only, do not install - -S,--sudo sudo to run install commands - --installdeps Only install dependencies - --showdeps Only display direct dependencies - --reinstall Reinstall the distribution even if you already have the latest version installed - --mirror Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/) - --mirror-only Use the mirror's index file instead of the CPAN Meta DB - -M,--from Use only this mirror base URL and its index file - --prompt Prompt when configure/build/test fails - -l,--local-lib Specify the install base to install modules - -L,--local-lib-contained Specify the install base to install all non-core modules - --self-contained Install all non-core modules, even if they're already installed. - --auto-cleanup Number of days that cpanm's work directories expire in. Defaults to 7 - - Commands: - --self-upgrade upgrades itself - --info Displays distribution info on CPAN - --look Opens the distribution with your SHELL - -U,--uninstall Uninstalls the modules (EXPERIMENTAL) - -V,--version Displays software version - - Examples: - - cpanm Test::More # install Test::More - cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path - cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL - cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file - cpanm --interactive Task::Kensho # Configure interactively - cpanm . # install from local directory - cpanm --installdeps . # install all the deps for the current directory - cpanm -L extlib Plack # install Plack and all non-core deps into extlib - cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror - cpanm -M https://cpan.metacpan.org App::perlbrew # use only this secure mirror and its index - - You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc: - - export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org" - - Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options. - - HELP - ! - ! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5 - ! To turn off this warning, you have to do one of the following: - ! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin}) - ! - Configure local::lib in your existing shell to set PERL_MM_OPT etc. - ! - Install local::lib by running the following commands - ! - ! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib) - ! - DIAG - WARNING: Your lib directory name ($base) contains a space in it. It's known to cause issues with perl builder tools such as local::lib and MakeMaker. You're recommended to rename your directory. - WARN - $module is not found in the following directories and can't be uninstalled. - - @{[ join(" \n", map " $_", @inc) ]} - - DIAG - package ModuleBuildSkipMan; - CHECK { - if (%Module::Build::) { - no warnings 'redefine'; - *Module::Build::Base::ACTION_manpages = sub {}; - *Module::Build::Base::ACTION_docs = sub {}; - } - } - 1; - EOF - ! Configuring $distname failed. See $self->{log} for details. - ! You might have to install the following modules first to get --scandeps working correctly. - DIAG -APP_CPANMINUS_SCRIPT - -$fatpacked{"CPAN/DistnameInfo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_DISTNAMEINFO'; - package CPAN::DistnameInfo;$VERSION="0.12";use strict;sub distname_info {my$file=shift or return;my ($dist,$version)=$file =~ /^ - ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))* - (?: - [A-Za-z](?=[^A-Za-z]|$) - | - \d(?=-) - )(? 6 and $1 & 1)or ($2 and $2 >= 50))or $3}elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/){$dev=1}}else {$version=undef}($dist,$version,$dev)}sub new {my$class=shift;my$distfile=shift;$distfile =~ s,//+,/,g;my%info=(pathname=>$distfile);($info{filename}=$distfile)=~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,, and $info{cpanid}=$6;if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i){$info{distvname}=$1;$info{extension}=$2}@info{qw(dist version beta)}=distname_info($info{distvname});$info{maturity}=delete$info{beta}? 'developer' : 'released';return bless \%info,$class}sub dist {shift->{dist}}sub version {shift->{version}}sub maturity {shift->{maturity}}sub filename {shift->{filename}}sub cpanid {shift->{cpanid}}sub distvname {shift->{distvname}}sub extension {shift->{extension}}sub pathname {shift->{pathname}}sub properties {%{$_[0]}}1; -CPAN_DISTNAMEINFO - -$fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META'; - use 5.006;use strict;use warnings;package CPAN::Meta;our$VERSION='2.150005';use Carp qw(carp croak);use CPAN::Meta::Feature;use CPAN::Meta::Prereqs;use CPAN::Meta::Converter;use CPAN::Meta::Validator;use Parse::CPAN::Meta 1.4414 ();BEGIN {*_dclone=\&CPAN::Meta::Converter::_dclone}BEGIN {my@STRING_READERS=qw(abstract description dynamic_config generated_by name release_status version);no strict 'refs';for my$attr (@STRING_READERS){*$attr=sub {$_[0]{$attr }}}}BEGIN {my@LIST_READERS=qw(author keywords license);no strict 'refs';for my$attr (@LIST_READERS){*$attr=sub {my$value=$_[0]{$attr };croak "$attr must be called in list context" unless wantarray;return @{_dclone($value)}if ref$value;return$value}}}sub authors {$_[0]->author}sub licenses {$_[0]->license}BEGIN {my@MAP_READERS=qw(meta-spec resources provides no_index prereqs optional_features);no strict 'refs';for my$attr (@MAP_READERS){(my$subname=$attr)=~ s/-/_/;*$subname=sub {my$value=$_[0]{$attr };return _dclone($value)if$value;return {}}}}sub custom_keys {return grep {/^x_/i}keys %{$_[0]}}sub custom {my ($self,$attr)=@_;my$value=$self->{$attr};return _dclone($value)if ref$value;return$value}sub _new {my ($class,$struct,$options)=@_;my$self;if ($options->{lazy_validation}){my$cmc=CPAN::Meta::Converter->new($struct);$self=$cmc->convert(version=>2);return bless$self,$class}else {my$cmv=CPAN::Meta::Validator->new($struct);unless ($cmv->is_valid){die "Invalid metadata structure. Errors: " .join(", ",$cmv->errors)."\n"}}my$version=$struct->{'meta-spec'}{version}|| '1.0';if ($version==2){$self=$struct}else {my$cmc=CPAN::Meta::Converter->new($struct);$self=$cmc->convert(version=>2)}return bless$self,$class}sub new {my ($class,$struct,$options)=@_;my$self=eval {$class->_new($struct,$options)};croak($@)if $@;return$self}sub create {my ($class,$struct,$options)=@_;my$version=__PACKAGE__->VERSION || 2;$struct->{generated_by}||= __PACKAGE__ ." version $version" ;$struct->{'meta-spec'}{version}||= int($version);my$self=eval {$class->_new($struct,$options)};croak ($@)if $@;return$self}sub load_file {my ($class,$file,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};croak "load_file() requires a valid, readable filename" unless -r $file;my$self;eval {my$struct=Parse::CPAN::Meta->load_file($file);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_yaml_string {my ($class,$yaml,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my ($struct)=Parse::CPAN::Meta->load_yaml_string($yaml);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_json_string {my ($class,$json,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my$struct=Parse::CPAN::Meta->load_json_string($json);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_string {my ($class,$string,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my$struct=Parse::CPAN::Meta->load_string($string);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub save {my ($self,$file,$options)=@_;my$version=$options->{version}|| '2';my$layer=$] ge '5.008001' ? ':utf8' : '';if ($version ge '2'){carp "'$file' should end in '.json'" unless$file =~ m{\.json$}}else {carp "'$file' should end in '.yml'" unless$file =~ m{\.yml$}}my$data=$self->as_string($options);open my$fh,">$layer",$file or die "Error opening '$file' for writing: $!\n";print {$fh}$data;close$fh or die "Error closing '$file': $!\n";return 1}sub meta_spec_version {my ($self)=@_;return$self->meta_spec->{version}}sub effective_prereqs {my ($self,$features)=@_;$features ||= [];my$prereq=CPAN::Meta::Prereqs->new($self->prereqs);return$prereq unless @$features;my@other=map {;$self->feature($_)->prereqs}@$features;return$prereq->with_merged_prereqs(\@other)}sub should_index_file {my ($self,$filename)=@_;for my$no_index_file (@{$self->no_index->{file}|| []}){return if$filename eq $no_index_file}for my$no_index_dir (@{$self->no_index->{directory}}){$no_index_dir =~ s{$}{/} unless$no_index_dir =~ m{/\z};return if index($filename,$no_index_dir)==0}return 1}sub should_index_package {my ($self,$package)=@_;for my$no_index_pkg (@{$self->no_index->{package}|| []}){return if$package eq $no_index_pkg}for my$no_index_ns (@{$self->no_index->{namespace}}){return if index($package,"${no_index_ns}::")==0}return 1}sub features {my ($self)=@_;my$opt_f=$self->optional_features;my@features=map {;CPAN::Meta::Feature->new($_=>$opt_f->{$_ })}keys %$opt_f;return@features}sub feature {my ($self,$ident)=@_;croak "no feature named $ident" unless my$f=$self->optional_features->{$ident };return CPAN::Meta::Feature->new($ident,$f)}sub as_struct {my ($self,$options)=@_;my$struct=_dclone($self);if ($options->{version}){my$cmc=CPAN::Meta::Converter->new($struct);$struct=$cmc->convert(version=>$options->{version})}return$struct}sub as_string {my ($self,$options)=@_;my$version=$options->{version}|| '2';my$struct;if ($self->meta_spec_version ne $version){my$cmc=CPAN::Meta::Converter->new($self->as_struct);$struct=$cmc->convert(version=>$version)}else {$struct=$self->as_struct}my ($data,$backend);if ($version ge '2'){$backend=Parse::CPAN::Meta->json_backend();local$struct->{x_serialization_backend}=sprintf '%s version %s',$backend,$backend->VERSION;$data=$backend->new->pretty->canonical->encode($struct)}else {$backend=Parse::CPAN::Meta->yaml_backend();local$struct->{x_serialization_backend}=sprintf '%s version %s',$backend,$backend->VERSION;$data=eval {no strict 'refs';&{"$backend\::Dump"}($struct)};if ($@){croak$backend->can('errstr')? $backend->errstr : $@}}return$data}sub TO_JSON {return {%{$_[0]}}}1; -CPAN_META - -$fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK'; - package CPAN::Meta::Check;$CPAN::Meta::Check::VERSION='0.012';use strict;use warnings;use base 'Exporter';our@EXPORT=qw//;our@EXPORT_OK=qw/check_requirements requirements_for verify_dependencies/;our%EXPORT_TAGS=(all=>[@EXPORT,@EXPORT_OK ]);use CPAN::Meta::Prereqs '2.132830';use CPAN::Meta::Requirements 2.121;use Module::Metadata 1.000023;sub _check_dep {my ($reqs,$module,$dirs)=@_;$module eq 'perl' and return ($reqs->accepts_module($module,$])? (): sprintf "Your Perl (%s) is not in the range '%s'",$],$reqs->requirements_for_module($module));my$metadata=Module::Metadata->new_from_module($module,inc=>$dirs);return "Module '$module' is not installed" if not defined$metadata;my$version=eval {$metadata->version};return "Missing version info for module '$module'" if$reqs->requirements_for_module($module)and not $version;return sprintf 'Installed version (%s) of %s is not in range \'%s\'',$version,$module,$reqs->requirements_for_module($module)if not $reqs->accepts_module($module,$version || 0);return}sub _check_conflict {my ($reqs,$module,$dirs)=@_;my$metadata=Module::Metadata->new_from_module($module,inc=>$dirs);return if not defined$metadata;my$version=eval {$metadata->version};return "Missing version info for module '$module'" if not $version;return sprintf 'Installed version (%s) of %s is in range \'%s\'',$version,$module,$reqs->requirements_for_module($module)if$reqs->accepts_module($module,$version);return}sub requirements_for {my ($meta,$phases,$type)=@_;my$prereqs=ref($meta)eq 'CPAN::Meta' ? $meta->effective_prereqs : $meta;return$prereqs->merged_requirements(ref($phases)? $phases : [$phases ],[$type ])}sub check_requirements {my ($reqs,$type,$dirs)=@_;return +{map {$_=>$type ne 'conflicts' ? scalar _check_dep($reqs,$_,$dirs): scalar _check_conflict($reqs,$_,$dirs)}$reqs->required_modules }}sub verify_dependencies {my ($meta,$phases,$type,$dirs)=@_;my$reqs=requirements_for($meta,$phases,$type);my$issues=check_requirements($reqs,$type,$dirs);return grep {defined}values %{$issues}}1; -CPAN_META_CHECK - -$fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CONVERTER'; - use 5.006;use strict;use warnings;package CPAN::Meta::Converter;our$VERSION='2.150005';use CPAN::Meta::Validator;use CPAN::Meta::Requirements;use Parse::CPAN::Meta 1.4400 ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};sub _dclone {my$ref=shift;no warnings 'once';no warnings 'redefine';local*UNIVERSAL::TO_JSON=sub {"$_[0]"};my$json=Parse::CPAN::Meta->json_backend()->new ->utf8 ->allow_blessed ->convert_blessed;$json->decode($json->encode($ref))}my%known_specs=('2'=>'http://search.cpan.org/perldoc?CPAN::Meta::Spec','1.4'=>'http://module-build.sourceforge.net/META-spec-v1.4.html','1.3'=>'http://module-build.sourceforge.net/META-spec-v1.3.html','1.2'=>'http://module-build.sourceforge.net/META-spec-v1.2.html','1.1'=>'http://module-build.sourceforge.net/META-spec-v1.1.html','1.0'=>'http://module-build.sourceforge.net/META-spec-v1.0.html');my@spec_list=sort {$a <=> $b}keys%known_specs;my ($LOWEST,$HIGHEST)=@spec_list[0,-1];sub _keep {$_[0]}sub _keep_or_one {defined($_[0])? $_[0]: 1}sub _keep_or_zero {defined($_[0])? $_[0]: 0}sub _keep_or_unknown {defined($_[0])&& length($_[0])? $_[0]: "unknown"}sub _generated_by {my$gen=shift;my$sig=__PACKAGE__ ." version " .(__PACKAGE__->VERSION || "");return$sig unless defined$gen and length$gen;return$gen if$gen =~ /\Q$sig/;return "$gen, $sig"}sub _listify {!defined $_[0]? undef : ref $_[0]eq 'ARRAY' ? $_[0]: [$_[0]]}sub _prefix_custom {my$key=shift;$key =~ s/^(?!x_) # Unless it already starts with x_ - (?:x-?)? # Remove leading x- or x (if present) - /x_/ix;return$key}sub _ucfirst_custom {my$key=shift;$key=ucfirst$key unless$key =~ /[A-Z]/;return$key}sub _no_prefix_ucfirst_custom {my$key=shift;$key =~ s/^x_//;return _ucfirst_custom($key)}sub _change_meta_spec {my ($element,undef,undef,$version)=@_;return {version=>$version,url=>$known_specs{$version},}}my@open_source=('perl','gpl','apache','artistic','artistic_2','lgpl','bsd','gpl','mit','mozilla','open_source',);my%is_open_source=map {;$_=>1}@open_source;my@valid_licenses_1=(@open_source,'unrestricted','restrictive','unknown',);my%license_map_1=((map {$_=>$_}@valid_licenses_1),artistic2=>'artistic_2',);sub _license_1 {my ($element)=@_;return 'unknown' unless defined$element;if ($license_map_1{lc$element}){return$license_map_1{lc$element}}else {return 'unknown'}}my@valid_licenses_2=qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);my%license_map_2=((map {$_=>$_}@valid_licenses_2),apache=>'apache_2_0',artistic=>'artistic_1',artistic2=>'artistic_2',gpl=>'open_source',lgpl=>'open_source',mozilla=>'open_source',perl=>'perl_5',restrictive=>'restricted',);sub _license_2 {my ($element)=@_;return ['unknown' ]unless defined$element;$element=[$element ]unless ref$element eq 'ARRAY';my@new_list;for my$lic (@$element){next unless defined$lic;if (my$new=$license_map_2{lc$lic}){push@new_list,$new}}return@new_list ? \@new_list : ['unknown' ]}my%license_downgrade_map=qw(agpl_3 open_source apache_1_1 apache apache_2_0 apache artistic_1 artistic artistic_2 artistic_2 bsd bsd freebsd open_source gfdl_1_2 open_source gfdl_1_3 open_source gpl_1 gpl gpl_2 gpl gpl_3 gpl lgpl_2_1 lgpl lgpl_3_0 lgpl mit mit mozilla_1_0 mozilla mozilla_1_1 mozilla openssl open_source perl_5 perl qpl_1_0 open_source ssleay open_source sun open_source zlib open_source open_source open_source restricted restrictive unrestricted unrestricted unknown unknown);sub _downgrade_license {my ($element)=@_;if (!defined$element){return "unknown"}elsif(ref$element eq 'ARRAY'){if (@$element > 1){if (grep {!$is_open_source{$license_downgrade_map{lc $_}|| 'unknown' }}@$element){return 'unknown'}else {return 'open_source'}}elsif (@$element==1){return$license_downgrade_map{lc$element->[0]}|| "unknown"}}elsif (!ref$element){return$license_downgrade_map{lc$element}|| "unknown"}return "unknown"}my$no_index_spec_1_2={'file'=>\&_listify,'dir'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,};my$no_index_spec_1_3={'file'=>\&_listify,'directory'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,};my$no_index_spec_2={'file'=>\&_listify,'directory'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,':custom'=>\&_prefix_custom,};sub _no_index_1_2 {my (undef,undef,$meta)=@_;my$no_index=$meta->{no_index}|| $meta->{private};return unless$no_index;if (!ref$no_index){my$item=$no_index;$no_index={dir=>[$item ],file=>[$item ]}}elsif (ref$no_index eq 'ARRAY'){my$list=$no_index;$no_index={dir=>[@$list ],file=>[@$list ]}}if (exists$no_index->{files}){$no_index->{file}=delete$no_index->{files}}if (exists$no_index->{modules}){$no_index->{module}=delete$no_index->{modules}}return _convert($no_index,$no_index_spec_1_2)}sub _no_index_directory {my ($element,$key,$meta,$version)=@_;return unless$element;if (!ref$element){my$item=$element;$element={directory=>[$item ],file=>[$item ]}}elsif (ref$element eq 'ARRAY'){my$list=$element;$element={directory=>[@$list ],file=>[@$list ]}}if (exists$element->{dir}){$element->{directory}=delete$element->{dir}}if (exists$element->{files}){$element->{file}=delete$element->{files}}if (exists$element->{modules}){$element->{module}=delete$element->{modules}}my$spec=$version==2 ? $no_index_spec_2 : $no_index_spec_1_3;return _convert($element,$spec)}sub _is_module_name {my$mod=shift;return unless defined$mod && length$mod;return$mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}}sub _clean_version {my ($element)=@_;return 0 if!defined$element;$element =~ s{^\s*}{};$element =~ s{\s*$}{};$element =~ s{^\.}{0.};return 0 if!length$element;return 0 if ($element eq 'undef' || $element eq '');my$v=eval {version->new($element)};if (defined$v){return _is_qv($v)? $v->normal : $element}else {return 0}}sub _bad_version_hook {my ($v)=@_;$v =~ s{^\s*}{};$v =~ s{\s*$}{};$v =~ s{[a-z]+$}{};my$vobj=eval {version->new($v)};return defined($vobj)? $vobj : version->new(0)}sub _version_map {my ($element)=@_;return unless defined$element;if (ref$element eq 'HASH'){my$new_map=CPAN::Meta::Requirements->new({bad_version_hook=>\&_bad_version_hook });while (my ($k,$v)=each %$element){next unless _is_module_name($k);if (!defined($v)||!length($v)|| $v eq 'undef' || $v eq ''){$v=0}if (_is_module_name($v)&&!version::is_lax($v)){$new_map->add_minimum($k=>0);$new_map->add_minimum($v=>0)}$new_map->add_string_requirement($k=>$v)}return$new_map->as_string_hash}elsif (ref$element eq 'ARRAY'){my$hashref={map {$_=>0}@$element };return _version_map($hashref)}elsif (ref$element eq '' && length$element){return {$element=>0 }}return}sub _prereqs_from_1 {my (undef,undef,$meta)=@_;my$prereqs={};for my$phase (qw/build configure/){my$key="${phase}_requires";$prereqs->{$phase}{requires}=_version_map($meta->{$key})if$meta->{$key}}for my$rel (qw/requires recommends conflicts/){$prereqs->{runtime}{$rel}=_version_map($meta->{$rel})if$meta->{$rel}}return$prereqs}my$prereqs_spec={configure=>\&_prereqs_rel,build=>\&_prereqs_rel,test=>\&_prereqs_rel,runtime=>\&_prereqs_rel,develop=>\&_prereqs_rel,':custom'=>\&_prefix_custom,};my$relation_spec={requires=>\&_version_map,recommends=>\&_version_map,suggests=>\&_version_map,conflicts=>\&_version_map,':custom'=>\&_prefix_custom,};sub _cleanup_prereqs {my ($prereqs,$key,$meta,$to_version)=@_;return unless$prereqs && ref$prereqs eq 'HASH';return _convert($prereqs,$prereqs_spec,$to_version)}sub _prereqs_rel {my ($relation,$key,$meta,$to_version)=@_;return unless$relation && ref$relation eq 'HASH';return _convert($relation,$relation_spec,$to_version)}BEGIN {my@old_prereqs=qw(requires configure_requires recommends conflicts);for (@old_prereqs){my$sub="_get_$_";my ($phase,$type)=split qr/_/,$_;if (!defined$type){$type=$phase;$phase='runtime'}no strict 'refs';*{$sub}=sub {_extract_prereqs($_[2]->{prereqs},$phase,$type)}}}sub _get_build_requires {my ($data,$key,$meta)=@_;my$test_h=_extract_prereqs($_[2]->{prereqs},qw(test requires))|| {};my$build_h=_extract_prereqs($_[2]->{prereqs},qw(build requires))|| {};my$test_req=CPAN::Meta::Requirements->from_string_hash($test_h);my$build_req=CPAN::Meta::Requirements->from_string_hash($build_h);$test_req->add_requirements($build_req)->as_string_hash}sub _extract_prereqs {my ($prereqs,$phase,$type)=@_;return unless ref$prereqs eq 'HASH';return scalar _version_map($prereqs->{$phase}{$type})}sub _downgrade_optional_features {my (undef,undef,$meta)=@_;return unless exists$meta->{optional_features};my$origin=$meta->{optional_features};my$features={};for my$name (keys %$origin){$features->{$name}={description=>$origin->{$name}{description},requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),configure_requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),build_requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),recommends=>_extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),conflicts=>_extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),};for my$k (keys %{$features->{$name}}){delete$features->{$name}{$k}unless defined$features->{$name}{$k}}}return$features}sub _upgrade_optional_features {my (undef,undef,$meta)=@_;return unless exists$meta->{optional_features};my$origin=$meta->{optional_features};my$features={};for my$name (keys %$origin){$features->{$name}={description=>$origin->{$name}{description},prereqs=>_prereqs_from_1(undef,undef,$origin->{$name}),};delete$features->{$name}{prereqs}{configure}}return$features}my$optional_features_2_spec={description=>\&_keep,prereqs=>\&_cleanup_prereqs,':custom'=>\&_prefix_custom,};sub _feature_2 {my ($element,$key,$meta,$to_version)=@_;return unless$element && ref$element eq 'HASH';_convert($element,$optional_features_2_spec,$to_version)}sub _cleanup_optional_features_2 {my ($element,$key,$meta,$to_version)=@_;return unless$element && ref$element eq 'HASH';my$new_data={};for my$k (keys %$element){$new_data->{$k}=_feature_2($element->{$k},$k,$meta,$to_version)}return unless keys %$new_data;return$new_data}sub _optional_features_1_4 {my ($element)=@_;return unless$element;$element=_optional_features_as_map($element);for my$name (keys %$element){for my$drop (qw/requires_packages requires_os excluded_os/){delete$element->{$name}{$drop}}}return$element}sub _optional_features_as_map {my ($element)=@_;return unless$element;if (ref$element eq 'ARRAY'){my%map;for my$feature (@$element){my (@parts)=%$feature;$map{$parts[0]}=$parts[1]}$element=\%map}return$element}sub _is_urlish {defined $_[0]&& $_[0]=~ m{\A[-+.a-z0-9]+:.+}i}sub _url_or_drop {my ($element)=@_;return$element if _is_urlish($element);return}sub _url_list {my ($element)=@_;return unless$element;$element=_listify($element);$element=[grep {_is_urlish($_)}@$element ];return unless @$element;return$element}sub _author_list {my ($element)=@_;return ['unknown' ]unless$element;$element=_listify($element);$element=[map {defined $_ && length $_ ? $_ : 'unknown'}@$element ];return ['unknown' ]unless @$element;return$element}my$resource2_upgrade={license=>sub {return _is_urlish($_[0])? _listify($_[0]): undef},homepage=>\&_url_or_drop,bugtracker=>sub {my ($item)=@_;return unless$item;if ($item =~ m{^mailto:(.*)$}){return {mailto=>$1 }}elsif(_is_urlish($item)){return {web=>$item }}else {return}},repository=>sub {return _is_urlish($_[0])? {url=>$_[0]}: undef},':custom'=>\&_prefix_custom,};sub _upgrade_resources_2 {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource2_upgrade)}my$bugtracker2_spec={web=>\&_url_or_drop,mailto=>\&_keep,':custom'=>\&_prefix_custom,};sub _repo_type {my ($element,$key,$meta,$to_version)=@_;return$element if defined$element;return unless exists$meta->{url};my$repo_url=$meta->{url};for my$type (qw/git svn/){return$type if$repo_url =~ m{\A$type}}return}my$repository2_spec={web=>\&_url_or_drop,url=>\&_url_or_drop,type=>\&_repo_type,':custom'=>\&_prefix_custom,};my$resources2_cleanup={license=>\&_url_list,homepage=>\&_url_or_drop,bugtracker=>sub {ref $_[0]? _convert($_[0],$bugtracker2_spec): undef},repository=>sub {my$data=shift;ref$data ? _convert($data,$repository2_spec): undef},':custom'=>\&_prefix_custom,};sub _cleanup_resources_2 {my ($resources,$key,$meta,$to_version)=@_;return unless$resources && ref$resources eq 'HASH';return _convert($resources,$resources2_cleanup,$to_version)}my$resource1_spec={license=>\&_url_or_drop,homepage=>\&_url_or_drop,bugtracker=>\&_url_or_drop,repository=>\&_url_or_drop,':custom'=>\&_keep,};sub _resources_1_3 {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource1_spec)}*_resources_1_4=*_resources_1_3;sub _resources_1_2 {my (undef,undef,$meta)=@_;my$resources=$meta->{resources}|| {};if ($meta->{license_url}&&!$resources->{license}){$resources->{license}=$meta->{license_url}if _is_urlish($meta->{license_url})}return unless keys %$resources;return _convert($resources,$resource1_spec)}my$resource_downgrade_spec={license=>sub {return ref $_[0]? $_[0]->[0]: $_[0]},homepage=>\&_url_or_drop,bugtracker=>sub {return $_[0]->{web}},repository=>sub {return $_[0]->{url}|| $_[0]->{web}},':custom'=>\&_no_prefix_ucfirst_custom,};sub _downgrade_resources {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource_downgrade_spec)}sub _release_status {my ($element,undef,$meta)=@_;return$element if$element && $element =~ m{\A(?:stable|testing|unstable)\z};return _release_status_from_version(undef,undef,$meta)}sub _release_status_from_version {my (undef,undef,$meta)=@_;my$version=$meta->{version}|| '';return ($version =~ /_/)? 'testing' : 'stable'}my$provides_spec={file=>\&_keep,version=>\&_keep,};my$provides_spec_2={file=>\&_keep,version=>\&_keep,':custom'=>\&_prefix_custom,};sub _provides {my ($element,$key,$meta,$to_version)=@_;return unless defined$element && ref$element eq 'HASH';my$spec=$to_version==2 ? $provides_spec_2 : $provides_spec;my$new_data={};for my$k (keys %$element){$new_data->{$k}=_convert($element->{$k},$spec,$to_version);$new_data->{$k}{version}=_clean_version($element->{$k}{version})if exists$element->{$k}{version}}return$new_data}sub _convert {my ($data,$spec,$to_version,$is_fragment)=@_;my$new_data={};for my$key (keys %$spec){next if$key eq ':custom' || $key eq ':drop';next unless my$fcn=$spec->{$key};if ($is_fragment && $key eq 'generated_by'){$fcn=\&_keep}die "spec for '$key' is not a coderef" unless ref$fcn && ref$fcn eq 'CODE';my$new_value=$fcn->($data->{$key},$key,$data,$to_version);$new_data->{$key}=$new_value if defined$new_value}my$drop_list=$spec->{':drop'};my$customizer=$spec->{':custom'}|| \&_keep;for my$key (keys %$data){next if$drop_list && grep {$key eq $_}@$drop_list;next if exists$spec->{$key};$new_data->{$customizer->($key)}=$data->{$key}}return$new_data}my%up_convert=('2-from-1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_2,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'release_status'=>\&_release_status,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_upgrade_optional_features,'provides'=>\&_provides,'resources'=>\&_upgrade_resources_2,'description'=>\&_keep,'prereqs'=>\&_prereqs_from_1,':drop'=>[qw(build_requires configure_requires conflicts distribution_type license_url private recommends requires) ],':custom'=>\&_prefix_custom,},'1.4-from-1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_1_4,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_4,'configure_requires'=>\&_keep,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.3-from-1.2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.2-from-1.1'=>{'version'=>\&_keep,'license'=>\&_license_1,'name'=>\&_keep,'generated_by'=>\&_generated_by,'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'recommends'=>\&_version_map,'requires'=>\&_version_map,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'resources'=>\&_resources_1_2,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.1-from-1.0'=>{'version'=>\&_keep,'name'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,'license_url'=>\&_url_or_drop,'private'=>\&_keep,':custom'=>\&_keep },);my%down_convert=('1.4-from-2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_downgrade_license,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_get_build_requires,'configure_requires'=>\&_get_configure_requires,'conflicts'=>\&_get_conflicts,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_downgrade_optional_features,'provides'=>\&_provides,'recommends'=>\&_get_recommends,'requires'=>\&_get_requires,'resources'=>\&_downgrade_resources,':drop'=>[qw(description prereqs release_status)],':custom'=>\&_keep },'1.3-from-1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':drop'=>[qw(configure_requires)],':custom'=>\&_keep,},'1.2-from-1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':custom'=>\&_keep,},'1.1-from-1.2'=>{'version'=>\&_keep,'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'private'=>\&_keep,'recommends'=>\&_version_map,'requires'=>\&_version_map,':drop'=>[qw(abstract author provides no_index keywords resources)],':custom'=>\&_keep,},'1.0-from-1.1'=>{'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,':custom'=>\&_keep,},);my%cleanup=('2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_2,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'release_status'=>\&_release_status,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_cleanup_optional_features_2,'provides'=>\&_provides,'resources'=>\&_cleanup_resources_2,'description'=>\&_keep,'prereqs'=>\&_cleanup_prereqs,':drop'=>[qw(build_requires configure_requires conflicts distribution_type license_url private recommends requires) ],':custom'=>\&_prefix_custom,},'1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_1_4,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_4,'configure_requires'=>\&_keep,':custom'=>\&_keep },'1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':custom'=>\&_keep },'1.2'=>{'version'=>\&_keep,'license'=>\&_license_1,'name'=>\&_keep,'generated_by'=>\&_generated_by,'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'recommends'=>\&_version_map,'requires'=>\&_version_map,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'resources'=>\&_resources_1_2,':custom'=>\&_keep },'1.1'=>{'version'=>\&_keep,'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,'license_url'=>\&_url_or_drop,'private'=>\&_keep,':custom'=>\&_keep },'1.0'=>{'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,':custom'=>\&_keep,},);my%fragments_generate=('2'=>{'abstract'=>'abstract','author'=>'author','generated_by'=>'generated_by','license'=>'license','name'=>'name','version'=>'version','dynamic_config'=>'dynamic_config','release_status'=>'release_status','keywords'=>'keywords','no_index'=>'no_index','optional_features'=>'optional_features','provides'=>'provides','resources'=>'resources','description'=>'description','prereqs'=>'prereqs',},'1.4'=>{'abstract'=>'abstract','author'=>'author','generated_by'=>'generated_by','license'=>'license','name'=>'name','version'=>'version','build_requires'=>'prereqs','conflicts'=>'prereqs','distribution_type'=>'distribution_type','dynamic_config'=>'dynamic_config','keywords'=>'keywords','no_index'=>'no_index','optional_features'=>'optional_features','provides'=>'provides','recommends'=>'prereqs','requires'=>'prereqs','resources'=>'resources','configure_requires'=>'prereqs',},);$fragments_generate{$_}=$fragments_generate{'1.4'}for qw/1.3 1.2 1.1 1.0/;sub new {my ($class,$data,%args)=@_;my$self={'data'=>$data,'spec'=>_extract_spec_version($data,$args{default_version}),};return bless$self,$class}sub _extract_spec_version {my ($data,$default)=@_;my$spec=$data->{'meta-spec'};return($default || "1.0")unless defined$spec && ref$spec eq 'HASH';my$v=$spec->{version};if (defined$v && $v =~ /^\d+(?:\.\d+)?$/){return$v if defined$v && grep {$v eq $_}keys%known_specs;return$v+0 if defined$v && grep {$v==$_}keys%known_specs}return "2" if exists$data->{prereqs};return "1.4" if exists$data->{configure_requires};return($default || "1.2")}sub convert {my ($self,%args)=@_;my$args={%args };my$new_version=$args->{version}|| $HIGHEST;my$is_fragment=$args->{is_fragment};my ($old_version)=$self->{spec};my$converted=_dclone($self->{data});if ($old_version==$new_version){$converted=_convert($converted,$cleanup{$old_version},$old_version,$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"}}return$converted}elsif ($old_version > $new_version){my@vers=sort {$b <=> $a}keys%known_specs;for my$i (0 .. $#vers-1){next if$vers[$i]> $old_version;last if$vers[$i+1]< $new_version;my$spec_string="$vers[$i+1]-from-$vers[$i]";$converted=_convert($converted,$down_convert{$spec_string},$vers[$i+1],$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"}}}return$converted}else {my@vers=sort {$a <=> $b}keys%known_specs;for my$i (0 .. $#vers-1){next if$vers[$i]< $old_version;last if$vers[$i+1]> $new_version;my$spec_string="$vers[$i+1]-from-$vers[$i]";$converted=_convert($converted,$up_convert{$spec_string},$vers[$i+1],$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"}}}return$converted}}sub upgrade_fragment {my ($self)=@_;my ($old_version)=$self->{spec};my%expected=map {;$_=>1}grep {defined}map {$fragments_generate{$old_version}{$_}}keys %{$self->{data}};my$converted=$self->convert(version=>$HIGHEST,is_fragment=>1);for my$key (keys %$converted){next if$key =~ /^x_/i || $key eq 'meta-spec';delete$converted->{$key}unless$expected{$key}}return$converted}1; -CPAN_META_CONVERTER - -$fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_FEATURE'; - use 5.006;use strict;use warnings;package CPAN::Meta::Feature;our$VERSION='2.150005';use CPAN::Meta::Prereqs;sub new {my ($class,$identifier,$spec)=@_;my%guts=(identifier=>$identifier,description=>$spec->{description},prereqs=>CPAN::Meta::Prereqs->new($spec->{prereqs}),);bless \%guts=>$class}sub identifier {$_[0]{identifier}}sub description {$_[0]{description}}sub prereqs {$_[0]{prereqs}}1; -CPAN_META_FEATURE - -$fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_HISTORY'; - use 5.006;use strict;use warnings;package CPAN::Meta::History;our$VERSION='2.150005';1; -CPAN_META_HISTORY - -$fatpacked{"CPAN/Meta/Merge.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_MERGE'; - use strict;use warnings;package CPAN::Meta::Merge;our$VERSION='2.150005';use Carp qw/croak/;use Scalar::Util qw/blessed/;use CPAN::Meta::Converter 2.141170;sub _is_identical {my ($left,$right)=@_;return (not defined$left and not defined$right)|| (defined$left and defined$right and $left eq $right)}sub _identical {my ($left,$right,$path)=@_;croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'",join('.',@{$path}),$left,$right unless _is_identical($left,$right);return$left}sub _merge {my ($current,$next,$mergers,$path)=@_;for my$key (keys %{$next}){if (not exists$current->{$key}){$current->{$key}=$next->{$key}}elsif (my$merger=$mergers->{$key}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}elsif ($merger=$mergers->{':default'}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}else {croak sprintf "Can't merge unknown attribute '%s'",join '.',@{$path},$key}}return$current}sub _uniq {my%seen=();return grep {not $seen{$_}++}@_}sub _set_addition {my ($left,$right)=@_;return [+_uniq(@{$left},@{$right})]}sub _uniq_map {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}elsif (_is_identical($left->{$key},$right->{$key})){1}elsif (ref$left->{$key}eq 'HASH' and ref$right->{$key}eq 'HASH'){$left->{$key}=_uniq_map($left->{$key},$right->{$key},[@{$path},$key ])}else {croak 'Duplication of element ' .join '.',@{$path},$key}}return$left}sub _improvize {my ($left,$right,$path)=@_;my ($name)=reverse @{$path};if ($name =~ /^x_/){if (ref($left)eq 'ARRAY'){return _set_addition($left,$right,$path)}elsif (ref($left)eq 'HASH'){return _uniq_map($left,$right,$path)}else {return _identical($left,$right,$path)}}croak sprintf "Can't merge '%s'",join '.',@{$path}}sub _optional_features {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}else {for my$subkey (keys %{$right->{$key}}){next if$subkey eq 'prereqs';if (not exists$left->{$key}{$subkey}){$left->{$key}{$subkey}=$right->{$key}{$subkey}}else {Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values" if do {no warnings 'uninitialized';$left->{$key}{$subkey}ne $right->{$key}{$subkey}}}}require CPAN::Meta::Prereqs;$left->{$key}{prereqs}=CPAN::Meta::Prereqs->new($left->{$key}{prereqs})->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))->as_string_hash}}return$left}my%default=(abstract=>\&_identical,author=>\&_set_addition,dynamic_config=>sub {my ($left,$right)=@_;return$left || $right},generated_by=>sub {my ($left,$right)=@_;return join ', ',_uniq(split(/, /,$left),split(/, /,$right))},license=>\&_set_addition,'meta-spec'=>{version=>\&_identical,url=>\&_identical },name=>\&_identical,release_status=>\&_identical,version=>\&_identical,description=>\&_identical,keywords=>\&_set_addition,no_index=>{map {($_=>\&_set_addition)}qw/file directory package namespace/ },optional_features=>\&_optional_features,prereqs=>sub {require CPAN::Meta::Prereqs;my ($left,$right)=map {CPAN::Meta::Prereqs->new($_)}@_[0,1];return$left->with_merged_prereqs($right)->as_string_hash},provides=>\&_uniq_map,resources=>{license=>\&_set_addition,homepage=>\&_identical,bugtracker=>\&_uniq_map,repository=>\&_uniq_map,':default'=>\&_improvize,},':default'=>\&_improvize,);sub new {my ($class,%arguments)=@_;croak 'default version required' if not exists$arguments{default_version};my%mapping=%default;my%extra=%{$arguments{extra_mappings}|| {}};for my$key (keys%extra){if (ref($mapping{$key})eq 'HASH'){$mapping{$key}={%{$mapping{$key}},%{$extra{$key}}}}else {$mapping{$key}=$extra{$key}}}return bless {default_version=>$arguments{default_version},mapping=>_coerce_mapping(\%mapping,[]),},$class}my%coderef_for=(set_addition=>\&_set_addition,uniq_map=>\&_uniq_map,identical=>\&_identical,improvize=>\&_improvize,);sub _coerce_mapping {my ($orig,$map_path)=@_;my%ret;for my$key (keys %{$orig}){my$value=$orig->{$key};if (ref($orig->{$key})eq 'CODE'){$ret{$key}=$value}elsif (ref($value)eq 'HASH'){my$mapping=_coerce_mapping($value,[@{$map_path},$key ]);$ret{$key}=sub {my ($left,$right,$path)=@_;return _merge($left,$right,$mapping,[@{$path}])}}elsif ($coderef_for{$value}){$ret{$key}=$coderef_for{$value}}else {croak "Don't know what to do with " .join '.',@{$map_path},$key}}return \%ret}sub merge {my ($self,@items)=@_;my$current={};for my$next (@items){if (blessed($next)&& $next->isa('CPAN::Meta')){$next=$next->as_struct}elsif (ref($next)eq 'HASH'){my$cmc=CPAN::Meta::Converter->new($next,default_version=>$self->{default_version});$next=$cmc->upgrade_fragment}else {croak "Don't know how to merge '$next'"}$current=_merge($current,$next,$self->{mapping},[])}return$current}1; -CPAN_META_MERGE - -$fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS'; - use 5.006;use strict;use warnings;package CPAN::Meta::Prereqs;our$VERSION='2.150005';use Carp qw(confess);use Scalar::Util qw(blessed);use CPAN::Meta::Requirements 2.121;sub __legal_phases {qw(configure build test runtime develop)}sub __legal_types {qw(requires recommends suggests conflicts)}sub new {my ($class,$prereq_spec)=@_;$prereq_spec ||= {};my%is_legal_phase=map {;$_=>1}$class->__legal_phases;my%is_legal_type=map {;$_=>1}$class->__legal_types;my%guts;PHASE: for my$phase (keys %$prereq_spec){next PHASE unless$phase =~ /\Ax_/i or $is_legal_phase{$phase};my$phase_spec=$prereq_spec->{$phase };next PHASE unless keys %$phase_spec;TYPE: for my$type (keys %$phase_spec){next TYPE unless$type =~ /\Ax_/i or $is_legal_type{$type};my$spec=$phase_spec->{$type };next TYPE unless keys %$spec;$guts{prereqs}{$phase}{$type}=CPAN::Meta::Requirements->from_string_hash($spec)}}return bless \%guts=>$class}sub requirements_for {my ($self,$phase,$type)=@_;confess "requirements_for called without phase" unless defined$phase;confess "requirements_for called without type" unless defined$type;unless ($phase =~ /\Ax_/i or grep {$phase eq $_}$self->__legal_phases){confess "requested requirements for unknown phase: $phase"}unless ($type =~ /\Ax_/i or grep {$type eq $_}$self->__legal_types){confess "requested requirements for unknown type: $type"}my$req=($self->{prereqs}{$phase}{$type}||= CPAN::Meta::Requirements->new);$req->finalize if$self->is_finalized;return$req}sub with_merged_prereqs {my ($self,$other)=@_;my@other=blessed($other)? $other : @$other;my@prereq_objs=($self,@other);my%new_arg;for my$phase ($self->__legal_phases){for my$type ($self->__legal_types){my$req=CPAN::Meta::Requirements->new;for my$prereq (@prereq_objs){my$this_req=$prereq->requirements_for($phase,$type);next unless$this_req->required_modules;$req->add_requirements($this_req)}next unless$req->required_modules;$new_arg{$phase }{$type }=$req->as_string_hash}}return (ref$self)->new(\%new_arg)}sub merged_requirements {my ($self,$phases,$types)=@_;$phases=[qw/runtime build test/]unless defined$phases;$types=[qw/requires recommends/]unless defined$types;confess "merged_requirements phases argument must be an arrayref" unless ref$phases eq 'ARRAY';confess "merged_requirements types argument must be an arrayref" unless ref$types eq 'ARRAY';my$req=CPAN::Meta::Requirements->new;for my$phase (@$phases){unless ($phase =~ /\Ax_/i or grep {$phase eq $_}$self->__legal_phases){confess "requested requirements for unknown phase: $phase"}for my$type (@$types){unless ($type =~ /\Ax_/i or grep {$type eq $_}$self->__legal_types){confess "requested requirements for unknown type: $type"}$req->add_requirements($self->requirements_for($phase,$type))}}$req->finalize if$self->is_finalized;return$req}sub as_string_hash {my ($self)=@_;my%hash;for my$phase ($self->__legal_phases){for my$type ($self->__legal_types){my$req=$self->requirements_for($phase,$type);next unless$req->required_modules;$hash{$phase }{$type }=$req->as_string_hash}}return \%hash}sub is_finalized {$_[0]{finalized}}sub finalize {my ($self)=@_;$self->{finalized}=1;for my$phase (keys %{$self->{prereqs}}){$_->finalize for values %{$self->{prereqs}{$phase}}}}sub clone {my ($self)=@_;my$clone=(ref$self)->new($self->as_string_hash)}1; -CPAN_META_PREREQS - -$fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_REQUIREMENTS'; - use strict;use warnings;package CPAN::Meta::Requirements;our$VERSION='2.133';use Carp ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};my$V0=version->new(0);my@valid_options=qw(bad_version_hook);sub new {my ($class,$options)=@_;$options ||= {};Carp::croak "Argument to $class\->new() must be a hash reference" unless ref$options eq 'HASH';my%self=map {;$_=>$options->{$_}}@valid_options;return bless \%self=>$class}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub _isa_version {UNIVERSAL::isa($_[0],'UNIVERSAL')&& $_[0]->isa('version')}sub _version_object {my ($self,$module,$version)=@_;my ($vobj,$err);if (not defined$version or (!ref($version)&& $version eq '0')){return$V0}elsif (ref($version)eq 'version' || _isa_version($version)){$vobj=$version}else {if ($INC{'version/vpp.pm'}|| $INC{'ExtUtils/MakeMaker/version/vpp.pm'}){my$magic=_find_magic_vstring($version);$version=$magic if length$magic}eval {local$SIG{__WARN__}=sub {die "Invalid version: $_[0]"};$vobj=version->new($version)};if (my$err=$@){my$hook=$self->{bad_version_hook};$vobj=eval {$hook->($version,$module)}if ref$hook eq 'CODE';unless (eval {$vobj->isa("version")}){$err =~ s{ at .* line \d+.*$}{};die "Can't convert '$version': $err"}}}if ($vobj =~ m{\A\.}){$vobj=version->new("0$vobj")}if (_is_qv($vobj)){$vobj=version->new($vobj->normal)}return$vobj}BEGIN {for my$type (qw(maximum exclusion exact_version)){my$method="with_$type";my$to_add=$type eq 'exact_version' ? $type : "add_$type";my$code=sub {my ($self,$name,$version)=@_;$version=$self->_version_object($name,$version);$self->__modify_entry_for($name,$method,$version);return$self};no strict 'refs';*$to_add=$code}}sub add_minimum {my ($self,$name,$version)=@_;if (not defined$version or "$version" eq '0'){return$self if$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$self->is_finalized;$self->{requirements}{$name }=CPAN::Meta::Requirements::_Range::Range->with_minimum($V0)}else {$version=$self->_version_object($name,$version);$self->__modify_entry_for($name,'with_minimum',$version)}return$self}sub add_requirements {my ($self,$req)=@_;for my$module ($req->required_modules){my$modifiers=$req->__entry_for($module)->as_modifiers;for my$modifier (@$modifiers){my ($method,@args)=@$modifier;$self->$method($module=>@args)}}return$self}sub accepts_module {my ($self,$module,$version)=@_;$version=$self->_version_object($module,$version);return 1 unless my$range=$self->__entry_for($module);return$range->_accepts($version)}sub clear_requirement {my ($self,$module)=@_;return$self unless$self->__entry_for($module);Carp::confess("can't clear requirements on finalized requirements")if$self->is_finalized;delete$self->{requirements}{$module };return$self}sub requirements_for_module {my ($self,$module)=@_;my$entry=$self->__entry_for($module);return unless$entry;return$entry->as_string}sub required_modules {keys %{$_[0]{requirements}}}sub clone {my ($self)=@_;my$new=(ref$self)->new;return$new->add_requirements($self)}sub __entry_for {$_[0]{requirements}{$_[1]}}sub __modify_entry_for {my ($self,$name,$method,$version)=@_;my$fin=$self->is_finalized;my$old=$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$fin and not $old;my$new=($old || 'CPAN::Meta::Requirements::_Range::Range')->$method($version);Carp::confess("can't modify finalized requirements")if$fin and $old->as_string ne $new->as_string;$self->{requirements}{$name }=$new}sub is_simple {my ($self)=@_;for my$module ($self->required_modules){return if$self->__entry_for($module)->as_string =~ /\s/}return 1}sub is_finalized {$_[0]{finalized}}sub finalize {$_[0]{finalized}=1}sub as_string_hash {my ($self)=@_;my%hash=map {;$_=>$self->{requirements}{$_}->as_string}$self->required_modules;return \%hash}my%methods_for_op=('=='=>[qw(exact_version) ],'!='=>[qw(add_exclusion) ],'>='=>[qw(add_minimum) ],'<='=>[qw(add_maximum) ],'>'=>[qw(add_minimum add_exclusion) ],'<'=>[qw(add_maximum add_exclusion) ],);sub add_string_requirement {my ($self,$module,$req)=@_;unless (defined$req && length$req){$req=0;$self->_blank_carp($module)}my$magic=_find_magic_vstring($req);if (length$magic){$self->add_minimum($module=>$magic);return}my@parts=split qr{\s*,\s*},$req;for my$part (@parts){my ($op,$ver)=$part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};if (!defined$op){$self->add_minimum($module=>$part)}else {Carp::confess("illegal requirement string: $req")unless my$methods=$methods_for_op{$op };$self->$_($module=>$ver)for @$methods}}}sub _blank_carp {my ($self,$module)=@_;Carp::carp("Undefined requirement for $module treated as '0'")}sub from_string_hash {my ($class,$hash,$options)=@_;my$self=$class->new($options);for my$module (keys %$hash){my$req=$hash->{$module};unless (defined$req && length$req){$req=0;$class->_blank_carp($module)}$self->add_string_requirement($module,$req)}return$self}{package CPAN::Meta::Requirements::_Range::Exact;sub _new {bless {version=>$_[1]}=>$_[0]}sub _accepts {return $_[0]{version}==$_[1]}sub as_string {return "== $_[0]{version}"}sub as_modifiers {return [[exact_version=>$_[0]{version}]]}sub _clone {(ref $_[0])->_new(version->new($_[0]{version}))}sub with_exact_version {my ($self,$version)=@_;return$self->_clone if$self->_accepts($version);Carp::confess("illegal requirements: unequal exact version specified")}sub with_minimum {my ($self,$minimum)=@_;return$self->_clone if$self->{version}>= $minimum;Carp::confess("illegal requirements: minimum above exact specification")}sub with_maximum {my ($self,$maximum)=@_;return$self->_clone if$self->{version}<= $maximum;Carp::confess("illegal requirements: maximum below exact specification")}sub with_exclusion {my ($self,$exclusion)=@_;return$self->_clone unless$exclusion==$self->{version};Carp::confess("illegal requirements: excluded exact specification")}}{package CPAN::Meta::Requirements::_Range::Range;sub _self {ref($_[0])? $_[0]: (bless {}=>$_[0])}sub _clone {return (bless {}=>$_[0])unless ref $_[0];my ($s)=@_;my%guts=((exists$s->{minimum}? (minimum=>version->new($s->{minimum})): ()),(exists$s->{maximum}? (maximum=>version->new($s->{maximum})): ()),(exists$s->{exclusions}? (exclusions=>[map {version->new($_)}@{$s->{exclusions}}]): ()),);bless \%guts=>ref($s)}sub as_modifiers {my ($self)=@_;my@mods;push@mods,[add_minimum=>$self->{minimum}]if exists$self->{minimum};push@mods,[add_maximum=>$self->{maximum}]if exists$self->{maximum};push@mods,map {;[add_exclusion=>$_ ]}@{$self->{exclusions}|| []};return \@mods}sub as_string {my ($self)=@_;return 0 if!keys %$self;return "$self->{minimum}" if (keys %$self)==1 and exists$self->{minimum};my@exclusions=@{$self->{exclusions}|| []};my@parts;for my$pair ([qw(>= > minimum) ],[qw(<= < maximum) ],){my ($op,$e_op,$k)=@$pair;if (exists$self->{$k}){my@new_exclusions=grep {$_!=$self->{$k }}@exclusions;if (@new_exclusions==@exclusions){push@parts,"$op $self->{ $k }"}else {push@parts,"$e_op $self->{ $k }";@exclusions=@new_exclusions}}}push@parts,map {;"!= $_"}@exclusions;return join q{, },@parts}sub with_exact_version {my ($self,$version)=@_;$self=$self->_clone;Carp::confess("illegal requirements: exact specification outside of range")unless$self->_accepts($version);return CPAN::Meta::Requirements::_Range::Exact->_new($version)}sub _simplify {my ($self)=@_;if (defined$self->{minimum}and defined$self->{maximum}){if ($self->{minimum}==$self->{maximum}){Carp::confess("illegal requirements: excluded all values")if grep {$_==$self->{minimum}}@{$self->{exclusions}|| []};return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})}Carp::confess("illegal requirements: minimum exceeds maximum")if$self->{minimum}> $self->{maximum}}if ($self->{exclusions}){my%seen;@{$self->{exclusions}}=grep {(!defined$self->{minimum}or $_ >= $self->{minimum})and (!defined$self->{maximum}or $_ <= $self->{maximum})and !$seen{$_}++}@{$self->{exclusions}}}return$self}sub with_minimum {my ($self,$minimum)=@_;$self=$self->_clone;if (defined (my$old_min=$self->{minimum})){$self->{minimum}=(sort {$b cmp $a}($minimum,$old_min))[0]}else {$self->{minimum}=$minimum}return$self->_simplify}sub with_maximum {my ($self,$maximum)=@_;$self=$self->_clone;if (defined (my$old_max=$self->{maximum})){$self->{maximum}=(sort {$a cmp $b}($maximum,$old_max))[0]}else {$self->{maximum}=$maximum}return$self->_simplify}sub with_exclusion {my ($self,$exclusion)=@_;$self=$self->_clone;push @{$self->{exclusions}||= []},$exclusion;return$self->_simplify}sub _accepts {my ($self,$version)=@_;return if defined$self->{minimum}and $version < $self->{minimum};return if defined$self->{maximum}and $version > $self->{maximum};return if defined$self->{exclusions}and grep {$version==$_}@{$self->{exclusions}};return 1}}1; -CPAN_META_REQUIREMENTS - -$fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_SPEC'; - use 5.006;use strict;use warnings;package CPAN::Meta::Spec;our$VERSION='2.150005';1; -CPAN_META_SPEC - -$fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_VALIDATOR'; - use 5.006;use strict;use warnings;package CPAN::Meta::Validator;our$VERSION='2.150005';my%known_specs=('1.4'=>'http://module-build.sourceforge.net/META-spec-v1.4.html','1.3'=>'http://module-build.sourceforge.net/META-spec-v1.3.html','1.2'=>'http://module-build.sourceforge.net/META-spec-v1.2.html','1.1'=>'http://module-build.sourceforge.net/META-spec-v1.1.html','1.0'=>'http://module-build.sourceforge.net/META-spec-v1.0.html');my%known_urls=map {$known_specs{$_}=>$_}keys%known_specs;my$module_map1={'map'=>{':key'=>{name=>\&module,value=>\&exversion }}};my$module_map2={'map'=>{':key'=>{name=>\&module,value=>\&version }}};my$no_index_2={'map'=>{file=>{list=>{value=>\&string }},directory=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&custom_2,value=>\&anything },}};my$no_index_1_3={'map'=>{file=>{list=>{value=>\&string }},directory=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&string,value=>\&anything },}};my$no_index_1_2={'map'=>{file=>{list=>{value=>\&string }},dir=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&string,value=>\&anything },}};my$no_index_1_1={'map'=>{':key'=>{name=>\&string,list=>{value=>\&string }},}};my$prereq_map={map=>{':key'=>{name=>\&phase,'map'=>{':key'=>{name=>\&relation,%$module_map1,},},}},};my%definitions=('2'=>{'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'dynamic_config'=>{mandatory=>1,value=>\&boolean },'generated_by'=>{mandatory=>1,value=>\&string },'license'=>{mandatory=>1,list=>{value=>\&license }},'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{value=>\&url },':key'=>{name=>\&custom_2,value=>\&anything },}},'name'=>{mandatory=>1,value=>\&string },'release_status'=>{mandatory=>1,value=>\&release_status },'version'=>{mandatory=>1,value=>\&version },'description'=>{value=>\&string },'keywords'=>{list=>{value=>\&string }},'no_index'=>$no_index_2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },prereqs=>$prereq_map,':key'=>{name=>\&custom_2,value=>\&anything },}}}},'prereqs'=>$prereq_map,'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&custom_2,value=>\&anything },}}}},'resources'=>{'map'=>{license=>{list=>{value=>\&url }},homepage=>{value=>\&url },bugtracker=>{'map'=>{web=>{value=>\&url },mailto=>{value=>\&string},':key'=>{name=>\&custom_2,value=>\&anything },}},repository=>{'map'=>{web=>{value=>\&url },url=>{value=>\&url },type=>{value=>\&string },':key'=>{name=>\&custom_2,value=>\&anything },}},':key'=>{value=>\&string,name=>\&custom_2 },}},':key'=>{name=>\&custom_2,value=>\&anything },},'1.4'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'configure_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'no_index'=>$no_index_1_3,'private'=>$no_index_1_3,'keywords'=>{list=>{value=>\&string }},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.3'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'no_index'=>$no_index_1_3,'private'=>$no_index_1_3,'keywords'=>{list=>{value=>\&string }},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.2'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'abstract'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'keywords'=>{list=>{value=>\&string }},'private'=>$no_index_1_2,'$no_index'=>$no_index_1_2,'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.1'=>{'name'=>{value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{value=>\&license },'generated_by'=>{value=>\&string },'license_uri'=>{value=>\&url },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'private'=>$no_index_1_1,'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,':key'=>{name=>\&string,value=>\&anything },},'1.0'=>{'name'=>{value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{value=>\&license },'generated_by'=>{value=>\&string },'license_uri'=>{value=>\&url },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,':key'=>{name=>\&string,value=>\&anything },},);sub new {my ($class,$data)=@_;my$self={'data'=>$data,'spec'=>eval {$data->{'meta-spec'}{'version'}}|| "1.0",'errors'=>undef,};return bless$self,$class}sub is_valid {my$self=shift;my$data=$self->{data};my$spec_version=$self->{spec};$self->check_map($definitions{$spec_version},$data);return!$self->errors}sub errors {my$self=shift;return ()unless(defined$self->{errors});return @{$self->{errors}}}my$spec_error="Missing validation action in specification. " ."Must be one of 'map', 'list', or 'value'";sub check_map {my ($self,$spec,$data)=@_;if(ref($spec)ne 'HASH'){$self->_error("Unknown META specification, cannot validate.");return}if(ref($data)ne 'HASH'){$self->_error("Expected a map structure from string or file.");return}for my$key (keys %$spec){next unless($spec->{$key}->{mandatory});next if(defined$data->{$key});push @{$self->{stack}},$key;$self->_error("Missing mandatory field, '$key'");pop @{$self->{stack}}}for my$key (keys %$data){push @{$self->{stack}},$key;if($spec->{$key}){if($spec->{$key}{value}){$spec->{$key}{value}->($self,$key,$data->{$key})}elsif($spec->{$key}{'map'}){$self->check_map($spec->{$key}{'map'},$data->{$key})}elsif($spec->{$key}{'list'}){$self->check_list($spec->{$key}{'list'},$data->{$key})}else {$self->_error("$spec_error for '$key'")}}elsif ($spec->{':key'}){$spec->{':key'}{name}->($self,$key,$key);if($spec->{':key'}{value}){$spec->{':key'}{value}->($self,$key,$data->{$key})}elsif($spec->{':key'}{'map'}){$self->check_map($spec->{':key'}{'map'},$data->{$key})}elsif($spec->{':key'}{'list'}){$self->check_list($spec->{':key'}{'list'},$data->{$key})}else {$self->_error("$spec_error for ':key'")}}else {$self->_error("Unknown key, '$key', found in map structure")}pop @{$self->{stack}}}}sub check_list {my ($self,$spec,$data)=@_;if(ref($data)ne 'ARRAY'){$self->_error("Expected a list structure");return}if(defined$spec->{mandatory}){if(!defined$data->[0]){$self->_error("Missing entries from mandatory list")}}for my$value (@$data){push @{$self->{stack}},$value || "";if(defined$spec->{value}){$spec->{value}->($self,'list',$value)}elsif(defined$spec->{'map'}){$self->check_map($spec->{'map'},$value)}elsif(defined$spec->{'list'}){$self->check_list($spec->{'list'},$value)}elsif ($spec->{':key'}){$self->check_map($spec,$value)}else {$self->_error("$spec_error associated with '$self->{stack}[-2]'")}pop @{$self->{stack}}}}sub header {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value && $value =~ /^--- #YAML:1.0/)}$self->_error("file does not have a valid YAML header.");return 0}sub release_status {my ($self,$key,$value)=@_;if(defined$value){my$version=$self->{data}{version}|| '';if ($version =~ /_/){return 1 if ($value =~ /\A(?:testing|unstable)\z/);$self->_error("'$value' for '$key' is invalid for version '$version'")}else {return 1 if ($value =~ /\A(?:stable|testing|unstable)\z/);$self->_error("'$value' for '$key' is invalid")}}else {$self->_error("'$key' is not defined")}return 0}sub _uri_split {return $_[0]=~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,}sub url {my ($self,$key,$value)=@_;if(defined$value){my ($scheme,$auth,$path,$query,$frag)=_uri_split($value);unless (defined$scheme && length$scheme){$self->_error("'$value' for '$key' does not have a URL scheme");return 0}unless (defined$auth && length$auth){$self->_error("'$value' for '$key' does not have a URL authority");return 0}return 1}$value ||= '';$self->_error("'$value' for '$key' is not a valid URL.");return 0}sub urlspec {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value && $known_specs{$self->{spec}}eq $value);if($value && $known_urls{$value}){$self->_error('META specification URL does not match version');return 0}}$self->_error('Unknown META specification');return 0}sub anything {return 1}sub string {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value || $value =~ /^0$/)}$self->_error("value is an undefined string");return 0}sub string_or_undef {my ($self,$key,$value)=@_;return 1 unless(defined$value);return 1 if($value || $value =~ /^0$/);$self->_error("No string defined for '$key'");return 0}sub file {my ($self,$key,$value)=@_;return 1 if(defined$value);$self->_error("No file defined for '$key'");return 0}sub exversion {my ($self,$key,$value)=@_;if(defined$value && ($value || $value =~ /0/)){my$pass=1;for(split(",",$value)){$self->version($key,$_)or ($pass=0)}return$pass}$value='' unless(defined$value);$self->_error("'$value' for '$key' is not a valid version.");return 0}sub version {my ($self,$key,$value)=@_;if(defined$value){return 0 unless($value || $value =~ /0/);return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/)}else {$value=''}$self->_error("'$value' for '$key' is not a valid version.");return 0}sub boolean {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value =~ /^(0|1|true|false)$/)}else {$value=''}$self->_error("'$value' for '$key' is not a boolean value.");return 0}my%v1_licenses=('perl'=>'http://dev.perl.org/licenses/','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','apache'=>'http://apache.org/licenses/LICENSE-2.0','artistic'=>'http://opensource.org/licenses/artistic-license.php','artistic_2'=>'http://opensource.org/licenses/artistic-license-2.0.php','lgpl'=>'http://www.opensource.org/licenses/lgpl-license.php','bsd'=>'http://www.opensource.org/licenses/bsd-license.php','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','mit'=>'http://opensource.org/licenses/mit-license.php','mozilla'=>'http://opensource.org/licenses/mozilla1.1.php','open_source'=>undef,'unrestricted'=>undef,'restrictive'=>undef,'unknown'=>undef,);my%v2_licenses=map {$_=>1}qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);sub license {my ($self,$key,$value)=@_;my$licenses=$self->{spec}< 2 ? \%v1_licenses : \%v2_licenses;if(defined$value){return 1 if($value && exists$licenses->{$value})}else {$value=''}$self->_error("License '$value' is invalid");return 0}sub custom_1 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/)}else {$key=''}$self->_error("Custom resource '$key' must be in CamelCase.");return 0}sub custom_2 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^x_/i)}else {$key=''}$self->_error("Custom key '$key' must begin with 'x_' or 'X_'.");return 0}sub identifier {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i)}else {$key=''}$self->_error("Key '$key' is not a legal identifier.");return 0}sub module {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/)}else {$key=''}$self->_error("Key '$key' is not a legal module name.");return 0}my@valid_phases=qw/configure build test runtime develop/;sub phase {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_phases);return 1 if$key =~ /x_/i}else {$key=''}$self->_error("Key '$key' is not a legal phase.");return 0}my@valid_relations=qw/requires recommends suggests conflicts/;sub relation {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_relations);return 1 if$key =~ /x_/i}else {$key=''}$self->_error("Key '$key' is not a legal prereq relationship.");return 0}sub _error {my$self=shift;my$mess=shift;$mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});$mess .= " [Validation: $self->{spec}]";push @{$self->{errors}},$mess}1; -CPAN_META_VALIDATOR - -$fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML'; - use 5.008001;use strict;use warnings;package CPAN::Meta::YAML;$CPAN::Meta::YAML::VERSION='0.016';;use Exporter;our@ISA=qw{Exporter};our@EXPORT=qw{Load Dump};our@EXPORT_OK=qw{LoadFile DumpFile freeze thaw};sub Dump {return CPAN::Meta::YAML->new(@_)->_dump_string}sub Load {my$self=CPAN::Meta::YAML->_load_string(@_);if (wantarray){return @$self}else {return$self->[-1]}}BEGIN {*freeze=\&Dump;*thaw=\&Load}sub DumpFile {my$file=shift;return CPAN::Meta::YAML->new(@_)->_dump_file($file)}sub LoadFile {my$file=shift;my$self=CPAN::Meta::YAML->_load_file($file);if (wantarray){return @$self}else {return$self->[-1]}}sub new {my$class=shift;bless [@_ ],$class}sub read_string {my$self=shift;$self->_load_string(@_)}sub write_string {my$self=shift;$self->_dump_string(@_)}sub read {my$self=shift;$self->_load_file(@_)}sub write {my$self=shift;$self->_dump_file(@_)}my@UNPRINTABLE=qw(0 x01 x02 x03 x04 x05 x06 a b t n v f r x0E x0F x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x1A e x1C x1D x1E x1F);my%UNESCAPES=(0=>"\x00",z=>"\x00",N=>"\x85",a=>"\x07",b=>"\x08",t=>"\x09",n=>"\x0a",v=>"\x0b",f=>"\x0c",r=>"\x0d",e=>"\x1b",'\\'=>'\\',);my%QUOTE=map {$_=>1}qw{null true false};my$re_capture_double_quoted=qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;my$re_capture_single_quoted=qr/\'([^\']*(?:\'\'[^\']*)*)\'/;my$re_capture_unquoted_key=qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;my$re_trailing_comment=qr/(?:\s+\#.*)?/;my$re_key_value_separator=qr/\s*:(?:\s+(?:\#.*)?|$)/;sub _load_file {my$class=ref $_[0]? ref shift : shift;my$file=shift or $class->_error('You did not specify a file name');$class->_error("File '$file' does not exist")unless -e $file;$class->_error("'$file' is a directory, not a file")unless -f _;$class->_error("Insufficient permissions to read '$file'")unless -r _;open(my$fh,"<:unix:encoding(UTF-8)",$file);unless ($fh){$class->_error("Failed to open file '$file': $!")}if (_can_flock()){flock($fh,Fcntl::LOCK_SH())or warn "Couldn't lock '$file' for reading: $!"}my$contents=eval {use warnings FATAL=>'utf8';local $/;<$fh>};if (my$err=$@){$class->_error("Error reading from file '$file': $err")}unless (close$fh){$class->_error("Failed to close file '$file': $!")}$class->_load_string($contents)}sub _load_string {my$class=ref $_[0]? ref shift : shift;my$self=bless [],$class;my$string=$_[0];eval {unless (defined$string){die \"Did not provide a string to load"}if (utf8::is_utf8($string)&&!utf8::valid($string)){die \<<'...'}utf8::upgrade($string);$string =~ s/^\x{FEFF}//;return$self unless length$string;my@lines=grep {!/^\s*(?:\#.*)?\z/}split /(?:\015{1,2}\012|\015|\012)/,$string;@lines and $lines[0]=~ /^\%YAML[: ][\d\.]+.*\z/ and shift@lines;my$in_document=0;while (@lines){if ($lines[0]=~ /^---\s*(?:(.+)\s*)?\z/){shift@lines;if (defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/){push @$self,$self->_load_scalar("$1",[undef ],\@lines);next}$in_document=1}if (!@lines or $lines[0]=~ /^(?:---|\.\.\.)/){push @$self,undef;while (@lines and $lines[0]!~ /^---/){shift@lines}$in_document=0}elsif (!$in_document && @$self){die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}elsif ($lines[0]=~ /^\s*\-(?:\s|$|-+$)/){my$document=[];push @$self,$document;$self->_load_array($document,[0 ],\@lines)}elsif ($lines[0]=~ /^(\s*)\S/){my$document={};push @$self,$document;$self->_load_hash($document,[length($1)],\@lines)}else {die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}}};my$err=$@;if (ref$err eq 'SCALAR'){$self->_error(${$err})}elsif ($err){$self->_error($err)}return$self}sub _unquote_single {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\'\'/\'/g;return$string}sub _unquote_double {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\\"/"/g;$string =~ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))} - Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set). - Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"? - ... - {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;return$string}sub _load_scalar {my ($self,$string,$indent,$lines)=@_;$string =~ s/\s*\z//;return undef if$string eq '~';if ($string =~ /^$re_capture_single_quoted$re_trailing_comment\z/){return$self->_unquote_single($1)}if ($string =~ /^$re_capture_double_quoted$re_trailing_comment\z/){return$self->_unquote_double($1)}if ($string =~ /^[\'\"!&]/){die \"CPAN::Meta::YAML does not support a feature in line '$string'"}return {}if$string =~ /^{}(?:\s+\#.*)?\z/;return []if$string =~ /^\[\](?:\s+\#.*)?\z/;if ($string !~ /^[>|]/){die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'" if$string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or $string =~ /:(?:\s|$)/;$string =~ s/\s+#.*\z//;return$string}die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;$lines->[0]=~ /^(\s*)/;$indent->[-1]=length("$1");if (defined$indent->[-2]and $indent->[-1]<= $indent->[-2]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}my@multiline=();while (@$lines){$lines->[0]=~ /^(\s*)/;last unless length($1)>= $indent->[-1];push@multiline,substr(shift(@$lines),length($1))}my$j=(substr($string,0,1)eq '>')? ' ' : "\n";my$t=(substr($string,1,1)eq '-')? '' : "\n";return join($j,@multiline).$t}sub _load_array {my ($self,$array,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$lines->[0]=~ /^(\s*)/;if (length($1)< $indent->[-1]){return 1}elsif (length($1)> $indent->[-1]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}if ($lines->[0]=~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/){my$indent2=length("$1");$lines->[0]=~ s/-/ /;push @$array,{};$self->_load_hash($array->[-1],[@$indent,$indent2 ],$lines)}elsif ($lines->[0]=~ /^\s*\-\s*\z/){shift @$lines;unless (@$lines){push @$array,undef;return 1}if ($lines->[0]=~ /^(\s*)\-/){my$indent2=length("$1");if ($indent->[-1]==$indent2){push @$array,undef}else {push @$array,[];$self->_load_array($array->[-1],[@$indent,$indent2 ],$lines)}}elsif ($lines->[0]=~ /^(\s*)\S/){push @$array,{};$self->_load_hash($array->[-1],[@$indent,length("$1")],$lines)}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}elsif ($lines->[0]=~ /^\s*\-(\s*)(.+?)\s*\z/){shift @$lines;push @$array,$self->_load_scalar("$2",[@$indent,undef ],$lines)}elsif (defined$indent->[-2]and $indent->[-1]==$indent->[-2]){return 1}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}return 1}sub _load_hash {my ($self,$hash,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$lines->[0]=~ /^(\s*)/;if (length($1)< $indent->[-1]){return 1}elsif (length($1)> $indent->[-1]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}my$key;if ($lines->[0]=~ s/^\s*$re_capture_single_quoted$re_key_value_separator//){$key=$self->_unquote_single($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_double_quoted$re_key_value_separator//){$key=$self->_unquote_double($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_unquoted_key$re_key_value_separator//){$key=$1;$key =~ s/\s+$//}elsif ($lines->[0]=~ /^\s*\?/){die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}if (exists$hash->{$key}){warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'"}if (length$lines->[0]){$hash->{$key}=$self->_load_scalar(shift(@$lines),[@$indent,undef ],$lines)}else {shift @$lines;unless (@$lines){$hash->{$key}=undef;return 1}if ($lines->[0]=~ /^(\s*)-/){$hash->{$key}=[];$self->_load_array($hash->{$key},[@$indent,length($1)],$lines)}elsif ($lines->[0]=~ /^(\s*)./){my$indent2=length("$1");if ($indent->[-1]>= $indent2){$hash->{$key}=undef}else {$hash->{$key}={};$self->_load_hash($hash->{$key},[@$indent,length($1)],$lines)}}}}return 1}sub _dump_file {my$self=shift;require Fcntl;my$file=shift or $self->_error('You did not specify a file name');my$fh;if (_can_flock()){my$flags=Fcntl::O_WRONLY()|Fcntl::O_CREAT();sysopen($fh,$file,$flags);unless ($fh){$self->_error("Failed to open file '$file' for writing: $!")}binmode($fh,":raw:encoding(UTF-8)");flock($fh,Fcntl::LOCK_EX())or warn "Couldn't lock '$file' for reading: $!";truncate$fh,0;seek$fh,0,0}else {open$fh,">:unix:encoding(UTF-8)",$file}print {$fh}$self->_dump_string;unless (close$fh){$self->_error("Failed to close file '$file': $!")}return 1}sub _dump_string {my$self=shift;return '' unless ref$self && @$self;my$indent=0;my@lines=();eval {for my$cursor (@$self){push@lines,'---';if (!defined$cursor){}elsif (!ref$cursor){$lines[-1].= ' ' .$self->_dump_scalar($cursor)}elsif (ref$cursor eq 'ARRAY'){unless (@$cursor){$lines[-1].= ' []';next}push@lines,$self->_dump_array($cursor,$indent,{})}elsif (ref$cursor eq 'HASH'){unless (%$cursor){$lines[-1].= ' {}';next}push@lines,$self->_dump_hash($cursor,$indent,{})}else {die \("Cannot serialize " .ref($cursor))}}};if (ref $@ eq 'SCALAR'){$self->_error(${$@})}elsif ($@){$self->_error($@)}join '',map {"$_\n"}@lines}sub _has_internal_string_value {my$value=shift;my$b_obj=B::svref_2object(\$value);return$b_obj->FLAGS & B::SVf_POK()}sub _dump_scalar {my$string=$_[1];my$is_key=$_[2];my$has_string_flag=_has_internal_string_value($string);return '~' unless defined$string;return "''" unless length$string;if (Scalar::Util::looks_like_number($string)){if ($is_key || $has_string_flag){return qq['$string']}else {return$string}}if ($string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/){$string =~ s/\\/\\\\/g;$string =~ s/"/\\"/g;$string =~ s/\n/\\n/g;$string =~ s/[\x85]/\\N/g;$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;$string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;return qq|"$string"|}if ($string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or $QUOTE{$string}){return "'$string'"}return$string}sub _dump_array {my ($self,$array,$indent,$seen)=@_;if ($seen->{refaddr($array)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$el (@$array){my$line=(' ' x $indent).'-';my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}sub _dump_hash {my ($self,$hash,$indent,$seen)=@_;if ($seen->{refaddr($hash)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$name (sort keys %$hash){my$el=$hash->{$name};my$line=(' ' x $indent).$self->_dump_scalar($name,1).":";my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}our$errstr='';sub _error {require Carp;$errstr=$_[1];$errstr =~ s/ at \S+ line \d+.*//;Carp::croak($errstr)}my$errstr_warned;sub errstr {require Carp;Carp::carp("CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated")unless$errstr_warned++;$errstr}use B;my$HAS_FLOCK;sub _can_flock {if (defined$HAS_FLOCK){return$HAS_FLOCK}else {require Config;my$c=\%Config::Config;$HAS_FLOCK=grep {$c->{$_}}qw/d_flock d_fcntl_can_lock d_lockf/;require Fcntl if$HAS_FLOCK;return$HAS_FLOCK}}use Scalar::Util ();BEGIN {local $@;if (eval {Scalar::Util->VERSION(1.18)}){*refaddr=*Scalar::Util::refaddr}else {eval <<'END_PERL'}}delete$CPAN::Meta::YAML::{refaddr};1; - # Scalar::Util failed to load or too old - sub refaddr { - my $pkg = ref($_[0]) or return undef; - if ( !! UNIVERSAL::can($_[0], 'can') ) { - bless $_[0], 'Scalar::Util::Fake'; - } else { - $pkg = undef; - } - "$_[0]" =~ /0x(\w+)/; - my $i = do { no warnings 'portable'; hex $1 }; - bless $_[0], $pkg if defined $pkg; - $i; - } - END_PERL -CPAN_META_YAML - -$fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER'; - package Exporter;require 5.006;our$Debug=0;our$ExportLevel=0;our$Verbose ||=0;our$VERSION='5.70';our (%Cache);sub as_heavy {require Exporter::Heavy;my$c=(caller(1))[3];$c =~ s/.*:://;\&{"Exporter::Heavy::heavy_$c"}}sub export {goto &{as_heavy()}}sub import {my$pkg=shift;my$callpkg=caller($ExportLevel);if ($pkg eq "Exporter" and @_ and $_[0]eq "import"){*{$callpkg."::import"}=\&import;return}my$exports=\@{"$pkg\::EXPORT"};my$fail=${$pkg .'::'}{EXPORT_FAIL}&& \@{"$pkg\::EXPORT_FAIL"};return export$pkg,$callpkg,@_ if$Verbose or $Debug or $fail && @$fail > 1;my$export_cache=($Cache{$pkg}||={});my$args=@_ or @_=@$exports;if ($args and not %$export_cache){s/^&//,$export_cache->{$_}=1 foreach (@$exports,@{"$pkg\::EXPORT_OK"})}my$heavy;if ($args or $fail){($heavy=(/\W/ or $args and not exists$export_cache->{$_}or $fail and @$fail and $_ eq $fail->[0]))and last foreach (@_)}else {($heavy=/\W/)and last foreach (@_)}return export$pkg,$callpkg,($args ? @_ : ())if$heavy;local$SIG{__WARN__}=sub {require Carp;&Carp::carp}if not $SIG{__WARN__};*{"$callpkg\::$_"}=\&{"$pkg\::$_"}foreach @_}sub export_fail {my$self=shift;@_}sub export_to_level {goto &{as_heavy()}}sub export_tags {goto &{as_heavy()}}sub export_ok_tags {goto &{as_heavy()}}sub require_version {goto &{as_heavy()}}1; -EXPORTER - -$fatpacked{"Exporter/Heavy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_HEAVY'; - package Exporter::Heavy;use strict;no strict 'refs';require Exporter;our$VERSION=$Exporter::VERSION;sub _rebuild_cache {my ($pkg,$exports,$cache)=@_;s/^&// foreach @$exports;@{$cache}{@$exports}=(1)x @$exports;my$ok=\@{"${pkg}::EXPORT_OK"};if (@$ok){s/^&// foreach @$ok;@{$cache}{@$ok}=(1)x @$ok}}sub heavy_export {my$oldwarn=$SIG{__WARN__};local$SIG{__WARN__}=sub {local$SIG{__WARN__}=$oldwarn;my$text=shift;if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//){require Carp;local$Carp::CarpLevel=1;Carp::carp($text)}else {warn$text}};local$SIG{__DIE__}=sub {require Carp;local$Carp::CarpLevel=1;Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")if $_[0]=~ /^Unable to create sub named "(.*?)::"/};my($pkg,$callpkg,@imports)=@_;my($type,$sym,$cache_is_current,$oops);my($exports,$export_cache)=(\@{"${pkg}::EXPORT"},$Exporter::Cache{$pkg}||={});if (@imports){if (!%$export_cache){_rebuild_cache ($pkg,$exports,$export_cache);$cache_is_current=1}if (grep m{^[/!:]},@imports){my$tagsref=\%{"${pkg}::EXPORT_TAGS"};my$tagdata;my%imports;my($remove,$spec,@names,@allexports);unshift@imports,':DEFAULT' if$imports[0]=~ m/^!/;for$spec (@imports){$remove=$spec =~ s/^!//;if ($spec =~ s/^://){if ($spec eq 'DEFAULT'){@names=@$exports}elsif ($tagdata=$tagsref->{$spec}){@names=@$tagdata}else {warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];++$oops;next}}elsif ($spec =~ m:^/(.*)/$:){my$patn=$1;@allexports=keys %$export_cache unless@allexports;@names=grep(/$patn/,@allexports)}else {@names=($spec)}warn "Import ".($remove ? "del":"add").": @names " if$Exporter::Verbose;if ($remove){for$sym (@names){delete$imports{$sym}}}else {@imports{@names}=(1)x @names}}@imports=keys%imports}my@carp;for$sym (@imports){if (!$export_cache->{$sym}){if ($sym =~ m/^\d/){$pkg->VERSION($sym);if (@imports==1){@imports=@$exports;last}if (@imports==2 and!$imports[1]){@imports=();last}}elsif ($sym !~ s/^&// ||!$export_cache->{$sym}){unless ($cache_is_current){%$export_cache=();_rebuild_cache ($pkg,$exports,$export_cache);$cache_is_current=1}if (!$export_cache->{$sym}){push@carp,qq["$sym" is not exported by the $pkg module\n];$oops++}}}}if ($oops){require Carp;Carp::croak("@{carp}Can't continue after import errors")}}else {@imports=@$exports}my($fail,$fail_cache)=(\@{"${pkg}::EXPORT_FAIL"},$Exporter::FailCache{$pkg}||={});if (@$fail){if (!%$fail_cache){my@expanded=map {/^\w/ ? ($_,'&'.$_): $_}@$fail;warn "${pkg}::EXPORT_FAIL cached: @expanded" if$Exporter::Verbose;@{$fail_cache}{@expanded}=(1)x @expanded}my@failed;for$sym (@imports){push(@failed,$sym)if$fail_cache->{$sym}}if (@failed){@failed=$pkg->export_fail(@failed);for$sym (@failed){require Carp;Carp::carp(qq["$sym" is not implemented by the $pkg module ],"on this architecture")}if (@failed){require Carp;Carp::croak("Can't continue after import errors")}}}warn "Importing into $callpkg from $pkg: ",join(", ",sort@imports)if$Exporter::Verbose;for$sym (@imports){(*{"${callpkg}::$sym"}=\&{"${pkg}::$sym"},next)unless$sym =~ s/^(\W)//;$type=$1;no warnings 'once';*{"${callpkg}::$sym"}=$type eq '&' ? \&{"${pkg}::$sym"}: $type eq '$' ? \${"${pkg}::$sym"}: $type eq '@' ? \@{"${pkg}::$sym"}: $type eq '%' ? \%{"${pkg}::$sym"}: $type eq '*' ? *{"${pkg}::$sym"}: do {require Carp;Carp::croak("Can't export symbol: $type$sym")}}}sub heavy_export_to_level {my$pkg=shift;my$level=shift;(undef)=shift;my$callpkg=caller($level);$pkg->export($callpkg,@_)}sub _push_tags {my($pkg,$var,$syms)=@_;my@nontag=();my$export_tags=\%{"${pkg}::EXPORT_TAGS"};push(@{"${pkg}::$var"},map {$export_tags->{$_}? @{$export_tags->{$_}}: scalar(push(@nontag,$_),$_)}(@$syms)? @$syms : keys %$export_tags);if (@nontag and $^W){require Carp;Carp::carp(join(", ",@nontag)." are not tags of $pkg")}}sub heavy_require_version {my($self,$wanted)=@_;my$pkg=ref$self || $self;return ${pkg}->VERSION($wanted)}sub heavy_export_tags {_push_tags((caller)[0],"EXPORT",\@_)}sub heavy_export_ok_tags {_push_tags((caller)[0],"EXPORT_OK",\@_)}1; -EXPORTER_HEAVY - -$fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_PUSHD'; - use strict;use warnings;package File::pushd;our$VERSION='1.009';our@EXPORT=qw(pushd tempd);our@ISA=qw(Exporter);use Exporter;use Carp;use Cwd qw(getcwd abs_path);use File::Path qw(rmtree);use File::Temp qw();use File::Spec;use overload q{""}=>sub {File::Spec->canonpath($_[0]->{_pushd})},fallback=>1;sub pushd {my ($target_dir,$options)=@_;$options->{untaint_pattern}||= qr{^([-+@\w./]+)$};$target_dir="." unless defined$target_dir;croak "Can't locate directory $target_dir" unless -d $target_dir;my$tainted_orig=getcwd;my$orig;if ($tainted_orig =~ $options->{untaint_pattern}){$orig=$1}else {$orig=$tainted_orig}my$tainted_dest;eval {$tainted_dest=$target_dir ? abs_path($target_dir): $orig};croak "Can't locate absolute path for $target_dir: $@" if $@;my$dest;if ($tainted_dest =~ $options->{untaint_pattern}){$dest=$1}else {$dest=$tainted_dest}if ($dest ne $orig){chdir$dest or croak "Can't chdir to $dest\: $!"}my$self=bless {_pushd=>$dest,_original=>$orig },__PACKAGE__;return$self}sub tempd {my ($options)=@_;my$dir;eval {$dir=pushd(File::Temp::tempdir(CLEANUP=>0),$options)};croak $@ if $@;$dir->{_tempd}=1;return$dir}sub preserve {my$self=shift;return 1 if!$self->{"_tempd"};if (@_==0){return$self->{_preserve}=1}else {return$self->{_preserve}=$_[0]? 1 : 0}}sub DESTROY {my ($self)=@_;my$orig=$self->{_original};chdir$orig if$orig;if ($self->{_tempd}&&!$self->{_preserve}){my$err=do {local $@;eval {rmtree($self->{_pushd})};$@};carp$err if$err}}1; -FILE_PUSHD - -$fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY'; - package HTTP::Tiny;use strict;use warnings;our$VERSION='0.056';use Carp ();my@attributes;BEGIN {@attributes=qw(cookie_jar default_headers http_proxy https_proxy keep_alive local_address max_redirect max_size proxy no_proxy timeout SSL_options verify_SSL);my%persist_ok=map {;$_=>1}qw(cookie_jar default_headers max_redirect max_size);no strict 'refs';no warnings 'uninitialized';for my$accessor (@attributes){*{$accessor}=sub {@_ > 1 ? do {delete $_[0]->{handle}if!$persist_ok{$accessor}&& $_[1]ne $_[0]->{$accessor};$_[0]->{$accessor}=$_[1]}: $_[0]->{$accessor}}}}sub agent {my($self,$agent)=@_;if(@_ > 1){$self->{agent}=(defined$agent && $agent =~ / $/)? $agent .$self->_agent : $agent}return$self->{agent}}sub new {my($class,%args)=@_;my$self={max_redirect=>5,timeout=>60,keep_alive=>1,verify_SSL=>$args{verify_SSL}|| $args{verify_ssl}|| 0,no_proxy=>$ENV{no_proxy},};bless$self,$class;$class->_validate_cookie_jar($args{cookie_jar})if$args{cookie_jar};for my$key (@attributes){$self->{$key}=$args{$key}if exists$args{$key}}$self->agent(exists$args{agent}? $args{agent}: $class->_agent);$self->_set_proxies;return$self}sub _set_proxies {my ($self)=@_;if (!exists$self->{proxy}){$self->{proxy}=$ENV{all_proxy}|| $ENV{ALL_PROXY}}if (defined$self->{proxy}){$self->_split_proxy('generic proxy'=>$self->{proxy})}else {delete$self->{proxy}}if (!exists$self->{http_proxy}){local$ENV{HTTP_PROXY}if$ENV{REQUEST_METHOD};$self->{http_proxy}=$ENV{http_proxy}|| $ENV{HTTP_PROXY}|| $self->{proxy}}if (defined$self->{http_proxy}){$self->_split_proxy(http_proxy=>$self->{http_proxy});$self->{_has_proxy}{http}=1}else {delete$self->{http_proxy}}if (!exists$self->{https_proxy}){$self->{https_proxy}=$ENV{https_proxy}|| $ENV{HTTPS_PROXY}|| $self->{proxy}}if ($self->{https_proxy}){$self->_split_proxy(https_proxy=>$self->{https_proxy});$self->{_has_proxy}{https}=1}else {delete$self->{https_proxy}}unless (ref$self->{no_proxy}eq 'ARRAY'){$self->{no_proxy}=(defined$self->{no_proxy})? [split /\s*,\s*/,$self->{no_proxy}]: []}return}for my$sub_name (qw/get head put post delete/){my$req_method=uc$sub_name;no strict 'refs';eval <<"HERE"}sub post_form {my ($self,$url,$data,$args)=@_;(@_==3 || @_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ ."\n");my$headers={};while (my ($key,$value)=each %{$args->{headers}|| {}}){$headers->{lc$key}=$value}delete$args->{headers};return$self->request('POST',$url,{%$args,content=>$self->www_form_urlencode($data),headers=>{%$headers,'content-type'=>'application/x-www-form-urlencoded' },})}sub mirror {my ($self,$url,$file,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ ."\n");if (-e $file and my$mtime=(stat($file))[9]){$args->{headers}{'if-modified-since'}||= $self->_http_date($mtime)}my$tempfile=$file .int(rand(2**31));require Fcntl;sysopen my$fh,$tempfile,Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()or Carp::croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);binmode$fh;$args->{data_callback}=sub {print {$fh}$_[0]};my$response=$self->request('GET',$url,$args);close$fh or Carp::croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);if ($response->{success}){rename$tempfile,$file or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);my$lm=$response->{headers}{'last-modified'};if ($lm and my$mtime=$self->_parse_http_date($lm)){utime$mtime,$mtime,$file}}$response->{success}||= $response->{status}eq '304';unlink$tempfile;return$response}my%idempotent=map {$_=>1}qw/GET HEAD PUT DELETE OPTIONS TRACE/;sub request {my ($self,$method,$url,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ ."\n");$args ||= {};my$response;for (0 .. 1){$response=eval {$self->_request($method,$url,$args)};last unless $@ && $idempotent{$method}&& $@ =~ m{^(?:Socket closed|Unexpected end)}}if (my$e=$@){if (ref$e eq 'HASH' && exists$e->{status}){return$e}$e="$e";$response={url=>$url,success=>q{},status=>599,reason=>'Internal Exception',content=>$e,headers=>{'content-type'=>'text/plain','content-length'=>length$e,}}}return$response}sub www_form_urlencode {my ($self,$data)=@_;(@_==2 && ref$data)or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ ."\n");(ref$data eq 'HASH' || ref$data eq 'ARRAY')or Carp::croak("form data must be a hash or array reference\n");my@params=ref$data eq 'HASH' ? %$data : @$data;@params % 2==0 or Carp::croak("form data reference must have an even number of terms\n");my@terms;while(@params){my ($key,$value)=splice(@params,0,2);if (ref$value eq 'ARRAY'){unshift@params,map {$key=>$_}@$value}else {push@terms,join("=",map {$self->_uri_escape($_)}$key,$value)}}return join("&",(ref$data eq 'ARRAY')? (@terms): (sort@terms))}sub can_ssl {my ($self)=@_;my($ok,$reason)=(1,'');unless (eval {require IO::Socket::SSL;IO::Socket::SSL->VERSION(1.42)}){$ok=0;$reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/}unless (eval {require Net::SSLeay;Net::SSLeay->VERSION(1.49)}){$ok=0;$reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/}if (ref($self)&& ($self->{verify_SSL}|| $self->{SSL_options}{SSL_verify_mode})){my$handle=HTTP::Tiny::Handle->new(SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},);unless (eval {$handle->_find_CA_file;1}){$ok=0;$reason .= "$@"}}wantarray ? ($ok,$reason): $ok}my%DefaultPort=(http=>80,https=>443,);sub _agent {my$class=ref($_[0])|| $_[0];(my$default_agent=$class)=~ s{::}{-}g;return$default_agent ."/" .$class->VERSION}sub _request {my ($self,$method,$url,$args)=@_;my ($scheme,$host,$port,$path_query,$auth)=$self->_split_url($url);my$request={method=>$method,scheme=>$scheme,host=>$host,port=>$port,host_port=>($port==$DefaultPort{$scheme}? $host : "$host:$port"),uri=>$path_query,headers=>{},};my$handle=delete$self->{handle};if ($handle){unless ($handle->can_reuse($scheme,$host,$port)){$handle->close;undef$handle}}$handle ||= $self->_open_handle($request,$scheme,$host,$port);$self->_prepare_headers_and_cb($request,$args,$url,$auth);$handle->write_request($request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');$self->_update_cookie_jar($url,$response)if$self->{cookie_jar};if (my@redir_args=$self->_maybe_redirect($request,$response,$args)){$handle->close;return$self->_request(@redir_args,$args)}my$known_message_length;if ($method eq 'HEAD' || $response->{status}=~ /^[23]04/){$known_message_length=1}else {my$data_cb=$self->_prepare_data_cb($response,$args);$known_message_length=$handle->read_body($data_cb,$response)}if ($self->{keep_alive}&& $known_message_length && $response->{protocol}eq 'HTTP/1.1' && ($response->{headers}{connection}|| '')ne 'close'){$self->{handle}=$handle}else {$handle->close}$response->{success}=substr($response->{status},0,1)eq '2';$response->{url}=$url;return$response}sub _open_handle {my ($self,$request,$scheme,$host,$port)=@_;my$handle=HTTP::Tiny::Handle->new(timeout=>$self->{timeout},SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},local_address=>$self->{local_address},keep_alive=>$self->{keep_alive});if ($self->{_has_proxy}{$scheme}&&!grep {$host =~ /\Q$_\E$/}@{$self->{no_proxy}}){return$self->_proxy_connect($request,$handle)}else {return$handle->connect($scheme,$host,$port)}}sub _proxy_connect {my ($self,$request,$handle)=@_;my@proxy_vars;if ($request->{scheme}eq 'https'){Carp::croak(qq{No https_proxy defined})unless$self->{https_proxy};@proxy_vars=$self->_split_proxy(https_proxy=>$self->{https_proxy});if ($proxy_vars[0]eq 'https'){Carp::croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}})}}else {Carp::croak(qq{No http_proxy defined})unless$self->{http_proxy};@proxy_vars=$self->_split_proxy(http_proxy=>$self->{http_proxy})}my ($p_scheme,$p_host,$p_port,$p_auth)=@proxy_vars;if (length$p_auth &&!defined$request->{headers}{'proxy-authorization'}){$self->_add_basic_auth_header($request,'proxy-authorization'=>$p_auth)}$handle->connect($p_scheme,$p_host,$p_port);if ($request->{scheme}eq 'https'){$self->_create_proxy_tunnel($request,$handle)}else {$request->{uri}="$request->{scheme}://$request->{host_port}$request->{uri}"}return$handle}sub _split_proxy {my ($self,$type,$proxy)=@_;my ($scheme,$host,$port,$path_query,$auth)=eval {$self->_split_url($proxy)};unless(defined($scheme)&& length($scheme)&& length($host)&& length($port)&& $path_query eq '/'){Carp::croak(qq{$type URL must be in format http[s]://[auth@]:/\n})}return ($scheme,$host,$port,$auth)}sub _create_proxy_tunnel {my ($self,$request,$handle)=@_;$handle->_assert_ssl;my$agent=exists($request->{headers}{'user-agent'})? $request->{headers}{'user-agent'}: $self->{agent};my$connect_request={method=>'CONNECT',uri=>"$request->{host}:$request->{port}",headers=>{host=>"$request->{host}:$request->{port}",'user-agent'=>$agent,}};if ($request->{headers}{'proxy-authorization'}){$connect_request->{headers}{'proxy-authorization'}=delete$request->{headers}{'proxy-authorization'}}$handle->write_request($connect_request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');unless (substr($response->{status},0,1)eq '2'){die$response}$handle->start_ssl($request->{host});return}sub _prepare_headers_and_cb {my ($self,$request,$args,$url,$auth)=@_;for ($self->{default_headers},$args->{headers}){next unless defined;while (my ($k,$v)=each %$_){$request->{headers}{lc$k}=$v}}if (exists$request->{headers}{'host'}){die(qq/The 'Host' header must not be provided as header option\n/)}$request->{headers}{'host'}=$request->{host_port};$request->{headers}{'user-agent'}||= $self->{agent};$request->{headers}{'connection'}="close" unless$self->{keep_alive};if (defined$args->{content}){if (ref$args->{content}eq 'CODE'){$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'transfer-encoding'}='chunked' unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=$args->{content}}elsif (length$args->{content}){my$content=$args->{content};if ($] ge '5.008'){utf8::downgrade($content,1)or die(qq/Wide character in request message body\n/)}$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'content-length'}=length$content unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=sub {substr$content,0,length$content,''}}$request->{trailer_cb}=$args->{trailer_callback}if ref$args->{trailer_callback}eq 'CODE'}if ($self->{cookie_jar}){my$cookies=$self->cookie_jar->cookie_header($url);$request->{headers}{cookie}=$cookies if length$cookies}if (length$auth &&!defined$request->{headers}{authorization}){$self->_add_basic_auth_header($request,'authorization'=>$auth)}return}sub _add_basic_auth_header {my ($self,$request,$header,$auth)=@_;require MIME::Base64;$request->{headers}{$header}="Basic " .MIME::Base64::encode_base64($auth,"");return}sub _prepare_data_cb {my ($self,$response,$args)=@_;my$data_cb=$args->{data_callback};$response->{content}='';if (!$data_cb || $response->{status}!~ /^2/){if (defined$self->{max_size}){$data_cb=sub {$_[1]->{content}.= $_[0];die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)if length $_[1]->{content}> $self->{max_size}}}else {$data_cb=sub {$_[1]->{content}.= $_[0]}}}return$data_cb}sub _update_cookie_jar {my ($self,$url,$response)=@_;my$cookies=$response->{headers}->{'set-cookie'};return unless defined$cookies;my@cookies=ref$cookies ? @$cookies : $cookies;$self->cookie_jar->add($url,$_)for@cookies;return}sub _validate_cookie_jar {my ($class,$jar)=@_;for my$method (qw/add cookie_header/){Carp::croak(qq/Cookie jar must provide the '$method' method\n/)unless ref($jar)&& ref($jar)->can($method)}return}sub _maybe_redirect {my ($self,$request,$response,$args)=@_;my$headers=$response->{headers};my ($status,$method)=($response->{status},$request->{method});if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/))and $headers->{location}and ++$args->{redirects}<= $self->{max_redirect}){my$location=($headers->{location}=~ /^\//)? "$request->{scheme}://$request->{host_port}$headers->{location}" : $headers->{location};return (($status eq '303' ? 'GET' : $method),$location)}return}sub _split_url {my$url=pop;my ($scheme,$host,$path_query)=$url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> or die(qq/Cannot parse URL: '$url'\n/);$scheme=lc$scheme;$path_query="/$path_query" unless$path_query =~ m<\A/>;my$auth='';if ((my$i=index$host,'@')!=-1){$auth=substr$host,0,$i,'';substr$host,0,1,'';$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg}my$port=$host =~ s/:(\d*)\z// && length $1 ? $1 : $scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef;return ($scheme,(length$host ? lc$host : "localhost"),$port,$path_query,$auth)}my$DoW="Sun|Mon|Tue|Wed|Thu|Fri|Sat";my$MoY="Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";sub _http_date {my ($sec,$min,$hour,$mday,$mon,$year,$wday)=gmtime($_[1]);return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",substr($DoW,$wday*4,3),$mday,substr($MoY,$mon*4,3),$year+1900,$hour,$min,$sec)}sub _parse_http_date {my ($self,$str)=@_;require Time::Local;my@tl_parts;if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/){@tl_parts=($5,$4,$3,$2,(index($MoY,$1)/4),$6)}return eval {my$t=@tl_parts ? Time::Local::timegm(@tl_parts): -1;$t < 0 ? undef : $t}}my%escapes=map {chr($_)=>sprintf("%%%02X",$_)}0..255;$escapes{' '}="+";my$unsafe_char=qr/[^A-Za-z0-9\-\._~]/;sub _uri_escape {my ($self,$str)=@_;if ($] ge '5.008'){utf8::encode($str)}else {$str=pack("U*",unpack("C*",$str))if (length$str==do {use bytes;length$str});$str=pack("C*",unpack("C*",$str))}$str =~ s/($unsafe_char)/$escapes{$1}/ge;return$str}package HTTP::Tiny::Handle;use strict;use warnings;use Errno qw[EINTR EPIPE];use IO::Socket qw[SOCK_STREAM];my$SOCKET_CLASS=$ENV{PERL_HTTP_TINY_IPV4_ONLY}? 'IO::Socket::INET' : eval {require IO::Socket::IP;IO::Socket::IP->VERSION(0.25)}? 'IO::Socket::IP' : 'IO::Socket::INET';sub BUFSIZE () {32768}my$Printable=sub {local $_=shift;s/\r/\\r/g;s/\n/\\n/g;s/\t/\\t/g;s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;$_};my$Token=qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;sub new {my ($class,%args)=@_;return bless {rbuf=>'',timeout=>60,max_line_size=>16384,max_header_lines=>64,verify_SSL=>0,SSL_options=>{},%args },$class}sub connect {@_==4 || die(q/Usage: $handle->connect(scheme, host, port)/ ."\n");my ($self,$scheme,$host,$port)=@_;if ($scheme eq 'https'){$self->_assert_ssl}elsif ($scheme ne 'http'){die(qq/Unsupported URL scheme '$scheme'\n/)}$self->{fh}=$SOCKET_CLASS->new(PeerHost=>$host,PeerPort=>$port,$self->{local_address}? (LocalAddr=>$self->{local_address}): (),Proto=>'tcp',Type=>SOCK_STREAM,Timeout=>$self->{timeout},KeepAlive=>!!$self->{keep_alive})or die(qq/Could not connect to '$host:$port': $@\n/);binmode($self->{fh})or die(qq/Could not binmode() socket: '$!'\n/);$self->start_ssl($host)if$scheme eq 'https';$self->{scheme}=$scheme;$self->{host}=$host;$self->{port}=$port;$self->{pid}=$$;$self->{tid}=_get_tid();return$self}sub start_ssl {my ($self,$host)=@_;if (ref($self->{fh})eq 'IO::Socket::SSL'){unless ($self->{fh}->stop_SSL){my$ssl_err=IO::Socket::SSL->errstr;die(qq/Error halting prior SSL connection: $ssl_err/)}}my$ssl_args=$self->_ssl_args($host);IO::Socket::SSL->start_SSL($self->{fh},%$ssl_args,SSL_create_ctx_callback=>sub {my$ctx=shift;Net::SSLeay::CTX_set_mode($ctx,Net::SSLeay::MODE_AUTO_RETRY())},);unless (ref($self->{fh})eq 'IO::Socket::SSL'){my$ssl_err=IO::Socket::SSL->errstr;die(qq/SSL connection failed for $host: $ssl_err\n/)}}sub close {@_==1 || die(q/Usage: $handle->close()/ ."\n");my ($self)=@_;CORE::close($self->{fh})or die(qq/Could not close socket: '$!'\n/)}sub write {@_==2 || die(q/Usage: $handle->write(buf)/ ."\n");my ($self,$buf)=@_;if ($] ge '5.008'){utf8::downgrade($buf,1)or die(qq/Wide character in write()\n/)}my$len=length$buf;my$off=0;local$SIG{PIPE}='IGNORE';while (){$self->can_write or die(qq/Timed out while waiting for socket to become ready for writing\n/);my$r=syswrite($self->{fh},$buf,$len,$off);if (defined$r){$len -= $r;$off += $r;last unless$len > 0}elsif ($!==EPIPE){die(qq/Socket closed by remote server: $!\n/)}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not write to SSL socket: '$err'\n /)}else {die(qq/Could not write to socket: '$!'\n/)}}}return$off}sub read {@_==2 || @_==3 || die(q/Usage: $handle->read(len [, allow_partial])/ ."\n");my ($self,$len,$allow_partial)=@_;my$buf='';my$got=length$self->{rbuf};if ($got){my$take=($got < $len)? $got : $len;$buf=substr($self->{rbuf},0,$take,'');$len -= $take}while ($len > 0){$self->can_read or die(q/Timed out while waiting for socket to become ready for reading/ ."\n");my$r=sysread($self->{fh},$buf,$len,length$buf);if (defined$r){last unless$r;$len -= $r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}if ($len &&!$allow_partial){die(qq/Unexpected end of stream\n/)}return$buf}sub readline {@_==1 || die(q/Usage: $handle->readline()/ ."\n");my ($self)=@_;while (){if ($self->{rbuf}=~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x){return $1}if (length$self->{rbuf}>= $self->{max_line_size}){die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/)}$self->can_read or die(qq/Timed out while waiting for socket to become ready for reading\n/);my$r=sysread($self->{fh},$self->{rbuf},BUFSIZE,length$self->{rbuf});if (defined$r){last unless$r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}die(qq/Unexpected end of stream while looking for line\n/)}sub read_header_lines {@_==1 || @_==2 || die(q/Usage: $handle->read_header_lines([headers])/ ."\n");my ($self,$headers)=@_;$headers ||= {};my$lines=0;my$val;while (){my$line=$self->readline;if (++$lines >= $self->{max_header_lines}){die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/)}elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x){my ($field_name)=lc $1;if (exists$headers->{$field_name}){for ($headers->{$field_name}){$_=[$_]unless ref $_ eq "ARRAY";push @$_,$2;$val=\$_->[-1]}}else {$val=\($headers->{$field_name}=$2)}}elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x){$val or die(qq/Unexpected header continuation line\n/);next unless length $1;$$val .= ' ' if length $$val;$$val .= $1}elsif ($line =~ /\A \x0D?\x0A \z/x){last}else {die(q/Malformed header line: / .$Printable->($line)."\n")}}return$headers}sub write_request {@_==2 || die(q/Usage: $handle->write_request(request)/ ."\n");my($self,$request)=@_;$self->write_request_header(@{$request}{qw/method uri headers/});$self->write_body($request)if$request->{cb};return}my%HeaderCase=('content-md5'=>'Content-MD5','etag'=>'ETag','te'=>'TE','www-authenticate'=>'WWW-Authenticate','x-xss-protection'=>'X-XSS-Protection',);sub write_header_lines {(@_==2 || @_==3 && ref $_[1]eq 'HASH')|| die(q/Usage: $handle->write_header_lines(headers[,prefix])/ ."\n");my($self,$headers,$prefix_data)=@_;my$buf=(defined$prefix_data ? $prefix_data : '');while (my ($k,$v)=each %$headers){my$field_name=lc$k;if (exists$HeaderCase{$field_name}){$field_name=$HeaderCase{$field_name}}else {$field_name =~ /\A $Token+ \z/xo or die(q/Invalid HTTP header field name: / .$Printable->($field_name)."\n");$field_name =~ s/\b(\w)/\u$1/g;$HeaderCase{lc$field_name}=$field_name}for (ref$v eq 'ARRAY' ? @$v : $v){$_='' unless defined $_;$buf .= "$field_name: $_\x0D\x0A"}}$buf .= "\x0D\x0A";return$self->write($buf)}sub read_body {@_==3 || die(q/Usage: $handle->read_body(callback, response)/ ."\n");my ($self,$cb,$response)=@_;my$te=$response->{headers}{'transfer-encoding'}|| '';my$chunked=grep {/chunked/i}(ref$te eq 'ARRAY' ? @$te : $te);return$chunked ? $self->read_chunked_body($cb,$response): $self->read_content_body($cb,$response)}sub write_body {@_==2 || die(q/Usage: $handle->write_body(request)/ ."\n");my ($self,$request)=@_;if ($request->{headers}{'content-length'}){return$self->write_content_body($request)}else {return$self->write_chunked_body($request)}}sub read_content_body {@_==3 || @_==4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ ."\n");my ($self,$cb,$response,$content_length)=@_;$content_length ||= $response->{headers}{'content-length'};if (defined$content_length){my$len=$content_length;while ($len > 0){my$read=($len > BUFSIZE)? BUFSIZE : $len;$cb->($self->read($read,0),$response);$len -= $read}return length($self->{rbuf})==0}my$chunk;$cb->($chunk,$response)while length($chunk=$self->read(BUFSIZE,1));return}sub write_content_body {@_==2 || die(q/Usage: $handle->write_content_body(request)/ ."\n");my ($self,$request)=@_;my ($len,$content_length)=(0,$request->{headers}{'content-length'});while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_content()\n/)}$len += $self->write($data)}$len==$content_length or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);return$len}sub read_chunked_body {@_==3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ ."\n");my ($self,$cb,$response)=@_;while (){my$head=$self->readline;$head =~ /\A ([A-Fa-f0-9]+)/x or die(q/Malformed chunk head: / .$Printable->($head)."\n");my$len=hex($1)or last;$self->read_content_body($cb,$response,$len);$self->read(2)eq "\x0D\x0A" or die(qq/Malformed chunk: missing CRLF after chunk data\n/)}$self->read_header_lines($response->{headers});return 1}sub write_chunked_body {@_==2 || die(q/Usage: $handle->write_chunked_body(request)/ ."\n");my ($self,$request)=@_;my$len=0;while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_chunked_body()\n/)}$len += length$data;my$chunk=sprintf '%X',length$data;$chunk .= "\x0D\x0A";$chunk .= $data;$chunk .= "\x0D\x0A";$self->write($chunk)}$self->write("0\x0D\x0A");$self->write_header_lines($request->{trailer_cb}->())if ref$request->{trailer_cb}eq 'CODE';return$len}sub read_response_header {@_==1 || die(q/Usage: $handle->read_response_header()/ ."\n");my ($self)=@_;my$line=$self->readline;$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x or die(q/Malformed Status-Line: / .$Printable->($line)."\n");my ($protocol,$version,$status,$reason)=($1,$2,$3,$4);die (qq/Unsupported HTTP protocol: $protocol\n/)unless$version =~ /0*1\.0*[01]/;return {status=>$status,reason=>$reason,headers=>$self->read_header_lines,protocol=>$protocol,}}sub write_request_header {@_==4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ ."\n");my ($self,$method,$request_uri,$headers)=@_;return$self->write_header_lines($headers,"$method $request_uri HTTP/1.1\x0D\x0A")}sub _do_timeout {my ($self,$type,$timeout)=@_;$timeout=$self->{timeout}unless defined$timeout && $timeout >= 0;my$fd=fileno$self->{fh};defined$fd && $fd >= 0 or die(qq/select(2): 'Bad file descriptor'\n/);my$initial=time;my$pending=$timeout;my$nfound;vec(my$fdset='',$fd,1)=1;while (){$nfound=($type eq 'read')? select($fdset,undef,undef,$pending): select(undef,$fdset,undef,$pending);if ($nfound==-1){$!==EINTR or die(qq/select(2): '$!'\n/);redo if!$timeout || ($pending=$timeout - (time - $initial))> 0;$nfound=0}last}$!=0;return$nfound}sub can_read {@_==1 || @_==2 || die(q/Usage: $handle->can_read([timeout])/ ."\n");my$self=shift;if (ref($self->{fh})eq 'IO::Socket::SSL'){return 1 if$self->{fh}->pending}return$self->_do_timeout('read',@_)}sub can_write {@_==1 || @_==2 || die(q/Usage: $handle->can_write([timeout])/ ."\n");my$self=shift;return$self->_do_timeout('write',@_)}sub _assert_ssl {my($ok,$reason)=HTTP::Tiny->can_ssl();die$reason unless$ok}sub can_reuse {my ($self,$scheme,$host,$port)=@_;return 0 if $self->{pid}!=$$ || $self->{tid}!=_get_tid()|| length($self->{rbuf})|| $scheme ne $self->{scheme}|| $host ne $self->{host}|| $port ne $self->{port}|| eval {$self->can_read(0)}|| $@ ;return 1}sub _find_CA_file {my$self=shift();if ($self->{SSL_options}->{SSL_ca_file}){unless (-r $self->{SSL_options}->{SSL_ca_file}){die qq/SSL_ca_file '$self->{SSL_options}->{SSL_ca_file}' not found or not readable\n/}return$self->{SSL_options}->{SSL_ca_file}}return Mozilla::CA::SSL_ca_file()if eval {require Mozilla::CA;1};for my$ca_bundle ("/etc/ssl/certs/ca-certificates.crt","/etc/pki/tls/certs/ca-bundle.crt","/etc/ssl/ca-bundle.pem","/etc/openssl/certs/ca-certificates.crt","/etc/ssl/cert.pem","/usr/local/share/certs/ca-root-nss.crt","/etc/pki/tls/cacert.pem","/etc/certs/ca-certificates.crt",){return$ca_bundle if -e $ca_bundle}die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ .qq/Try installing Mozilla::CA from CPAN\n/}sub _get_tid {no warnings 'reserved';return threads->can("tid")? threads->tid : 0}sub _ssl_args {my ($self,$host)=@_;my%ssl_args;if (Net::SSLeay::OPENSSL_VERSION_NUMBER()>= 0x01000000){$ssl_args{SSL_hostname}=$host,}if ($self->{verify_SSL}){$ssl_args{SSL_verifycn_scheme}='http';$ssl_args{SSL_verifycn_name}=$host;$ssl_args{SSL_verify_mode}=0x01;$ssl_args{SSL_ca_file}=$self->_find_CA_file}else {$ssl_args{SSL_verifycn_scheme}='none';$ssl_args{SSL_verify_mode}=0x00}for my$k (keys %{$self->{SSL_options}}){$ssl_args{$k}=$self->{SSL_options}{$k}if$k =~ m/^SSL_/}return \%ssl_args}1; - sub $sub_name { - my (\$self, \$url, \$args) = \@_; - \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH') - or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n"); - return \$self->request('$req_method', \$url, \$args || {}); - } - HERE -HTTP_TINY - -$fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP'; - package JSON::PP;use 5.005;use strict;use base qw(Exporter);use overload ();use Carp ();use B ();$JSON::PP::VERSION='2.27300';@JSON::PP::EXPORT=qw(encode_json decode_json from_json to_json);use constant P_ASCII=>0;use constant P_LATIN1=>1;use constant P_UTF8=>2;use constant P_INDENT=>3;use constant P_CANONICAL=>4;use constant P_SPACE_BEFORE=>5;use constant P_SPACE_AFTER=>6;use constant P_ALLOW_NONREF=>7;use constant P_SHRINK=>8;use constant P_ALLOW_BLESSED=>9;use constant P_CONVERT_BLESSED=>10;use constant P_RELAXED=>11;use constant P_LOOSE=>12;use constant P_ALLOW_BIGNUM=>13;use constant P_ALLOW_BAREKEY=>14;use constant P_ALLOW_SINGLEQUOTE=>15;use constant P_ESCAPE_SLASH=>16;use constant P_AS_NONBLESSED=>17;use constant P_ALLOW_UNKNOWN=>18;use constant OLD_PERL=>$] < 5.008 ? 1 : 0;BEGIN {my@xs_compati_bit_properties=qw(latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink allow_blessed convert_blessed relaxed allow_unknown);my@pp_bit_properties=qw(allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed);if ($] < 5.008){my$helper=$] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';eval qq| require $helper |;if ($@){Carp::croak $@}}for my$name (@xs_compati_bit_properties,@pp_bit_properties){my$flag_name='P_' .uc($name);eval qq/ - sub $name { - my \$enable = defined \$_[1] ? \$_[1] : 1; - - if (\$enable) { - \$_[0]->{PROPS}->[$flag_name] = 1; - } - else { - \$_[0]->{PROPS}->[$flag_name] = 0; - } - - \$_[0]; - } - - sub get_$name { - \$_[0]->{PROPS}->[$flag_name] ? 1 : ''; - } - /}}my%encode_allow_method =map {($_=>1)}qw/utf8 pretty allow_nonref latin1 self_encode escape_slash allow_blessed convert_blessed indent indent_length allow_bignum as_nonblessed/;my%decode_allow_method =map {($_=>1)}qw/utf8 allow_nonref loose allow_singlequote allow_bignum allow_barekey max_size relaxed/;my$JSON;sub encode_json ($) {($JSON ||= __PACKAGE__->new->utf8)->encode(@_)}sub decode_json {($JSON ||= __PACKAGE__->new->utf8)->decode(@_)}sub to_json($) {Carp::croak ("JSON::PP::to_json has been renamed to encode_json.")}sub from_json($) {Carp::croak ("JSON::PP::from_json has been renamed to decode_json.")}sub new {my$class=shift;my$self={max_depth=>512,max_size=>0,indent=>0,FLAGS=>0,fallback=>sub {encode_error('Invalid value. JSON can only reference.')},indent_length=>3,};bless$self,$class}sub encode {return $_[0]->PP_encode_json($_[1])}sub decode {return $_[0]->PP_decode_json($_[1],0x00000000)}sub decode_prefix {return $_[0]->PP_decode_json($_[1],0x00000001)}sub pretty {my ($self,$v)=@_;my$enable=defined$v ? $v : 1;if ($enable){$self->indent(1)->indent_length(3)->space_before(1)->space_after(1)}else {$self->indent(0)->space_before(0)->space_after(0)}$self}sub max_depth {my$max=defined $_[1]? $_[1]: 0x80000000;$_[0]->{max_depth}=$max;$_[0]}sub get_max_depth {$_[0]->{max_depth}}sub max_size {my$max=defined $_[1]? $_[1]: 0;$_[0]->{max_size}=$max;$_[0]}sub get_max_size {$_[0]->{max_size}}sub filter_json_object {$_[0]->{cb_object}=defined $_[1]? $_[1]: 0;$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub filter_json_single_key_object {if (@_ > 1){$_[0]->{cb_sk_object}->{$_[1]}=$_[2]}$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub indent_length {if (!defined $_[1]or $_[1]> 15 or $_[1]< 0){Carp::carp "The acceptable range of indent_length() is 0 to 15."}else {$_[0]->{indent_length}=$_[1]}$_[0]}sub get_indent_length {$_[0]->{indent_length}}sub sort_by {$_[0]->{sort_by}=defined $_[1]? $_[1]: 1;$_[0]}sub allow_bigint {Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.")}{my$max_depth;my$indent;my$ascii;my$latin1;my$utf8;my$space_before;my$space_after;my$canonical;my$allow_blessed;my$convert_blessed;my$indent_length;my$escape_slash;my$bignum;my$as_nonblessed;my$depth;my$indent_count;my$keysort;sub PP_encode_json {my$self=shift;my$obj=shift;$indent_count=0;$depth=0;my$idx=$self->{PROPS};($ascii,$latin1,$utf8,$indent,$canonical,$space_before,$space_after,$allow_blessed,$convert_blessed,$escape_slash,$bignum,$as_nonblessed)=@{$idx}[P_ASCII .. P_SPACE_AFTER,P_ALLOW_BLESSED,P_CONVERT_BLESSED,P_ESCAPE_SLASH,P_ALLOW_BIGNUM,P_AS_NONBLESSED];($max_depth,$indent_length)=@{$self}{qw/max_depth indent_length/};$keysort=$canonical ? sub {$a cmp $b}: undef;if ($self->{sort_by}){$keysort=ref($self->{sort_by})eq 'CODE' ? $self->{sort_by}: $self->{sort_by}=~ /\D+/ ? $self->{sort_by}: sub {$a cmp $b}}encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")if(!ref$obj and!$idx->[P_ALLOW_NONREF ]);my$str=$self->object_to_json($obj);$str .= "\n" if ($indent);unless ($ascii or $latin1 or $utf8){utf8::upgrade($str)}if ($idx->[P_SHRINK ]){utf8::downgrade($str,1)}return$str}sub object_to_json {my ($self,$obj)=@_;my$type=ref($obj);if($type eq 'HASH'){return$self->hash_to_json($obj)}elsif($type eq 'ARRAY'){return$self->array_to_json($obj)}elsif ($type){if (blessed($obj)){return$self->value_to_json($obj)if ($obj->isa('JSON::PP::Boolean'));if ($convert_blessed and $obj->can('TO_JSON')){my$result=$obj->TO_JSON();if (defined$result and ref($result)){if (refaddr($obj)eq refaddr($result)){encode_error(sprintf("%s::TO_JSON method returned same object as was passed instead of a new one",ref$obj))}}return$self->object_to_json($result)}return "$obj" if ($bignum and _is_bignum($obj));return$self->blessed_to_json($obj)if ($allow_blessed and $as_nonblessed);encode_error(sprintf("encountered object '%s', but neither allow_blessed " ."nor convert_blessed settings are enabled",$obj))unless ($allow_blessed);return 'null'}else {return$self->value_to_json($obj)}}else{return$self->value_to_json($obj)}}sub hash_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');my$del=($space_before ? ' ' : '').':' .($space_after ? ' ' : '');for my$k (_sort($obj)){if (OLD_PERL){utf8::decode($k)}push@res,string_to_json($self,$k).$del .($self->object_to_json($obj->{$k})|| $self->value_to_json($obj->{$k}))}--$depth;$self->_down_indent()if ($indent);return '{' .(@res ? $pre : '').(@res ? join(",$pre",@res).$post : '').'}'}sub array_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');for my$v (@$obj){push@res,$self->object_to_json($v)|| $self->value_to_json($v)}--$depth;$self->_down_indent()if ($indent);return '[' .(@res ? $pre : '').(@res ? join(",$pre",@res).$post : '').']'}sub value_to_json {my ($self,$value)=@_;return 'null' if(!defined$value);my$b_obj=B::svref_2object(\$value);my$flags=$b_obj->FLAGS;return$value if$flags & (B::SVp_IOK | B::SVp_NOK)and!($flags & B::SVp_POK);my$type=ref($value);if(!$type){return string_to_json($self,$value)}elsif(blessed($value)and $value->isa('JSON::PP::Boolean')){return $$value==1 ? 'true' : 'false'}elsif ($type){if ((overload::StrVal($value)=~ /=(\w+)/)[0]){return$self->value_to_json("$value")}if ($type eq 'SCALAR' and defined $$value){return $$value eq '1' ? 'true' : $$value eq '0' ? 'false' : $self->{PROPS}->[P_ALLOW_UNKNOWN ]? 'null' : encode_error("cannot encode reference to scalar")}if ($self->{PROPS}->[P_ALLOW_UNKNOWN ]){return 'null'}else {if ($type eq 'SCALAR' or $type eq 'REF'){encode_error("cannot encode reference to scalar")}else {encode_error("encountered $value, but JSON can only represent references to arrays or hashes")}}}else {return$self->{fallback}->($value)if ($self->{fallback}and ref($self->{fallback})eq 'CODE');return 'null'}}my%esc=("\n"=>'\n',"\r"=>'\r',"\t"=>'\t',"\f"=>'\f',"\b"=>'\b',"\""=>'\"',"\\"=>'\\\\',"\'"=>'\\\'',);sub string_to_json {my ($self,$arg)=@_;$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;$arg =~ s/\//\\\//g if ($escape_slash);$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;if ($ascii){$arg=JSON_PP_encode_ascii($arg)}if ($latin1){$arg=JSON_PP_encode_latin1($arg)}if ($utf8){utf8::encode($arg)}return '"' .$arg .'"'}sub blessed_to_json {my$reftype=reftype($_[1])|| '';if ($reftype eq 'HASH'){return $_[0]->hash_to_json($_[1])}elsif ($reftype eq 'ARRAY'){return $_[0]->array_to_json($_[1])}else {return 'null'}}sub encode_error {my$error=shift;Carp::croak "$error"}sub _sort {defined$keysort ? (sort$keysort (keys %{$_[0]})): keys %{$_[0]}}sub _up_indent {my$self=shift;my$space=' ' x $indent_length;my ($pre,$post)=('','');$post="\n" .$space x $indent_count;$indent_count++;$pre="\n" .$space x $indent_count;return ($pre,$post)}sub _down_indent {$indent_count--}sub PP_encode_box {{depth=>$depth,indent_count=>$indent_count,}}}sub _encode_ascii {join('',map {$_ <= 127 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_latin1 {join('',map {$_ <= 255 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_surrogates {my$uni=$_[0]- 0x10000;return ($uni / 0x400 + 0xD800,$uni % 0x400 + 0xDC00)}sub _is_bignum {$_[0]->isa('Math::BigInt')or $_[0]->isa('Math::BigFloat')}my$max_intsize;BEGIN {my$checkint=1111;for my$d (5..64){$checkint .= 1;my$int=eval qq| $checkint |;if ($int =~ /[eE]/){$max_intsize=$d - 1;last}}}{my%escapes=(b=>"\x8",t=>"\x9",n=>"\xA",f=>"\xC",r=>"\xD",'\\'=>'\\','"'=>'"','/'=>'/',);my$text;my$at;my$ch;my$len;my$depth;my$encoding;my$is_valid_utf8;my$utf8_len;my$utf8;my$max_depth;my$max_size;my$relaxed;my$cb_object;my$cb_sk_object;my$F_HOOK;my$allow_bigint;my$singlequote;my$loose;my$allow_barekey;sub PP_decode_json {my ($self,$opt);($self,$text,$opt)=@_;($at,$ch,$depth)=(0,'',0);if (!defined$text or ref$text){decode_error("malformed JSON string, neither array, object, number, string or atom")}my$idx=$self->{PROPS};($utf8,$relaxed,$loose,$allow_bigint,$allow_barekey,$singlequote)=@{$idx}[P_UTF8,P_RELAXED,P_LOOSE .. P_ALLOW_SINGLEQUOTE];if ($utf8){utf8::downgrade($text,1)or Carp::croak("Wide character in subroutine entry")}else {utf8::upgrade($text);utf8::encode($text)}$len=length$text;($max_depth,$max_size,$cb_object,$cb_sk_object,$F_HOOK)=@{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};if ($max_size > 1){use bytes;my$bytes=length$text;decode_error(sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" ,$bytes,$max_size),1)if ($bytes > $max_size)}my@octets=unpack('C4',$text);$encoding=($octets[0]and $octets[1])? 'UTF-8' : (!$octets[0]and $octets[1])? 'UTF-16BE' : (!$octets[0]and!$octets[1])? 'UTF-32BE' : ($octets[2])? 'UTF-16LE' : (!$octets[2])? 'UTF-32LE' : 'unknown';white();my$valid_start=defined$ch;my$result=value();return undef if (!$result && ($opt & 0x10000000));decode_error("malformed JSON string, neither array, object, number, string or atom")unless$valid_start;if (!$idx->[P_ALLOW_NONREF ]and!ref$result){decode_error('JSON text must be an object or array (but found number, string, true, false or null,' .' use allow_nonref to allow this)',1)}Carp::croak('something wrong.')if$len < $at;my$consumed=defined$ch ? $at - 1 : $at;white();if ($ch){return ($result,$consumed)if ($opt & 0x00000001);decode_error("garbage after JSON object")}($opt & 0x00000001)? ($result,$consumed): $result}sub next_chr {return$ch=undef if($at >= $len);$ch=substr($text,$at++,1)}sub value {white();return if(!defined$ch);return object()if($ch eq '{');return array()if($ch eq '[');return string()if($ch eq '"' or ($singlequote and $ch eq "'"));return number()if($ch =~ /[0-9]/ or $ch eq '-');return word()}sub string {my ($i,$s,$t,$u);my$utf16;my$is_utf8;($is_valid_utf8,$utf8_len)=('',0);$s='';if($ch eq '"' or ($singlequote and $ch eq "'")){my$boundChar=$ch;OUTER: while(defined(next_chr())){if($ch eq $boundChar){next_chr();if ($utf16){decode_error("missing low surrogate character in surrogate pair")}utf8::decode($s)if($is_utf8);return$s}elsif($ch eq '\\'){next_chr();if(exists$escapes{$ch}){$s .= $escapes{$ch}}elsif($ch eq 'u'){my$u='';for(1..4){$ch=next_chr();last OUTER if($ch !~ /[0-9a-fA-F]/);$u .= $ch}if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/){$utf16=$u}elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/){unless (defined$utf16){decode_error("missing high surrogate character in surrogate pair")}$is_utf8=1;$s .= JSON_PP_decode_surrogates($utf16,$u)|| next;$utf16=undef}else {if (defined$utf16){decode_error("surrogate pair expected")}if ((my$hex=hex($u))> 127){$is_utf8=1;$s .= JSON_PP_decode_unicode($u)|| next}else {$s .= chr$hex}}}else{unless ($loose){$at -= 2;decode_error('illegal backslash escape sequence in string')}$s .= $ch}}else{if (ord$ch > 127){unless($ch=is_valid_utf8($ch)){$at -= 1;decode_error("malformed UTF-8 character in JSON string")}else {$at += $utf8_len - 1}$is_utf8=1}if (!$loose){if ($ch =~ /[\x00-\x1f\x22\x5c]/){$at--;decode_error('invalid character encountered while parsing JSON string')}}$s .= $ch}}}decode_error("unexpected end of string while parsing JSON string")}sub white {while(defined$ch){if($ch le ' '){next_chr()}elsif($ch eq '/'){next_chr();if(defined$ch and $ch eq '/'){1 while(defined(next_chr())and $ch ne "\n" and $ch ne "\r")}elsif(defined$ch and $ch eq '*'){next_chr();while(1){if(defined$ch){if($ch eq '*'){if(defined(next_chr())and $ch eq '/'){next_chr();last}}else{next_chr()}}else{decode_error("Unterminated comment")}}next}else{$at--;decode_error("malformed JSON string, neither array, object, number, string or atom")}}else{if ($relaxed and $ch eq '#'){pos($text)=$at;$text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;$at=pos($text);next_chr;next}last}}}sub array {my$a=$_[0]|| [];decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq ']'){--$depth;next_chr();return$a}else {while(defined($ch)){push @$a,value();white();if (!defined$ch){last}if($ch eq ']'){--$depth;next_chr();return$a}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq ']'){--$depth;next_chr();return$a}}}decode_error(", or ] expected while parsing array")}sub object {my$o=$_[0]|| {};my$k;decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}else {while (defined$ch){$k=($allow_barekey and $ch ne '"' and $ch ne "'")? bareKey(): string();white();if(!defined$ch or $ch ne ':'){$at--;decode_error("':' expected")}next_chr();$o->{$k}=value();white();last if (!defined$ch);if($ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}}}$at--;decode_error(", or } expected while parsing object/hash")}sub bareKey {my$key;while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){$key .= $ch;next_chr()}return$key}sub word {my$word=substr($text,$at-1,4);if($word eq 'true'){$at += 3;next_chr;return$JSON::PP::true}elsif($word eq 'null'){$at += 3;next_chr;return undef}elsif($word eq 'fals'){$at += 3;if(substr($text,$at,1)eq 'e'){$at++;next_chr;return$JSON::PP::false}}$at--;decode_error("'null' expected")if ($word =~ /^n/);decode_error("'true' expected")if ($word =~ /^t/);decode_error("'false' expected")if ($word =~ /^f/);decode_error("malformed JSON string, neither array, object, number, string or atom")}sub number {my$n='';my$v;if($ch eq '0'){my$peek=substr($text,$at,1);my$hex=$peek =~ /[xX]/;if($hex){decode_error("malformed number (leading zero must not be followed by another digit)");($n)=(substr($text,$at+1)=~ /^([0-9a-fA-F]+)/)}else{($n)=(substr($text,$at)=~ /^([0-7]+)/);if (defined$n and length$n > 1){decode_error("malformed number (leading zero must not be followed by another digit)")}}if(defined$n and length($n)){if (!$hex and length($n)==1){decode_error("malformed number (leading zero must not be followed by another digit)")}$at += length($n)+ $hex;next_chr;return$hex ? hex($n): oct($n)}}if($ch eq '-'){$n='-';next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after initial minus)")}}while(defined$ch and $ch =~ /\d/){$n .= $ch;next_chr}if(defined$ch and $ch eq '.'){$n .= '.';next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after decimal point)")}else {$n .= $ch}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}if(defined$ch and ($ch eq 'e' or $ch eq 'E')){$n .= $ch;next_chr;if(defined($ch)and ($ch eq '+' or $ch eq '-')){$n .= $ch;next_chr;if (!defined$ch or $ch =~ /\D/){decode_error("malformed number (no digits after exp sign)")}$n .= $ch}elsif(defined($ch)and $ch =~ /\d/){$n .= $ch}else {decode_error("malformed number (no digits after exp sign)")}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}$v .= $n;if ($v !~ /[.eE]/ and length$v > $max_intsize){if ($allow_bigint){require Math::BigInt;return Math::BigInt->new($v)}else {return "$v"}}elsif ($allow_bigint){require Math::BigFloat;return Math::BigFloat->new($v)}return 0+$v}sub is_valid_utf8 {$utf8_len=$_[0]=~ /[\x00-\x7F]/ ? 1 : $_[0]=~ /[\xC2-\xDF]/ ? 2 : $_[0]=~ /[\xE0-\xEF]/ ? 3 : $_[0]=~ /[\xF0-\xF4]/ ? 4 : 0 ;return unless$utf8_len;my$is_valid_utf8=substr($text,$at - 1,$utf8_len);return ($is_valid_utf8 =~ /^(?: - [\x00-\x7F] - |[\xC2-\xDF][\x80-\xBF] - |[\xE0][\xA0-\xBF][\x80-\xBF] - |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] - |[\xED][\x80-\x9F][\x80-\xBF] - |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] - |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] - |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] - |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] - )$/x)? $is_valid_utf8 : ''}sub decode_error {my$error=shift;my$no_rep=shift;my$str=defined$text ? substr($text,$at): '';my$mess='';my$type=$] >= 5.008 ? 'U*' : $] < 5.006 ? 'C*' : utf8::is_utf8($str)? 'U*' : 'C*' ;for my$c (unpack($type,$str)){$mess .= $c==0x07 ? '\a' : $c==0x09 ? '\t' : $c==0x0a ? '\n' : $c==0x0d ? '\r' : $c==0x0c ? '\f' : $c < 0x20 ? sprintf('\x{%x}',$c): $c==0x5c ? '\\\\' : $c < 0x80 ? chr($c): sprintf('\x{%x}',$c);if (length$mess >= 20){$mess .= '...';last}}unless (length$mess){$mess='(end of string)'}Carp::croak ($no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")")}sub _json_object_hook {my$o=$_[0];my@ks=keys %{$o};if ($cb_sk_object and @ks==1 and exists$cb_sk_object->{$ks[0]}and ref$cb_sk_object->{$ks[0]}){my@val=$cb_sk_object->{$ks[0]}->($o->{$ks[0]});if (@val==1){return$val[0]}}my@val=$cb_object->($o)if ($cb_object);if (@val==0 or @val > 1){return$o}else {return$val[0]}}sub PP_decode_box {{text=>$text,at=>$at,ch=>$ch,len=>$len,depth=>$depth,encoding=>$encoding,is_valid_utf8=>$is_valid_utf8,}}}sub _decode_surrogates {my$uni=0x10000 + (hex($_[0])- 0xD800)* 0x400 + (hex($_[1])- 0xDC00);my$un=pack('U*',$uni);utf8::encode($un);return$un}sub _decode_unicode {my$un=pack('U',hex shift);utf8::encode($un);return$un}BEGIN {unless (defined&utf8::is_utf8){require Encode;*utf8::is_utf8=*Encode::is_utf8}if ($] >= 5.008){*JSON::PP::JSON_PP_encode_ascii=\&_encode_ascii;*JSON::PP::JSON_PP_encode_latin1=\&_encode_latin1;*JSON::PP::JSON_PP_decode_surrogates=\&_decode_surrogates;*JSON::PP::JSON_PP_decode_unicode=\&_decode_unicode}if ($] >= 5.008 and $] < 5.008003){package JSON::PP;require subs;subs->import('join');eval q| - sub join { - return '' if (@_ < 2); - my $j = shift; - my $str = shift; - for (@_) { $str .= $j . $_; } - return $str; - } - |}sub JSON::PP::incr_parse {local$Carp::CarpLevel=1;($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_parse(@_)}sub JSON::PP::incr_skip {($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_skip}sub JSON::PP::incr_reset {($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_reset}eval q{ - sub JSON::PP::incr_text : lvalue { - $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; - - if ( $_[0]->{_incr_parser}->{incr_parsing} ) { - Carp::croak("incr_text can not be called when the incremental parser already started parsing"); - } - $_[0]->{_incr_parser}->{incr_text}; - } - } if ($] >= 5.006)}BEGIN {eval 'require Scalar::Util';unless($@){*JSON::PP::blessed=\&Scalar::Util::blessed;*JSON::PP::reftype=\&Scalar::Util::reftype;*JSON::PP::refaddr=\&Scalar::Util::refaddr}else{eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';*JSON::PP::blessed=sub {local($@,$SIG{__DIE__},$SIG{__WARN__});ref($_[0])? eval {$_[0]->a_sub_not_likely_to_be_here}: undef};my%tmap=qw(B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP);*JSON::PP::reftype=sub {my$r=shift;return undef unless length(ref($r));my$t=ref(B::svref_2object($r));return exists$tmap{$t}? $tmap{$t}: length(ref($$r))? 'REF' : 'SCALAR'};*JSON::PP::refaddr=sub {return undef unless length(ref($_[0]));my$addr;if(defined(my$pkg=blessed($_[0]))){$addr .= bless $_[0],'Scalar::Util::Fake';bless $_[0],$pkg}else {$addr .= $_[0]}$addr =~ /0x(\w+)/;local $^W;hex($1)}}}$JSON::PP::true=do {bless \(my$dummy=1),"JSON::PP::Boolean"};$JSON::PP::false=do {bless \(my$dummy=0),"JSON::PP::Boolean"};sub is_bool {defined $_[0]and UNIVERSAL::isa($_[0],"JSON::PP::Boolean")}sub true {$JSON::PP::true}sub false {$JSON::PP::false}sub null {undef}package JSON::PP::Boolean;use overload ("0+"=>sub {${$_[0]}},"++"=>sub {$_[0]=${$_[0]}+ 1},"--"=>sub {$_[0]=${$_[0]}- 1},fallback=>1,);package JSON::PP::IncrParser;use strict;use constant INCR_M_WS=>0;use constant INCR_M_STR=>1;use constant INCR_M_BS=>2;use constant INCR_M_JSON=>3;use constant INCR_M_C0=>4;use constant INCR_M_C1=>5;$JSON::PP::IncrParser::VERSION='1.01';my$unpack_format=$] < 5.006 ? 'C*' : 'U*';sub new {my ($class)=@_;bless {incr_nest=>0,incr_text=>undef,incr_parsing=>0,incr_p=>0,},$class}sub incr_parse {my ($self,$coder,$text)=@_;$self->{incr_text}='' unless (defined$self->{incr_text});if (defined$text){if (utf8::is_utf8($text)and!utf8::is_utf8($self->{incr_text})){utf8::upgrade($self->{incr_text});utf8::decode($self->{incr_text})}$self->{incr_text}.= $text}my$max_size=$coder->get_max_size;if (defined wantarray){$self->{incr_mode}=INCR_M_WS unless defined$self->{incr_mode};if (wantarray){my@ret;$self->{incr_parsing}=1;do {push@ret,$self->_incr_parse($coder,$self->{incr_text});unless (!$self->{incr_nest}and $self->{incr_mode}==INCR_M_JSON){$self->{incr_mode}=INCR_M_WS if$self->{incr_mode}!=INCR_M_STR}}until (length$self->{incr_text}>= $self->{incr_p});$self->{incr_parsing}=0;return@ret}else {$self->{incr_parsing}=1;my$obj=$self->_incr_parse($coder,$self->{incr_text});$self->{incr_parsing}=0 if defined$obj;return$obj ? $obj : undef}}}sub _incr_parse {my ($self,$coder,$text,$skip)=@_;my$p=$self->{incr_p};my$restore=$p;my@obj;my$len=length$text;if ($self->{incr_mode}==INCR_M_WS){while ($len > $p){my$s=substr($text,$p,1);$p++ and next if (0x20 >= unpack($unpack_format,$s));$self->{incr_mode}=INCR_M_JSON;last}}while ($len > $p){my$s=substr($text,$p++,1);if ($s eq '"'){if (substr($text,$p - 2,1)eq '\\'){next}if ($self->{incr_mode}!=INCR_M_STR){$self->{incr_mode}=INCR_M_STR}else {$self->{incr_mode}=INCR_M_JSON;unless ($self->{incr_nest}){last}}}if ($self->{incr_mode}==INCR_M_JSON){if ($s eq '[' or $s eq '{'){if (++$self->{incr_nest}> $coder->get_max_depth){Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')}}elsif ($s eq ']' or $s eq '}'){last if (--$self->{incr_nest}<= 0)}elsif ($s eq '#'){while ($len > $p){last if substr($text,$p++,1)eq "\n"}}}}$self->{incr_p}=$p;return if ($self->{incr_mode}==INCR_M_STR and not $self->{incr_nest});return if ($self->{incr_mode}==INCR_M_JSON and $self->{incr_nest}> 0);return '' unless (length substr($self->{incr_text},0,$p));local$Carp::CarpLevel=2;$self->{incr_p}=$restore;$self->{incr_c}=$p;my ($obj,$tail)=$coder->PP_decode_json(substr($self->{incr_text},0,$p),0x10000001);$self->{incr_text}=substr($self->{incr_text},$p);$self->{incr_p}=0;return$obj || ''}sub incr_text {if ($_[0]->{incr_parsing}){Carp::croak("incr_text can not be called when the incremental parser already started parsing")}$_[0]->{incr_text}}sub incr_skip {my$self=shift;$self->{incr_text}=substr($self->{incr_text},$self->{incr_c});$self->{incr_p}=0}sub incr_reset {my$self=shift;$self->{incr_text}=undef;$self->{incr_p}=0;$self->{incr_mode}=0;$self->{incr_nest}=0;$self->{incr_parsing}=0}1; -JSON_PP - -$fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN'; - use JSON::PP ();use strict;1; -JSON_PP_BOOLEAN - -$fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE'; - package Module::CPANfile;use strict;use warnings;use Cwd;use Carp ();use Module::CPANfile::Environment;use Module::CPANfile::Requirement;our$VERSION='1.1000';sub new {my($class,$file)=@_;bless {},$class}sub load {my($proto,$file)=@_;my$self=ref$proto ? $proto : $proto->new;$self->parse($file || Cwd::abs_path('cpanfile'));$self}sub save {my($self,$path)=@_;open my$out,">",$path or die "$path: $!";print {$out}$self->to_string}sub parse {my($self,$file)=@_;my$code=do {open my$fh,"<",$file or die "$file: $!";join '',<$fh>};my$env=Module::CPANfile::Environment->new($file);$env->parse($code)or die $@;$self->{_mirrors}=$env->mirrors;$self->{_prereqs}=$env->prereqs}sub from_prereqs {my($proto,$prereqs)=@_;my$self=$proto->new;$self->{_prereqs}=Module::CPANfile::Prereqs->from_cpan_meta($prereqs);$self}sub mirrors {my$self=shift;$self->{_mirrors}|| []}sub features {my$self=shift;map$self->feature($_),$self->{_prereqs}->identifiers}sub feature {my($self,$identifier)=@_;$self->{_prereqs}->feature($identifier)}sub prereq {shift->prereqs}sub prereqs {my$self=shift;$self->{_prereqs}->as_cpan_meta}sub merged_requirements {my$self=shift;$self->{_prereqs}->merged_requirements}sub effective_prereqs {my($self,$features)=@_;$self->prereqs_with(@{$features || []})}sub prereqs_with {my($self,@feature_identifiers)=@_;my$prereqs=$self->prereqs;my@others=map {$self->feature($_)->prereqs}@feature_identifiers;$prereqs->with_merged_prereqs(\@others)}sub prereq_specs {my$self=shift;$self->prereqs->as_string_hash}sub prereq_for_module {my($self,$module)=@_;$self->{_prereqs}->find($module)}sub options_for_module {my($self,$module)=@_;my$prereq=$self->prereq_for_module($module)or return;$prereq->requirement->options}sub merge_meta {my($self,$file,$version)=@_;require CPAN::Meta;$version ||= $file =~ /\.yml$/ ? '1.4' : '2';my$prereq=$self->prereqs;my$meta=CPAN::Meta->load_file($file);my$prereqs_hash=$prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash;my$struct={%{$meta->as_struct},prereqs=>$prereqs_hash };CPAN::Meta->new($struct)->save($file,{version=>$version })}sub _dump {my$str=shift;require Data::Dumper;chomp(my$value=Data::Dumper->new([$str])->Terse(1)->Dump);$value}sub to_string {my($self,$include_empty)=@_;my$mirrors=$self->mirrors;my$prereqs=$self->prereq_specs;my$code='';$code .= $self->_dump_mirrors($mirrors);$code .= $self->_dump_prereqs($prereqs,$include_empty);for my$feature ($self->features){$code .= sprintf "feature %s, %s => sub {\n",_dump($feature->{identifier}),_dump($feature->{description});$code .= $self->_dump_prereqs($feature->{spec},$include_empty,4);$code .= "}\n\n"}$code =~ s/\n+$/\n/s;$code}sub _dump_mirrors {my($self,$mirrors)=@_;my$code="";for my$url (@$mirrors){$code .= "mirror '$url';\n"}$code =~ s/\n+$/\n/s;$code}sub _dump_prereqs {my($self,$prereqs,$include_empty,$base_indent)=@_;my$code='';for my$phase (qw(runtime configure build test develop)){my$indent=$phase eq 'runtime' ? '' : ' ';$indent=(' ' x ($base_indent || 0)).$indent;my($phase_code,$requirements);$phase_code .= "on $phase => sub {\n" unless$phase eq 'runtime';for my$type (qw(requires recommends suggests conflicts)){for my$mod (sort keys %{$prereqs->{$phase}{$type}}){my$ver=$prereqs->{$phase}{$type}{$mod};$phase_code .= $ver eq '0' ? "${indent}$type '$mod';\n" : "${indent}$type '$mod', '$ver';\n";$requirements++}}$phase_code .= "\n" unless$requirements;$phase_code .= "};\n" unless$phase eq 'runtime';$code .= $phase_code ."\n" if$requirements or $include_empty}$code =~ s/\n+$/\n/s;$code}1; -MODULE_CPANFILE - -$fatpacked{"Module/CPANfile/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_ENVIRONMENT'; - package Module::CPANfile::Environment;use strict;use warnings;use Module::CPANfile::Prereqs;use Carp ();my@bindings=qw(on requires recommends suggests conflicts feature osname mirror configure_requires build_requires test_requires author_requires);my$file_id=1;sub new {my($class,$file)=@_;bless {file=>$file,phase=>'runtime',feature=>undef,features=>{},prereqs=>Module::CPANfile::Prereqs->new,mirrors=>[],},$class}sub bind {my$self=shift;my$pkg=caller;for my$binding (@bindings){no strict 'refs';*{"$pkg\::$binding"}=sub {$self->$binding(@_)}}}sub parse {my($self,$code)=@_;my$err;{local $@;$file_id++;$self->_evaluate(<{file} failed: $err"};return 1}sub _evaluate {my$_environment=$_[0];eval $_[1]}sub prereqs {$_[0]->{prereqs}}sub mirrors {$_[0]->{mirrors}}sub on {my($self,$phase,$code)=@_;local$self->{phase}=$phase;$code->()}sub feature {my($self,$identifier,$description,$code)=@_;if (@_==3 && ref($description)eq 'CODE'){$code=$description;$description=$identifier}unless (ref$description eq '' && ref$code eq 'CODE'){Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }")}local$self->{feature}=$identifier;$self->prereqs->add_feature($identifier,$description);$code->()}sub osname {die "TODO"}sub mirror {my($self,$url)=@_;push @{$self->{mirrors}},$url}sub requirement_for {my($self,$module,@args)=@_;my$requirement=0;$requirement=shift@args if@args % 2;return Module::CPANfile::Requirement->new(name=>$module,version=>$requirement,@args,)}sub requires {my$self=shift;$self->add_prereq(requires=>@_)}sub recommends {my$self=shift;$self->add_prereq(recommends=>@_)}sub suggests {my$self=shift;$self->add_prereq(suggests=>@_)}sub conflicts {my$self=shift;$self->add_prereq(conflicts=>@_)}sub add_prereq {my($self,$type,$module,@args)=@_;$self->prereqs->add_prereq(feature=>$self->{feature},phase=>$self->{phase},type=>$type,module=>$module,requirement=>$self->requirement_for($module,@args),)}sub configure_requires {my($self,@args)=@_;$self->on(configure=>sub {$self->requires(@args)})}sub build_requires {my($self,@args)=@_;$self->on(build=>sub {$self->requires(@args)})}sub test_requires {my($self,@args)=@_;$self->on(test=>sub {$self->requires(@args)})}sub author_requires {my($self,@args)=@_;$self->on(develop=>sub {$self->requires(@args)})}1; - package Module::CPANfile::Sandbox$file_id; - no warnings; - BEGIN { \$_environment->bind } - - # line 1 "$self->{file}" - $code; - EVAL -MODULE_CPANFILE_ENVIRONMENT - -$fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ'; - package Module::CPANfile::Prereq;use strict;sub new {my($class,%options)=@_;bless \%options,$class}sub feature {$_[0]->{feature}}sub phase {$_[0]->{phase}}sub type {$_[0]->{type}}sub module {$_[0]->{module}}sub requirement {$_[0]->{requirement}}sub match_feature {my($self,$identifier)=@_;no warnings 'uninitialized';$self->feature eq $identifier}1; -MODULE_CPANFILE_PREREQ - -$fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS'; - package Module::CPANfile::Prereqs;use strict;use Carp ();use CPAN::Meta::Feature;use Module::CPANfile::Prereq;sub from_cpan_meta {my($class,$prereqs)=@_;my$self=$class->new;for my$phase (keys %$prereqs){for my$type (keys %{$prereqs->{$phase}}){while (my($module,$requirement)=each %{$prereqs->{$phase}{$type}}){$self->add_prereq(phase=>$phase,type=>$type,module=>$module,requirement=>Module::CPANfile::Requirement->new(name=>$module,version=>$requirement),)}}}$self}sub new {my$class=shift;bless {prereqs=>[],features=>{},},$class}sub add_feature {my($self,$identifier,$description)=@_;$self->{features}{$identifier}={description=>$description }}sub add_prereq {my($self,%args)=@_;$self->add(Module::CPANfile::Prereq->new(%args))}sub add {my($self,$prereq)=@_;push @{$self->{prereqs}},$prereq}sub as_cpan_meta {my$self=shift;$self->{cpanmeta}||= $self->build_cpan_meta}sub build_cpan_meta {my($self,$identifier)=@_;my$prereq_spec={};$self->prereq_each($identifier,sub {my$prereq=shift;$prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module}=$prereq->requirement->version});CPAN::Meta::Prereqs->new($prereq_spec)}sub prereq_each {my($self,$identifier,$code)=@_;for my$prereq (@{$self->{prereqs}}){next unless$prereq->match_feature($identifier);$code->($prereq)}}sub merged_requirements {my$self=shift;my$reqs=CPAN::Meta::Requirements->new;for my$prereq (@{$self->{prereqs}}){$reqs->add_string_requirement($prereq->module,$prereq->requirement->version)}$reqs}sub find {my($self,$module)=@_;for my$prereq (@{$self->{prereqs}}){return$prereq if$prereq->module eq $module}return}sub identifiers {my$self=shift;keys %{$self->{features}}}sub feature {my($self,$identifier)=@_;my$data=$self->{features}{$identifier}or Carp::croak("Unknown feature '$identifier'");my$prereqs=$self->build_cpan_meta($identifier);CPAN::Meta::Feature->new($identifier,{description=>$data->{description},prereqs=>$prereqs->as_string_hash,})}1; -MODULE_CPANFILE_PREREQS - -$fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT'; - package Module::CPANfile::Requirement;use strict;sub new {my ($class,%args)=@_;$args{version}||= 0;bless +{name=>delete$args{name},version=>delete$args{version},options=>\%args,},$class}sub name {$_[0]->{name}}sub version {$_[0]->{version}}sub options {$_[0]->{options}}sub has_options {keys %{$_[0]->{options}}> 0}1; -MODULE_CPANFILE_REQUIREMENT - -$fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA'; - package Module::Metadata;sub __clean_eval {eval $_[0]}use strict;use warnings;our$VERSION='1.000027';use Carp qw/croak/;use File::Spec;BEGIN {eval {require Fcntl;Fcntl->import('SEEK_SET');1}or *SEEK_SET=sub {0}}use version 0.87;BEGIN {if ($INC{'Log/Contextual.pm'}){require "Log/Contextual/WarnLogger.pm";Log::Contextual->import('log_info','-default_logger'=>Log::Contextual::WarnLogger->new({env_prefix=>'MODULE_METADATA',}),)}else {*log_info=sub (&) {warn $_[0]->()}}}use File::Find qw(find);my$V_NUM_REGEXP=qr{v?[0-9._]+};my$PKG_FIRST_WORD_REGEXP=qr{ # the FIRST word in a package name - [a-zA-Z_] # the first word CANNOT start with a digit - (?: - [\w']? # can contain letters, digits, _, or ticks - \w # But, NO multi-ticks or trailing ticks - )* - }x;my$PKG_ADDL_WORD_REGEXP=qr{ # the 2nd+ word in a package name - \w # the 2nd+ word CAN start with digits - (?: - [\w']? # and can contain letters or ticks - \w # But, NO multi-ticks or trailing ticks - )* - }x;my$PKG_NAME_REGEXP=qr{ # match a package name - (?: :: )? # a pkg name can start with arisdottle - $PKG_FIRST_WORD_REGEXP # a package word - (?: - (?: :: )+ ### arisdottle (allow one or many times) - $PKG_ADDL_WORD_REGEXP ### a package word - )* # ^ zero, one or many times - (?: - :: # allow trailing arisdottle - )? - }x;my$PKG_REGEXP=qr{ # match a package declaration - ^[\s\{;]* # intro chars on a line - package # the word 'package' - \s+ # whitespace - ($PKG_NAME_REGEXP) # a package name - \s* # optional whitespace - ($V_NUM_REGEXP)? # optional version number - \s* # optional whitesapce - [;\{] # semicolon line terminator or block start (since 5.16) - }x;my$VARNAME_REGEXP=qr{ # match fully-qualified VERSION name - ([\$*]) # sigil - $ or * - ( - ( # optional leading package name - (?:::|\')? # possibly starting like just :: (a la $::VERSION) - (?:\w+(?:::|\'))* # Foo::Bar:: ... - )? - VERSION - )\b - }x;my$VERS_REGEXP=qr{ # match a VERSION definition - (?: - \(\s*$VARNAME_REGEXP\s*\) # with parens - | - $VARNAME_REGEXP # without parens - ) - \s* - =[^=~>] # = but not ==, nor =~, nor => - }x;sub new_from_file {my$class=shift;my$filename=File::Spec->rel2abs(shift);return undef unless defined($filename)&& -f $filename;return$class->_init(undef,$filename,@_)}sub new_from_handle {my$class=shift;my$handle=shift;my$filename=shift;return undef unless defined($handle)&& defined($filename);$filename=File::Spec->rel2abs($filename);return$class->_init(undef,$filename,@_,handle=>$handle)}sub new_from_module {my$class=shift;my$module=shift;my%props=@_;$props{inc}||= \@INC;my$filename=$class->find_module_by_name($module,$props{inc});return undef unless defined($filename)&& -f $filename;return$class->_init($module,$filename,%props)}{my$compare_versions=sub {my ($v1,$op,$v2)=@_;$v1=version->new($v1)unless UNIVERSAL::isa($v1,'version');my$eval_str="\$v1 $op \$v2";my$result=eval$eval_str;log_info {"error comparing versions: '$eval_str' $@"}if $@;return$result};my$normalize_version=sub {my ($version)=@_;if ($version =~ /[=<>!,]/){}elsif (ref$version eq 'version'){$version=$version->is_qv ? $version->normal : $version->stringify}elsif ($version =~ /^[^v][^.]*\.[^.]+\./){$version="v$version"}else {}return$version};my$resolve_module_versions=sub {my$packages=shift;my($file,$version);my$err='';for my$p (@$packages){if (defined($p->{version})){if (defined($version)){if ($compare_versions->($version,'!=',$p->{version})){$err .= " $p->{file} ($p->{version})\n"}else {}}else {$file=$p->{file};$version=$p->{version}}}$file ||= $p->{file}if defined($p->{file})}if ($err){$err=" $file ($version)\n" .$err}my%result=(file=>$file,version=>$version,err=>$err);return \%result};sub provides {my$class=shift;croak "provides() requires key/value pairs \n" if @_ % 2;my%args=@_;croak "provides() takes only one of 'dir' or 'files'\n" if$args{dir}&& $args{files};croak "provides() requires a 'version' argument" unless defined$args{version};croak "provides() does not support version '$args{version}' metadata" unless grep {$args{version}eq $_}qw/1.4 2/;$args{prefix}='lib' unless defined$args{prefix};my$p;if ($args{dir}){$p=$class->package_versions_from_directory($args{dir})}else {croak "provides() requires 'files' to be an array reference\n" unless ref$args{files}eq 'ARRAY';$p=$class->package_versions_from_directory($args{files})}if (length$args{prefix}){$args{prefix}=~ s{/$}{};for my$v (values %$p){$v->{file}="$args{prefix}/$v->{file}"}}return$p}sub package_versions_from_directory {my ($class,$dir,$files)=@_;my@files;if ($files){@files=@$files}else {find({wanted=>sub {push@files,$_ if -f $_ && /\.pm$/},no_chdir=>1,},$dir)}my(%prime,%alt);for my$file (@files){my$mapped_filename=File::Spec::Unix->abs2rel($file,$dir);my@path=split(/\//,$mapped_filename);(my$prime_package=join('::',@path))=~ s/\.pm$//;my$pm_info=$class->new_from_file($file);for my$package ($pm_info->packages_inside){next if$package eq 'main';next if$package eq 'DB';next if grep /^_/,split(/::/,$package);my$version=$pm_info->version($package);$prime_package=$package if lc($prime_package)eq lc($package);if ($package eq $prime_package){if (exists($prime{$package})){croak "Unexpected conflict in '$package'; multiple versions found.\n"}else {$mapped_filename="$package.pm" if lc("$package.pm")eq lc($mapped_filename);$prime{$package}{file}=$mapped_filename;$prime{$package}{version}=$version if defined($version)}}else {push(@{$alt{$package}},{file=>$mapped_filename,version=>$version,})}}}for my$package (keys(%alt)){my$result=$resolve_module_versions->($alt{$package});if (exists($prime{$package})){if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" .$result->{err}}}elsif (defined($result->{version})){if (exists($prime{$package}{version})&& defined($prime{$package}{version})){if ($compare_versions->($prime{$package}{version},'!=',$result->{version})){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" ." $result->{file} ($result->{version})\n"}}}else {$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}}}else {}}else {if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" .$result->{err}}}$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}if defined($result->{version})}}for (grep defined $_->{version},values%prime){$_->{version}=$normalize_version->($_->{version})}return \%prime}}sub _init {my$class=shift;my$module=shift;my$filename=shift;my%props=@_;my$handle=delete$props{handle};my(%valid_props,@valid_props);@valid_props=qw(collect_pod inc);@valid_props{@valid_props}=delete(@props{@valid_props});warn "Unknown properties: @{[keys %props]}\n" if scalar(%props);my%data=(module=>$module,filename=>$filename,version=>undef,packages=>[],versions=>{},pod=>{},pod_headings=>[],collect_pod=>0,%valid_props,);my$self=bless(\%data,$class);if (not $handle){my$filename=$self->{filename};open$handle,'<',$filename or croak("Can't open '$filename': $!");$self->_handle_bom($handle,$filename)}$self->_parse_fh($handle);unless($self->{module}and length($self->{module})){my ($v,$d,$f)=File::Spec->splitpath($self->{filename});if($f =~ /\.pm$/){$f =~ s/\..+$//;my@candidates=grep /$f$/,@{$self->{packages}};$self->{module}=shift(@candidates)}else {if(grep /main/,@{$self->{packages}}){$self->{module}='main'}else {$self->{module}=$self->{packages}[0]|| ''}}}$self->{version}=$self->{versions}{$self->{module}}if defined($self->{module});return$self}sub _do_find_module {my$class=shift;my$module=shift || croak 'find_module_by_name() requires a package name';my$dirs=shift || \@INC;my$file=File::Spec->catfile(split(/::/,$module));for my$dir (@$dirs){my$testfile=File::Spec->catfile($dir,$file);return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile and!-d _;$testfile .= '.pm';return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile}return}sub find_module_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[0]}sub find_module_dir_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[1]}sub _parse_version_expression {my$self=shift;my$line=shift;my($sigil,$variable_name,$package);if ($line =~ /$VERS_REGEXP/o){($sigil,$variable_name,$package)=$2 ? ($1,$2,$3): ($4,$5,$6);if ($package){$package=($package eq '::')? 'main' : $package;$package =~ s/::$//}}return ($sigil,$variable_name,$package)}sub _handle_bom {my ($self,$fh,$filename)=@_;my$pos=tell$fh;return unless defined$pos;my$buf=' ' x 2;my$count=read$fh,$buf,length$buf;return unless defined$count and $count >= 2;my$encoding;if ($buf eq "\x{FE}\x{FF}"){$encoding='UTF-16BE'}elsif ($buf eq "\x{FF}\x{FE}"){$encoding='UTF-16LE'}elsif ($buf eq "\x{EF}\x{BB}"){$buf=' ';$count=read$fh,$buf,length$buf;if (defined$count and $count >= 1 and $buf eq "\x{BF}"){$encoding='UTF-8'}}if (defined$encoding){if ("$]" >= 5.008){binmode($fh,":encoding($encoding)")}}else {seek$fh,$pos,SEEK_SET or croak(sprintf "Can't reset position to the top of '$filename'")}return$encoding}sub _parse_fh {my ($self,$fh)=@_;my($in_pod,$seen_end,$need_vers)=(0,0,0);my(@packages,%vers,%pod,@pod);my$package='main';my$pod_sect='';my$pod_data='';my$in_end=0;while (defined(my$line=<$fh>)){my$line_num=$.;chomp($line);my$is_cut;if ($line =~ /^=([a-zA-Z].*)/){my$cmd=$1;$is_cut=$cmd =~ /^cut(?:[^a-zA-Z]|$)/;$in_pod=!$is_cut}if ($in_pod){if ($line =~ /^=head[1-4]\s+(.+)\s*$/){push(@pod,$1);if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=$1}elsif ($self->{collect_pod}){$pod_data .= "$line\n"}}elsif ($is_cut){if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=''}else {next if$in_end;next if$line =~ /^\s*#/;if ($line eq '__END__'){$in_end++;next}last if$line eq '__DATA__';my($version_sigil,$version_fullname,$version_package)=index($line,'VERSION')>= 1 ? $self->_parse_version_expression($line): ();if ($line =~ /$PKG_REGEXP/o){$package=$1;my$version=$2;push(@packages,$package)unless grep($package eq $_,@packages);$need_vers=defined$version ? 0 : 1;if (not exists$vers{$package}and defined$version){my$dwim_version=eval {_dwim_version($version)};croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" unless defined$dwim_version;$vers{$package}=$dwim_version}}elsif ($version_fullname && $version_package){push(@packages,$version_package)unless grep($version_package eq $_,@packages);$need_vers=0 if$version_package eq $package;unless (defined$vers{$version_package}&& length$vers{$version_package}){$vers{$version_package}=$self->_evaluate_version_line($version_sigil,$version_fullname,$line)}}elsif ($package eq 'main' && $version_fullname &&!exists($vers{main})){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);$vers{$package}=$v;push(@packages,'main')}elsif ($package eq 'main' &&!exists($vers{main})&& $line =~ /\w/){$need_vers=1;$vers{main}='';push(@packages,'main')}elsif ($version_fullname && $need_vers){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);unless (defined$vers{$package}&& length$vers{$package}){$vers{$package}=$v}}}}if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data}$self->{versions}=\%vers;$self->{packages}=\@packages;$self->{pod}=\%pod;$self->{pod_headings}=\@pod}{my$pn=0;sub _evaluate_version_line {my$self=shift;my($sigil,$variable_name,$line)=@_;$pn++;my$eval=qq{ my \$dummy = q# Hide from _packages_inside() - #; package Module::Metadata::_version::p${pn}; - use version; - sub { - local $sigil$variable_name; - $line; - \$$variable_name - }; - };$eval=$1 if$eval =~ m{^(.+)}s;local $^W;my$vsub=__clean_eval($eval);if ($@ =~ /Can't locate/ && -d 'lib'){local@INC=('lib',@INC);$vsub=__clean_eval($eval)}warn "Error evaling version line '$eval' in $self->{filename}: $@\n" if $@;(ref($vsub)eq 'CODE')or croak "failed to build version sub for $self->{filename}";my$result=eval {$vsub->()};croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@;my$version=eval {_dwim_version($result)};croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" unless defined$version;return$version}}{my@version_prep=(sub {return shift},sub {my$v=shift;$v =~ s{([0-9])[a-z-].*$}{$1}i;return$v},sub {my$v=shift;my$num_dots=()=$v =~ m{(\.)}g;my$num_unders=()=$v =~ m{(_)}g;my$leading_v=substr($v,0,1)eq 'v';if (!$leading_v && $num_dots < 2 && $num_unders > 1){$v =~ s{_}{}g;$num_unders=()=$v =~ m{(_)}g}return$v},sub {my$v=shift;no warnings 'numeric';return 0 + $v},);sub _dwim_version {my ($result)=shift;return$result if ref($result)eq 'version';my ($version,$error);for my$f (@version_prep){$result=$f->($result);$version=eval {version->new($result)};$error ||= $@ if $@;last if defined$version}croak$error unless defined$version;return$version}}sub name {$_[0]->{module}}sub filename {$_[0]->{filename}}sub packages_inside {@{$_[0]->{packages}}}sub pod_inside {@{$_[0]->{pod_headings}}}sub contains_pod {0+@{$_[0]->{pod_headings}}}sub version {my$self=shift;my$mod=shift || $self->{module};my$vers;if (defined($mod)&& length($mod)&& exists($self->{versions}{$mod})){return$self->{versions}{$mod}}else {return undef}}sub pod {my$self=shift;my$sect=shift;if (defined($sect)&& length($sect)&& exists($self->{pod}{$sect})){return$self->{pod}{$sect}}else {return undef}}sub is_indexable {my ($self,$package)=@_;my@indexable_packages=grep {$_ ne 'main'}$self->packages_inside;return!!grep {$_ eq $package}@indexable_packages if$package;return!!@indexable_packages}1; -MODULE_METADATA - -$fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_CPAN_META'; - use 5.008001;use strict;package Parse::CPAN::Meta;our$VERSION='1.4414';use Exporter;use Carp 'croak';our@ISA=qw/Exporter/;our@EXPORT_OK=qw/Load LoadFile/;sub load_file {my ($class,$filename)=@_;my$meta=_slurp($filename);if ($filename =~ /\.ya?ml$/){return$class->load_yaml_string($meta)}elsif ($filename =~ /\.json$/){return$class->load_json_string($meta)}else {$class->load_string($meta)}}sub load_string {my ($class,$string)=@_;if ($string =~ /^---/){return$class->load_yaml_string($string)}elsif ($string =~ /^\s*\{/){return$class->load_json_string($string)}else {return$class->load_yaml_string($string)}}sub load_yaml_string {my ($class,$string)=@_;my$backend=$class->yaml_backend();my$data=eval {no strict 'refs';&{"$backend\::Load"}($string)};croak $@ if $@;return$data || {}}sub load_json_string {my ($class,$string)=@_;my$data=eval {$class->json_backend()->new->decode($string)};croak $@ if $@;return$data || {}}sub yaml_backend {if (!defined$ENV{PERL_YAML_BACKEND}){_can_load('CPAN::Meta::YAML',0.011)or croak "CPAN::Meta::YAML 0.011 is not available\n";return "CPAN::Meta::YAML"}else {my$backend=$ENV{PERL_YAML_BACKEND};_can_load($backend)or croak "Could not load PERL_YAML_BACKEND '$backend'\n";$backend->can("Load")or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";return$backend}}sub json_backend {if (!$ENV{PERL_JSON_BACKEND}or $ENV{PERL_JSON_BACKEND}eq 'JSON::PP'){_can_load('JSON::PP'=>2.27103)or croak "JSON::PP 2.27103 is not available\n";return 'JSON::PP'}else {_can_load('JSON'=>2.5)or croak "JSON 2.5 is required for " ."\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";return "JSON"}}sub _slurp {require Encode;open my$fh,"<:raw","$_[0]" or die "can't open $_[0] for reading: $!";my$content=do {local $/;<$fh>};$content=Encode::decode('UTF-8',$content,Encode::PERLQQ());return$content}sub _can_load {my ($module,$version)=@_;(my$file=$module)=~ s{::}{/}g;$file .= ".pm";return 1 if$INC{$file};return 0 if exists$INC{$file};eval {require$file;1}or return 0;if (defined$version){eval {$module->VERSION($version);1}or return 0}return 1}sub LoadFile ($) {return Load(_slurp(shift))}sub Load ($) {require CPAN::Meta::YAML;my$object=eval {CPAN::Meta::YAML::Load(shift)};croak $@ if $@;return$object}1; -PARSE_CPAN_META - -$fatpacked{"Parse/PMFile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_PMFILE'; - package Parse::PMFile;sub __clean_eval {eval $_[0]}use strict;use warnings;use Safe;use JSON::PP ();use Dumpvalue;use version ();use File::Spec ();our$VERSION='0.36';our$VERBOSE=0;our$ALLOW_DEV_VERSION=0;our$FORK=0;our$UNSAFE=$] < 5.010000 ? 1 : 0;sub new {my ($class,$meta,$opts)=@_;bless {%{$opts || {}},META_CONTENT=>$meta},$class}sub parse {my ($self,$pmfile)=@_;$pmfile =~ s|\\|/|g;my($filemtime)=(stat$pmfile)[9];$self->{MTIME}=$filemtime;$self->{PMFILE}=$pmfile;unless ($self->_version_from_meta_ok){my$version;unless (eval {$version=$self->_parse_version;1}){$self->_verbose(1,"error with version in $pmfile: $@");return}$self->{VERSION}=$version;if ($self->{VERSION}=~ /^\{.*\}$/){}elsif ($self->{VERSION}=~ /[_\s]/ &&!$self->{ALLOW_DEV_VERSION}&&!$ALLOW_DEV_VERSION){return}}my($ppp)=$self->_packages_per_pmfile;my@keys_ppp=$self->_filter_ppps(sort keys %$ppp);$self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n");my ($package,%errors);my%checked_in;DBPACK: foreach$package (@keys_ppp){if ($package !~ /^\w[\w\:\']*\w?\z/ || $package !~ /\w\z/ || $package =~ /:/ && $package !~ /::/ || $package =~ /\w:\w/ || $package =~ /:::/){$self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");delete$ppp->{$package};next}if ($self->{USERID}&& $self->{PERMISSIONS}&&!$self->_perm_check($package)){delete$ppp->{$package};next}{my (undef,$module)=split m{/lib/},$self->{PMFILE},2;if ($module){$module =~ s{\.pm\z}{};$module =~ s{/}{::}g;if (lc$module eq lc$package && $module ne $package){$errors{$package}={indexing_warning=>"Capitalization of package ($package) does not match filename!",infile=>$self->{PMFILE},}}}}my$pp=$ppp->{$package};if ($pp->{version}&& $pp->{version}=~ /^\{.*\}$/){my$err=JSON::PP::decode_json($pp->{version});if ($err->{x_normalize}){$errors{$package}={normalize=>$err->{version},infile=>$pp->{infile},};$pp->{version}="undef"}elsif ($err->{openerr}){$pp->{version}="undef";$self->_verbose(1,qq{Parse::PMFile was not able to - read the file. It issued the following error: C< $err->{r} >},);$errors{$package}={open=>$err->{r},infile=>$pp->{infile},}}else {$pp->{version}="undef";$self->_verbose(1,qq{Parse::PMFile was not able to - parse the following line in that file: C< $err->{line} > - - Note: the indexer is running in a Safe compartement and cannot - provide the full functionality of perl in the VERSION line. It - is trying hard, but sometime it fails. As a workaround, please - consider writing a META.yml that contains a 'provides' - attribute or contact the CPAN admins to investigate (yet - another) workaround against "Safe" limitations.)},);$errors{$package}={parse_version=>$err->{line},infile=>$err->{file},}}}for ($package,$pp->{version},){if (!defined || /^\s*$/ || /\s/){delete$ppp->{$package};next}}$checked_in{$package}=$ppp->{$package}}return (wantarray && %errors)? (\%checked_in,\%errors): \%checked_in}sub _perm_check {my ($self,$package)=@_;my$userid=$self->{USERID};my$module=$self->{PERMISSIONS}->module_permissions($package);return 1 if!$module;return 1 if defined$module->m && $module->m eq $userid;return 1 if defined$module->f && $module->f eq $userid;return 1 if defined$module->c && grep {$_ eq $userid}@{$module->c};return}sub _parse_version {my$self=shift;use strict;my$pmfile=$self->{PMFILE};my$tmpfile=File::Spec->catfile(File::Spec->tmpdir,"ParsePMFile$$" .rand(1000));my$pmcp=$pmfile;for ($pmcp){s/([^\\](\\\\)*)@/$1\\@/g}my($v);{package main;my$pid;if ($self->{FORK}|| $FORK){$pid=fork();die "Can't fork: $!" unless defined$pid}if ($pid){waitpid($pid,0);if (open my$fh,'<',$tmpfile){$v=<$fh>}}else {my($comp)=Safe->new;my$eval=qq{ - local(\$^W) = 0; - Parse::PMFile::_parse_version_safely("$pmcp"); - };$comp->permit("entereval");$comp->share("*Parse::PMFile::_parse_version_safely");$comp->share("*version::new");$comp->share("*version::numify");$comp->share_from('main',['*version::','*charstar::','*Exporter::','*DynaLoader::']);$comp->share_from('version',['&qv']);$comp->permit(":base_math");$comp->deny(qw/enteriter iter unstack goto/);version->import('qv')if$self->{UNSAFE}|| $UNSAFE;{no strict;$v=($self->{UNSAFE}|| $UNSAFE)? eval$eval : $comp->reval($eval)}if ($@){my$err=$@;if (ref$err){if ($err->{line}=~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/){local($^W)=0;my ($sigil,$vstr)=($1,$3);$self->_restore_overloaded_stuff(1)if$err->{line}=~ /use\s+version\b|version\->|qv\(/;$v=($self->{UNSAFE}|| $UNSAFE)? eval$vstr : $comp->reval($vstr);$v=$$v if$sigil eq '*' && ref$v}if ($@ or!$v){$self->_verbose(1,sprintf("reval failed: err[%s] for eval[%s]",JSON::PP::encode_json($err),$eval,));$v=JSON::PP::encode_json($err)}}else {$v=JSON::PP::encode_json({openerr=>$err })}}if (defined$v){$v=$v->numify if ref($v)=~ /^version(::vpp)?$/}else {$v=""}if ($self->{FORK}|| $FORK){open my$fh,'>:utf8',$tmpfile;print$fh $v;exit 0}else {utf8::encode($v);$v=undef if defined$v &&!length$v;$comp->erase;$self->_restore_overloaded_stuff}}}unlink$tmpfile if ($self->{FORK}|| $FORK)&& -e $tmpfile;return$self->_normalize_version($v)}sub _restore_overloaded_stuff {my ($self,$used_version_in_safe)=@_;return if$self->{UNSAFE}|| $UNSAFE;no strict 'refs';no warnings 'redefine';my$restored;if ($INC{'version/vxs.pm'}){*{'version::(""'}=\&version::vxs::stringify;*{'version::(0+'}=\&version::vxs::numify;*{'version::(cmp'}=\&version::vxs::VCMP;*{'version::(<=>'}=\&version::vxs::VCMP;*{'version::(bool'}=\&version::vxs::boolean;$restored=1}if ($INC{'version/vpp.pm'}){{package charstar;overload->import}if (!$used_version_in_safe){package version::vpp;overload->import}unless ($restored){*{'version::(""'}=\&version::vpp::stringify;*{'version::(0+'}=\&version::vpp::numify;*{'version::(cmp'}=\&version::vpp::vcmp;*{'version::(<=>'}=\&version::vpp::vcmp;*{'version::(bool'}=\&version::vpp::vbool}*{'version::vpp::(""'}=\&version::vpp::stringify;*{'version::vpp::(0+'}=\&version::vpp::numify;*{'version::vpp::(cmp'}=\&version::vpp::vcmp;*{'version::vpp::(<=>'}=\&version::vpp::vcmp;*{'version::vpp::(bool'}=\&version::vpp::vbool;*{'charstar::(""'}=\&charstar::thischar;*{'charstar::(0+'}=\&charstar::thischar;*{'charstar::(++'}=\&charstar::increment;*{'charstar::(--'}=\&charstar::decrement;*{'charstar::(+'}=\&charstar::plus;*{'charstar::(-'}=\&charstar::minus;*{'charstar::(*'}=\&charstar::multiply;*{'charstar::(cmp'}=\&charstar::cmp;*{'charstar::(<=>'}=\&charstar::spaceship;*{'charstar::(bool'}=\&charstar::thischar;*{'charstar::(='}=\&charstar::clone;$restored=1}if (!$restored){*{'version::(""'}=\&version::stringify;*{'version::(0+'}=\&version::numify;*{'version::(cmp'}=\&version::vcmp;*{'version::(<=>'}=\&version::vcmp;*{'version::(bool'}=\&version::boolean}}sub _packages_per_pmfile {my$self=shift;my$ppp={};my$pmfile=$self->{PMFILE};my$filemtime=$self->{MTIME};my$version=$self->{VERSION};open my$fh,"<","$pmfile" or return$ppp;local $/="\n";my$inpod=0;PLINE: while (<$fh>){chomp;my($pline)=$_;$inpod=$pline =~ /^=(?!cut)/ ? 1 : $pline =~ /^=cut/ ? 0 : $inpod;next if$inpod;next if substr($pline,0,4)eq "=cut";$pline =~ s/\#.*//;next if$pline =~ /^\s*$/;if ($pline =~ /^__(?:END|DATA)__\b/ and $pmfile !~ /\.PL$/){last PLINE}my$pkg;my$strict_version;if ($pline =~ m{ - # (.*) # takes too much time if $pline is long - (? 128;$ppp->{$pkg}{parsed}++;$ppp->{$pkg}{infile}=$pmfile;if ($self->_simile($pmfile,$pkg)){$ppp->{$pkg}{simile}=$pmfile;if ($self->_version_from_meta_ok){my$provides=$self->{META_CONTENT}{provides};if (exists$provides->{$pkg}){if (defined$provides->{$pkg}{version}){my$v=$provides->{$pkg}{version};if ($v =~ /[_\s]/ &&!$self->{ALLOW_DEV_VERSION}&&!$ALLOW_DEV_VERSION){next PLINE}unless (eval {$version=$self->_normalize_version($v);1}){$self->_verbose(1,"error with version in $pmfile: $@");next}$ppp->{$pkg}{version}=$version}else {$ppp->{$pkg}{version}="undef"}}}else {if (defined$strict_version){$ppp->{$pkg}{version}=$strict_version }else {$ppp->{$pkg}{version}=defined$version ? $version : ""}no warnings;if ($version eq 'undef'){$ppp->{$pkg}{version}=$version unless defined$ppp->{$pkg}{version}}else {$ppp->{$pkg}{version}=$version if$version > $ppp->{$pkg}{version}|| $version gt $ppp->{$pkg}{version}}}}else {$ppp->{$pkg}{version}=$version unless defined$ppp->{$pkg}{version}&& length($ppp->{$pkg}{version})}$ppp->{$pkg}{filemtime}=$filemtime}else {}}close$fh;$ppp}{no strict;sub _parse_version_safely {my($parsefile)=@_;my$result;local*FH;local $/="\n";open(FH,$parsefile)or die "Could not open '$parsefile': $!";my$inpod=0;while (){$inpod=/^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;next if$inpod || /^\s*#/;last if /^__(?:END|DATA)__\b/;chop;if (my ($ver)=/package \s+ \S+ \s+ (\S+) \s* [;{]/x){return$ver if version::is_lax($ver)}next unless /(?<=])\=(?![=>])/;my$current_parsed_line=$_;my$eval=qq{ - package # - ExtUtils::MakeMaker::_version; - - local $1$2; - \$$2=undef; do { - $_ - }; \$$2 - };local $^W=0;local$SIG{__WARN__}=sub {};$result=__clean_eval($eval);if ($@ or!defined$result){die +{eval=>$eval,line=>$current_parsed_line,file=>$parsefile,err=>$@,}}last}close FH;$result="undef" unless defined$result;if ((ref$result)=~ /^version(?:::vpp)?\b/){$result=$result->numify}return$result}}sub _filter_ppps {my($self,@ppps)=@_;my@res;MANI: for my$ppp (@ppps){if ($self->{META_CONTENT}){my$no_index=$self->{META_CONTENT}{no_index}|| $self->{META_CONTENT}{private};if (ref($no_index)eq 'HASH'){my%map=(package=>qr{\z},namespace=>qr{::},);for my$k (qw(package namespace)){next unless my$v=$no_index->{$k};my$rest=$map{$k};if (ref$v eq "ARRAY"){for my$ve (@$v){$ve =~ s|::$||;if ($ppp =~ /^$ve$rest/){$self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");next MANI}else {$self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]")}}}else {$v =~ s|::$||;if ($ppp =~ /^$v$rest/){$self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");next MANI}else {$self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]")}}}}else {$self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT")}}else {}push@res,$ppp}$self->_verbose(1,"Result of filter_ppps: res[@res]");@res}sub _simile {my($self,$file,$package)=@_;$file =~ s|.*/||;$file =~ s|\.pm(?:\.PL)?||;my$ret=$package =~ m/\b\Q$file\E$/;$ret ||= 0;unless ($ret){$ret=1 if lc$file eq 'version'}$self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");$ret}sub _normalize_version {my($self,$v)=@_;$v="undef" unless defined$v;my$dv=Dumpvalue->new;my$sdv=$dv->stringify($v,1);$self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");return$v if$v eq "undef";return$v if$v =~ /^\{.*\}$/;$v =~ s/^\s+//;$v =~ s/\s+\z//;if ($v =~ /_/){return$v }if (!version::is_lax($v)){return JSON::PP::encode_json({x_normalize=>'version::is_lax failed',version=>$v })}my$vv=eval {no warnings;version->new($v)->numify};if ($@){return JSON::PP::encode_json({x_normalize=>$@,version=>$v })}if ($vv eq $v){}else {my$forced=$self->_force_numeric($v);if ($forced eq $vv){}elsif ($forced =~ /^v(.+)/){$vv=version->new($1)->numify}else {if ($forced==$vv){$vv=$forced}}}return$vv}sub _force_numeric {my($self,$v)=@_;$v=$self->_readable($v);if ($v =~ /^(\+?)(\d*)(\.(\d*))?/ && (defined $2 && length $2 || defined $4 && length $4)){my$two=defined $2 ? $2 : "";my$three=defined $3 ? $3 : "";$v="$two$three"}$v}sub _version_from_meta_ok {my($self)=@_;return$self->{VERSION_FROM_META_OK}if exists$self->{VERSION_FROM_META_OK};my$c=$self->{META_CONTENT};return($self->{VERSION_FROM_META_OK}=0)unless$c->{provides};my ($mb_v)=(defined$c->{generated_by}? $c->{generated_by}: '')=~ /Module::Build version ([\d\.]+)/;return($self->{VERSION_FROM_META_OK}=1)unless$mb_v;return($self->{VERSION_FROM_META_OK}=1)if$mb_v eq '0.250.0';if ($mb_v >= 0.19 && $mb_v < 0.26 &&!keys %{$c->{provides}}){return($self->{VERSION_FROM_META_OK}=0)}return($self->{VERSION_FROM_META_OK}=1)}sub _verbose {my($self,$level,@what)=@_;warn@what if$level <= ((ref$self && $self->{VERBOSE})|| $VERBOSE)}sub _vcmp {my($self,$l,$r)=@_;local($^W)=0;$self->_verbose(9,"l[$l] r[$r]");return 0 if$l eq $r;for ($l,$r){s/_//g}$self->_verbose(9,"l[$l] r[$r]");for ($l,$r){next unless tr/.// > 1 || /^v/;s/^v?/v/;1 while s/\.0+(\d)/.$1/}$self->_verbose(9,"l[$l] r[$r]");if ($l=~/^v/ <=> $r=~/^v/){for ($l,$r){next if /^v/;$_=$self->_float2vv($_)}}$self->_verbose(9,"l[$l] r[$r]");my$lvstring="v0";my$rvstring="v0";if ($] >= 5.006 && $l =~ /^v/ && $r =~ /^v/){$lvstring=$self->_vstring($l);$rvstring=$self->_vstring($r);$self->_verbose(9,sprintf "lv[%vd] rv[%vd]",$lvstring,$rvstring)}return (($l ne "undef")<=> ($r ne "undef")|| $lvstring cmp $rvstring || $l <=> $r || $l cmp $r)}sub _vgt {my($self,$l,$r)=@_;$self->_vcmp($l,$r)> 0}sub _vlt {my($self,$l,$r)=@_;$self->_vcmp($l,$r)< 0}sub _vge {my($self,$l,$r)=@_;$self->_vcmp($l,$r)>= 0}sub _vle {my($self,$l,$r)=@_;$self->_vcmp($l,$r)<= 0}sub _vstring {my($self,$n)=@_;$n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]";pack "U*",split /\./,$n}sub _float2vv {my($self,$n)=@_;my($rev)=int($n);$rev ||= 0;my($mantissa)=$n =~ /\.(\d{1,12})/;$mantissa ||= 0;$mantissa .= "0" while length($mantissa)%3;my$ret="v" .$rev;while ($mantissa){$mantissa =~ s/(\d{1,3})// or die "Panic: length>0 but not a digit? mantissa[$mantissa]";$ret .= ".".int($1)}$ret =~ s/(\.0)+/.0/;$ret}sub _readable {my($self,$n)=@_;$n =~ /^([\w\-\+\.]+)/;return $1 if defined $1 && length($1)>0;if ($] < 5.006){$self->_verbose(9,"Suspicious version string seen [$n]\n");return$n}my$better=sprintf "v%vd",$n;$self->_verbose(9,"n[$n] better[$better]");return$better}1; -PARSE_PMFILE - -$fatpacked{"String/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_SHELLQUOTE'; - package String::ShellQuote;use strict;use vars qw($VERSION @ISA @EXPORT);require Exporter;$VERSION='1.04';@ISA=qw(Exporter);@EXPORT=qw(shell_quote shell_quote_best_effort shell_comment_quote);sub croak {require Carp;goto&Carp::croak}sub _shell_quote_backend {my@in=@_;my@err=();if (0){require RS::Handy;print RS::Handy::data_dump(\@in)}return \@err,'' unless@in;my$ret='';my$saw_non_equal=0;for (@in){if (!defined $_ or $_ eq ''){$_="''";next}if (s/\x00//g){push@err,"No way to quote string containing null (\\000) bytes"}my$escape=0;if (/=/){if (!$saw_non_equal){$escape=1}}else {$saw_non_equal=1}if (m|[^\w!%+,\-./:=@^]|){$escape=1}if ($escape || (!$saw_non_equal && /=/)){s/'/'\\''/g;s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;$_="'$_'";s/^''//;s/''$//}}continue {$ret .= "$_ "}chop$ret;return \@err,$ret}sub shell_quote {my ($rerr,$s)=_shell_quote_backend @_;if (@$rerr){my%seen;@$rerr=grep {!$seen{$_}++}@$rerr;my$s=join '',map {"shell_quote(): $_\n"}@$rerr;chomp$s;croak$s}return$s}sub shell_quote_best_effort {my ($rerr,$s)=_shell_quote_backend @_;return$s}sub shell_comment_quote {return '' unless @_;unless (@_==1){croak "Too many arguments to shell_comment_quote " ."(got " .@_ ." expected 1)"}local $_=shift;s/\n/\n#/g;return $_}1; -STRING_SHELLQUOTE - -$fatpacked{"lib/core/only.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY'; - package lib::core::only;use strict;use warnings FATAL=>'all';use Config;sub import {@INC=@Config{qw(privlibexp archlibexp)};return}1; -LIB_CORE_ONLY - -$fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL_LIB'; - package local::lib;use 5.006;use strict;use warnings;use Config;our$VERSION='2.000015';$VERSION=eval$VERSION;BEGIN {*_WIN32=($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')? sub(){1}: sub(){0};*_USE_FSPEC=($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})? sub(){1}: sub(){0}}our$_DIR_JOIN=_WIN32 ? '\\' : '/';our$_DIR_SPLIT=(_WIN32 || $^O eq 'cygwin')? qr{[\\/]} : qr{/};our$_ROOT=_WIN32 ? do {my$UNC=qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT}}: qr{^/};our$_PERL;sub _cwd {my$drive=shift;if (!$_PERL){($_PERL)=$^X =~ /(.+)/;if (_is_abs($_PERL)){}elsif (-x $Config{perlpath}){$_PERL=$Config{perlpath}}else {($_PERL)=map {/(.*)/}grep {-x $_}map {join($_DIR_JOIN,$_,$_PERL)}split /\Q$Config{path_sep}\E/,$ENV{PATH}}}local@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};my$cmd=$drive ? "eval { Cwd::getdcwd(q($drive)) }" : 'getcwd';my$cwd=`"$_PERL" -MCwd -le "print $cmd"`;chomp$cwd;if (!length$cwd && $drive){$cwd=$drive}$cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;$cwd}sub _catdir {if (_USE_FSPEC){require File::Spec;File::Spec->catdir(@_)}else {my$dir=join($_DIR_JOIN,@_);$dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;$dir}}sub _is_abs {if (_USE_FSPEC){require File::Spec;File::Spec->file_name_is_absolute($_[0])}else {$_[0]=~ $_ROOT}}sub _rel2abs {my ($dir,$base)=@_;return$dir if _is_abs($dir);$base=_WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1"): $base ? $base : _cwd;return _catdir($base,$dir)}sub import {my ($class,@args)=@_;push@args,@ARGV if $0 eq '-';my@steps;my%opts;my$shelltype;while (@args){my$arg=shift@args;if ($arg =~ /\xE2\x88\x92/ or $arg =~ /āˆ’/){die <<'DEATH'}elsif ($arg eq '--self-contained'){die <<'DEATH'}elsif($arg =~ /^--deactivate(?:=(.*))?$/){my$path=defined $1 ? $1 : shift@args;push@steps,['deactivate',$path]}elsif ($arg eq '--deactivate-all'){push@steps,['deactivate_all']}elsif ($arg =~ /^--shelltype(?:=(.*))?$/){$shelltype=defined $1 ? $1 : shift@args}elsif ($arg eq '--no-create'){$opts{no_create}=1}elsif ($arg =~ /^--/){die "Unknown import argument: $arg"}else {push@steps,['activate',$arg]}}if (!@steps){push@steps,['activate',undef]}my$self=$class->new(%opts);for (@steps){my ($method,@args)=@$_;$self=$self->$method(@args)}if ($0 eq '-'){print$self->environment_vars_string($shelltype);exit 0}else {$self->setup_local_lib}}sub new {my$class=shift;bless {@_},$class}sub clone {my$self=shift;bless {%$self,@_},ref$self}sub inc {$_[0]->{inc}||= \@INC}sub libs {$_[0]->{libs}||= [\'PERL5LIB' ]}sub bins {$_[0]->{bins}||= [\'PATH' ]}sub roots {$_[0]->{roots}||= [\'PERL_LOCAL_LIB_ROOT' ]}sub extra {$_[0]->{extra}||= {}}sub no_create {$_[0]->{no_create}}my$_archname=$Config{archname};my$_version=$Config{version};my@_inc_version_list=reverse split / /,$Config{inc_version_list};my$_path_sep=$Config{path_sep};sub _as_list {my$list=shift;grep length,map {!(ref $_ && ref $_ eq 'SCALAR')? $_ : (defined$ENV{$$_}? split(/\Q$_path_sep/,$ENV{$$_}): ())}ref$list ? @$list : $list}sub _remove_from {my ($list,@remove)=@_;return @$list if!@remove;my%remove=map {$_=>1}@remove;grep!$remove{$_},_as_list($list)}my@_lib_subdirs=([$_version,$_archname],[$_version],[$_archname],(@_inc_version_list ? \@_inc_version_list : ()),[],);sub install_base_bin_path {my ($class,$path)=@_;return _catdir($path,'bin')}sub install_base_perl_path {my ($class,$path)=@_;return _catdir($path,'lib','perl5')}sub install_base_arch_path {my ($class,$path)=@_;_catdir($class->install_base_perl_path($path),$_archname)}sub lib_paths_for {my ($class,$path)=@_;my$base=$class->install_base_perl_path($path);return map {_catdir($base,@$_)}@_lib_subdirs}sub _mm_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;if ($path =~ s/ /\\ /g){$path=qq{"$path"}}return$path}sub _mb_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;return qq{"$path"}}sub installer_options_for {my ($class,$path)=@_;return (PERL_MM_OPT=>defined$path ? "INSTALL_BASE="._mm_escape_path($path): undef,PERL_MB_OPT=>defined$path ? "--install_base "._mb_escape_path($path): undef,)}sub active_paths {my ($self)=@_;$self=ref$self ? $self : $self->new;return grep {my$active_ll=$self->install_base_perl_path($_);grep {$_ eq $active_ll}@{$self->inc}}_as_list($self->roots)}sub deactivate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (!grep {$_ eq $path}@active_lls){warn "Tried to deactivate inactive local::lib '$path'\n";return$self}my%args=(bins=>[_remove_from($self->bins,$self->install_base_bin_path($path))],libs=>[_remove_from($self->libs,$self->install_base_perl_path($path))],inc=>[_remove_from($self->inc,$self->lib_paths_for($path))],roots=>[_remove_from($self->roots,$path)],);$args{extra}={$self->installer_options_for($args{roots}[0])};$self->clone(%args)}sub deactivate_all {my ($self)=@_;$self=$self->new unless ref$self;my@active_lls=$self->active_paths;my%args;if (@active_lls){%args=(bins=>[_remove_from($self->bins,map$self->install_base_bin_path($_),@active_lls)],libs=>[_remove_from($self->libs,map$self->install_base_perl_path($_),@active_lls)],inc=>[_remove_from($self->inc,map$self->lib_paths_for($_),@active_lls)],roots=>[_remove_from($self->roots,@active_lls)],)}$args{extra}={$self->installer_options_for(undef)};$self->clone(%args)}sub activate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$self->ensure_dir_structure_for($path)unless$self->no_create;$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (grep {$_ eq $path}@active_lls[1 .. $#active_lls]){$self=$self->deactivate($path)}my%args;if (!@active_lls || $active_lls[0]ne $path){%args=(bins=>[$self->install_base_bin_path($path),@{$self->bins}],libs=>[$self->install_base_perl_path($path),@{$self->libs}],inc=>[$self->lib_paths_for($path),@{$self->inc}],roots=>[$path,@{$self->roots}],)}$args{extra}={$self->installer_options_for($path)};$self->clone(%args)}sub normalize_path {my ($self,$path)=@_;$path=(Win32::GetShortPathName($path)|| $path)if $^O eq 'MSWin32';return$path}sub build_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_activate_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_deactivate_environment_vars_for {my$self=$_[0]->new->deactivate($_[1]);$self->build_environment_vars}sub build_deact_all_environment_vars_for {my$self=$_[0]->new->deactivate_all;$self->build_environment_vars}sub build_environment_vars {my$self=shift;(PATH=>join($_path_sep,_as_list($self->bins)),PERL5LIB=>join($_path_sep,_as_list($self->libs)),PERL_LOCAL_LIB_ROOT=>join($_path_sep,_as_list($self->roots)),%{$self->extra},)}sub setup_local_lib_for {my$self=$_[0]->new->activate($_[1]);$self->setup_local_lib}sub setup_local_lib {my$self=shift;require Carp::Heavy if$INC{'Carp.pm'};$self->setup_env_hash;@INC=@{$self->inc}}sub setup_env_hash_for {my$self=$_[0]->new->activate($_[1]);$self->setup_env_hash}sub setup_env_hash {my$self=shift;my%env=$self->build_environment_vars;for my$key (keys%env){if (defined$env{$key}){$ENV{$key}=$env{$key}}else {delete$ENV{$key}}}}sub print_environment_vars_for {print $_[0]->environment_vars_string_for(@_[1..$#_])}sub environment_vars_string_for {my$self=$_[0]->new->activate($_[1]);$self->environment_vars_string}sub environment_vars_string {my ($self,$shelltype)=@_;$shelltype ||= $self->guess_shelltype;my$extra=$self->extra;my@envs=(PATH=>$self->bins,PERL5LIB=>$self->libs,PERL_LOCAL_LIB_ROOT=>$self->roots,map {$_=>$extra->{$_}}sort keys %$extra,);$self->_build_env_string($shelltype,\@envs)}sub _build_env_string {my ($self,$shelltype,$envs)=@_;my@envs=@$envs;my$build_method="build_${shelltype}_env_declaration";my$out='';while (@envs){my ($name,$value)=(shift(@envs),shift(@envs));if (ref$value && @$value==1 && ref$value->[0]&& ref$value->[0]eq 'SCALAR' && ${$value->[0]}eq $name){next}$out .= $self->$build_method($name,$value)}my$wrap_method="wrap_${shelltype}_output";if ($self->can($wrap_method)){return$self->$wrap_method($out)}return$out}sub build_bourne_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'${%s}',qr/["\\\$!`]/,'\\%s');if (!defined$value){return qq{unset $name;\n}}$value =~ s/(^|\G|$_path_sep)\$\{$name\}$_path_sep/$1\${$name}\${$name+$_path_sep}/g;$value =~ s/$_path_sep\$\{$name\}$/\${$name+$_path_sep}\${$name}/;qq{${name}="$value"; export ${name};\n}}sub build_csh_env_declaration {my ($class,$name,$args)=@_;my ($value,@vars)=$class->_interpolate($args,'${%s}','"','"\\%s"');if (!defined$value){return qq{unsetenv $name;\n}}my$out='';for my$var (@vars){$out .= qq{if ! \$?$name setenv $name '';\n}}my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g){$out .= qq{if "\${$name}" != '' setenv $name "$value";\n};$out .= qq{if "\${$name}" == '' }}$out .= qq{setenv $name "$value_without";\n};return$out}sub build_cmd_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'%%%s%%',qr(%),'%s');if (!$value){return qq{\@set $name=\n}}my$out='';my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g){$out .= qq{\@if not "%$name%"=="" set "$name=$value"\n};$out .= qq{\@if "%$name%"=="" }}$out .= qq{\@set "$name=$value_without"\n};return$out}sub build_powershell_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$env:%s','"','`%s');if (!$value){return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n}}my$maybe_path_sep=qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};$value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;$value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;qq{\$env:$name = \$("$value");\n}}sub wrap_powershell_output {my ($class,$out)=@_;return$out || " \n"}sub build_fish_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$%s',qr/[\\"' ]/,'\\%s');if (!defined$value){return qq{set -e $name;\n}}$value =~ s/$_path_sep/ /g;qq{set -x $name $value;\n}}sub _interpolate {my ($class,$args,$var_pat,$escape,$escape_pat)=@_;return unless defined$args;my@args=ref$args ? @$args : $args;return unless@args;my@vars=map {$$_}grep {ref $_ eq 'SCALAR'}@args;my$string=join$_path_sep,map {ref $_ eq 'SCALAR' ? sprintf($var_pat,$$_): do {s/($escape)/sprintf($escape_pat, $1)/ge;$_}}@args;return wantarray ? ($string,\@vars): $string}sub pipeline;sub pipeline {my@methods=@_;my$last=pop(@methods);if (@methods){\sub {my ($obj,@args)=@_;$obj->${pipeline@methods}($obj->$last(@args))}}else {\sub {shift->$last(@_)}}}sub resolve_path {my ($class,$path)=@_;$path=$class->${pipeline qw(resolve_relative_path resolve_home_path resolve_empty_path)}($path);$path}sub resolve_empty_path {my ($class,$path)=@_;if (defined$path){$path}else {'~/perl5'}}sub resolve_home_path {my ($class,$path)=@_;$path =~ /^~([^\/]*)/ or return$path;my$user=$1;my$homedir=do {if (!length($user)&& defined$ENV{HOME}){$ENV{HOME}}else {require File::Glob;File::Glob::bsd_glob("~$user",File::Glob::GLOB_TILDE())}};unless (defined$homedir){require Carp;require Carp::Heavy;Carp::croak("Couldn't resolve homedir for " .(defined$user ? $user : 'current user'))}$path =~ s/^~[^\/]*/$homedir/;$path}sub resolve_relative_path {my ($class,$path)=@_;_rel2abs($path)}sub ensure_dir_structure_for {my ($class,$path)=@_;unless (-d $path){warn "Attempting to create directory ${path}\n"}require File::Basename;my@dirs;while(!-d $path){push@dirs,$path;$path=File::Basename::dirname($path)}mkdir $_ for reverse@dirs;return}sub guess_shelltype {my$shellbin =defined$ENV{SHELL}? ($ENV{SHELL}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' && exists$ENV{'!EXITCODE'})? 'bash' : ($^O eq 'MSWin32' && $ENV{PROMPT}&& $ENV{COMSPEC})? ($ENV{COMSPEC}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' &&!$ENV{PROMPT})? 'powershell.exe' : 'sh';for ($shellbin){return /csh$/ ? 'csh' : /fish/ ? 'fish' : /command(?:\.com)?$/i ? 'cmd' : /cmd(?:\.exe)?$/i ? 'cmd' : /4nt(?:\.exe)?$/i ? 'cmd' : /powershell(?:\.exe)?$/i ? 'powershell' : 'bourne'}}1; - WHOA THERE! It looks like you've got some fancy dashes in your commandline! - These are *not* the traditional -- dashes that software recognizes. You - probably got these by copy-pasting from the perldoc for this module as - rendered by a UTF8-capable formatter. This most typically happens on an OS X - terminal, but can happen elsewhere too. Please try again after replacing the - dashes with normal minus signs. - DEATH - FATAL: The local::lib --self-contained flag has never worked reliably and the - original author, Mark Stosberg, was unable or unwilling to maintain it. As - such, this flag has been removed from the local::lib codebase in order to - prevent misunderstandings and potentially broken builds. The local::lib authors - recommend that you look at the lib::core::only module shipped with this - distribution in order to create a more robust environment that is equivalent to - what --self-contained provided (although quite possibly not what you originally - thought it provided due to the poor quality of the documentation, for which we - apologise). - DEATH -LOCAL_LIB - -$fatpacked{"parent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARENT'; - package parent;use strict;use vars qw($VERSION);$VERSION='0.228';sub import {my$class=shift;my$inheritor=caller(0);if (@_ and $_[0]eq '-norequire'){shift @_}else {for (my@filename=@_){if ($_ eq $inheritor){warn "Class '$inheritor' tried to inherit from itself\n"};s{::|'}{/}g;require "$_.pm"}}{no strict 'refs';push @{"$inheritor\::ISA"},@_}};"All your base are belong to us" -PARENT - -$fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION'; - package version;use 5.006002;use strict;use warnings::register;if ($] >= 5.015){warnings::register_categories(qw/version/)}use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);$VERSION=0.9912;$CLASS='version';{local$SIG{'__DIE__'};if (1){eval "use version::vpp $VERSION";die "$@" if ($@);push@ISA,"version::vpp";local $^W;*version::qv=\&version::vpp::qv;*version::declare=\&version::vpp::declare;*version::_VERSION=\&version::vpp::_VERSION;*version::vcmp=\&version::vpp::vcmp;*version::new=\&version::vpp::new;*version::numify=\&version::vpp::numify;*version::normal=\&version::vpp::normal;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vpp::stringify;*{'version::(""'}=\&version::vpp::stringify;*{'version::(<=>'}=\&version::vpp::vcmp;*version::parse=\&version::vpp::parse}}else {push@ISA,"version::vxs";local $^W;*version::declare=\&version::vxs::declare;*version::qv=\&version::vxs::qv;*version::_VERSION=\&version::vxs::_VERSION;*version::vcmp=\&version::vxs::VCMP;*version::new=\&version::vxs::new;*version::numify=\&version::vxs::numify;*version::normal=\&version::vxs::normal;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vxs::stringify;*{'version::(""'}=\&version::vxs::stringify;*{'version::(<=>'}=\&version::vxs::VCMP;*version::parse=\&version::vxs::parse}}}require version::regex;*version::is_lax=\&version::regex::is_lax;*version::is_strict=\&version::regex::is_strict;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){local $^W;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}1; -VERSION - -$fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_REGEX'; - package version::regex;use strict;use vars qw($VERSION $CLASS $STRICT $LAX);$VERSION=0.9912;my$FRACTION_PART=qr/\.[0-9]+/;my$STRICT_INTEGER_PART=qr/0|[1-9][0-9]*/;my$LAX_INTEGER_PART=qr/[0-9]+/;my$STRICT_DOTTED_DECIMAL_PART=qr/\.[0-9]{1,3}/;my$LAX_DOTTED_DECIMAL_PART=qr/\.[0-9]+/;my$LAX_ALPHA_PART=qr/_[0-9]+/;my$STRICT_DECIMAL_VERSION=qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;my$STRICT_DOTTED_DECIMAL_VERSION=qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;$STRICT=qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;my$LAX_DECIMAL_VERSION=qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? - | - $FRACTION_PART $LAX_ALPHA_PART? - /x;my$LAX_DOTTED_DECIMAL_VERSION=qr/ - v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? - | - $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? - /x;$LAX=qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;sub is_strict {defined $_[0]&& $_[0]=~ qr/ \A $STRICT \z /x}sub is_lax {defined $_[0]&& $_[0]=~ qr/ \A $LAX \z /x}1; -VERSION_REGEX - -$fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VPP'; - package charstar;use overload ('""'=>\&thischar,'0+'=>\&thischar,'++'=>\&increment,'--'=>\&decrement,'+'=>\&plus,'-'=>\&minus,'*'=>\&multiply,'cmp'=>\&cmp,'<=>'=>\&spaceship,'bool'=>\&thischar,'='=>\&clone,);sub new {my ($self,$string)=@_;my$class=ref($self)|| $self;my$obj={string=>[split(//,$string)],current=>0,};return bless$obj,$class}sub thischar {my ($self)=@_;my$last=$#{$self->{string}};my$curr=$self->{current};if ($curr >= 0 && $curr <= $last){return$self->{string}->[$curr]}else {return ''}}sub increment {my ($self)=@_;$self->{current}++}sub decrement {my ($self)=@_;$self->{current}--}sub plus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}+= $offset;return$rself}sub minus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}-= $offset;return$rself}sub multiply {my ($left,$right,$swapped)=@_;my$char=$left->thischar();return$char * $right}sub spaceship {my ($left,$right,$swapped)=@_;unless (ref($right)){$right=$left->new($right)}return$left->{current}<=> $right->{current}}sub cmp {my ($left,$right,$swapped)=@_;unless (ref($right)){if (length($right)==1){return$left->thischar cmp $right}$right=$left->new($right)}return$left->currstr cmp $right->currstr}sub bool {my ($self)=@_;my$char=$self->thischar;return ($char ne '')}sub clone {my ($left,$right,$swapped)=@_;$right={string=>[@{$left->{string}}],current=>$left->{current},};return bless$right,ref($left)}sub currstr {my ($self,$s)=@_;my$curr=$self->{current};my$last=$#{$self->{string}};if (defined($s)&& $s->{current}< $last){$last=$s->{current}}my$string=join('',@{$self->{string}}[$curr..$last]);return$string}package version::vpp;use 5.006002;use strict;use warnings::register;use Config;use vars qw($VERSION $CLASS @ISA $LAX $STRICT $WARN_CATEGORY);$VERSION=0.9912;$CLASS='version::vpp';if ($] > 5.015){warnings::register_categories(qw/version/);$WARN_CATEGORY='version'}else {$WARN_CATEGORY='numeric'}require version::regex;*version::vpp::is_strict=\&version::regex::is_strict;*version::vpp::is_lax=\&version::regex::is_lax;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;use overload ('""'=>\&stringify,'0+'=>\&numify,'cmp'=>\&vcmp,'<=>'=>\&vcmp,'bool'=>\&vbool,'+'=>\&vnoop,'-'=>\&vnoop,'*'=>\&vnoop,'/'=>\&vnoop,'+='=>\&vnoop,'-='=>\&vnoop,'*='=>\&vnoop,'/='=>\&vnoop,'abs'=>\&vnoop,);sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){no warnings qw/redefine/;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}my$VERSION_MAX=0x7FFFFFFF;use constant TRUE=>1;use constant FALSE=>0;sub isDIGIT {my ($char)=shift->thischar();return ($char =~ /\d/)}sub isALPHA {my ($char)=shift->thischar();return ($char =~ /[a-zA-Z]/)}sub isSPACE {my ($char)=shift->thischar();return ($char =~ /\s/)}sub BADVERSION {my ($s,$errstr,$error)=@_;if ($errstr){$$errstr=$error}return$s}sub prescan_version {my ($s,$strict,$errstr,$sqv,$ssaw_decimal,$swidth,$salpha)=@_;my$qv=defined$sqv ? $$sqv : FALSE;my$saw_decimal=defined$ssaw_decimal ? $$ssaw_decimal : 0;my$width=defined$swidth ? $$swidth : 3;my$alpha=defined$salpha ? $$salpha : FALSE;my$d=$s;if ($qv && isDIGIT($d)){goto dotted_decimal_version}if ($d eq 'v'){$d++;if (isDIGIT($d)){$qv=TRUE}else {return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}else {if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}else {goto version_prescan_finish}}{my$i=0;my$j=0;while (isDIGIT($d)){$i++;while (isDIGIT($d)){$d++;$j++;if ($strict && $j > 3){return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)")}}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}$d++;$alpha=TRUE}elsif ($d eq '.'){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}$saw_decimal++;$d++}elsif (!isDIGIT($d)){last}$j=0}if ($strict && $i < 2){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}}}else {my$j=0;if ($strict){if ($d eq '.'){return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)")}if ($d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}}if ($d eq '-'){return BADVERSION($s,$errstr,"Invalid version format (negative version number)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}elsif (!$d || $d eq ';' || isSPACE($d)|| $d eq '}'){if ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (version required)")}goto version_prescan_finish}elsif ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}elsif ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}elsif (isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)")}else {return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}}elsif ($d){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($d &&!isDIGIT($d)&& ($strict ||!($d eq ';' || isSPACE($d)|| $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (fractional part required)")}while (isDIGIT($d)){$d++;$j++;if ($d eq '.' && isDIGIT($d-1)){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')")}$d=$s;$qv=TRUE;goto dotted_decimal_version}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}if (!isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}$width=$j;$d++;$alpha=TRUE}}}version_prescan_finish: while (isSPACE($d)){$d++}if ($d &&!isDIGIT($d)&& (!($d eq ';' || $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($saw_decimal > 1 && ($d-1)eq '.'){return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)")}if (defined$sqv){$$sqv=$qv}if (defined$swidth){$$swidth=$width}if (defined$ssaw_decimal){$$ssaw_decimal=$saw_decimal}if (defined$salpha){$$salpha=$alpha}return$d}sub scan_version {my ($s,$rv,$qv)=@_;my$start;my$pos;my$last;my$errstr;my$saw_decimal=0;my$width=3;my$alpha=FALSE;my$vinf=FALSE;my@av;$s=new charstar$s;while (isSPACE($s)){$s++}$last=prescan_version($s,FALSE,\$errstr,\$qv,\$saw_decimal,\$width,\$alpha);if ($errstr){if ($s ne 'undef'){require Carp;Carp::croak($errstr)}}$start=$s;if ($s eq 'v'){$s++}$pos=$s;if ($qv){$$rv->{qv}=$qv}if ($alpha){$$rv->{alpha}=$alpha}if (!$qv && $width < 3){$$rv->{width}=$width}while (isDIGIT($pos)){$pos++}if (!isALPHA($pos)){my$rev;for (;;){$rev=0;{my$end=$pos;my$mult=1;my$orev;if (!$qv && $s > $start && $saw_decimal==1){$mult *= 100;while ($s < $end){$orev=$rev;$rev += $s * $mult;$mult /= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version %d",$VERSION_MAX);$s=$end - 1;$rev=$VERSION_MAX;$vinf=1}$s++;if ($s eq '_'){$s++}}}else {while (--$end >= $s){$orev=$rev;$rev += $end * $mult;$mult *= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version");$end=$s - 1;$rev=$VERSION_MAX;$vinf=1}}}}push@av,$rev;if ($vinf){$s=$last;last}elsif ($pos eq '.'){$pos++;if ($qv){while ($pos eq '0'){$pos++}}$s=$pos}elsif ($pos eq '_' && isDIGIT($pos+1)){$s=++$pos}elsif ($pos eq ',' && isDIGIT($pos+1)){$s=++$pos}elsif (isDIGIT($pos)){$s=$pos}else {$s=$pos;last}if ($qv){while (isDIGIT($pos)){$pos++}}else {my$digits=0;while ((isDIGIT($pos)|| $pos eq '_')&& $digits < 3){if ($pos ne '_'){$digits++}$pos++}}}}if ($qv){my$len=$#av;$len=2 - $len;while ($len-- > 0){push@av,0}}if ($vinf){$$rv->{original}="v.Inf";$$rv->{vinf}=1}elsif ($s > $start){$$rv->{original}=$start->currstr($s);if ($qv && $saw_decimal==1 && $start ne 'v'){$$rv->{original}='v' .$$rv->{original}}}else {$$rv->{original}='0';push(@av,0)}$$rv->{version}=\@av;if ($s eq 'undef'){$s += 5}return$s}sub new {my$class=shift;unless (defined$class or $#_ > 1){require Carp;Carp::croak('Usage: version::new(class, version)')}my$self=bless ({},ref ($class)|| $class);my$qv=FALSE;if ($#_==1){$qv=TRUE}my$value=pop;if (ref($value)&& eval('$value->isa("version")')){$self->{version}=[@{$value->{version}}];$self->{qv}=1 if$value->{qv};$self->{alpha}=1 if$value->{alpha};$self->{original}=''.$value->{original};return$self}if (not defined$value or $value =~ /^undef$/){push @{$self->{version}},0;$self->{original}="0";return ($self)}if (ref($value)=~ m/ARRAY|HASH/){require Carp;Carp::croak("Invalid version format (non-numeric data)")}$value=_un_vstring($value);if ($Config{d_setlocale}){use POSIX qw/locale_h/;use if$Config{d_setlocale},'locale';my$currlocale=setlocale(LC_ALL);if (localeconv()->{decimal_point}eq ','){$value =~ tr/,/./}}if ($value =~ /\d+.?\d*e[-+]?\d+/){$value=sprintf("%.9f",$value);$value =~ s/(0+)$//}my$s=scan_version($value,\$self,$qv);if ($s){warn("Version string '%s' contains invalid data; " ."ignoring: '%s'",$value,$s)}return ($self)}*parse=\&new;sub numify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$width=$self->{width}|| 3;my$alpha=$self->{alpha}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("%d.",$digit);if ($alpha and warnings::enabled()){warnings::warn($WARN_CATEGORY,'alpha->numify() is lossy')}for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];if ($width < 3){my$denom=10**(3-$width);my$quot=int($digit/$denom);my$rem=$digit - ($quot * $denom);$string .= sprintf("%0".$width."d_%d",$quot,$rem)}else {$string .= sprintf("%03d",$digit)}}if ($len > 0){$digit=$self->{version}[$len];if ($alpha && $width==3){$string .= "_"}$string .= sprintf("%0".$width."d",$digit)}else {$string .= sprintf("000")}return$string}sub normal {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$alpha=$self->{alpha}|| "";my$qv=$self->{qv}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("v%d",$digit);for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];$string .= sprintf(".%d",$digit)}if ($len > 0){$digit=$self->{version}[$len];if ($alpha){$string .= sprintf("_%0d",$digit)}else {$string .= sprintf(".%0d",$digit)}}if ($len <= 2){for ($len=2 - $len;$len!=0;$len-- ){$string .= sprintf(".%0d",0)}}return$string}sub stringify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}return exists$self->{original}? $self->{original}: exists$self->{qv}? $self->normal : $self->numify}sub vcmp {require UNIVERSAL;my ($left,$right,$swap)=@_;my$class=ref($left);unless (UNIVERSAL::isa($right,$class)){$right=$class->new($right)}if ($swap){($left,$right)=($right,$left)}unless (_verify($left)){require Carp;Carp::croak("Invalid version object")}unless (_verify($right)){require Carp;Carp::croak("Invalid version format")}my$l=$#{$left->{version}};my$r=$#{$right->{version}};my$m=$l < $r ? $l : $r;my$lalpha=$left->is_alpha;my$ralpha=$right->is_alpha;my$retval=0;my$i=0;while ($i <= $m && $retval==0){$retval=$left->{version}[$i]<=> $right->{version}[$i];$i++}if ($retval==0 && $l==$r && $left->{version}[$m]==$right->{version}[$m]&& ($lalpha || $ralpha)){if ($lalpha &&!$ralpha){$retval=-1}elsif ($ralpha &&!$lalpha){$retval=+1}}if ($retval==0 && $l!=$r){if ($l < $r){while ($i <= $r && $retval==0){if ($right->{version}[$i]!=0){$retval=-1}$i++}}else {while ($i <= $l && $retval==0){if ($left->{version}[$i]!=0){$retval=+1}$i++}}}return$retval}sub vbool {my ($self)=@_;return vcmp($self,$self->new("0"),1)}sub vnoop {require Carp;Carp::croak("operation not supported with version object")}sub is_alpha {my ($self)=@_;return (exists$self->{alpha})}sub qv {my$value=shift;my$class=$CLASS;if (@_){$class=ref($value)|| $value;$value=shift}$value=_un_vstring($value);$value='v'.$value unless$value =~ /(^v|\d+\.\d+\.\d)/;my$obj=$CLASS->new($value);return bless$obj,$class}*declare=\&qv;sub is_qv {my ($self)=@_;return (exists$self->{qv})}sub _verify {my ($self)=@_;if (ref($self)&& eval {exists$self->{version}}&& ref($self->{version})eq 'ARRAY'){return 1}else {return 0}}sub _is_non_alphanumeric {my$s=shift;$s=new charstar$s;while ($s){return 0 if isSPACE($s);return 1 unless (isALPHA($s)|| isDIGIT($s)|| $s =~ /[.-]/);$s++}return 0}sub _un_vstring {my$value=shift;if (length($value)>= 1 && $value !~ /[,._]/ && _is_non_alphanumeric($value)){my$tvalue;if ($] >= 5.008_001){$tvalue=_find_magic_vstring($value);$value=$tvalue if length$tvalue}elsif ($] >= 5.006_000){$tvalue=sprintf("v%vd",$value);if ($tvalue =~ /^v\d+(\.\d+)*$/){$value=$tvalue}}}return$value}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub _VERSION {my ($obj,$req)=@_;my$class=ref($obj)|| $obj;no strict 'refs';if (exists$INC{"$class.pm"}and not %{"$class\::"}and $] >= 5.008){require Carp;Carp::croak("$class defines neither package nor VERSION" ."--version check failed")}my$version=eval "\$$class\::VERSION";if (defined$version){local $^W if $] <= 5.008;$version=version::vpp->new($version)}if (defined$req){unless (defined$version){require Carp;my$msg=$] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed";if ($ENV{VERSION_DEBUG}){Carp::confess($msg)}else {Carp::croak($msg)}}$req=version::vpp->new($req);if ($req > $version){require Carp;if ($req->is_qv){Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->normal,$version->normal))}else {Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->stringify,$version->stringify))}}}return defined$version ? $version->stringify : undef}1; -VERSION_VPP - -s/^ //mg for values %fatpacked; - -my $class = 'FatPacked::'.(0+\%fatpacked); -no strict 'refs'; -*{"${class}::files"} = sub { keys %{$_[0]} }; - -if ($] < 5.008) { - *{"${class}::INC"} = sub { - if (my $fat = $_[0]{$_[1]}) { - my $pos = 0; - my $last = length $fat; - return (sub { - return 0 if $pos == $last; - my $next = (1 + index $fat, "\n", $pos) || $last; - $_ .= substr $fat, $pos, $next - $pos; - $pos = $next; - return 1; - }); - } - }; -} - -else { - *{"${class}::INC"} = sub { - if (my $fat = $_[0]{$_[1]}) { - open my $fh, '<', \$fat - or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; - return $fh; - } - return; - }; -} - -unshift @INC, bless \%fatpacked, $class; - } # END OF FATPACK CODE - - - -use strict; -use App::cpanminus::script; - - -unless (caller) { - my $app = App::cpanminus::script->new; - $app->parse_options(@ARGV); - exit $app->doit; -} - -__END__ - -=head1 NAME - -cpanm - get, unpack build and install modules from CPAN - -=head1 SYNOPSIS - - cpanm Test::More # install Test::More - cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path - cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL - cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file - cpanm --interactive Task::Kensho # Configure interactively - cpanm . # install from local directory - cpanm --installdeps . # install all the deps for the current directory - cpanm -L extlib Plack # install Plack and all non-core deps into extlib - cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror - cpanm --from https://cpan.metacpan.org/ Plack # use only the HTTPS mirror - -=head1 COMMANDS - -=over 4 - -=item (arguments) - -Command line arguments can be either a module name, distribution file, -local file path, HTTP URL or git repository URL. Following commands -will all work as you expect. - - cpanm Plack - cpanm Plack/Request.pm - cpanm MIYAGAWA/Plack-1.0000.tar.gz - cpanm /path/to/Plack-1.0000.tar.gz - cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz - cpanm git://github.com/plack/Plack.git - -Additionally, you can use the notation using C<~> and C<@> to specify -version for a given module. C<~> specifies the version requirement in -the L format, while C<@> pins the exact version, and -is a shortcut for C<~"== VERSION">. - - cpanm Plack~1.0000 # 1.0000 or later - cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx - cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990" - -The version query including specific version or range will be sent to -L to search for previous releases. The query will search for -BackPAN archives by default, unless you specify C<--dev> option, in -which case, archived versions will be filtered out. - -For a git repository, you can specify a branch, tag, or commit SHA to -build. The default is C - - cpanm git://github.com/plack/Plack.git@1.0000 # tag - cpanm git://github.com/plack/Plack.git@devel # branch - -=item -i, --install - -Installs the modules. This is a default behavior and this is just a -compatibility option to make it work like L or L. - -=item --self-upgrade - -Upgrades itself. It's just an alias for: - - cpanm App::cpanminus - -=item --info - -Displays the distribution information in -C format in the standard out. - -=item --installdeps - -Installs the dependencies of the target distribution but won't build -itself. Handy if you want to try the application from a version -controlled repository such as git. - - cpanm --installdeps . - -=item --look - -Download and unpack the distribution and then open the directory with -your shell. Handy to poke around the source code or do manual -testing. - -=item -h, --help - -Displays the help message. - -=item -V, --version - -Displays the version number. - -=back - -=head1 OPTIONS - -You can specify the default options in C environment variable. - -=over 4 - -=item -f, --force - -Force install modules even when testing failed. - -=item -n, --notest - -Skip the testing of modules. Use this only when you just want to save -time for installing hundreds of distributions to the same perl and -architecture you've already tested to make sure it builds fine. - -Defaults to false, and you can say C<--no-notest> to override when it -is set in the default options in C. - -=item --test-only - -Run the tests only, and do not install the specified module or -distributions. Handy if you want to verify the new (or even old) -releases pass its unit tests without installing the module. - -Note that if you specify this option with a module or distribution -that has dependencies, these dependencies will be installed if you -don't currently have them. - -=item -S, --sudo - -Switch to the root user with C when installing modules. Use this -if you want to install modules to the system perl include path. - -Defaults to false, and you can say C<--no-sudo> to override when it is -set in the default options in C. - -=item -v, --verbose - -Makes the output verbose. It also enables the interactive -configuration. (See --interactive) - -=item -q, --quiet - -Makes the output even more quiet than the default. It only shows the -successful/failed dependencies to the output. - -=item -l, --local-lib - -Sets the L compatible path to install modules to. You -don't need to set this if you already configure the shell environment -variables using L, but this can be used to override that -as well. - -=item -L, --local-lib-contained - -Same with C<--local-lib> but with L<--self-contained> set. All -non-core dependencies will be installed even if they're already -installed. - -For instance, - - cpanm -L extlib Plack - -would install Plack and all of its non-core dependencies into the -directory C, which can be loaded from your application with: - - use local::lib '/path/to/extlib'; - -Note that this option does B reliably work with perl installations -supplied by operating system vendors that strips standard modules from perl, -such as RHEL, Fedora and CentOS, B you also install packages supplying -all the modules that have been stripped. For these systems you will probably -want to install the C meta-package which does just that. - -=item --self-contained - -When examining the dependencies, assume no non-core modules are -installed on the system. Handy if you want to bundle application -dependencies in one directory so you can distribute to other machines. - -=item --exclude-vendor - -Don't include modules installed under the 'vendor' paths when searching for -core modules when the C<--self-contained> flag is in effect. This restores -the behaviour from before version 1.7023 - -=item --mirror - -Specifies the base URL for the CPAN mirror to use, such as -C (you can omit the trailing slash). You -can specify multiple mirror URLs by repeating the command line option. - -You can use a local directory that has a CPAN mirror structure -(created by tools such as L or L) by using a special -URL scheme C. If the given URL begins with `/` (without any -scheme), it is considered as a file scheme as well. - - cpanm --mirror file:///path/to/mirror - cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user - -Defaults to C. - -=item --mirror-only - -Download the mirror's 02packages.details.txt.gz index file instead of -querying the CPAN Meta DB. This will also effectively opt out sending -your local perl versions to backend database servers such as CPAN Meta -DB and MetaCPAN. - -Select this option if you are using a local mirror of CPAN, such as -minicpan when you're offline, or your own CPAN index (a.k.a darkpan). - -=item --from, -M - - cpanm -M https://cpan.metacpan.org/ - cpanm --from https://cpan.metacpan.org/ - -Use the given mirror URL and its index as the I source to search -and download modules from. - -It works similar to C<--mirror> and C<--mirror-only> combined, with a -small difference: unlike C<--mirror> which I the URL to the -list of mirrors, C<--from> (or C<-M> for short) uses the specified URL -as its I source to download index and modules from. This makes -the option always override the default mirror, which might have been -set via global options such as the one set by C -environment variable. - -B It might be useful if you name these options with your shell -aliases, like: - - alias minicpanm='cpanm --from ~/minicpan' - alias darkpan='cpanm --from http://mycompany.example.com/DPAN' - -=item --mirror-index - -B: Specifies the file path to C<02packages.details.txt> -for module search index. - -=item --cpanmetadb - -B: Specifies an alternate URI for CPAN MetaDB index lookups. - -=item --metacpan - -Prefers MetaCPAN API over CPAN MetaDB. - -=item --cpanfile - -B: Specified an alternate path for cpanfile to search for, -when C<--installdeps> command is in use. Defaults to C. - -=item --prompt - -Prompts when a test fails so that you can skip, force install, retry -or look in the shell to see what's going wrong. It also prompts when -one of the dependency failed if you want to proceed the installation. - -Defaults to false, and you can say C<--no-prompt> to override if it's -set in the default options in C. - -=item --dev - -B: search for a newer developer release as well. Defaults to false. - -=item --reinstall - -cpanm, when given a module name in the command line (i.e. C), checks the locally installed version first and skips if it is -already installed. This option makes it skip the check, so: - - cpanm --reinstall Plack - -would reinstall L even if your locally installed version is -latest, or even newer (which would happen if you install a developer -release from version control repositories). - -Defaults to false. - -=item --interactive - -Makes the configuration (such as C and C) -interactive, so you can answer questions in the distribution that -requires custom configuration or Task:: distributions. - -Defaults to false, and you can say C<--no-interactive> to override -when it's set in the default options in C. - -=item --pp, --pureperl - -Prefer Pure perl build of modules by setting C for -MakeMaker and C<--pureperl-only> for Build.PL based -distributions. Note that not all of the CPAN modules support this -convention yet. - -=item --with-recommends, --with-suggests - -B: Installs dependencies declared as C and -C respectively, per META spec. When these dependencies fail -to install, cpanm continues the installation, since they're just -recommendation/suggestion. - -Enabling this could potentially make a circular dependency for a few -modules on CPAN, when C adds a module that C -back the module in return. - -There's also C<--without-recommend> and C<--without-suggests> to -override the default decision made earlier in C. - -Defaults to false for both. - -=item --with-develop - -B: Installs develop phase dependencies in META files or -C when used with C<--installdeps>. Defaults to false. - -=item --with-configure - -B: Installs configure phase dependencies in C -when used with C<--installdeps>. Defaults to false. - -=item --with-feature, --without-feature, --with-all-features - -B: Specifies the feature to enable, if a module supports -optional features per META spec 2.0. - - cpanm --with-feature=opt_csv Spreadsheet::Read - -the features can also be interactively chosen when C<--interactive> -option is enabled. - -C<--with-all-features> enables all the optional features, and -C<--without-feature> can select a feature to disable. - -=item --configure-timeout, --build-timeout, --test-timeout - -Specify the timeout length (in seconds) to wait for the configure, -build and test process. Current default values are: 60 for configure, -3600 for build and 1800 for test. - -=item --configure-args, --build-args, --test-args, --install-args - -B: Pass arguments for configure/build/test/install -commands respectively, for a given module to install. - - cpanm DBD::mysql --configure-args="--cflags=... --libs=..." - -The argument is only enabled for the module passed as a command line -argument, not dependencies. - -=item --scandeps - -B: Scans the depencencies of given modules and output the -tree in a text format. (See C<--format> below for more options) - -Because this command doesn't actually install any distributions, it -will be useful that by typing: - - cpanm --scandeps Catalyst::Runtime - -you can make sure what modules will be installed. - -This command takes into account which modules you already have -installed in your system. If you want to see what modules will be -installed against a vanilla perl installation, you might want to -combine it with C<-L> option. - -=item --format - -B: Determines what format to display the scanned -dependency tree. Available options are C, C, C and -C. - -=over 8 - -=item tree - -Displays the tree in a plain text format. This is the default value. - -=item json, yaml - -Outputs the tree in a JSON or YAML format. L and L modules -need to be installed respectively. The output tree is represented as a -recursive tuple of: - - [ distribution, dependencies ] - -and the container is an array containing the root elements. Note that -there may be multiple root nodes, since you can give multiple modules -to the C<--scandeps> command. - -=item dists - -C is a special output format, where it prints the distribution -filename in the I after the dependency resolution, -like: - - GAAS/MIME-Base64-3.13.tar.gz - GAAS/URI-1.58.tar.gz - PETDANCE/HTML-Tagset-3.20.tar.gz - GAAS/HTML-Parser-3.68.tar.gz - GAAS/libwww-perl-5.837.tar.gz - -which means you can install these distributions in this order without -extra dependencies. When combined with C<-L> option, it will be useful -to replay installations on other machines. - -=back - -=item --save-dists - -Specifies the optional directory path to copy downloaded tarballs in -the CPAN mirror compatible directory structure -i.e. I - -If the distro tarball did not come from CPAN, for example from a local -file or from GitHub, then it will be saved under -I. - -=item --uninst-shadows - -Uninstalls the shadow files of the distribution that you're -installing. This eliminates the confusion if you're trying to install -core (dual-life) modules from CPAN against perl 5.10 or older, or -modules that used to be XS-based but switched to pure perl at some -version. - -If you run cpanm as root and use C or equivalent to -specify custom installation path, you SHOULD disable this option so -you won't accidentally uninstall dual-life modules from the core -include path. - -Defaults to true if your perl version is smaller than 5.12, and you -can disable that with C<--no-uninst-shadows>. - -B: Since version 1.3000 this flag is turned off by default for -perl newer than 5.12, since with 5.12 @INC contains site_perl directory -I the perl core library path, and uninstalling shadows is not -necessary anymore and does more harm by deleting files from the core -library path. - -=item --uninstall, -U - -Uninstalls a module from the library path. It finds a packlist for -given modules, and removes all the files included in the same -distribution. - -If you enable local::lib, it only removes files from the local::lib -directory. - -If you try to uninstall a module in C directory (i.e. core -module), an error will be thrown. - -A dialog will be prompted to confirm the files to be deleted. If you pass -C<-f> option as well, the dialog will be skipped and uninstallation -will be forced. - -=item --cascade-search - -B: Specifies whether to cascade search when you specify -multiple mirrors and a mirror doesn't have a module or has a lower -version of the module than requested. Defaults to false. - -=item --skip-installed - -Specifies whether a module given in the command line is skipped if its latest -version is already installed. Defaults to true. - -B: The C environment variable have to be correctly set -for this to work with modules installed using L, unless -you always use the C<-l> option. - -=item --skip-satisfied - -B: Specifies whether a module (and version) given in the -command line is skipped if it's already installed. - -If you run: - - cpanm --skip-satisfied CGI DBI~1.2 - -cpanm won't install them if you already have CGI (for whatever -versions) or have DBI with version higher than 1.2. It is similar to -C<--skip-installed> but while C<--skip-installed> checks if the -I version of CPAN is installed, C<--skip-satisfied> checks if -a requested version (or not, which means any version) is installed. - -Defaults to false. - -=item --verify - -Verify the integrity of distribution files retrieved from PAUSE using -CHECKSUMS and SIGNATURES (if found). Defaults to false. - -=item --report-perl-version - -Whether it reports the locally installed perl version to the various -web server as part of User-Agent. Defaults to true unless CI related -environment variables such as C, C or C -is enabled. You can disable it by using C<--no-report-perl-version>. - -=item --auto-cleanup - -Specifies the number of days in which cpanm's work directories -expire. Defaults to 7, which means old work directories will be -cleaned up in one week. - -You can set the value to C<0> to make cpan never cleanup those -directories. - -=item --man-pages - -Generates man pages for executables (man1) and libraries (man3). - -Defaults to true (man pages generated) unless C<-L|--local-lib-contained> -option is supplied in which case it's set to false. You can disable -it with C<--no-man-pages>. - -=item --lwp - -Uses L module to download stuff over HTTP. Defaults to true, and -you can say C<--no-lwp> to disable using LWP, when you want to upgrade -LWP from CPAN on some broken perl systems. - -=item --wget - -Uses GNU Wget (if available) to download stuff. Defaults to true, and -you can say C<--no-wget> to disable using Wget (versions of Wget older -than 1.9 don't support the C<--retry-connrefused> option used by cpanm). - -=item --curl - -Uses cURL (if available) to download stuff. Defaults to true, and -you can say C<--no-curl> to disable using cURL. - -Normally with C<--lwp>, C<--wget> and C<--curl> options set to true -(which is the default) cpanm tries L, Wget, cURL and L -(in that order) and uses the first one available. - -=back - -=head1 ENVIRONMENT VARIABLES - -=over 4 - -=item PERL_CPANM_HOME - -The directory cpanm should use to store downloads and build and test -modules. Defaults to the C<.cpanm> directory in your user's home -directory. - -=item PERL_CPANM_OPT - -If set, adds a set of default options to every cpanm command. These -options come first, and so are overridden by command-line options. - -=back - -=head1 SEE ALSO - -L - -=head1 COPYRIGHT - -Copyright 2010- Tatsuhiko Miyagawa. - -=head1 AUTHOR - -Tatsuhiko Miyagawa - -=cut diff --git a/bin/enc2xs b/bin/enc2xs deleted file mode 100755 index 6e904860..00000000 --- a/bin/enc2xs +++ /dev/null @@ -1,1499 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; -#!./perl -BEGIN { - # @INC poking no longer needed w/ new MakeMaker and Makefile.PL's - # with $ENV{PERL_CORE} set - # In case we need it in future... - require Config; import Config; - pop @INC if $INC[-1] eq '.'; -} -use strict; -use warnings; -use Getopt::Std; -use Config; -my @orig_ARGV = @ARGV; -our $VERSION = do { my @r = (q$Revision: 2.20 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -# These may get re-ordered. -# RAW is a do_now as inserted by &enter -# AGG is an aggregated do_now, as built up by &process - -use constant { - RAW_NEXT => 0, - RAW_IN_LEN => 1, - RAW_OUT_BYTES => 2, - RAW_FALLBACK => 3, - - AGG_MIN_IN => 0, - AGG_MAX_IN => 1, - AGG_OUT_BYTES => 2, - AGG_NEXT => 3, - AGG_IN_LEN => 4, - AGG_OUT_LEN => 5, - AGG_FALLBACK => 6, -}; - -# (See the algorithm in encengine.c - we're building structures for it) - -# There are two sorts of structures. -# "do_now" (an array, two variants of what needs storing) is whatever we need -# to do now we've read an input byte. -# It's housed in a "do_next" (which is how we got to it), and in turn points -# to a "do_next" which contains all the "do_now"s for the next input byte. - -# There will be a "do_next" which is the start state. -# For a single byte encoding it's the only "do_next" - each "do_now" points -# back to it, and each "do_now" will cause bytes. There is no state. - -# For a multi-byte encoding where all characters in the input are the same -# length, then there will be a tree of "do_now"->"do_next"->"do_now" -# branching out from the start state, one step for each input byte. -# The leaf "do_now"s will all be at the same distance from the start state, -# only the leaf "do_now"s cause output bytes, and they in turn point back to -# the start state. - -# For an encoding where there are variable length input byte sequences, you -# will encounter a leaf "do_now" sooner for the shorter input sequences, but -# as before the leaves will point back to the start state. - -# The system will cope with escape encodings (imagine them as a mostly -# self-contained tree for each escape state, and cross links between trees -# at the state-switching characters) but so far no input format defines these. - -# The system will also cope with having output "leaves" in the middle of -# the bifurcating branches, not just at the extremities, but again no -# input format does this yet. - -# There are two variants of the "do_now" structure. The first, smaller variant -# is generated by &enter as the input file is read. There is one structure -# for each input byte. Say we are mapping a single byte encoding to a -# single byte encoding, with "ABCD" going "abcd". There will be -# 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...} - -# &process then walks the tree, building aggregate "do_now" structures for -# adjacent bytes where possible. The aggregate is for a contiguous range of -# bytes which each produce the same length of output, each move to the -# same next state, and each have the same fallback flag. -# So our 4 RAW "do_now"s above become replaced by a single structure -# containing: -# ["A", "D", "abcd", 1, ...] -# ie, for an input byte $_ in "A".."D", output 1 byte, found as -# substr ("abcd", (ord $_ - ord "A") * 1, 1) -# which maps very nicely into pointer arithmetic in C for encengine.c - -sub encode_U -{ - # UTF-8 encode long hand - only covers part of perl's range - ## my $uv = shift; - # chr() works in native space so convert value from table - # into that space before using chr(). - my $ch = chr(utf8::unicode_to_native($_[0])); - # Now get core perl to encode that the way it likes. - utf8::encode($ch); - return $ch; -} - -sub encode_S -{ - # encode single byte - ## my ($ch,$page) = @_; return chr($ch); - return chr $_[0]; -} - -sub encode_D -{ - # encode double byte MS byte first - ## my ($ch,$page) = @_; return chr($page).chr($ch); - return chr ($_[1]) . chr $_[0]; -} - -sub encode_M -{ - # encode Multi-byte - single for 0..255 otherwise double - ## my ($ch,$page) = @_; - ## return &encode_D if $page; - ## return &encode_S; - return chr ($_[1]) . chr $_[0] if $_[1]; - return chr $_[0]; -} - -my %encode_types = (U => \&encode_U, - S => \&encode_S, - D => \&encode_D, - M => \&encode_M, - ); - -# Win32 does not expand globs on command line -if ($^O eq 'MSWin32' and !$ENV{PERL_CORE}) { - eval "\@ARGV = map(glob(\$_),\@ARGV)"; - @ARGV = @orig_ARGV unless @ARGV; -} - -my %opt; -# I think these are: -# -Q to disable the duplicate codepoint test -# -S make mapping errors fatal -# -q to remove comments written to output files -# -O to enable the (brute force) substring optimiser -# -o to specify the output file name (else it's the first arg) -# -f to give a file with a list of input files (else use the args) -# -n to name the encoding (else use the basename of the input file. -#Getopt::Long::Configure("bundling"); -#GetOptions(\%opt, qw(C M=s S Q q O o=s f=s n=s v)); -getopts('CM:SQqOo:f:n:v',\%opt); - -$opt{M} and make_makefile_pl($opt{M}, @ARGV); -$opt{C} and make_configlocal_pm($opt{C}, @ARGV); -$opt{v} ||= $ENV{ENC2XS_VERBOSE}; - -sub verbose { - print STDERR @_ if $opt{v}; -} -sub verbosef { - printf STDERR @_ if $opt{v}; -} - - -# ($cpp, $static, $sized) = compiler_info($declaration) -# -# return some information about the compiler and compile options we're using: -# -# $declaration - true if we're doing a declaration rather than a definition. -# -# $cpp - we're using C++ -# $static - ok to declare the arrays as static -# $sized - the array declarations should be sized - -sub compiler_info { - my ($declaration) = @_; - - my $ccflags = $Config{ccflags}; - if (defined $Config{ccwarnflags}) { - $ccflags .= " " . $Config{ccwarnflags}; - } - my $compat = $ccflags =~ /\Q-Wc++-compat/; - my $pedantic = $ccflags =~ /-pedantic/; - - my $cpp = ($Config{d_cplusplus} || '') eq 'define'; - - # The encpage_t tables contain recursive and mutually recursive - # references. To allow them to compile under C++ and some restrictive - # cc options, it may be necessary to make the tables non-static/const - # (thus moving them from the text to the data segment) and/or not - # include the size in the declaration. - - my $static = !( - $cpp - || ($compat && $pedantic) - || ($^O eq 'MacOS' && $declaration) - ); - - # -Wc++-compat on its own warns if the array declaration is sized. - # The easiest way to avoid this warning is simply not to include - # the size in the declaration. - # With -pedantic as well, the issue doesn't arise because $static - # above becomes false. - my $sized = $declaration && !($compat && !$pedantic); - - return ($cpp, $static, $sized); -} - - -# This really should go first, else the die here causes empty (non-erroneous) -# output files to be written. -my @encfiles; -if (exists $opt{f}) { - # -F is followed by name of file containing list of filenames - my $flist = $opt{f}; - open(FLIST,$flist) || die "Cannot open $flist:$!"; - chomp(@encfiles = ); - close(FLIST); -} else { - @encfiles = @ARGV; -} - -my $cname = $opt{o} ? $opt{o} : shift(@ARGV); -unless ($cname) { #debuging a win32 nmake error-only. works via cmdline - print "\nARGV:"; - print "$_ " for @ARGV; - print "\nopt:"; - print " $_ => ",defined $opt{$_}?$opt{$_}:"undef","\n" for keys %opt; -} -chmod(0666,$cname) if -f $cname && !-w $cname; -open(C,">", $cname) || die "Cannot open $cname:$!"; - -my $dname = $cname; -my $hname = $cname; - -my ($doC,$doEnc,$doUcm,$doPet); - -if ($cname =~ /\.(c|xs)$/i) # VMS may have upcased filenames with DECC$ARGV_PARSE_STYLE defined - { - $doC = 1; - $dname =~ s/(\.[^\.]*)?$/.exh/; - chmod(0666,$dname) if -f $cname && !-w $dname; - open(D,">", $dname) || die "Cannot open $dname:$!"; - $hname =~ s/(\.[^\.]*)?$/.h/; - chmod(0666,$hname) if -f $cname && !-w $hname; - open(H,">", $hname) || die "Cannot open $hname:$!"; - - foreach my $fh (\*C,\*D,\*H) - { - print $fh <<"END" unless $opt{'q'}; -/* - !!!!!!! DO NOT EDIT THIS FILE !!!!!!! - This file was autogenerated by: - $^X $0 @orig_ARGV - enc2xs VERSION $VERSION -*/ -END - } - - if ($cname =~ /(\w+)\.xs$/) - { - print C "#define PERL_NO_GET_CONTEXT\n"; - print C "#include \n"; - print C "#include \n"; - print C "#include \n"; - } - print C "#include \"encode.h\"\n\n"; - - } -elsif ($cname =~ /\.enc$/) - { - $doEnc = 1; - } -elsif ($cname =~ /\.ucm$/) - { - $doUcm = 1; - } -elsif ($cname =~ /\.pet$/) - { - $doPet = 1; - } - -my %encoding; -my %strings; -my $string_acc; -my %strings_in_acc; - -my $saved = 0; -my $subsave = 0; -my $strings = 0; - -sub cmp_name -{ - if ($a =~ /^.*-(\d+)/) - { - my $an = $1; - if ($b =~ /^.*-(\d+)/) - { - my $r = $an <=> $1; - return $r if $r; - } - } - return $a cmp $b; -} - - -foreach my $enc (sort cmp_name @encfiles) - { - my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/; - $name = $opt{'n'} if exists $opt{'n'}; - if (open(E,$enc)) - { - if ($sfx eq 'enc') - { - compile_enc(\*E,lc($name)); - } - else - { - compile_ucm(\*E,lc($name)); - } - } - else - { - warn "Cannot open $enc for $name:$!"; - } - } - -if ($doC) - { - verbose "Writing compiled form\n"; - foreach my $name (sort cmp_name keys %encoding) - { - my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}}; - process($name.'_utf8',$e2u); - addstrings(\*C,$e2u); - - process('utf8_'.$name,$u2e); - addstrings(\*C,$u2e); - } - outbigstring(\*C,"enctable"); - foreach my $name (sort cmp_name keys %encoding) - { - my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}}; - outtable(\*C,$e2u, "enctable"); - outtable(\*C,$u2e, "enctable"); - - # push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep)); - } - my ($cpp) = compiler_info(0); - my $ext = $cpp ? 'extern "C"' : "extern"; - my $exta = $cpp ? 'extern "C"' : "static"; - my $extb = $cpp ? 'extern "C"' : ""; - foreach my $enc (sort cmp_name keys %encoding) - { - # my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}}; - my ($e2u,$u2e,$rep,$min_el,$max_el) = @{$encoding{$enc}}; - #my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el); - my $replen = 0; - $replen++ while($rep =~ /\G\\x[0-9A-Fa-f]/g); - my $sym = "${enc}_encoding"; - $sym =~ s/\W+/_/g; - my @info = ($e2u->{Cname},$u2e->{Cname},"${sym}_rep_character",$replen, - $min_el,$max_el); - print C "${exta} const U8 ${sym}_rep_character[] = \"$rep\";\n"; - print C "${exta} const char ${sym}_enc_name[] = \"$enc\";\n\n"; - print C "${extb} const encode_t $sym = \n"; - # This is to make null encoding work -- dankogai - for (my $i = (scalar @info) - 1; $i >= 0; --$i){ - $info[$i] ||= 1; - } - # end of null tweak -- dankogai - print C " {",join(',',@info,"{${sym}_enc_name,(const char *)0}"),"};\n\n"; - } - - foreach my $enc (sort cmp_name keys %encoding) - { - my $sym = "${enc}_encoding"; - $sym =~ s/\W+/_/g; - print H "${ext} encode_t $sym;\n"; - print D " Encode_XSEncoding(aTHX_ &$sym);\n"; - } - - if ($cname =~ /(\w+)\.xs$/) - { - my $mod = $1; - print C <<'END'; - -static void -Encode_XSEncoding(pTHX_ encode_t *enc) -{ - dSP; - HV *stash = gv_stashpv("Encode::XS", TRUE); - SV *iv = newSViv(PTR2IV(enc)); - SV *sv = sv_bless(newRV_noinc(iv),stash); - int i = 0; - /* with the SvLEN() == 0 hack, PVX won't be freed. We cast away name's - constness, in the hope that perl won't mess with it. */ - assert(SvTYPE(iv) >= SVt_PV); assert(SvLEN(iv) == 0); - SvFLAGS(iv) |= SVp_POK; - SvPVX(iv) = (char*) enc->name[0]; - PUSHMARK(sp); - XPUSHs(sv); - while (enc->name[i]) - { - const char *name = enc->name[i++]; - XPUSHs(sv_2mortal(newSVpvn(name,strlen(name)))); - } - PUTBACK; - call_pv("Encode::define_encoding",G_DISCARD); - SvREFCNT_dec(sv); -} - -END - - print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n"; - print C "BOOT:\n{\n"; - print C "#include \"$dname\"\n"; - print C "}\n"; - } - # Close in void context is bad, m'kay - close(D) or warn "Error closing '$dname': $!"; - close(H) or warn "Error closing '$hname': $!"; - - my $perc_saved = $saved/($strings + $saved) * 100; - my $perc_subsaved = $subsave/($strings + $subsave) * 100; - verbosef "%d bytes in string tables\n",$strings; - verbosef "%d bytes (%.3g%%) saved spotting duplicates\n", - $saved, $perc_saved if $saved; - verbosef "%d bytes (%.3g%%) saved using substrings\n", - $subsave, $perc_subsaved if $subsave; - } -elsif ($doEnc) - { - foreach my $name (sort cmp_name keys %encoding) - { - my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}}; - output_enc(\*C,$name,$e2u); - } - } -elsif ($doUcm) - { - foreach my $name (sort cmp_name keys %encoding) - { - my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}}; - output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el); - } - } - -# writing half meg files and then not checking to see if you just filled the -# disk is bad, m'kay -close(C) or die "Error closing '$cname': $!"; - -# End of the main program. - -sub compile_ucm -{ - my ($fh,$name) = @_; - my $e2u = {}; - my $u2e = {}; - my $cs; - my %attr; - while (<$fh>) - { - s/#.*$//; - last if /^\s*CHARMAP\s*$/i; - if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr - { - $attr{$1} = $2; - } - } - if (!defined($cs = $attr{'code_set_name'})) - { - warn "No in $name\n"; - } - else - { - $name = $cs unless exists $opt{'n'}; - } - my $erep; - my $urep; - my $max_el; - my $min_el; - if (exists $attr{'subchar'}) - { - #my @byte; - #$attr{'subchar'} =~ /^\s*/cg; - #push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg; - #$erep = join('',map(chr(hex($_)),@byte)); - $erep = $attr{'subchar'}; - $erep =~ s/^\s+//; $erep =~ s/\s+$//; - } - print "Reading $name ($cs)\n" - unless defined $ENV{MAKEFLAGS} - and $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/; - my $nfb = 0; - my $hfb = 0; - while (<$fh>) - { - s/#.*$//; - last if /^\s*END\s+CHARMAP\s*$/i; - next if /^\s*$/; - my (@uni, @byte) = (); - my ($uni, $byte, $fb) = m/^(\S+)\s+(\S+)\s+(\S+)\s+/o - or die "Bad line: $_"; - while ($uni =~ m/\G<([U0-9a-fA-F\+]+)>/g){ - push @uni, map { substr($_, 1) } split(/\+/, $1); - } - while ($byte =~ m/\G\\x([0-9a-fA-F]+)/g){ - push @byte, $1; - } - if (@uni) - { - my $uch = join('', map { encode_U(hex($_)) } @uni ); - my $ech = join('',map(chr(hex($_)),@byte)); - my $el = length($ech); - $max_el = $el if (!defined($max_el) || $el > $max_el); - $min_el = $el if (!defined($min_el) || $el < $min_el); - if (length($fb)) - { - $fb = substr($fb,1); - $hfb++; - } - else - { - $nfb++; - $fb = '0'; - } - # $fb is fallback flag - # 0 - round trip safe - # 1 - fallback for unicode -> enc - # 2 - skip sub-char mapping - # 3 - fallback enc -> unicode - enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/); - enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/); - } - else - { - warn $_; - } - } - if ($nfb && $hfb) - { - die "$nfb entries without fallback, $hfb entries with\n"; - } - $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el]; -} - - - -sub compile_enc -{ - my ($fh,$name) = @_; - my $e2u = {}; - my $u2e = {}; - - my $type; - while ($type = <$fh>) - { - last if $type !~ /^\s*#/; - } - chomp($type); - return if $type eq 'E'; - # Do the hash lookup once, rather than once per function call. 4% speedup. - my $type_func = $encode_types{$type}; - my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>)); - warn "$type encoded $name\n"; - my $rep = ''; - # Save a defined test by setting these to defined values. - my $min_el = ~0; # A very big integer - my $max_el = 0; # Anything must be longer than 0 - { - my $v = hex($def); - $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe); - } - my $errors; - my $seen; - # use -Q to silence the seen test. Makefile.PL uses this by default. - $seen = {} unless $opt{Q}; - do - { - my $line = <$fh>; - chomp($line); - my $page = hex($line); - my $ch = 0; - my $i = 16; - do - { - # So why is it 1% faster to leave the my here? - my $line = <$fh>; - $line =~ s/\r\n$/\n/; - die "$.:${line}Line should be exactly 65 characters long including - newline (".length($line).")" unless length ($line) == 65; - # Split line into groups of 4 hex digits, convert groups to ints - # This takes 65.35 - # map {hex $_} $line =~ /(....)/g - # This takes 63.75 (2.5% less time) - # unpack "n*", pack "H*", $line - # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay - # Doing it as while ($line =~ /(....)/g) took 74.63 - foreach my $val (unpack "n*", pack "H*", $line) - { - next if $val == 0xFFFD; - my $ech = &$type_func($ch,$page); - if ($val || (!$ch && !$page)) - { - my $el = length($ech); - $max_el = $el if $el > $max_el; - $min_el = $el if $el < $min_el; - my $uch = encode_U($val); - if ($seen) { - # We're doing the test. - # We don't need to read this quickly, so storing it as a scalar, - # rather than 3 (anon array, plus the 2 scalars it holds) saves - # RAM and may make us faster on low RAM systems. [see __END__] - if (exists $seen->{$uch}) - { - warn sprintf("U%04X is %02X%02X and %04X\n", - $val,$page,$ch,$seen->{$uch}); - $errors++; - } - else - { - $seen->{$uch} = $page << 8 | $ch; - } - } - # Passing 2 extra args each time is 3.6% slower! - # Even with having to add $fallback ||= 0 later - enter_fb0($e2u,$ech,$uch); - enter_fb0($u2e,$uch,$ech); - } - else - { - # No character at this position - # enter($e2u,$ech,undef,$e2u); - } - $ch++; - } - } while --$i; - } while --$pages; - die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines" - if $min_el > $max_el; - die "$errors mapping conflicts\n" if ($errors && $opt{'S'}); - $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el]; -} - -# my ($a,$s,$d,$t,$fb) = @_; -sub enter { - my ($current,$inbytes,$outbytes,$next,$fallback) = @_; - # state we shift to after this (multibyte) input character defaults to same - # as current state. - $next ||= $current; - # Making sure it is defined seems to be faster than {no warnings;} in - # &process, or passing it in as 0 explicitly. - # XXX $fallback ||= 0; - - # Start at the beginning and work forwards through the string to zero. - # effectively we are removing 1 character from the front each time - # but we don't actually edit the string. [this alone seems to be 14% speedup] - # Hence -$pos is the length of the remaining string. - my $pos = -length $inbytes; - while (1) { - my $byte = substr $inbytes, $pos, 1; - # RAW_NEXT => 0, - # RAW_IN_LEN => 1, - # RAW_OUT_BYTES => 2, - # RAW_FALLBACK => 3, - # to unicode an array would seem to be better, because the pages are dense. - # from unicode can be very sparse, favouring a hash. - # hash using the bytes (all length 1) as keys rather than ord value, - # as it's easier to sort these in &process. - - # It's faster to always add $fallback even if it's undef, rather than - # choosing between 3 and 4 element array. (hence why we set it defined - # above) - my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback]; - # When $pos was -1 we were at the last input character. - unless (++$pos) { - $do_now->[RAW_OUT_BYTES] = $outbytes; - $do_now->[RAW_NEXT] = $next; - return; - } - # Tail recursion. The intermediate state may not have a name yet. - $current = $do_now->[RAW_NEXT]; - } -} - -# This is purely for optimisation. It's just &enter hard coded for $fallback -# of 0, using only a 3 entry array ref to save memory for every entry. -sub enter_fb0 { - my ($current,$inbytes,$outbytes,$next) = @_; - $next ||= $current; - - my $pos = -length $inbytes; - while (1) { - my $byte = substr $inbytes, $pos, 1; - my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'']; - unless (++$pos) { - $do_now->[RAW_OUT_BYTES] = $outbytes; - $do_now->[RAW_NEXT] = $next; - return; - } - $current = $do_now->[RAW_NEXT]; - } -} - -sub process -{ - my ($name,$a) = @_; - $name =~ s/\W+/_/g; - $a->{Cname} = $name; - my $raw = $a->{Raw}; - my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback); - my @ent; - $agg_max_in = 0; - foreach my $key (sort keys %$raw) { - # RAW_NEXT => 0, - # RAW_IN_LEN => 1, - # RAW_OUT_BYTES => 2, - # RAW_FALLBACK => 3, - my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}}; - # Now we are converting from raw to aggregate, switch from 1 byte strings - # to numbers - my $b = ord $key; - $fallback ||= 0; - if ($l && - # If this == fails, we're going to reset $agg_max_in below anyway. - $b == ++$agg_max_in && - # References in numeric context give the pointer as an int. - $agg_next == $next && - $agg_in_len == $in_len && - $agg_out_len == length $out_bytes && - $agg_fallback == $fallback - # && length($l->[AGG_OUT_BYTES]) < 16 - ) { - # my $i = ord($b)-ord($l->[AGG_MIN_IN]); - # we can aggregate this byte onto the end. - $l->[AGG_MAX_IN] = $b; - $l->[AGG_OUT_BYTES] .= $out_bytes; - } else { - # AGG_MIN_IN => 0, - # AGG_MAX_IN => 1, - # AGG_OUT_BYTES => 2, - # AGG_NEXT => 3, - # AGG_IN_LEN => 4, - # AGG_OUT_LEN => 5, - # AGG_FALLBACK => 6, - # Reset the last thing we saw, plus set 5 lexicals to save some derefs. - # (only gains .6% on euc-jp -- is it worth it?) - push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next, - $agg_in_len = $in_len, $agg_out_len = length $out_bytes, - $agg_fallback = $fallback]; - } - if (exists $next->{Cname}) { - $next->{'Forward'} = 1 if $next != $a; - } else { - process(sprintf("%s_%02x",$name,$b),$next); - } - } - # encengine.c rules say that last entry must be for 255 - if ($agg_max_in < 255) { - push @ent, [1+$agg_max_in, 255,undef,$a,0,0]; - } - $a->{'Entries'} = \@ent; -} - - -sub addstrings -{ - my ($fh,$a) = @_; - my $name = $a->{'Cname'}; - # String tables - foreach my $b (@{$a->{'Entries'}}) - { - next unless $b->[AGG_OUT_LEN]; - $strings{$b->[AGG_OUT_BYTES]} = undef; - } - if ($a->{'Forward'}) - { - my ($cpp, $static, $sized) = compiler_info(1); - my $count = $sized ? scalar(@{$a->{'Entries'}}) : ''; - if ($static) { - # we cannot ask Config for d_plusplus since we can override CC=g++-6 on the cmdline - print $fh "#ifdef __cplusplus\n"; # -fpermissive since g++-6 - print $fh "extern encpage_t $name\[$count];\n"; - print $fh "#else\n"; - print $fh "static const encpage_t $name\[$count];\n"; - print $fh "#endif\n"; - } else { - print $fh "extern encpage_t $name\[$count];\n"; - } - } - $a->{'DoneStrings'} = 1; - foreach my $b (@{$a->{'Entries'}}) - { - my ($s,$e,$out,$t,$end,$l) = @$b; - addstrings($fh,$t) unless $t->{'DoneStrings'}; - } -} - -sub outbigstring -{ - my ($fh,$name) = @_; - - $string_acc = ''; - - # Make the big string in the string accumulator. Longest first, on the hope - # that this makes it more likely that we find the short strings later on. - # Not sure if it helps sorting strings of the same length lexically. - foreach my $s (sort {length $b <=> length $a || $a cmp $b} keys %strings) { - my $index = index $string_acc, $s; - if ($index >= 0) { - $saved += length($s); - $strings_in_acc{$s} = $index; - } else { - OPTIMISER: { - if ($opt{'O'}) { - my $sublength = length $s; - while (--$sublength > 0) { - # progressively lop characters off the end, to see if the start of - # the new string overlaps the end of the accumulator. - if (substr ($string_acc, -$sublength) - eq substr ($s, 0, $sublength)) { - $subsave += $sublength; - $strings_in_acc{$s} = length ($string_acc) - $sublength; - # append the last bit on the end. - $string_acc .= substr ($s, $sublength); - last OPTIMISER; - } - # or if the end of the new string overlaps the start of the - # accumulator - next unless substr ($string_acc, 0, $sublength) - eq substr ($s, -$sublength); - # well, the last $sublength characters of the accumulator match. - # so as we're prepending to the accumulator, need to shift all our - # existing offsets forwards - $_ += $sublength foreach values %strings_in_acc; - $subsave += $sublength; - $strings_in_acc{$s} = 0; - # append the first bit on the start. - $string_acc = substr ($s, 0, -$sublength) . $string_acc; - last OPTIMISER; - } - } - # Optimiser (if it ran) found nothing, so just going have to tack the - # whole thing on the end. - $strings_in_acc{$s} = length $string_acc; - $string_acc .= $s; - }; - } - } - - $strings = length $string_acc; - my ($cpp) = compiler_info(0); - my $var = $cpp ? '' : 'static'; - my $definition = "\n$var const U8 $name\[$strings] = { " . - join(',',unpack "C*",$string_acc); - # We have a single long line. Split it at convenient commas. - print $fh $1, "\n" while $definition =~ /\G(.{74,77},)/gcs; - print $fh substr ($definition, pos $definition), " };\n"; -} - -sub findstring { - my ($name,$s) = @_; - my $offset = $strings_in_acc{$s}; - die "Can't find string " . join (',',unpack "C*",$s) . " in accumulator" - unless defined $offset; - "$name + $offset"; -} - -sub outtable -{ - my ($fh,$a,$bigname) = @_; - my $name = $a->{'Cname'}; - $a->{'Done'} = 1; - foreach my $b (@{$a->{'Entries'}}) - { - my ($s,$e,$out,$t,$end,$l) = @$b; - outtable($fh,$t,$bigname) unless $t->{'Done'}; - } - my ($cpp, $static) = compiler_info(0); - my $count = scalar(@{$a->{'Entries'}}); - if ($static) { - print $fh "#ifdef __cplusplus\n"; # -fpermissive since g++-6 - print $fh "encpage_t $name\[$count] = {\n"; - print $fh "#else\n"; - print $fh "static const encpage_t $name\[$count] = {\n"; - print $fh "#endif\n"; - } else { - print $fh "\nencpage_t $name\[$count] = {\n"; - } - foreach my $b (@{$a->{'Entries'}}) - { - my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b; - # $end |= 0x80 if $fb; # what the heck was on your mind, Nick? -- Dan - print $fh "{"; - if ($l) - { - printf $fh findstring($bigname,$out); - } - else - { - print $fh "0"; - } - print $fh ",",$t->{Cname}; - printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec; - } - print $fh "};\n"; -} - -sub output_enc -{ - my ($fh,$name,$a) = @_; - die "Changed - fix me for new structure"; - foreach my $b (sort keys %$a) - { - my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}}; - } -} - -sub decode_U -{ - my $s = shift; -} - -my @uname; -sub char_names -{ - my $s = do "unicore/Name.pl"; - die "char_names: unicore/Name.pl: $!\n" unless defined $s; - pos($s) = 0; - while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc) - { - my $name = $3; - my $s = hex($1); - last if $s >= 0x10000; - my $e = length($2) ? hex($2) : $s; - for (my $i = $s; $i <= $e; $i++) - { - $uname[$i] = $name; -# print sprintf("U%04X $name\n",$i); - } - } -} - -sub output_ucm_page -{ - my ($cmap,$a,$t,$pre) = @_; - # warn sprintf("Page %x\n",$pre); - my $raw = $t->{Raw}; - foreach my $key (sort keys %$raw) { - # RAW_NEXT => 0, - # RAW_IN_LEN => 1, - # RAW_OUT_BYTES => 2, - # RAW_FALLBACK => 3, - my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}}; - my $u = ord $key; - $fallback ||= 0; - - if ($next != $a && $next != $t) { - output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF); - } elsif (length $out_bytes) { - if ($pre) { - $u = $pre|($u &0x3f); - } - my $s = sprintf " ",$u; - #foreach my $c (split(//,$out_bytes)) { - # $s .= sprintf "\\x%02X",ord($c); - #} - # 9.5% faster changing that loop to this: - $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes; - $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u]; - push(@$cmap,$s); - } else { - warn join(',',$u, @{$raw->{$key}},$a,$t); - } - } -} - -sub output_ucm -{ - my ($fh,$name,$h,$rep,$min_el,$max_el) = @_; - print $fh "# $0 @orig_ARGV\n" unless $opt{'q'}; - print $fh " \"$name\"\n"; - char_names(); - if (defined $min_el) - { - print $fh " $min_el\n"; - } - if (defined $max_el) - { - print $fh " $max_el\n"; - } - if (defined $rep) - { - print $fh " "; - foreach my $c (split(//,$rep)) - { - printf $fh "\\x%02X",ord($c); - } - print $fh "\n"; - } - my @cmap; - output_ucm_page(\@cmap,$h,$h,0); - print $fh "#\nCHARMAP\n"; - foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap) - { - print $fh $line; - } - print $fh "END CHARMAP\n"; -} - -use vars qw( - $_Enc2xs - $_Version - $_Inc - $_E2X - $_Name - $_TableFiles - $_Now -); - -sub find_e2x{ - eval { require File::Find; }; - my (@inc, %e2x_dir); - for my $inc (@INC){ - push @inc, $inc unless $inc eq '.'; #skip current dir - } - File::Find::find( - sub { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) - = lstat($_) or return; - -f _ or return; - if (/^.*\.e2x$/o){ - no warnings 'once'; - $e2x_dir{$File::Find::dir} ||= $mtime; - } - return; - }, @inc); - warn join("\n", keys %e2x_dir), "\n"; - for my $d (sort {$e2x_dir{$a} <=> $e2x_dir{$b}} keys %e2x_dir){ - $_E2X = $d; - # warn "$_E2X => ", scalar localtime($e2x_dir{$d}); - return $_E2X; - } -} - -sub make_makefile_pl -{ - eval { require Encode; }; - $@ and die "You need to install Encode to use enc2xs -M\nerror: $@\n"; - # our used for variable expansion - $_Enc2xs = $0; - $_Version = $VERSION; - $_E2X = find_e2x(); - $_Name = shift; - $_TableFiles = join(",", map {qq('$_')} @_); - $_Now = scalar localtime(); - - eval { require File::Spec; }; - _print_expand(File::Spec->catfile($_E2X,"Makefile_PL.e2x"),"Makefile.PL"); - _print_expand(File::Spec->catfile($_E2X,"_PM.e2x"), "$_Name.pm"); - _print_expand(File::Spec->catfile($_E2X,"_T.e2x"), "t/$_Name.t"); - _print_expand(File::Spec->catfile($_E2X,"README.e2x"), "README"); - _print_expand(File::Spec->catfile($_E2X,"Changes.e2x"), "Changes"); - exit; -} - -use vars qw( - $_ModLines - $_LocalVer - ); - -sub make_configlocal_pm { - eval { require Encode; }; - $@ and die "Unable to require Encode: $@\n"; - eval { require File::Spec; }; - - # our used for variable expantion - my %in_core = map { $_ => 1 } ( - 'ascii', 'iso-8859-1', 'utf8', - 'ascii-ctrl', 'null', 'utf-8-strict' - ); - my %LocalMod = (); - # check @enc; - use File::Find (); - my $wanted = sub{ - -f $_ or return; - $File::Find::name =~ /\A\./ and return; - $File::Find::name =~ /\.pm\z/ or return; - $File::Find::name =~ m/\bEncode\b/ or return; - my $mod = $File::Find::name; - $mod =~ s/.*\bEncode\b/Encode/o; - $mod =~ s/\.pm\z//o; - $mod =~ s,/,::,og; - eval qq{ require $mod; }; - return if $@; - warn qq{ require $mod;\n}; - for my $enc ( Encode->encodings() ) { - no warnings; - $in_core{$enc} and next; - $Encode::Config::ExtModule{$enc} and next; - $LocalMod{$enc} ||= $mod; - } - }; - File::Find::find({wanted => $wanted}, @INC); - $_ModLines = ""; - for my $enc ( sort keys %LocalMod ) { - $_ModLines .= - qq(\$Encode::ExtModule{'$enc'} = "$LocalMod{$enc}";\n); - } - warn $_ModLines if $_ModLines; - $_LocalVer = _mkversion(); - $_E2X = find_e2x(); - $_Inc = $INC{"Encode.pm"}; - $_Inc =~ s/\.pm$//o; - _print_expand( File::Spec->catfile( $_E2X, "ConfigLocal_PM.e2x" ), - File::Spec->catfile( $_Inc, "ConfigLocal.pm" ), 1 ); - exit; -} - -sub _mkversion{ - # v-string is now depreciated; use time() instead; - #my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime(); - #$yyyy += 1900, $mo +=1; - #return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm); - return time(); -} - -sub _print_expand{ - eval { require File::Basename; }; - $@ and die "File::Basename needed. Are you on miniperl?;\nerror: $@\n"; - File::Basename->import(); - my ($src, $dst, $clobber) = @_; - if (!$clobber and -e $dst){ - warn "$dst exists. skipping\n"; - return; - } - warn "Generating $dst...\n"; - open my $in, $src or die "$src : $!"; - if ((my $d = dirname($dst)) ne '.'){ - -d $d or mkdir $d, 0755 or die "mkdir $d : $!"; - } - open my $out, ">", $dst or die "$!"; - my $asis = 0; - while (<$in>){ - if (/^#### END_OF_HEADER/){ - $asis = 1; next; - } - s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis; - print $out $_; - } -} -__END__ - -=head1 NAME - -enc2xs -- Perl Encode Module Generator - -=head1 SYNOPSIS - - enc2xs -[options] - enc2xs -M ModName mapfiles... - enc2xs -C - -=head1 DESCRIPTION - -F builds a Perl extension for use by Encode from either -Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc). -Besides being used internally during the build process of the Encode -module, you can use F to add your own encoding to perl. -No knowledge of XS is necessary. - -=head1 Quick Guide - -If you want to know as little about Perl as possible but need to -add a new encoding, just read this chapter and forget the rest. - -=over 4 - -=item 0.Z<> - -Have a .ucm file ready. You can get it from somewhere or you can write -your own from scratch or you can grab one from the Encode distribution -and customize it. For the UCM format, see the next Chapter. In the -example below, I'll call my theoretical encoding myascii, defined -in I. C<$> is a shell prompt. - - $ ls -F - my.ucm - -=item 1.Z<> - -Issue a command as follows; - - $ enc2xs -M My my.ucm - generating Makefile.PL - generating My.pm - generating README - generating Changes - -Now take a look at your current directory. It should look like this. - - $ ls -F - Makefile.PL My.pm my.ucm t/ - -The following files were created. - - Makefile.PL - MakeMaker script - My.pm - Encode submodule - t/My.t - test file - -=over 4 - -=item 1.1.Z<> - -If you want *.ucm installed together with the modules, do as follows; - - $ mkdir Encode - $ mv *.ucm Encode - $ enc2xs -M My Encode/*ucm - -=back - -=item 2.Z<> - -Edit the files generated. You don't have to if you have no time AND no -intention to give it to someone else. But it is a good idea to edit -the pod and to add more tests. - -=item 3.Z<> - -Now issue a command all Perl Mongers love: - - $ perl Makefile.PL - Writing Makefile for Encode::My - -=item 4.Z<> - -Now all you have to do is make. - - $ make - cp My.pm blib/lib/Encode/My.pm - /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \ - -o encode_t.c -f encode_t.fnm - Reading myascii (myascii) - Writing compiled form - 128 bytes in string tables - 384 bytes (75%) saved spotting duplicates - 1 bytes (0.775%) saved using substrings - .... - chmod 644 blib/arch/auto/Encode/My/My.bs - $ - -The time it takes varies depending on how fast your machine is and -how large your encoding is. Unless you are working on something big -like euc-tw, it won't take too long. - -=item 5.Z<> - -You can "make install" already but you should test first. - - $ make test - PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \ - -e 'use Test::Harness qw(&runtests $verbose); \ - $verbose=0; runtests @ARGV;' t/*.t - t/My....ok - All tests successful. - Files=1, Tests=2, 0 wallclock secs - ( 0.09 cusr + 0.01 csys = 0.09 CPU) - -=item 6.Z<> - -If you are content with the test result, just "make install" - -=item 7.Z<> - -If you want to add your encoding to Encode's demand-loading list -(so you don't have to "use Encode::YourEncoding"), run - - enc2xs -C - -to update Encode::ConfigLocal, a module that controls local settings. -After that, "use Encode;" is enough to load your encodings on demand. - -=back - -=head1 The Unicode Character Map - -Encode uses the Unicode Character Map (UCM) format for source character -mappings. This format is used by IBM's ICU package and was adopted -by Nick Ing-Simmons for use with the Encode module. Since UCM is -more flexible than Tcl's Encoding Map and far more user-friendly, -this is the recommended format for Encode now. - -A UCM file looks like this. - - # - # Comments - # - "US-ascii" # Required - "ascii" # Optional - 1 # Required; usually 1 - 1 # Max. # of bytes/char - \x3F # Substitution char - # - CHARMAP - \x00 |0 # - \x01 |0 # - \x02 |0 # - .... - \x7C |0 # VERTICAL LINE - \x7D |0 # RIGHT CURLY BRACKET - \x7E |0 # TILDE - \x7F |0 # - END CHARMAP - -=over 4 - -=item * - -Anything that follows C<#> is treated as a comment. - -=item * - -The header section continues until a line containing the word -CHARMAP. This section has a form of IkeywordE value>, one -pair per line. Strings used as values must be quoted. Barewords are -treated as numbers. I<\xXX> represents a byte. - -Most of the keywords are self-explanatory. I means -substitution character, not subcharacter. When you decode a Unicode -sequence to this encoding but no matching character is found, the byte -sequence defined here will be used. For most cases, the value here is -\x3F; in ASCII, this is a question mark. - -=item * - -CHARMAP starts the character map section. Each line has a form as -follows: - - \xXX.. |0 # comment - ^ ^ ^ - | | +- Fallback flag - | +-------- Encoded byte sequence - +-------------- Unicode Character ID in hex - -The format is roughly the same as a header section except for the -fallback flag: | followed by 0..3. The meaning of the possible -values is as follows: - -=over 4 - -=item |0 - -Round trip safe. A character decoded to Unicode encodes back to the -same byte sequence. Most characters have this flag. - -=item |1 - -Fallback for unicode -> encoding. When seen, enc2xs adds this -character for the encode map only. - -=item |2 - -Skip sub-char mapping should there be no code point. - -=item |3 - -Fallback for encoding -> unicode. When seen, enc2xs adds this -character for the decode map only. - -=back - -=item * - -And finally, END OF CHARMAP ends the section. - -=back - -When you are manually creating a UCM file, you should copy ascii.ucm -or an existing encoding which is close to yours, rather than write -your own from scratch. - -When you do so, make sure you leave at least B to B as -is, unless your environment is EBCDIC. - -B: not all features in UCM are implemented. For example, -icu:state is not used. Because of that, you need to write a perl -module if you want to support algorithmical encodings, notably -the ISO-2022 series. Such modules include L, -L, and L. - -=head2 Coping with duplicate mappings - -When you create a map, you SHOULD make your mappings round-trip safe. -That is, C stands for all characters that are marked as C<|0>. Here is -how to make sure: - -=over 4 - -=item * - -Sort your map in Unicode order. - -=item * - -When you have a duplicate entry, mark either one with '|1' or '|3'. - -=item * - -And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry. - -=back - -Here is an example from big5-eten. - - \xF9\xF9 |0 - \xA2\xA4 |3 - -Internally Encoding -> Unicode and Unicode -> Encoding Map looks like -this; - - E to U U to E - -------------------------------------- - \xF9\xF9 => U2550 U2550 => \xF9\xF9 - \xA2\xA4 => U2550 - -So it is round-trip safe for \xF9\xF9. But if the line above is upside -down, here is what happens. - - E to U U to E - -------------------------------------- - \xA2\xA4 => U2550 U2550 => \xF9\xF9 - (\xF9\xF9 => U2550 is now overwritten!) - -The Encode package comes with F, a crude but sufficient -utility to check the integrity of a UCM file. Check under the -Encode/bin directory for this. - -When in doubt, you can use F, yet another utility under -Encode/bin directory. - -=head1 Bookmarks - -=over 4 - -=item * - -ICU Home Page -L - -=item * - -ICU Character Mapping Tables -L - -=item * - -ICU:Conversion Data -L - -=back - -=head1 SEE ALSO - -L, -L, -L - -=cut - -# -Q to disable the duplicate codepoint test -# -S make mapping errors fatal -# -q to remove comments written to output files -# -O to enable the (brute force) substring optimiser -# -o to specify the output file name (else it's the first arg) -# -f to give a file with a list of input files (else use the args) -# -n to name the encoding (else use the basename of the input file. - -With %seen holding array refs: - - 865.66 real 28.80 user 8.79 sys - 7904 maximum resident set size - 1356 average shared memory size - 18566 average unshared data size - 229 average unshared stack size - 46080 page reclaims - 33373 page faults - -With %seen holding simple scalars: - - 342.16 real 27.11 user 3.54 sys - 8388 maximum resident set size - 1394 average shared memory size - 14969 average unshared data size - 236 average unshared stack size - 28159 page reclaims - 9839 page faults - -Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is -how %seen is storing things its seen. So it is pathalogically bad on a 16M -RAM machine, but it's going to help even on modern machines. -Swapping is bad, m'kay :-) diff --git a/bin/encguess b/bin/encguess deleted file mode 100755 index 6724b136..00000000 --- a/bin/encguess +++ /dev/null @@ -1,149 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; -#!./perl -use 5.008001; -BEGIN { pop @INC if $INC[-1] eq '.' } -use strict; -use warnings; -use Encode; -use Getopt::Std; -use Carp; -use Encode::Guess; -$Getopt::Std::STANDARD_HELP_VERSION = 1; - -my %opt; -getopts( "huSs:", \%opt ); -my @suspect_list; -list_valid_suspects() and exit if $opt{S}; -@suspect_list = split /:,/, $opt{s} if $opt{s}; -HELP_MESSAGE() if $opt{h}; -HELP_MESSAGE() unless @ARGV; -do_guess($_) for @ARGV; - -sub read_file { - my $filename = shift; - local $/; - open my $fh, '<:raw', $filename or croak "$filename:$!"; - my $content = <$fh>; - close $fh; - return $content; -} - -sub do_guess { - my $filename = shift; - my $data = read_file($filename); - my $enc = guess_encoding( $data, @suspect_list ); - if ( !ref($enc) && $opt{u} ) { - return 1; - } - print "$filename\t"; - if ( ref($enc) ) { - print $enc->mime_name(); - } - else { - print "unknown"; - } - print "\n"; - return 1; -} - -sub list_valid_suspects { - print join( "\n", Encode->encodings(":all") ); - print "\n"; - return 1; -} - -sub HELP_MESSAGE { - exec 'pod2usage', $0 or die "pod2usage: $!" -} -__END__ -=head1 NAME - -encguess - guess character encodings of files - -=head1 VERSION - -$Id: encguess,v 0.2 2016/08/04 03:15:58 dankogai Exp $ - -=head1 SYNOPSIS - - encguess [switches] filename... - -=head2 SWITCHES - -=over 2 - -=item -h - -show this message and exit. - -=item -s - -specify a list of "suspect encoding types" to test, -seperated by either C<:> or C<,> - -=item -S - -output a list of all acceptable encoding types that can be used with -the -s param - -=item -u - -suppress display of unidentified types - -=back - -=head2 EXAMPLES: - -=over 2 - -=item * - -Guess encoding of a file named C, using only the default -suspect types. - - encguess test.txt - -=item * - -Guess the encoding type of a file named C, using the suspect -types C. - - encguess -s euc-jp,shiftjis,7bit-jis test.txt - encguess -s euc-jp:shiftjis:7bit-jis test.txt - -=item * - -Guess the encoding type of several files, do not display results for -unidentified files. - - encguess -us euc-jp,shiftjis,7bit-jis test*.txt - -=back - -=head1 DESCRIPTION - -The encoding identification is done by checking one encoding type at a -time until all but the right type are eliminated. The set of encoding -types to try is defined by the -s parameter and defaults to ascii, -utf8 and UTF-16/32 with BOM. This can be overridden by passing one or -more encoding types via the -s parameter. If you need to pass in -multiple suspect encoding types, use a quoted string with the a space -separating each value. - -=head1 SEE ALSO - -L, L - -=head1 LICENSE AND COPYRIGHT - -Copyright 2015 Michael LaGrasta and Dan Kogai. - -This program is free software; you can redistribute it and/or modify it -under the terms of the the Artistic License (2.0). You may obtain a -copy of the full license at: - -L - -=cut diff --git a/bin/h2ph b/bin/h2ph deleted file mode 100755 index 527b00f9..00000000 --- a/bin/h2ph +++ /dev/null @@ -1,988 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; - -BEGIN { pop @INC if $INC[-1] eq '.' } - -use strict; - -use Config; -use File::Path qw(mkpath); -use Getopt::Std; - -# Make sure read permissions for all are set: -if (defined umask && (umask() & 0444)) { - umask (umask() & ~0444); -} - -getopts('Dd:rlhaQe'); -use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e); -die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a); -my @inc_dirs = inc_dirs() if $opt_a; - -my $Exit = 0; - -my $Dest_dir = $opt_d || $Config{installsitearch}; -die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" - unless -d $Dest_dir; - -my @isatype = qw( - char uchar u_char - short ushort u_short - int uint u_int - long ulong u_long - FILE key_t caddr_t - float double size_t -); - -my %isatype; -@isatype{@isatype} = (1) x @isatype; -my $inif = 0; -my %Is_converted; -my %bad_file = (); - -@ARGV = ('-') unless @ARGV; - -build_preamble_if_necessary(); - -sub reindent($) { - my($text) = shift; - $text =~ s/\n/\n /g; - $text =~ s/ /\t/g; - $text; -} - -my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile); -my ($incl, $incl_type, $incl_quote, $next); -while (defined (my $file = next_file())) { - if (-l $file and -d $file) { - link_if_possible($file) if ($opt_l); - next; - } - - # Recover from header files with unbalanced cpp directives - $t = ''; - $tab = 0; - - # $eval_index goes into '#line' directives, to help locate syntax errors: - $eval_index = 1; - - if ($file eq '-') { - open(IN, "-"); - open(OUT, ">-"); - } else { - ($outfile = $file) =~ s/\.h$/.ph/ || next; - print "$file -> $outfile\n" unless $opt_Q; - if ($file =~ m|^(.*)/|) { - $dir = $1; - mkpath "$Dest_dir/$dir"; - } - - if ($opt_a) { # automagic mode: locate header file in @inc_dirs - foreach (@inc_dirs) { - chdir $_; - last if -f $file; - } - } - - open(IN, "<", "$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next); - open(OUT, ">", "$Dest_dir/$outfile") || die "Can't create $outfile: $!\n"; - } - - print OUT - "require '_h2ph_pre.ph';\n\n", - "no warnings qw(redefine misc);\n\n"; - - while (defined (local $_ = next_line($file))) { - if (s/^\s*\#\s*//) { - if (s/^define\s+(\w+)//) { - $name = $1; - $new = ''; - s/\s+$//; - s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0 - if (s/^\(([\w,\s]*)\)//) { - $args = $1; - my $proto = '() '; - if ($args ne '') { - $proto = ''; - foreach my $arg (split(/,\s*/,$args)) { - $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; - $curargs{$arg} = 1; - } - $args =~ s/\b(\w)/\$$1/g; - $args = "my($args) = \@_;\n$t "; - } - s/^\s+//; - expr(); - $new =~ s/(["\\])/\\$1/g; #"]); - EMIT($proto); - } else { - s/^\s+//; - expr(); - - $new = 1 if $new eq ''; - - # Shunt around such directives as '#define FOO FOO': - next if $new =~ /^\s*&\Q$name\E\s*\z/; - - $new = reindent($new); - $args = reindent($args); - $new =~ s/(['\\])/\\$1/g; #']); - - print OUT $t, 'eval '; - if ($opt_h) { - print OUT "\"\\n#line $eval_index $outfile\\n\" . "; - $eval_index++; - } - print OUT "'sub $name () {$new;}' unless defined(&$name);\n"; - } - } elsif (/^(include|import|include_next)\s*([<\"])(.*)[>\"]/) { - $incl_type = $1; - $incl_quote = $2; - $incl = $3; - if (($incl_type eq 'include_next') || - ($opt_e && exists($bad_file{$incl}))) { - $incl =~ s/\.h$/.ph/; - print OUT ($t, - "eval {\n"); - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT ($t, "my(\@REM);\n"); - if ($incl_type eq 'include_next') { - print OUT ($t, - "my(\%INCD) = map { \$INC{\$_} => 1 } ", - "(grep { \$_ eq \"$incl\" } ", - "keys(\%INC));\n"); - print OUT ($t, - "\@REM = map { \"\$_/$incl\" } ", - "(grep { not exists(\$INCD{\"\$_/$incl\"})", - " and -f \"\$_/$incl\" } \@INC);\n"); - } else { - print OUT ($t, - "\@REM = map { \"\$_/$incl\" } ", - "(grep {-r \"\$_/$incl\" } \@INC);\n"); - } - print OUT ($t, - "require \"\$REM[0]\" if \@REM;\n"); - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT ($t, - "};\n"); - print OUT ($t, - "warn(\$\@) if \$\@;\n"); - } else { - $incl =~ s/\.h$/.ph/; - # copy the prefix in the quote syntax (#include "x.h") case - if ($incl !~ m|/| && $incl_quote eq q{"} && $file =~ m|^(.*)/|) { - $incl = "$1/$incl"; - } - print OUT $t,"require '$incl';\n"; - } - } elsif (/^ifdef\s+(\w+)/) { - print OUT $t,"if(defined(&$1)) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } elsif (/^ifndef\s+(\w+)/) { - print OUT $t,"unless(defined(&$1)) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } elsif (s/^if\s+//) { - $new = ''; - $inif = 1; - expr(); - $inif = 0; - print OUT $t,"if($new) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } elsif (s/^elif\s+//) { - $new = ''; - $inif = 1; - expr(); - $inif = 0; - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n elsif($new) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } elsif (/^else/) { - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"} else {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } elsif (/^endif/) { - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n"; - } elsif(/^undef\s+(\w+)/) { - print OUT $t, "undef(&$1) if defined(&$1);\n"; - } elsif(/^error\s+(".*")/) { - print OUT $t, "die($1);\n"; - } elsif(/^error\s+(.*)/) { - print OUT $t, "die(\"", quotemeta($1), "\");\n"; - } elsif(/^warning\s+(.*)/) { - print OUT $t, "warn(\"", quotemeta($1), "\");\n"; - } elsif(/^ident\s+(.*)/) { - print OUT $t, "# $1\n"; - } - } elsif (/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) { # { for vi - until(/\{[^}]*\}.*;/ || /;/) { - last unless defined ($next = next_line($file)); - chomp $next; - # drop "#define FOO FOO" in enums - $next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//; - # #defines in enums (aliases) - $next =~ s/^\s*#\s*define\s+(\w+)\s+(\w+)\s*$/$1 = $2,/; - $_ .= $next; - print OUT "# $next\n" if $opt_D; - } - s/#\s*if.*?#\s*endif//g; # drop #ifdefs - s@/\*.*?\*/@@g; - s/\s+/ /g; - next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/; - (my $enum_subs = $3) =~ s/\s//g; - my @enum_subs = split(/,/, $enum_subs); - my $enum_val = -1; - foreach my $enum (@enum_subs) { - my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/; - $enum_name or next; - $enum_value =~ s/^=//; - $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1); - if ($opt_h) { - print OUT ($t, - "eval(\"\\n#line $eval_index $outfile\\n", - "sub $enum_name () \{ $enum_val; \}\") ", - "unless defined(\&$enum_name);\n"); - ++ $eval_index; - } else { - print OUT ($t, - "eval(\"sub $enum_name () \{ $enum_val; \}\") ", - "unless defined(\&$enum_name);\n"); - } - } - } elsif (/^(?:__extension__\s+)?(?:extern|static)\s+(?:__)?inline(?:__)?\s+/ - and !/;\s*$/ and !/{\s*}\s*$/) - { # { for vi - # This is a hack to parse the inline functions in the glibc headers. - # Warning: massive kludge ahead. We suppose inline functions - # are mainly constructed like macros. - while (1) { - last unless defined ($next = next_line($file)); - chomp $next; - undef $_, last if $next =~ /__THROW\s*;/ - or $next =~ /^(__extension__|extern|static)\b/; - $_ .= " $next"; - print OUT "# $next\n" if $opt_D; - last if $next =~ /^}|^{.*}\s*$/; - } - next if not defined; # because it's only a prototype - s/\b(__extension__|extern|static|(?:__)?inline(?:__)?)\b//g; - # violently drop #ifdefs - s/#\s*if.*?#\s*endif//g - and print OUT "# some #ifdef were dropped here -- fill in the blanks\n"; - if (s/^(?:\w|\s|\*)*\s(\w+)\s*//) { - $name = $1; - } else { - warn "name not found"; next; # shouldn't occur... - } - my @args; - if (s/^\(([^()]*)\)\s*(\w+\s*)*//) { - for my $arg (split /,/, $1) { - if ($arg =~ /(\w+)\s*$/) { - $curargs{$1} = 1; - push @args, $1; - } - } - } - $args = ( - @args - ? "my(" . (join ',', map "\$$_", @args) . ") = \@_;\n$t " - : "" - ); - my $proto = @args ? '' : '() '; - $new = ''; - s/\breturn\b//g; # "return" doesn't occur in macros usually... - expr(); - # try to find and perlify local C variables - our @local_variables = (); # needs to be a our(): (?{...}) bug workaround - { - use re "eval"; - my $typelist = join '|', keys %isatype; - $new =~ s[' - (?:(?:__)?const(?:__)?\s+)? - (?:(?:un)?signed\s+)? - (?:long\s+)? - (?:$typelist)\s+ - (\w+) - (?{ push @local_variables, $1 }) - '] - [my \$$1]gx; - $new =~ s[' - (?:(?:__)?const(?:__)?\s+)? - (?:(?:un)?signed\s+)? - (?:long\s+)? - (?:$typelist)\s+ - ' \s+ &(\w+) \s* ; - (?{ push @local_variables, $1 }) - ] - [my \$$1;]gx; - } - $new =~ s/&$_\b/\$$_/g for @local_variables; - $new =~ s/(["\\])/\\$1/g; #"]); - # now that's almost like a macro (we hope) - EMIT($proto); - } - } - $Is_converted{$file} = 1; - if ($opt_e && exists($bad_file{$file})) { - unlink($Dest_dir . '/' . $outfile); - $next = ''; - } else { - print OUT "1;\n"; - queue_includes_from($file) if $opt_a; - } -} - -if ($opt_e && (scalar(keys %bad_file) > 0)) { - warn "Was unable to convert the following files:\n"; - warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n"; -} - -exit $Exit; - -sub EMIT { - my $proto = shift; - - $new = reindent($new); - $args = reindent($args); - if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; #']); - if ($opt_h) { - print OUT $t, - "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; - $eval_index++; - } else { - print OUT $t, - "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; - } - } else { - print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n"; - } - %curargs = (); - return; -} - -sub expr { - if (/\b__asm__\b/) { # freak out - $new = '"(assembly code)"'; - return - } - my $joined_args; - if(keys(%curargs)) { - $joined_args = join('|', keys(%curargs)); - } - while ($_ ne '') { - s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator - s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of - s/^(\s+)// && do {$new .= ' '; next;}; - s/^0X([0-9A-F]+)[UL]*//i - && do {my $hex = $1; - $hex =~ s/^0+//; - if (length $hex > 8 && !$Config{use64bitint}) { - # Croak if nv_preserves_uv_bits < 64 ? - $new .= hex(substr($hex, -8)) + - 2**32 * hex(substr($hex, 0, -8)); - # The above will produce "erroneous" code - # if the hex constant was e.g. inside UINT64_C - # macro, but then again, h2ph is an approximation. - } else { - $new .= lc("0x$hex"); - } - next;}; - s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;}; - s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;}; - s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; - s/^'((\\"|[^"])*)'// && do { - if ($curargs{$1}) { - $new .= "ord('\$$1')"; - } else { - $new .= "ord('$1')"; - } - next; - }; - # replace "sizeof(foo)" with "{foo}" - # also, remove * (C dereference operator) to avoid perl syntax - # problems. Where the %sizeof array comes from is anyone's - # guess (c2ph?), but this at least avoids fatal syntax errors. - # Behavior is undefined if sizeof() delimiters are unbalanced. - # This code was modified to able to handle constructs like this: - # sizeof(*(p)), which appear in the HP-UX 10.01 header files. - s/^sizeof\s*\(// && do { - $new .= '$sizeof'; - my $lvl = 1; # already saw one open paren - # tack { on the front, and skip it in the loop - $_ = "{" . "$_"; - my $index = 1; - # find balanced closing paren - while ($index <= length($_) && $lvl > 0) { - $lvl++ if substr($_, $index, 1) eq "("; - $lvl-- if substr($_, $index, 1) eq ")"; - $index++; - } - # tack } on the end, replacing ) - substr($_, $index - 1, 1) = "}"; - # remove pesky * operators within the sizeof argument - substr($_, 0, $index - 1) =~ s/\*//g; - next; - }; - # Eliminate typedefs - /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do { - my $doit = 1; - foreach (split /\s+/, $1) { # Make sure all the words are types, - unless($isatype{$_} or $_ eq 'struct' or $_ eq 'union'){ - $doit = 0; - last; - } - } - if( $doit ){ - s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them. - } - }; - # struct/union member, including arrays: - s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do { - my $id = $1; - $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g; - $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args); - while($id =~ /\[\s*([^\$\&\d\]]+)\]/) { - my($index) = $1; - $index =~ s/\s//g; - if(exists($curargs{$index})) { - $index = "\$$index"; - } else { - $index = "&$index"; - } - $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/; - } - $new .= " (\$$id)"; - }; - s/^([_a-zA-Z]\w*)// && do { - my $id = $1; - if ($id eq 'struct' || $id eq 'union') { - s/^\s+(\w+)//; - $id .= ' ' . $1; - $isatype{$id} = 1; - } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { - while (s/^\s+(\w+)//) { $id .= ' ' . $1; } - $isatype{$id} = 1; - } - if ($curargs{$id}) { - $new .= "\$$id"; - $new .= '->' if /^[\[\{]/; - } elsif ($id eq 'defined') { - $new .= 'defined'; - } elsif (/^\s*\(/) { - s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat - $new .= " &$id"; - } elsif ($isatype{$id}) { - if ($new =~ /\{\s*$/) { - $new .= "'$id'"; - } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { - $new =~ s/\(\s*$//; - s/^[\s*]*\)//; - } else { - $new .= q(').$id.q('); - } - } else { - if ($inif) { - if ($new =~ /defined\s*$/) { - $new .= '(&' . $id . ')'; - } elsif ($new =~ /defined\s*\($/) { - $new .= '&' . $id; - } else { - $new .= '(defined(&' . $id . ') ? &' . $id . ' : undef)'; - } - } elsif (/^\[/) { - $new .= " \$$id"; - } else { - $new .= ' &' . $id; - } - } - next; - }; - s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;}; - } -} - - -sub next_line -{ - my $file = shift; - my ($in, $out); - my $pre_sub_tri_graphs = 1; - - READ: while (not eof IN) { - $in .= ; - chomp $in; - next unless length $in; - - while (length $in) { - if ($pre_sub_tri_graphs) { - # Preprocess all tri-graphs - # including things stuck in quoted string constants. - $in =~ s/\?\?=/#/g; # | ??=| #| - $in =~ s/\?\?\!/|/g; # | ??!| || - $in =~ s/\?\?'/^/g; # | ??'| ^| - $in =~ s/\?\?\(/[/g; # | ??(| [| - $in =~ s/\?\?\)/]/g; # | ??)| ]| - $in =~ s/\?\?\-/~/g; # | ??-| ~| - $in =~ s/\?\?\//\\/g; # | ??/| \| - $in =~ s/\?\?/}/g; # | ??>| }| - } - if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) { - # Tru64 disassembler.h evilness: mixed C and Pascal. - while () { - last if /^\#endif/; - } - $in = ""; - next READ; - } - if ($in =~ /^extern inline / && # Inlined assembler. - $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) { - while () { - last if /^}/; - } - $in = ""; - next READ; - } - if ($in =~ s/\\$//) { # \-newline - $out .= ' '; - next READ; - } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough - $out .= $1; - } elsif ($in =~ s/^(\\.)//) { # \... - $out .= $1; - } elsif ($in =~ /^'/) { # '... - if ($in =~ s/^('(\\.|[^'\\])*')//) { - $out .= $1; - } else { - next READ; - } - } elsif ($in =~ /^"/) { # "... - if ($in =~ s/^("(\\.|[^"\\])*")//) { - $out .= $1; - } else { - next READ; - } - } elsif ($in =~ s/^\/\/.*//) { # //... - # fall through - } elsif ($in =~ m/^\/\*/) { # /*... - # C comment removal adapted from perlfaq6: - if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) { - $out .= ' '; - } else { # Incomplete /* */ - next READ; - } - } elsif ($in =~ s/^(\/)//) { # /... - $out .= $1; - } elsif ($in =~ s/^([^\'\"\\\/]+)//) { - $out .= $1; - } elsif ($^O eq 'linux' && - $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! && - $in =~ s!\'T KNOW!!) { - $out =~ s!I DON$!I_DO_NOT_KNOW!; - } else { - if ($opt_e) { - warn "Cannot parse $file:\n$in\n"; - $bad_file{$file} = 1; - $in = ''; - $out = undef; - last READ; - } else { - die "Cannot parse:\n$in\n"; - } - } - } - - last READ if $out =~ /\S/; - } - - return $out; -} - - -# Handle recursive subdirectories without getting a grotesquely big stack. -# Could this be implemented using File::Find? -sub next_file -{ - my $file; - - while (@ARGV) { - $file = shift @ARGV; - - if ($file eq '-' or -f $file or -l $file) { - return $file; - } elsif (-d $file) { - if ($opt_r) { - expand_glob($file); - } else { - print STDERR "Skipping directory '$file'\n"; - } - } elsif ($opt_a) { - return $file; - } else { - print STDERR "Skipping '$file': not a file or directory\n"; - } - } - - return undef; -} - - -# Put all the files in $directory into @ARGV for processing. -sub expand_glob -{ - my ($directory) = @_; - - $directory =~ s:/$::; - - opendir DIR, $directory; - foreach (readdir DIR) { - next if ($_ eq '.' or $_ eq '..'); - - # expand_glob() is going to be called until $ARGV[0] isn't a - # directory; so push directories, and unshift everything else. - if (-d "$directory/$_") { push @ARGV, "$directory/$_" } - else { unshift @ARGV, "$directory/$_" } - } - closedir DIR; -} - - -# Given $file, a symbolic link to a directory in the C include directory, -# make an equivalent symbolic link in $Dest_dir, if we can figure out how. -# Otherwise, just duplicate the file or directory. -sub link_if_possible -{ - my ($dirlink) = @_; - my $target = eval 'readlink($dirlink)'; - - if ($target =~ m:^\.\./: or $target =~ m:^/:) { - # The target of a parent or absolute link could leave the $Dest_dir - # hierarchy, so let's put all of the contents of $dirlink (actually, - # the contents of $target) into @ARGV; as a side effect down the - # line, $dirlink will get created as an _actual_ directory. - expand_glob($dirlink); - } else { - if (-l "$Dest_dir/$dirlink") { - unlink "$Dest_dir/$dirlink" or - print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n"; - } - - if (eval 'symlink($target, "$Dest_dir/$dirlink")') { - print "Linking $target -> $Dest_dir/$dirlink\n"; - - # Make sure that the link _links_ to something: - if (! -e "$Dest_dir/$target") { - mkpath("$Dest_dir/$target", 0755) or - print STDERR "Could not create $Dest_dir/$target/\n"; - } - } else { - print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n"; - } - } -} - - -# Push all #included files in $file onto our stack, except for STDIN -# and files we've already processed. -sub queue_includes_from -{ - my ($file) = @_; - my $line; - - return if ($file eq "-"); - - open HEADER, "<", $file or return; - while (defined($line =
)) { - while (/\\$/) { # Handle continuation lines - chop $line; - $line .=
; - } - - if ($line =~ /^#\s*include\s+([<"])(.*?)[>"]/) { - my ($delimiter, $new_file) = ($1, $2); - # copy the prefix in the quote syntax (#include "x.h") case - if ($delimiter eq q{"} && $file =~ m|^(.*)/|) { - $new_file = "$1/$new_file"; - } - push(@ARGV, $new_file) unless $Is_converted{$new_file}; - } - } - close HEADER; -} - - -# Determine include directories; $Config{usrinc} should be enough for (all -# non-GCC?) C compilers, but gcc uses additional include directories. -sub inc_dirs -{ - my $from_gcc = `LC_ALL=C $Config{cc} -v -E - < /dev/null 2>&1 | awk '/^#include/, /^End of search list/' | grep '^ '`; - length($from_gcc) ? (split(' ', $from_gcc), $Config{usrinc}) : ($Config{usrinc}); -} - - -# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different -# version of h2ph. -sub build_preamble_if_necessary -{ - # Increment $VERSION every time this function is modified: - my $VERSION = 4; - my $preamble = "$Dest_dir/_h2ph_pre.ph"; - - # Can we skip building the preamble file? - if (-r $preamble) { - # Extract version number from first line of preamble: - open PREAMBLE, "<", $preamble or die "Cannot open $preamble: $!"; - my $line = ; - $line =~ /(\b\d+\b)/; - close PREAMBLE or die "Cannot close $preamble: $!"; - - # Don't build preamble if a compatible preamble exists: - return if $1 == $VERSION; - } - - my (%define) = _extract_cc_defines(); - - open PREAMBLE, ">", $preamble or die "Cannot open $preamble: $!"; - print PREAMBLE "# This file was created by h2ph version $VERSION\n"; - # Prevent non-portable hex constants from warning. - # - # We still produce an overflow warning if we can't represent - # a hex constant as an integer. - print PREAMBLE "no warnings qw(portable);\n"; - - foreach (sort keys %define) { - if ($opt_D) { - print PREAMBLE "# $_=$define{$_}\n"; - } - if ($define{$_} =~ /^\((.*)\)$/) { - # parenthesized value: d=(v) - $define{$_} = $1; - } - if (/^(\w+)\((\w)\)$/) { - my($macro, $arg) = ($1, $2); - my $def = $define{$_}; - $def =~ s/$arg/\$\{$arg\}/g; - print PREAMBLE < 10; - print PREAMBLE - "unless (defined &$_) { sub $_() { $code } }\n\n"; - } elsif ($define{$_} =~ /^\w+$/) { - my $def = $define{$_}; - if ($isatype{$def}) { - print PREAMBLE - "unless (defined &$_) { sub $_() { \"$def\" } }\n\n"; - } else { - print PREAMBLE - "unless (defined &$_) { sub $_() { &$def } }\n\n"; - } - } else { - print PREAMBLE - "unless (defined &$_) { sub $_() { \"", - quotemeta($define{$_}), "\" } }\n\n"; - } - } - print PREAMBLE "\n1;\n"; # avoid 'did not return a true value' when empty - close PREAMBLE or die "Cannot close $preamble: $!"; -} - - -# %Config contains information on macros that are pre-defined by the -# system's compiler. We need this information to make the .ph files -# function with perl as the .h files do with cc. -sub _extract_cc_defines -{ - my %define; - my $allsymbols = join " ", - @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'}; - - # Split compiler pre-definitions into 'key=value' pairs: - while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) { - $define{$1} = $2; - if ($opt_D) { - print STDERR "$_: $1 -> $2\n"; - } - } - - return %define; -} - - -1; - -############################################################################## -__END__ - -=head1 NAME - -h2ph - convert .h C header files to .ph Perl header files - -=head1 SYNOPSIS - -B - -=head1 DESCRIPTION - -I -converts any C header files specified to the corresponding Perl header file -format. -It is most easily run while in /usr/include: - - cd /usr/include; h2ph * sys/* - -or - - cd /usr/include; h2ph * sys/* arpa/* netinet/* - -or - - cd /usr/include; h2ph -r -l . - -The output files are placed in the hierarchy rooted at Perl's -architecture dependent library directory. You can specify a different -hierarchy with a B<-d> switch. - -If run with no arguments, filters standard input to standard output. - -=head1 OPTIONS - -=over 4 - -=item -d destination_dir - -Put the resulting B<.ph> files beneath B, instead of -beneath the default Perl library location (C<$Config{'installsitearch'}>). - -=item -r - -Run recursively; if any of B are directories, then run I -on all files in those directories (and their subdirectories, etc.). B<-r> -and B<-a> are mutually exclusive. - -=item -a - -Run automagically; convert B, as well as any B<.h> files -which they include. This option will search for B<.h> files in all -directories which your C compiler ordinarily uses. B<-a> and B<-r> are -mutually exclusive. - -=item -l - -Symbolic links will be replicated in the destination directory. If B<-l> -is not specified, then links are skipped over. - -=item -h - -Put 'hints' in the .ph files which will help in locating problems with -I. In those cases when you B a B<.ph> file containing syntax -errors, instead of the cryptic - - [ some error condition ] at (eval mmm) line nnn - -you will see the slightly more helpful - - [ some error condition ] at filename.ph line nnn - -However, the B<.ph> files almost double in size when built using B<-h>. - -=item -e - -If an error is encountered during conversion, output file will be removed and -a warning emitted instead of terminating the conversion immediately. - -=item -D - -Include the code from the B<.h> file as a comment in the B<.ph> file. -This is primarily used for debugging I. - -=item -Q - -'Quiet' mode; don't print out the names of the files being converted. - -=back - -=head1 ENVIRONMENT - -No environment variables are used. - -=head1 FILES - - /usr/include/*.h - /usr/include/sys/*.h - -etc. - -=head1 AUTHOR - -Larry Wall - -=head1 SEE ALSO - -perl(1) - -=head1 DIAGNOSTICS - -The usual warnings if it can't read or write the files involved. - -=head1 BUGS - -Doesn't construct the %sizeof array for you. - -It doesn't handle all C constructs, but it does attempt to isolate -definitions inside evals so that you can get at the definitions -that it can translate. - -It's only intended as a rough tool. -You may need to dicker with the files produced. - -You have to run this program by hand; it's not run as part of the Perl -installation. - -Doesn't handle complicated expressions built piecemeal, a la: - - enum { - FIRST_VALUE, - SECOND_VALUE, - #ifdef ABC - THIRD_VALUE - #endif - }; - -Doesn't necessarily locate all of your C compiler's internally-defined -symbols. - -=cut - diff --git a/bin/h2xs b/bin/h2xs deleted file mode 100755 index 27259f00..00000000 --- a/bin/h2xs +++ /dev/null @@ -1,2207 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; - -BEGIN { pop @INC if $INC[-1] eq '.' } - -use warnings; - -=head1 NAME - -h2xs - convert .h C header files to Perl extensions - -=head1 SYNOPSIS - -B [B ...] [headerfile ... [extra_libraries]] - -B B<-h>|B<-?>|B<--help> - -=head1 DESCRIPTION - -I builds a Perl extension from C header files. The extension -will include functions which can be used to retrieve the value of any -#define statement which was in the C header files. - -The I will be used for the name of the extension. If -module_name is not supplied then the name of the first header file -will be used, with the first character capitalized. - -If the extension might need extra libraries, they should be included -here. The extension Makefile.PL will take care of checking whether -the libraries actually exist and how they should be loaded. The extra -libraries should be specified in the form -lm -lposix, etc, just as on -the cc command line. By default, the Makefile.PL will search through -the library path determined by Configure. That path can be augmented -by including arguments of the form B<-L/another/library/path> in the -extra-libraries argument. - -In spite of its name, I may also be used to create a skeleton pure -Perl module. See the B<-X> option. - -=head1 OPTIONS - -=over 5 - -=item B<-A>, B<--omit-autoload> - -Omit all autoload facilities. This is the same as B<-c> but also -removes the S> statement from the .pm file. - -=item B<-B>, B<--beta-version> - -Use an alpha/beta style version number. Causes version number to -be "0.00_01" unless B<-v> is specified. - -=item B<-C>, B<--omit-changes> - -Omits creation of the F file, and adds a HISTORY section to -the POD template. - -=item B<-F>, B<--cpp-flags>=I - -Additional flags to specify to C preprocessor when scanning header for -function declarations. Writes these options in the generated F -too. - -=item B<-M>, B<--func-mask>=I - -selects functions/macros to process. - -=item B<-O>, B<--overwrite-ok> - -Allows a pre-existing extension directory to be overwritten. - -=item B<-P>, B<--omit-pod> - -Omit the autogenerated stub POD section. - -=item B<-X>, B<--omit-XS> - -Omit the XS portion. Used to generate a skeleton pure Perl module. -C<-c> and C<-f> are implicitly enabled. - -=item B<-a>, B<--gen-accessors> - -Generate an accessor method for each element of structs and unions. The -generated methods are named after the element name; will return the current -value of the element if called without additional arguments; and will set -the element to the supplied value (and return the new value) if called with -an additional argument. Embedded structures and unions are returned as a -pointer rather than the complete structure, to facilitate chained calls. - -These methods all apply to the Ptr type for the structure; additionally -two methods are constructed for the structure type itself, C<_to_ptr> -which returns a Ptr type pointing to the same structure, and a C -method to construct and return a new structure, initialised to zeroes. - -=item B<-b>, B<--compat-version>=I - -Generates a .pm file which is backwards compatible with the specified -perl version. - -For versions < 5.6.0, the changes are. - - no use of 'our' (uses 'use vars' instead) - - no 'use warnings' - -Specifying a compatibility version higher than the version of perl you -are using to run h2xs will have no effect. If unspecified h2xs will default -to compatibility with the version of perl you are using to run h2xs. - -=item B<-c>, B<--omit-constant> - -Omit C from the .xs file and corresponding specialised -C from the .pm file. - -=item B<-d>, B<--debugging> - -Turn on debugging messages. - -=item B<-e>, B<--omit-enums>=[I] - -If I is not given, skip all constants that are defined in -a C enumeration. Otherwise skip only those constants that are defined in an -enum whose name matches I. - -Since I is optional, make sure that this switch is followed -by at least one other switch if you omit I and have some -pending arguments such as header-file names. This is ok: - - h2xs -e -n Module::Foo foo.h - -This is not ok: - - h2xs -n Module::Foo -e foo.h - -In the latter, foo.h is taken as I. - -=item B<-f>, B<--force> - -Allows an extension to be created for a header even if that header is -not found in standard include directories. - -=item B<-g>, B<--global> - -Include code for safely storing static data in the .xs file. -Extensions that do no make use of static data can ignore this option. - -=item B<-h>, B<-?>, B<--help> - -Print the usage, help and version for this h2xs and exit. - -=item B<-k>, B<--omit-const-func> - -For function arguments declared as C, omit the const attribute in the -generated XS code. - -=item B<-m>, B<--gen-tied-var> - -B: for each variable declared in the header file(s), declare -a perl variable of the same name magically tied to the C variable. - -=item B<-n>, B<--name>=I - -Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> - -=item B<-o>, B<--opaque-re>=I - -Use "opaque" data type for the C types matched by the regular -expression, even if these types are C-equivalent to types -from typemaps. Should not be used without B<-x>. - -This may be useful since, say, types which are C-equivalent -to integers may represent OS-related handles, and one may want to work -with these handles in OO-way, as in C<$handle-Edo_something()>. -Use C<-o .> if you want to handle all the Ced types as opaque -types. - -The type-to-match is whitewashed (except for commas, which have no -whitespace before them, and multiple C<*> which have no whitespace -between them). - -=item B<-p>, B<--remove-prefix>=I - -Specify a prefix which should be removed from the Perl function names, -e.g., S<-p sec_rgy_> This sets up the XS B keyword and removes -the prefix from functions that are autoloaded via the C -mechanism. - -=item B<-s>, B<--const-subs>=I - -Create a perl subroutine for the specified macros rather than autoload -with the constant() subroutine. These macros are assumed to have a -return type of B, e.g., -S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>. - -=item B<-t>, B<--default-type>=I - -Specify the internal type that the constant() mechanism uses for macros. -The default is IV (signed integer). Currently all macros found during the -header scanning process will be assumed to have this type. Future versions -of C may gain the ability to make educated guesses. - -=item B<--use-new-tests> - -When B<--compat-version> (B<-b>) is present the generated tests will use -C rather than C which is the default for versions before -5.6.2. C will be added to PREREQ_PM in the generated -C. - -=item B<--use-old-tests> - -Will force the generation of test code that uses the older C module. - -=item B<--skip-exporter> - -Do not use C and/or export any symbol. - -=item B<--skip-ppport> - -Do not use C: no portability to older version. - -=item B<--skip-autoloader> - -Do not use the module C; but keep the constant() function -and C for constants. - -=item B<--skip-strict> - -Do not use the pragma C. - -=item B<--skip-warnings> - -Do not use the pragma C. - -=item B<-v>, B<--version>=I - -Specify a version number for this extension. This version number is added -to the templates. The default is 0.01, or 0.00_01 if C<-B> is specified. -The version specified should be numeric. - -=item B<-x>, B<--autogen-xsubs> - -Automatically generate XSUBs basing on function declarations in the -header file. The package C should be installed. If this -option is specified, the name of the header file may look like -C. In this case NAME1 is used instead of the specified -string, but XSUBs are emitted only for the declarations included from -file NAME2. - -Note that some types of arguments/return-values for functions may -result in XSUB-declarations/typemap-entries which need -hand-editing. Such may be objects which cannot be converted from/to a -pointer (like C), pointers to functions, or arrays. See -also the section on L>. - -=back - -=head1 EXAMPLES - - - # Default behavior, extension is Rusers - h2xs rpcsvc/rusers - - # Same, but extension is RUSERS - h2xs -n RUSERS rpcsvc/rusers - - # Extension is rpcsvc::rusers. Still finds - h2xs rpcsvc::rusers - - # Extension is ONC::RPC. Still finds - h2xs -n ONC::RPC rpcsvc/rusers - - # Without constant() or AUTOLOAD - h2xs -c rpcsvc/rusers - - # Creates templates for an extension named RPC - h2xs -cfn RPC - - # Extension is ONC::RPC. - h2xs -cfn ONC::RPC - - # Extension is a pure Perl module with no XS code. - h2xs -X My::Module - - # Extension is Lib::Foo which works at least with Perl5.005_03. - # Constants are created for all #defines and enums h2xs can find - # in foo.h. - h2xs -b 5.5.3 -n Lib::Foo foo.h - - # Extension is Lib::Foo which works at least with Perl5.005_03. - # Constants are created for all #defines but only for enums - # whose names do not start with 'bar_'. - h2xs -b 5.5.3 -e '^bar_' -n Lib::Foo foo.h - - # Makefile.PL will look for library -lrpc in - # additional directory /opt/net/lib - h2xs rpcsvc/rusers -L/opt/net/lib -lrpc - - # Extension is DCE::rgynbase - # prefix "sec_rgy_" is dropped from perl function names - h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase - - # Extension is DCE::rgynbase - # prefix "sec_rgy_" is dropped from perl function names - # subroutines are created for sec_rgy_wildcard_name and - # sec_rgy_wildcard_sid - h2xs -n DCE::rgynbase -p sec_rgy_ \ - -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase - - # Make XS without defines in perl.h, but with function declarations - # visible from perl.h. Name of the extension is perl1. - # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)= - # Extra backslashes below because the string is passed to shell. - # Note that a directory with perl header files would - # be added automatically to include path. - h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h - - # Same with function declaration in proto.h as visible from perl.h. - h2xs -xAn perl2 perl.h,proto.h - - # Same but select only functions which match /^av_/ - h2xs -M '^av_' -xAn perl2 perl.h,proto.h - - # Same but treat SV* etc as "opaque" types - h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h - -=head2 Extension based on F<.h> and F<.c> files - -Suppose that you have some C files implementing some functionality, -and the corresponding header files. How to create an extension which -makes this functionality accessible in Perl? The example below -assumes that the header files are F and -I, and you want the perl module be named as -C. If you need some preprocessor directives and/or -linking with external libraries, see the flags C<-F>, C<-L> and C<-l> -in L<"OPTIONS">. - -=over - -=item Find the directory name - -Start with a dummy run of h2xs: - - h2xs -Afn Ext::Ension - -The only purpose of this step is to create the needed directories, and -let you know the names of these directories. From the output you can -see that the directory for the extension is F. - -=item Copy C files - -Copy your header files and C files to this directory F. - -=item Create the extension - -Run h2xs, overwriting older autogenerated files: - - h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h - -h2xs looks for header files I changing to the extension -directory, so it will find your header files OK. - -=item Archive and test - -As usual, run - - cd Ext/Ension - perl Makefile.PL - make dist - make - make test - -=item Hints - -It is important to do C as early as possible. This way you -can easily merge(1) your changes to autogenerated files if you decide -to edit your C<.h> files and rerun h2xs. - -Do not forget to edit the documentation in the generated F<.pm> file. - -Consider the autogenerated files as skeletons only, you may invent -better interfaces than what h2xs could guess. - -Consider this section as a guideline only, some other options of h2xs -may better suit your needs. - -=back - -=head1 ENVIRONMENT - -No environment variables are used. - -=head1 AUTHOR - -Larry Wall and others - -=head1 SEE ALSO - -L, L, L, and L. - -=head1 DIAGNOSTICS - -The usual warnings if it cannot read or write the files involved. - -=head1 LIMITATIONS of B<-x> - -F would not distinguish whether an argument to a C function -which is of the form, say, C, is an input, output, or -input/output parameter. In particular, argument declarations of the -form - - int - foo(n) - int *n - -should be better rewritten as - - int - foo(n) - int &n - -if C is an input parameter. - -Additionally, F has no facilities to intuit that a function - - int - foo(addr,l) - char *addr - int l - -takes a pair of address and length of data at this address, so it is better -to rewrite this function as - - int - foo(sv) - SV *addr - PREINIT: - STRLEN len; - char *s; - CODE: - s = SvPV(sv,len); - RETVAL = foo(s, len); - OUTPUT: - RETVAL - -or alternately - - static int - my_foo(SV *sv) - { - STRLEN len; - char *s = SvPV(sv,len); - - return foo(s, len); - } - - MODULE = foo PACKAGE = foo PREFIX = my_ - - int - foo(sv) - SV *sv - -See L and L for additional details. - -=cut - -# ' # Grr -use strict; - - -my( $H2XS_VERSION ) = ' $Revision: 1.23 $ ' =~ /\$Revision:\s+([^\s]+)/; -my $TEMPLATE_VERSION = '0.01'; -my @ARGS = @ARGV; -my $compat_version = $]; - -use Getopt::Long; -use Config; -use Text::Wrap; -$Text::Wrap::huge = 'overflow'; -$Text::Wrap::columns = 80; -use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload); -use File::Compare; -use File::Path; - -sub usage { - warn "@_\n" if @_; - die <. - --skip-strict Do not use the pragma C. - --skip-warnings Do not use the pragma C. - -v, --version Specify a version number for this extension. - -x, --autogen-xsubs Autogenerate XSUBs using C::Scan. - --use-xsloader Use XSLoader in backward compatible modules (ignored - when used with -X). - -extra_libraries - are any libraries that might be needed for loading the - extension, e.g. -lm would try to link in the math library. -EOFUSAGE -} - -my ($opt_A, - $opt_B, - $opt_C, - $opt_F, - $opt_M, - $opt_O, - $opt_P, - $opt_X, - $opt_a, - $opt_c, - $opt_d, - $opt_e, - $opt_f, - $opt_g, - $opt_h, - $opt_k, - $opt_m, - $opt_n, - $opt_o, - $opt_p, - $opt_s, - $opt_v, - $opt_x, - $opt_b, - $opt_t, - $new_test, - $old_test, - $skip_exporter, - $skip_ppport, - $skip_autoloader, - $skip_strict, - $skip_warnings, - $use_xsloader - ); - -Getopt::Long::Configure('bundling'); -Getopt::Long::Configure('pass_through'); - -my %options = ( - 'omit-autoload|A' => \$opt_A, - 'beta-version|B' => \$opt_B, - 'omit-changes|C' => \$opt_C, - 'cpp-flags|F=s' => \$opt_F, - 'func-mask|M=s' => \$opt_M, - 'overwrite_ok|O' => \$opt_O, - 'omit-pod|P' => \$opt_P, - 'omit-XS|X' => \$opt_X, - 'gen-accessors|a' => \$opt_a, - 'compat-version|b=s' => \$opt_b, - 'omit-constant|c' => \$opt_c, - 'debugging|d' => \$opt_d, - 'omit-enums|e:s' => \$opt_e, - 'force|f' => \$opt_f, - 'global|g' => \$opt_g, - 'help|h|?' => \$opt_h, - 'omit-const-func|k' => \$opt_k, - 'gen-tied-var|m' => \$opt_m, - 'name|n=s' => \$opt_n, - 'opaque-re|o=s' => \$opt_o, - 'remove-prefix|p=s' => \$opt_p, - 'const-subs|s=s' => \$opt_s, - 'default-type|t=s' => \$opt_t, - 'version|v=s' => \$opt_v, - 'autogen-xsubs|x' => \$opt_x, - 'use-new-tests' => \$new_test, - 'use-old-tests' => \$old_test, - 'skip-exporter' => \$skip_exporter, - 'skip-ppport' => \$skip_ppport, - 'skip-autoloader' => \$skip_autoloader, - 'skip-warnings' => \$skip_warnings, - 'skip-strict' => \$skip_strict, - 'use-xsloader' => \$use_xsloader, - ); - -GetOptions(%options) || usage; - -usage if $opt_h; - -if( $opt_b ){ - usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m); - $opt_b =~ /^v?(\d+)\.(\d+)\.(\d+)/ || - usage "You must provide the backwards compatibility version in X.Y.Z form. " - . "(i.e. 5.5.0)\n"; - my ($maj,$min,$sub) = ($1,$2,$3); - if ($maj < 5 || ($maj == 5 && $min < 6)) { - $compat_version = - $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) : - sprintf("%d.%03d", $maj,$min); - } else { - $compat_version = sprintf("%d.%03d%03d",$maj,$min,$sub); - } -} else { - my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/; - $sub ||= 0; - warn sprintf <<'EOF', $maj,$min,$sub; -Defaulting to backwards compatibility with perl %d.%d.%d -If you intend this module to be compatible with earlier perl versions, please -specify a minimum perl version with the -b option. - -EOF -} - -if( $opt_B ){ - $TEMPLATE_VERSION = '0.00_01'; -} - -if( $opt_v ){ - $TEMPLATE_VERSION = $opt_v; - - # check if it is numeric - my $temp_version = $TEMPLATE_VERSION; - my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/; - my $notnum; - { - local $SIG{__WARN__} = sub { $notnum = 1 }; - use warnings 'numeric'; - $temp_version = 0+$temp_version; - } - - if ($notnum) { - my $module = $opt_n || 'Your::Module'; - warn <<"EOF"; -You have specified a non-numeric version. Unless you supply an -appropriate VERSION class method, users may not be able to specify a -minimum required version with C. - -EOF - } - else { - $opt_B = $beta_version; - } -} - -# -A implies -c. -$skip_autoloader = $opt_c = 1 if $opt_A; - -# -X implies -c and -f -$opt_c = $opt_f = 1 if $opt_X; - -$opt_t ||= 'IV'; - -my %const_xsub; -%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; - -my $extralibs = ''; - -my @path_h; - -while (my $arg = shift) { - if ($arg =~ /^-l/i) { - $extralibs .= "$arg "; - next; - } - last if $extralibs; - push(@path_h, $arg); -} - -usage "Must supply header file or module name\n" - unless (@path_h or $opt_n); - -my $fmask; -my $tmask; - -$fmask = qr{$opt_M} if defined $opt_M; -$tmask = qr{$opt_o} if defined $opt_o; -my $tmask_all = $tmask && $opt_o eq '.'; - -if ($opt_x) { - eval {require C::Scan; 1} - or die <= 0.70 - or die <curdir(), $Config{usrinc}, - (split / +/, $Config{locincpth} // ""), '/usr/include'); - } - foreach my $path_h (@path_h) { - $name ||= $path_h; - $module ||= do { - $name =~ s/\.h$//; - if ( $name !~ /::/ ) { - $name =~ s#^.*/##; - $name = "\u$name"; - } - $name; - }; - - if( $path_h =~ s#::#/#g && $opt_n ){ - warn "Nesting of headerfile ignored with -n\n"; - } - $path_h .= ".h" unless $path_h =~ /\.h$/; - my $fullpath = $path_h; - $path_h =~ s/,.*$// if $opt_x; - $fullpath{$path_h} = $fullpath; - - # Minor trickery: we can't chdir() before we processed the headers - # (so know the name of the extension), but the header may be in the - # extension directory... - my $tmp_path_h = $path_h; - my $rel_path_h = $path_h; - my @dirs = @paths; - if (not -f $path_h) { - my $found; - for my $dir (@paths) { - $found++, last - if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h)); - } - if ($found) { - $rel_path_h = $path_h; - $fullpath{$path_h} = $fullpath; - } else { - (my $epath = $module) =~ s,::,/,g; - $epath = File::Spec->catdir('ext', $epath) if -d 'ext'; - $rel_path_h = File::Spec->catfile($epath, $tmp_path_h); - $path_h = $tmp_path_h; # Used during -x - push @dirs, $epath; - } - } - - if (!$opt_c) { - die "Can't find $tmp_path_h in @dirs\n" - if ( ! $opt_f && ! -f "$rel_path_h" ); - # Scan the header file (we should deal with nested header files) - # Record the names of simple #define constants into const_names - # Function prototypes are processed below. - open(CH, "<", "$rel_path_h") || die "Can't open $rel_path_h: $!\n"; - defines: - while () { - if ($pre_sub_tri_graphs) { - # Preprocess all tri-graphs - # including things stuck in quoted string constants. - s/\?\?=/#/g; # | ??=| #| - s/\?\?\!/|/g; # | ??!| || - s/\?\?'/^/g; # | ??'| ^| - s/\?\?\(/[/g; # | ??(| [| - s/\?\?\)/]/g; # | ??)| ]| - s/\?\?\-/~/g; # | ??-| ~| - s/\?\?\//\\/g; # | ??/| \| - s/\?\?/}/g; # | ??>| }| - } - if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) { - my $def = $1; - my $rest = $2; - $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments - $rest =~ s/^\s+//; - $rest =~ s/\s+$//; - if ($rest eq '') { - print("Skip empty $def\n") if $opt_d; - next defines; - } - # Cannot do: (-1) and ((LHANDLE)3) are OK: - #print("Skip non-wordy $def => $rest\n"), - # next defines if $rest =~ /[^\w\$]/; - if ($rest =~ /"/) { - print("Skip stringy $def => $rest\n") if $opt_d; - next defines; - } - print "Matched $_ ($def)\n" if $opt_d; - $seen_define{$def} = $rest; - $_ = $def; - next if /^_.*_h_*$/i; # special case, but for what? - if (defined $opt_p) { - if (!/^$opt_p(\d)/) { - ++$prefix{$_} if s/^$opt_p//; - } - else { - warn "can't remove $opt_p prefix from '$_'!\n"; - } - } - $prefixless{$def} = $_; - if (!$fmask or /$fmask/) { - print "... Passes mask of -M.\n" if $opt_d and $fmask; - $const_names{$_}++; - } - } - } - if (defined $opt_e and !$opt_e) { - close(CH); - } - else { - # Work from miniperl too - on "normal" systems - my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' || 0; - seek CH, 0, $SEEK_SET; - my $src = do { local $/; }; - close CH; - no warnings 'uninitialized'; - - # Remove C and C++ comments - $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs; - $src =~ s#//.*$##gm; - - while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) { - my ($enum_name, $enum_body) = ($1, $2); - # skip enums matching $opt_e - next if $opt_e && $enum_name =~ /$opt_e/; - my $val = 0; - for my $item (split /,/, $enum_body) { - next if $item =~ /\A\s*\Z/; - my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/; - $val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val; - $seen_define{$key} = $val; - $const_names{$key} = { name => $key, macro => 1 }; - } - } # while (...) - } # if (!defined $opt_e or $opt_e) - } - } -} - -# Save current directory so that C::Scan can use it -my $cwd = File::Spec->rel2abs( File::Spec->curdir ); - -# As Ilya suggested, use a name that contains - and then it can't clash with -# the names of any packages. A directory 'fallback' will clash with any -# new pragmata down the fallback:: tree, but that seems unlikely. -my $constscfname = 'const-c.inc'; -my $constsxsfname = 'const-xs.inc'; -my $fallbackdirname = 'fallback'; - -my $ext = chdir 'ext' ? 'ext/' : ''; - -my @modparts = split(/::/,$module); -my $modpname = join('-', @modparts); -my $modfname = pop @modparts; -my $modpmdir = join '/', 'lib', @modparts; -my $modpmname = join '/', $modpmdir, $modfname.'.pm'; - -if ($opt_O) { - warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname; -} -else { - die "Won't overwrite existing $ext$modpname\n" if -e $modpname; -} --d "$modpname" || mkpath([$modpname], 0, 0775); -chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; - -my %types_seen; -my %std_types; -my $fdecls = []; -my $fdecls_parsed = []; -my $typedef_rex; -my %typedefs_pre; -my %known_fnames; -my %structs; - -my @fnames; -my @fnames_no_prefix; -my %vdecl_hash; -my @vdecls; - -if( ! $opt_X ){ # use XS, unless it was disabled - unless ($skip_ppport) { - require Devel::PPPort; - warn "Writing $ext$modpname/ppport.h\n"; - Devel::PPPort::WriteFile('ppport.h') - || die "Can't create $ext$modpname/ppport.h: $!\n"; - } - open(XS, ">", "$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; - if ($opt_x) { - warn "Scanning typemaps...\n"; - get_typemap(); - my @td; - my @good_td; - my $addflags = $opt_F || ''; - - foreach my $filename (@path_h) { - my $c; - my $filter; - - if ($fullpath{$filename} =~ /,/) { - $filename = $`; - $filter = $'; - } - warn "Scanning $filename for functions...\n"; - my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X); - $c = C::Scan->new('filename' => $filename, 'filename_filter' => $filter, - 'add_cppflags' => $addflags, 'c_styles' => \@styles); - $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]); - - $c->get('keywords')->{'__restrict'} = 1; - - push @$fdecls_parsed, @{ $c->get('parsed_fdecls') }; - push(@$fdecls, @{$c->get('fdecls')}); - - push @td, @{$c->get('typedefs_maybe')}; - if ($opt_a) { - my $structs = $c->get('typedef_structs'); - @structs{keys %$structs} = values %$structs; - } - - if ($opt_m) { - %vdecl_hash = %{ $c->get('vdecl_hash') }; - @vdecls = sort keys %vdecl_hash; - for (local $_ = 0; $_ < @vdecls; ++$_) { - my $var = $vdecls[$_]; - my($type, $post) = @{ $vdecl_hash{$var} }; - if (defined $post) { - warn "Can't handle variable '$type $var $post', skipping.\n"; - splice @vdecls, $_, 1; - redo; - } - $type = normalize_type($type); - $vdecl_hash{$var} = $type; - } - } - - unless ($tmask_all) { - warn "Scanning $filename for typedefs...\n"; - my $td = $c->get('typedef_hash'); - # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d; - my @f_good_td = grep $td->{$_}[1] eq '', keys %$td; - push @good_td, @f_good_td; - @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td}; - } - } - { local $" = '|'; - $typedef_rex = qr(\b(?[$i][1] =~ /$fmask/; # [1] is NAME - push @good, $i; - print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n" - if $opt_d; - } - $fdecls = [@$fdecls[@good]]; - $fdecls_parsed = [@$fdecls_parsed[@good]]; - } - @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME - # Sort declarations: - { - my %h = map( ($_->[1], $_), @$fdecls_parsed); - $fdecls_parsed = [ @h{@fnames} ]; - } - @fnames_no_prefix = @fnames; - @fnames_no_prefix - = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix - if defined $opt_p; - # Remove macros which expand to typedefs - print "Typedefs are @td.\n" if $opt_d; - my %td = map {($_, $_)} @td; - # Add some other possible but meaningless values for macros - for my $k (qw(char double float int long short unsigned signed void)) { - $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned '); - } - # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@; - my $n = 0; - my %bad_macs; - while (keys %td > $n) { - $n = keys %td; - my ($k, $v); - while (($k, $v) = each %seen_define) { - # print("found '$k'=>'$v'\n"), - $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v}; - } - } - # Now %bad_macs contains names of bad macros - for my $k (keys %bad_macs) { - delete $const_names{$prefixless{$k}}; - print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d; - } - } -} -my (@const_specs, @const_names); - -for (sort(keys(%const_names))) { - my $v = $const_names{$_}; - - push(@const_specs, ref($v) ? $v : $_); - push(@const_names, $_); -} - --d $modpmdir || mkpath([$modpmdir], 0, 0775); -open(PM, ">", "$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n"; - -$" = "\n\t"; -warn "Writing $ext$modpname/$modpmname\n"; - -print PM <<"END"; -package $module; - -use $compat_version; -END - -print PM <<"END" unless $skip_strict; -use strict; -END - -print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006; - -unless( $opt_X || $opt_c || $opt_A ){ - # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and - # will want Carp. - print PM <<'END'; -use Carp; -END -} - -print PM <<'END' unless $skip_exporter; - -require Exporter; -END - -my $use_Dyna = (not $opt_X and $compat_version < 5.006 and not $use_xsloader); -print PM <<"END" if $use_Dyna; # use DynaLoader, unless XS was disabled -require DynaLoader; -END - - -# Are we using AutoLoader or not? -unless ($skip_autoloader) { # no autoloader whatsoever. - unless ($opt_c) { # we're doing the AUTOLOAD - print PM "use AutoLoader;\n"; - } - else { - print PM "use AutoLoader qw(AUTOLOAD);\n" - } -} - -if ( $compat_version < 5.006 ) { - my $vars = '$VERSION @ISA'; - $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter; - $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A; - $vars .= ' $XS_VERSION' if $opt_B && !$opt_X; - print PM "use vars qw($vars);"; -} - -# Determine @ISA. -my @modISA; -push @modISA, 'Exporter' unless $skip_exporter; -push @modISA, 'DynaLoader' if $use_Dyna; # no XS -my $myISA = "our \@ISA = qw(@modISA);"; -$myISA =~ s/^our // if $compat_version < 5.006; - -print PM "\n$myISA\n\n"; - -my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls); - -my $tmp=''; -$tmp .= <<"END" unless $skip_exporter; -# Items to export into callers namespace by default. Note: do not export -# names by default without a very good reason. Use EXPORT_OK instead. -# Do not simply export all your public functions/methods/constants. - -# This allows declaration use $module ':all'; -# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK -# will save memory. -our %EXPORT_TAGS = ( 'all' => [ qw( - @exported_names -) ] ); - -our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); - -our \@EXPORT = qw( - @const_names -); - -END - -$tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n"; -if ($opt_B) { - $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X; - $tmp .= "\$VERSION = eval \$VERSION; # see L\n"; -} -$tmp .= "\n"; - -$tmp =~ s/^our //mg if $compat_version < 5.006; -print PM $tmp; - -if (@vdecls) { - printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n"; -} - - -print PM autoload ($module, $compat_version) unless $opt_c or $opt_X; - -if( ! $opt_X ){ # print bootstrap, unless XS is disabled - if ($use_Dyna) { - $tmp = <<"END"; -bootstrap $module \$VERSION; -END - } else { - $tmp = <<"END"; -require XSLoader; -XSLoader::load('$module', \$VERSION); -END - } - $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B; - print PM $tmp; -} - -# tying the variables can happen only after bootstrap -if (@vdecls) { - printf PM <))[0,6]; - if (defined $username && defined $author) { - $author =~ s/,.*$//; # in case of sub fields - my $domain = $Config{'mydomain'}; - $domain =~ s/^\.//; - $email = "$username\@$domain"; - } - }; - -$author =~ s/'/\\'/g if defined $author; -$author ||= "A. U. Thor"; -$email ||= 'a.u.thor@a.galaxy.far.far.away'; - -$licence = sprintf << "DEFAULT", $^V; -Copyright (C) ${\(1900 + (localtime) [5])} by $author - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself, either Perl version %vd or, -at your option, any later version of Perl 5 you may have available. -DEFAULT - -my $revhist = ''; -$revhist = < should be removed. -# -#EOD - $exp_doc .= <${email}E -# -#=head1 COPYRIGHT AND LICENSE -# -$licence_hash -# -#=cut -END - -$pod =~ s/^\#//gm unless $opt_P; -print PM $pod unless $opt_P; - -close PM; - - -if( ! $opt_X ){ # print XS, unless it is disabled -warn "Writing $ext$modpname/$modfname.xs\n"; - -print XS <<"END"; -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -END - -print XS <<"END" unless $skip_ppport; -#include "ppport.h" - -END - -if( @path_h ){ - foreach my $path_h (@path_h_ini) { - my($h) = $path_h; - $h =~ s#^/usr/include/##; - if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; } - print XS qq{#include <$h>\n}; - } - print XS "\n"; -} - -print XS <<"END" if $opt_g; - -/* Global Data */ - -#define MY_CXT_KEY "${module}::_guts" XS_VERSION - -typedef struct { - /* Put Global Data in here */ - int dummy; /* you can access this elsewhere as MY_CXT.dummy */ -} my_cxt_t; - -START_MY_CXT - -END - -my %pointer_typedefs; -my %struct_typedefs; - -sub td_is_pointer { - my $type = shift; - my $out = $pointer_typedefs{$type}; - return $out if defined $out; - my $otype = $type; - $out = ($type =~ /\*$/); - # This converts only the guys which do not have trailing part in the typedef - if (not $out - and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { - $type = normalize_type($type); - print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n" - if $opt_d; - $out = td_is_pointer($type); - } - return ($pointer_typedefs{$otype} = $out); -} - -sub td_is_struct { - my $type = shift; - my $out = $struct_typedefs{$type}; - return $out if defined $out; - my $otype = $type; - $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type); - # This converts only the guys which do not have trailing part in the typedef - if (not $out - and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { - $type = normalize_type($type); - print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n" - if $opt_d; - $out = td_is_struct($type); - } - return ($struct_typedefs{$otype} = $out); -} - -print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls; - -if( ! $opt_c ) { - # We write the "sample" files used when this module is built by perl without - # ExtUtils::Constant. - # h2xs will later check that these are the same as those generated by the - # code embedded into Makefile.PL - unless (-d $fallbackdirname) { - mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n"; - } - warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n"; - warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n"; - my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname); - my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname); - WriteConstants ( C_FILE => $cfallback, - XS_FILE => $xsfallback, - DEFAULT_TYPE => $opt_t, - NAME => $module, - NAMES => \@const_specs, - ); - print XS "#include \"$constscfname\"\n"; -} - - -my $prefix = defined $opt_p ? "PREFIX = $opt_p" : ''; - -# Now switch from C to XS by issuing the first MODULE declaration: -print XS <<"END"; - -MODULE = $module PACKAGE = $module $prefix - -END - -# If a constant() function was #included then output a corresponding -# XS declaration: -print XS "INCLUDE: $constsxsfname\n" unless $opt_c; - -print XS <<"END" if $opt_g; - -BOOT: -{ - MY_CXT_INIT; - /* If any of the fields in the my_cxt_t struct need - to be initialised, do it here. - */ -} - -END - -foreach (sort keys %const_xsub) { - print XS <<"END"; -char * -$_() - - CODE: -#ifdef $_ - RETVAL = $_; -#else - croak("Your vendor has not defined the $module macro $_"); -#endif - - OUTPUT: - RETVAL - -END -} - -my %seen_decl; -my %typemap; - -sub print_decl { - my $fh = shift; - my $decl = shift; - my ($type, $name, $args) = @$decl; - return if $seen_decl{$name}++; # Need to do the same for docs as well? - - my @argnames = map {$_->[1]} @$args; - my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args; - if ($opt_k) { - s/^\s*const\b\s*// for @argtypes; - } - my @argarrays = map { $_->[4] || '' } @$args; - my $numargs = @$args; - if ($numargs and $argtypes[-1] eq '...') { - $numargs--; - $argnames[-1] = '...'; - } - local $" = ', '; - $type = normalize_type($type, 1); - - print $fh <<"EOP"; - -$type -$name(@argnames) -EOP - - for my $arg (0 .. $numargs - 1) { - print $fh <<"EOP"; - $argtypes[$arg] $argnames[$arg]$argarrays[$arg] -EOP - } -} - -sub print_tievar_subs { - my($fh, $name, $type) = @_; - print $fh <[0] =~ /_ANON/) { - if (defined $item->[2]) { - push @items, map [ - @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", - ], @{ $structs{$item->[0]} }; - } else { - push @items, @{ $structs{$item->[0]} }; - } - } else { - my $type = normalize_type($item->[0]); - my $ttype = $structs{$type} ? normalize_type("$type *") : $type; - print $fh <<"EOF"; -$ttype -$item->[2](THIS, __value = NO_INIT) - $ptrname THIS - $type __value - PROTOTYPE: \$;\$ - CODE: - if (items > 1) - THIS->$item->[-1] = __value; - RETVAL = @{[ - $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])" - ]}; - OUTPUT: - RETVAL - -EOF - } - } -} - -sub accessor_docs { - my($name, $struct) = @_; - return unless defined $struct && $name !~ /\s|_ANON/; - $name = normalize_type($name); - my $ptrname = $name . 'Ptr'; - my @items = @$struct; - my @list; - while (@items) { - my $item = shift @items; - if ($item->[0] =~ /_ANON/) { - if (defined $item->[2]) { - push @items, map [ - @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", - ], @{ $structs{$item->[0]} }; - } else { - push @items, @{ $structs{$item->[0]} }; - } - } else { - push @list, $item->[2]; - } - } - my $methods = (join '(...)>, C<', @list) . '(...)'; - - my $pod = <<"EOF"; -# -#=head2 Object and class methods for C<$name>/C<$ptrname> -# -#The principal Perl representation of a C object of type C<$name> is an -#object of class C<$ptrname> which is a reference to an integer -#representation of a C pointer. To create such an object, one may use -#a combination -# -# my \$buffer = $name->new(); -# my \$obj = \$buffer->_to_ptr(); -# -#This exercises the following two methods, and an additional class -#C<$name>, the internal representation of which is a reference to a -#packed string with the C structure. Keep in mind that \$buffer should -#better survive longer than \$obj. -# -#=over -# -#=item C<\$object_of_type_$name-E_to_ptr()> -# -#Converts an object of type C<$name> to an object of type C<$ptrname>. -# -#=item C<$name-Enew()> -# -#Creates an empty object of type C<$name>. The corresponding packed -#string is zeroed out. -# -#=item C<$methods> -# -#return the current value of the corresponding element if called -#without additional arguments. Set the element to the supplied value -#(and return the new value) if called with an additional argument. -# -#Applicable to objects of type C<$ptrname>. -# -#=back -# -EOF - $pod =~ s/^\#//gm; - return $pod; -} - -# Should be called before any actual call to normalize_type(). -sub get_typemap { - # We do not want to read ./typemap by obvios reasons. - my @tm = qw(../../../typemap ../../typemap ../typemap); - my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap"; - unshift @tm, $stdtypemap; - my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; - - # Start with useful default values - $typemap{float} = 'T_NV'; - - foreach my $typemap (@tm) { - next unless -e $typemap ; - # skip directories, binary files etc. - warn " Scanning $typemap\n"; - warn("Warning: ignoring non-text typemap file '$typemap'\n"), next - unless -T $typemap ; - open(TYPEMAP, "<", $typemap) - or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; - my $mode = 'Typemap'; - while () { - next if /^\s*\#/; - if (/^INPUT\s*$/) { $mode = 'Input'; next; } - elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; } - elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; } - elsif ($mode eq 'Typemap') { - next if /^\s*($|\#)/ ; - my ($type, $image); - if ( ($type, $image) = - /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o - # This may reference undefined functions: - and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) { - $typemap{normalize_type($type)} = $image; - } - } - } - close(TYPEMAP) or die "Cannot close $typemap: $!"; - } - %std_types = %types_seen; - %types_seen = (); -} - - -sub normalize_type { # Second arg: do not strip const's before \* - my $type = shift; - my $do_keep_deep_const = shift; - # If $do_keep_deep_const this is heuristic only - my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : ''); - my $ignore_mods - = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*"; - if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately! - $type =~ s/$ignore_mods//go; - } - else { - $type =~ s/$ignore_mods//go; - } - $type =~ s/([^\s\w])/ $1 /g; - $type =~ s/\s+$//; - $type =~ s/^\s+//; - $type =~ s/\s+/ /g; - $type =~ s/\* (?=\*)/*/g; - $type =~ s/\. \. \./.../g; - $type =~ s/ ,/,/g; - $types_seen{$type}++ - unless $type eq '...' or $type eq 'void' or $std_types{$type}; - $type; -} - -my $need_opaque; - -sub assign_typemap_entry { - my $type = shift; - my $otype = $type; - my $entry; - if ($tmask and $type =~ /$tmask/) { - print "Type $type matches -o mask\n" if $opt_d; - $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); - } - elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { - $type = normalize_type $type; - print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d; - $entry = assign_typemap_entry($type); - } - # XXX good do better if our UV happens to be long long - return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/; - $entry ||= $typemap{$otype} - || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); - $typemap{$otype} = $entry; - $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT"; - return $entry; -} - -for (@vdecls) { - print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_}); -} - -if ($opt_x) { - for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } - if ($opt_a) { - while (my($name, $struct) = each %structs) { - print_accessors(\*XS, $name, $struct); - } - } -} - -close XS; - -if (%types_seen) { - my $type; - warn "Writing $ext$modpname/typemap\n"; - open TM, ">", "typemap" or die "Cannot open typemap file for write: $!"; - - for $type (sort keys %types_seen) { - my $entry = assign_typemap_entry $type; - print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n" - } - - print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry -############################################################################# -INPUT -T_OPAQUE_STRUCT - if (sv_derived_from($arg, \"${ntype}\")) { - STRLEN len; - char *s = SvPV((SV*)SvRV($arg), len); - - if (len != sizeof($var)) - croak(\"Size %d of packed data != expected %d\", - len, sizeof($var)); - $var = *($type *)s; - } - else - croak(\"$var is not of type ${ntype}\") -############################################################################# -OUTPUT -T_OPAQUE_STRUCT - sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var)); -EOP - - close TM or die "Cannot close typemap file for write: $!"; -} - -} # if( ! $opt_X ) - -warn "Writing $ext$modpname/Makefile.PL\n"; -open(PL, ">", "Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n"; - -my $prereq_pm = ''; - -if ( $compat_version < 5.006002 and $new_test ) -{ - $prereq_pm .= q%'Test::More' => 0, %; -} -elsif ( $compat_version < 5.006002 ) -{ - $prereq_pm .= q%'Test' => 0, %; -} - -if (!$opt_X and $use_xsloader) -{ - $prereq_pm .= q%'XSLoader' => 0, %; -} - -print PL <<"END"; -use $compat_version; -use ExtUtils::MakeMaker; -# See lib/ExtUtils/MakeMaker.pm for details of how to influence -# the contents of the Makefile that is written. -WriteMakefile( - NAME => '$module', - VERSION_FROM => '$modpmname', # finds \$VERSION, requires EU::MM from perl >= 5.5 - PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1 - ABSTRACT_FROM => '$modpmname', # retrieve abstract from module - AUTHOR => '$author <$email>', - #LICENSE => 'perl', - #Value must be from legacy list of licenses here - #http://search.cpan.org/perldoc?Module%3A%3ABuild%3A%3AAPI -END -if (!$opt_X) { # print C stuff, unless XS is disabled - $opt_F = '' unless defined $opt_F; - my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : ''); - my $Ihelp = ($I ? '-I. ' : ''); - my $Icomment = ($I ? '' : < ['$extralibs'], # e.g., '-lm' - DEFINE => '$opt_F', # e.g., '-DHAVE_SOMETHING' -$Icomment INC => '$I', # e.g., '${Ihelp}-I/usr/include/other' -END - - my $C = grep {$_ ne "$modfname.c"} - (glob '*.c'), (glob '*.cc'), (glob '*.C'); - my $Cpre = ($C ? '' : '# '); - my $Ccomment = ($C ? '' : < '\$(O_FILES)', # link all the C files too -END -} # ' # Grr -print PL ");\n"; -if (!$opt_c) { - my $generate_code = - WriteMakefileSnippet ( C_FILE => $constscfname, - XS_FILE => $constsxsfname, - DEFAULT_TYPE => $opt_t, - NAME => $module, - NAMES => \@const_specs, - ); - print PL <<"END"; -if (eval {require ExtUtils::Constant; 1}) { - # If you edit these definitions to change the constants used by this module, - # you will need to use the generated $constscfname and $constsxsfname - # files to replace their "fallback" counterparts before distributing your - # changes. -$generate_code -} -else { - use File::Copy; - use File::Spec; - foreach my \$file ('$constscfname', '$constsxsfname') { - my \$fallback = File::Spec->catfile('$fallbackdirname', \$file); - copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!"; - } -} -END - - eval $generate_code; - if ($@) { - warn <<"EOM"; -Attempting to test constant code in $ext$modpname/Makefile.PL: -$generate_code -__END__ -gave unexpected error $@ -Please report the circumstances of this bug in h2xs version $H2XS_VERSION -using the perlbug script. -EOM - } else { - my $fail; - - foreach my $file ($constscfname, $constsxsfname) { - my $fallback = File::Spec->catfile($fallbackdirname, $file); - if (compare($file, $fallback)) { - warn << "EOM"; -Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ. -EOM - $fail++; - } - } - if ($fail) { - warn fill ('','', <<"EOM") . "\n"; -It appears that the code in $ext$modpname/Makefile.PL does not autogenerate -the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname -correctly. - -Please report the circumstances of this bug in h2xs version $H2XS_VERSION -using the perlbug script. -EOM - } else { - unlink $constscfname, $constsxsfname; - } - } -} -close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n"; - -# Create a simple README since this is a CPAN requirement -# and it doesn't hurt to have one -warn "Writing $ext$modpname/README\n"; -open(RM, ">", "README") || die "Can't create $ext$modpname/README:$!\n"; -my $thisyear = (gmtime)[5] + 1900; -my $rmhead = "$modpname version $TEMPLATE_VERSION"; -my $rmheadeq = "=" x length($rmhead); - -my $rm_prereq; - -if ( $compat_version < 5.006002 and $new_test ) -{ - $rm_prereq = 'Test::More'; -} -elsif ( $compat_version < 5.006002 ) -{ - $rm_prereq = 'Test'; -} -else -{ - $rm_prereq = 'blah blah blah'; -} - -print RM <<_RMEND_; -$rmhead -$rmheadeq - -The README is used to introduce the module and provide instructions on -how to install the module, any machine dependencies it may have (for -example C compilers and installed libraries) and any other information -that should be provided before the module is installed. - -A README file is required for CPAN modules since CPAN extracts the -README file from a module distribution so that people browsing the -archive can use it get an idea of the modules uses. It is usually a -good idea to provide version information here so that people can -decide whether fixes for the module are worth downloading. - -INSTALLATION - -To install this module type the following: - - perl Makefile.PL - make - make test - make install - -DEPENDENCIES - -This module requires these other modules and libraries: - - $rm_prereq - -COPYRIGHT AND LICENCE - -Put the correct copyright and licence information here. - -$licence - -_RMEND_ -close(RM) || die "Can't close $ext$modpname/README: $!\n"; - -my $testdir = "t"; -my $testfile = "$testdir/$modpname.t"; -unless (-d "$testdir") { - mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n"; -} -warn "Writing $ext$modpname/$testfile\n"; -my $tests = @const_names ? 2 : 1; - -open EX, ">", "$testfile" or die "Can't create $ext$modpname/$testfile: $!\n"; - -print EX <<_END_; -# Before 'make install' is performed this script should be runnable with -# 'make test'. After 'make install' it should work as 'perl $modpname.t' - -######################### - -# change 'tests => $tests' to 'tests => last_test_to_print'; - -use strict; -use warnings; - -_END_ - -my $test_mod = 'Test::More'; - -if ( $old_test or ($compat_version < 5.006002 and not $new_test )) -{ - my $test_mod = 'Test'; - - print EX <<_END_; -use Test; -BEGIN { plan tests => $tests }; -use $module; -ok(1); # If we made it this far, we're ok. - -_END_ - - if (@const_names) { - my $const_names = join " ", @const_names; - print EX <<'_END_'; - -my $fail; -foreach my $constname (qw( -_END_ - - print EX wrap ("\t", "\t", $const_names); - print EX (")) {\n"); - - print EX <<_END_; - next if (eval "my \\\$a = \$constname; 1"); - if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) { - print "# pass: \$\@"; - } else { - print "# fail: \$\@"; - \$fail = 1; - } -} -if (\$fail) { - print "not ok 2\\n"; -} else { - print "ok 2\\n"; -} - -_END_ - } -} -else -{ - print EX <<_END_; -use Test::More tests => $tests; -BEGIN { use_ok('$module') }; - -_END_ - - if (@const_names) { - my $const_names = join " ", @const_names; - print EX <<'_END_'; - -my $fail = 0; -foreach my $constname (qw( -_END_ - - print EX wrap ("\t", "\t", $const_names); - print EX (")) {\n"); - - print EX <<_END_; - next if (eval "my \\\$a = \$constname; 1"); - if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) { - print "# pass: \$\@"; - } else { - print "# fail: \$\@"; - \$fail = 1; - } - -} - -ok( \$fail == 0 , 'Constants' ); -_END_ - } -} - -print EX <<_END_; -######################### - -# Insert your test code below, the $test_mod module is use()ed here so read -# its man page ( perldoc $test_mod ) for help writing this test script. - -_END_ - -close(EX) || die "Can't close $ext$modpname/$testfile: $!\n"; - -unless ($opt_C) { - warn "Writing $ext$modpname/Changes\n"; - $" = ' '; - open(EX, ">", "Changes") || die "Can't create $ext$modpname/Changes: $!\n"; - @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS; - print EX <', 'MANIFEST') or die "Can't create MANIFEST: $!"; -my @files = grep { -f } (<*>, , <$fallbackdirname/*>, <$modpmdir/*>); -if (!@files) { - eval {opendir(D,'.');}; - unless ($@) { @files = readdir(D); closedir(D); } -} -if (!@files) { @files = map {chomp && $_} `ls`; } -if ($^O eq 'VMS') { - foreach (@files) { - # Clip trailing '.' for portability -- non-VMS OSs don't expect it - s%\.$%%; - # Fix up for case-sensitive file systems - s/$modfname/$modfname/i && next; - $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes'; - $_ = 'Makefile.PL' if $_ eq 'makefile.pl'; - } -} -print MANI join("\n",@files), "\n"; -close MANI; diff --git a/bin/instmodsh b/bin/instmodsh deleted file mode 100755 index 14580e3f..00000000 --- a/bin/instmodsh +++ /dev/null @@ -1,196 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; -#!/usr/bin/perl -w - -BEGIN { pop @INC if $INC[-1] eq '.' } -use strict; -use IO::File; -use ExtUtils::Packlist; -use ExtUtils::Installed; - -use vars qw($Inst @Modules); - - -=head1 NAME - -instmodsh - A shell to examine installed modules - -=head1 SYNOPSIS - - instmodsh - -=head1 DESCRIPTION - -A little interface to ExtUtils::Installed to examine installed modules, -validate your packlists and even create a tarball from an installed module. - -=head1 SEE ALSO - -ExtUtils::Installed - -=cut - - -my $Module_Help = < - Create a tar archive of the module - h - Display module help - q - Quit the module -EOF - -my %Module_Commands = ( - f => \&list_installed, - d => \&list_directories, - v => \&validate_packlist, - t => \&create_archive, - h => \&module_help, - ); - -sub do_module($) { - my ($module) = @_; - - print($Module_Help); - MODULE_CMD: while (1) { - print("$module cmd? "); - - my $reply = ; chomp($reply); - my($cmd) = $reply =~ /^(\w)\b/; - - last if $cmd eq 'q'; - - if( $Module_Commands{$cmd} ) { - $Module_Commands{$cmd}->($reply, $module); - } - elsif( $cmd eq 'q' ) { - last MODULE_CMD; - } - else { - module_help(); - } - } -} - - -sub list_installed { - my($reply, $module) = @_; - - my $class = (split(' ', $reply))[1]; - $class = 'all' unless $class; - - my @files; - if (eval { @files = $Inst->files($module, $class); }) { - print("$class files in $module are:\n ", - join("\n ", @files), "\n"); - } - else { - print($@); - } -}; - - -sub list_directories { - my($reply, $module) = @_; - - my $class = (split(' ', $reply))[1]; - $class = 'all' unless $class; - - my @dirs; - if (eval { @dirs = $Inst->directories($module, $class); }) { - print("$class directories in $module are:\n ", - join("\n ", @dirs), "\n"); - } - else { - print($@); - } -} - - -sub create_archive { - my($reply, $module) = @_; - - my $file = (split(' ', $reply))[1]; - - if( !(defined $file and length $file) ) { - print "No tar file specified\n"; - } - elsif( eval { require Archive::Tar } ) { - Archive::Tar->create_archive($file, 0, $Inst->files($module)); - } - else { - my($first, @rest) = $Inst->files($module); - system('tar', 'cvf', $file, $first); - for my $f (@rest) { - system('tar', 'rvf', $file, $f); - } - print "Can't use tar\n" if $?; - } -} - - -sub validate_packlist { - my($reply, $module) = @_; - - if (my @missing = $Inst->validate($module)) { - print("Files missing from $module are:\n ", - join("\n ", @missing), "\n"); - } - else { - print("$module has no missing files\n"); - } -} - -sub module_help { - print $Module_Help; -} - - - -############################################################################## - -sub toplevel() -{ -my $help = < - Select a module - q - Quit the program -EOF -print($help); -while (1) - { - print("cmd? "); - my $reply = ; chomp($reply); - CASE: - { - $reply eq 'l' and do - { - print("Installed modules are:\n ", join("\n ", @Modules), "\n"); - last CASE; - }; - $reply =~ /^m\s+/ and do - { - do_module((split(' ', $reply))[1]); - last CASE; - }; - $reply eq 'q' and do - { - exit(0); - }; - # Default - print($help); - } - } -} - - -############################################################################### - -$Inst = ExtUtils::Installed->new(); -@Modules = $Inst->modules(); -toplevel(); - -############################################################################### diff --git a/bin/json_pp b/bin/json_pp deleted file mode 100755 index e2bb722e..00000000 --- a/bin/json_pp +++ /dev/null @@ -1,209 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; -#!/usr/bin/perl - -BEGIN { pop @INC if $INC[-1] eq '.' } -use strict; -use Getopt::Long; - -use JSON::PP (); - -my $VERSION = '1.00'; - -# imported from JSON-XS/bin/json_xs - -my %allow_json_opt = map { $_ => 1 } qw( - ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref - allow_singlequote allow_barekey allow_bignum loose escape_slash -); - - -GetOptions( - 'v' => \( my $opt_verbose ), - 'f=s' => \( my $opt_from = 'json' ), - 't=s' => \( my $opt_to = 'json' ), - 'json_opt=s' => \( my $json_opt = 'pretty' ), - 'V' => \( my $version ), -) or die "Usage: $0 [-v] -f from_format [-t to_format]\n"; - - -if ( $version ) { - print "$VERSION\n"; - exit; -} - - -$json_opt = '' if $json_opt eq '-'; - -my @json_opt = grep { $allow_json_opt{ $_ } or die "'$_' is not a valid json option" } split/,/, $json_opt; - -my %F = ( - 'json' => sub { - my $json = JSON::PP->new; - $json->$_() for @json_opt; - $json->decode( $_ ); - }, - 'eval' => sub { - my $v = eval "no strict;\n#line 1 \"input\"\n$_"; - die "$@" if $@; - return $v; - }, -); - - -my %T = ( - 'null' => sub { "" }, - 'json' => sub { - my $json = JSON::PP->new; - $json->$_() for @json_opt; - $json->encode( $_ ); - }, - 'dumper' => sub { - require Data::Dumper; - Data::Dumper::Dumper($_) - }, -); - - - -$F{$opt_from} - or die "$opt_from: not a valid fromformat\n"; - -$T{$opt_to} - or die "$opt_from: not a valid toformat\n"; - -local $/; -$_ = ; - -$_ = $F{$opt_from}->(); -$_ = $T{$opt_to}->(); - -print $_; - - -__END__ - -=pod - -=encoding utf8 - -=head1 NAME - -json_pp - JSON::PP command utility - -=head1 SYNOPSIS - - json_pp [-v] [-f from_format] [-t to_format] [-json_opt options_to_json] - -=head1 DESCRIPTION - -json_pp converts between some input and output formats (one of them is JSON). -This program was copied from L and modified. - -The default input format is json and the default output format is json with pretty option. - -=head1 OPTIONS - -=head2 -f - - -f from_format - -Reads a data in the given format from STDIN. - -Format types: - -=over - -=item json - -as JSON - -=item eval - -as Perl code - -=back - -=head2 -t - -Writes a data in the given format to STDOUT. - -=over - -=item null - -no action. - -=item json - -as JSON - -=item dumper - -as Data::Dumper - -=back - -=head2 -json_opt - -options to JSON::PP - -Acceptable options are: - - ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref - allow_singlequote allow_barekey allow_bignum loose escape_slash - -=head2 -v - -Verbose option, but currently no action in fact. - -=head2 -V - -Prints version and exits. - - -=head1 EXAMPLES - - $ perl -e'print q|{"foo":"恂恄","bar":1234567890000000000000000}|' |\ - json_pp -f json -t dumper -json_opt pretty,utf8,allow_bignum - - $VAR1 = { - 'bar' => bless( { - 'value' => [ - '0000000', - '0000000', - '5678900', - '1234' - ], - 'sign' => '+' - }, 'Math::BigInt' ), - 'foo' => "\x{3042}\x{3044}" - }; - - $ perl -e'print q|{"foo":"恂恄","bar":1234567890000000000000000}|' |\ - json_pp -f json -t dumper -json_opt pretty - - $VAR1 = { - 'bar' => '1234567890000000000000000', - 'foo' => "\x{e3}\x{81}\x{82}\x{e3}\x{81}\x{84}" - }; - -=head1 SEE ALSO - -L, L - -=head1 AUTHOR - -Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE - - -=head1 COPYRIGHT AND LICENSE - -Copyright 2010 by Makamaka Hannyaharamitu - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - diff --git a/bin/libnetcfg b/bin/libnetcfg deleted file mode 100755 index a190f38a..00000000 --- a/bin/libnetcfg +++ /dev/null @@ -1,722 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; - -=head1 NAME - -libnetcfg - configure libnet - -=head1 DESCRIPTION - -The libnetcfg utility can be used to configure the libnet. -Starting from perl 5.8 libnet is part of the standard Perl -distribution, but the libnetcfg can be used for any libnet -installation. - -=head1 USAGE - -Without arguments libnetcfg displays the current configuration. - - $ libnetcfg - # old config ./libnet.cfg - daytime_hosts ntp1.none.such - ftp_int_passive 0 - ftp_testhost ftp.funet.fi - inet_domain none.such - nntp_hosts nntp.none.such - ph_hosts - pop3_hosts pop.none.such - smtp_hosts smtp.none.such - snpp_hosts - test_exist 1 - test_hosts 1 - time_hosts ntp.none.such - # libnetcfg -h for help - $ - -It tells where the old configuration file was found (if found). - -The C<-h> option will show a usage message. - -To change the configuration you will need to use either the C<-c> or -the C<-d> options. - -The default name of the old configuration file is by default -"libnet.cfg", unless otherwise specified using the -i option, -C<-i oldfile>, and it is searched first from the current directory, -and then from your module path. - -The default name of the new configuration file is "libnet.cfg", and by -default it is written to the current directory, unless otherwise -specified using the -o option, C<-o newfile>. - -=head1 SEE ALSO - -L, L - -=head1 AUTHORS - -Graham Barr, the original Configure script of libnet. - -Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8. - -=cut - -# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $ - -BEGIN { pop @INC if $INC[-1] eq '.' } -use strict; -use IO::File; -use Getopt::Std; -use ExtUtils::MakeMaker qw(prompt); -use File::Spec; - -use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i); - -## -## -## - -my %cfg = (); -my @cfg = (); - -my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old); - -## -## -## - -sub valid_host -{ - my $h = shift; - - defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h)); -} - -## -## -## - -sub test_hostnames (\@) -{ - my $hlist = shift; - my @h = (); - my $host; - my $err = 0; - - foreach $host (@$hlist) - { - if(valid_host($host)) - { - push(@h, $host); - next; - } - warn "Bad hostname: '$host'\n"; - $err++; - } - @$hlist = @h; - $err ? join(" ",@h) : undef; -} - -## -## -## - -sub Prompt -{ - my($prompt,$def) = @_; - - $def = "" unless defined $def; - - chomp($prompt); - - if($opt_d) - { - print $prompt,," [",$def,"]\n"; - return $def; - } - prompt($prompt,$def); -} - -## -## -## - -sub get_host_list -{ - my($prompt,$def) = @_; - - $def = join(" ",@$def) if ref($def); - - my @hosts; - - do - { - my $ans = Prompt($prompt,$def); - - $ans =~ s/(\A\s+|\s+\Z)//g; - - @hosts = split(/\s+/, $ans); - } - while(@hosts && defined($def = test_hostnames(@hosts))); - - \@hosts; -} - -## -## -## - -sub get_hostname -{ - my($prompt,$def) = @_; - - my $host; - - while(1) - { - my $ans = Prompt($prompt,$def); - $host = ($ans =~ /(\S*)/)[0]; - last - if(!length($host) || valid_host($host)); - - $def ="" - if $def eq $host; - - print <<"EDQ"; - -*** ERROR: - Hostname '$host' does not seem to exist, please enter again - or a single space to clear any default - -EDQ - } - - length $host - ? $host - : undef; -} - -## -## -## - -sub get_bool ($$) -{ - my($prompt,$def) = @_; - - chomp($prompt); - - my $val = Prompt($prompt,$def ? "yes" : "no"); - - $val =~ /^y/i ? 1 : 0; -} - -## -## -## - -sub get_netmask ($$) -{ - my($prompt,$def) = @_; - - chomp($prompt); - - my %list; - @list{@$def} = (); - -MASK: - while(1) { - my $bad = 0; - my $ans = Prompt($prompt) or last; - - if($ans eq '*') { - %list = (); - next; - } - - if($ans eq '=') { - print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n"; - next; - } - - unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) { - warn "Bad netmask '$ans'\n"; - next; - } - - my($remove,$bits,@ip) = ($1,$3,split(/\./, $2),0,0,0); - if ( $ip[0] < 1 || $bits < 1 || $bits > 32) { - warn "Bad netmask '$ans'\n"; - next MASK; - } - foreach my $byte (@ip) { - if ( $byte > 255 ) { - warn "Bad netmask '$ans'\n"; - next MASK; - } - } - - my $mask = sprintf("%d.%d.%d.%d/%d",@ip[0..3],$bits); - - if ($remove) { - delete $list{$mask}; - } - else { - $list{$mask} = 1; - } - - } - - [ keys %list ]; -} - -## -## -## - -sub default_hostname -{ - my $host; - my @host; - - foreach $host (@_) - { - if(defined($host) && valid_host($host)) - { - return $host - unless wantarray; - push(@host,$host); - } - } - - return wantarray ? @host : undef; -} - -## -## -## - -getopts('dcho:i:'); - -$libnet_cfg_in = "libnet.cfg" - unless(defined($libnet_cfg_in = $opt_i)); - -$libnet_cfg_out = "libnet.cfg" - unless(defined($libnet_cfg_out = $opt_o)); - -my %oldcfg = (); - -$Net::Config::CONFIGURE = 1; # Suppress load of user overrides -if( -f $libnet_cfg_in ) - { - %oldcfg = ( %{ local @INC = '.'; do $libnet_cfg_in } ); - } -elsif (eval { require Net::Config }) - { - $have_old = 1; - %oldcfg = %Net::Config::NetConfig; - } - -map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg; - -#--------------------------------------------------------------------------- - -if ($opt_h) { - print <, and it is searched first from the current directory, -and then from your module path. - -The default name of the new configuration file is "libnet.cfg", and by -default it is written to the current directory, unless otherwise -specified using the -o option. - -EOU - exit(0); -} - -#--------------------------------------------------------------------------- - -{ - my $oldcfgfile; - my @inc; - push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB}; - push @inc, $ENV{PERLLIB} if exists $ENV{PERLLIB}; - push @inc, @INC; - for (@inc) { - my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in); - if (-f $trycfgfile && -r $trycfgfile) { - $oldcfgfile = $trycfgfile; - last; - } - } - print "# old config $oldcfgfile\n" if defined $oldcfgfile; - for (sort keys %oldcfg) { - printf "%-20s %s\n", $_, - ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_}; - } - unless ($opt_c || $opt_d) { - print "# $0 -h for help\n"; - exit(0); - } -} - -#--------------------------------------------------------------------------- - -$oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'}; -$oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'}; - -#--------------------------------------------------------------------------- - -if($have_old && !$opt_d) - { - $msg = <. To accept the -default, hit - -EDQ - -$msg = 'Enter a list of available NNTP hosts :'; - -$def = $oldcfg{'nntp_hosts'} || - [ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ]; - -$cfg{'nntp_hosts'} = get_host_list($msg,$def); - -#--------------------------------------------------------------------------- - -$msg = 'Enter a list of available SMTP hosts :'; - -$def = $oldcfg{'smtp_hosts'} || - [ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ]; - -$cfg{'smtp_hosts'} = get_host_list($msg,$def); - -#--------------------------------------------------------------------------- - -$msg = 'Enter a list of available POP3 hosts :'; - -$def = $oldcfg{'pop3_hosts'} || []; - -$cfg{'pop3_hosts'} = get_host_list($msg,$def); - -#--------------------------------------------------------------------------- - -$msg = 'Enter a list of available SNPP hosts :'; - -$def = $oldcfg{'snpp_hosts'} || []; - -$cfg{'snpp_hosts'} = get_host_list($msg,$def); - -#--------------------------------------------------------------------------- - -$msg = 'Enter a list of available PH Hosts :' ; - -$def = $oldcfg{'ph_hosts'} || - [ default_hostname('dirserv') ]; - -$cfg{'ph_hosts'} = get_host_list($msg,$def); - -#--------------------------------------------------------------------------- - -$msg = 'Enter a list of available TIME Hosts :' ; - -$def = $oldcfg{'time_hosts'} || []; - -$cfg{'time_hosts'} = get_host_list($msg,$def); - -#--------------------------------------------------------------------------- - -$msg = 'Enter a list of available DAYTIME Hosts :' ; - -$def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'}; - -$cfg{'daytime_hosts'} = get_host_list($msg,$def); - -#--------------------------------------------------------------------------- - -$msg = < external user & password -fwuser/fwpass => firewall user & password - -0) None -1) ----------------------- - USER user@remote.host - PASS pass -2) ----------------------- - USER fwuser - PASS fwpass - USER user@remote.host - PASS pass -3) ----------------------- - USER fwuser - PASS fwpass - SITE remote.site - USER user - PASS pass -4) ----------------------- - USER fwuser - PASS fwpass - OPEN remote.site - USER user - PASS pass -5) ----------------------- - USER user@fwuser@remote.site - PASS pass@fwpass -6) ----------------------- - USER fwuser@remote.site - PASS fwpass - USER user - PASS pass -7) ----------------------- - USER user@remote.host - PASS pass - AUTH fwuser - RESP fwpass - -Choice: -EDQ - $def = exists $oldcfg{'ftp_firewall_type'} ? $oldcfg{'ftp_firewall_type'} : 1; - $ans = Prompt($msg,$def); - $cfg{'ftp_firewall_type'} = 0+$ans; - $def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL}; - - $cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def); -} -else { - delete $cfg{'ftp_firewall'}; -} - - -#--------------------------------------------------------------------------- - -if (defined $cfg{'ftp_firewall'}) - { - print <new($libnet_cfg_out, "w") or - die "Cannot create '$libnet_cfg_out': $!"; - -print "Writing $libnet_cfg_out\n"; - -print $fh "{\n"; - -my $key; -foreach $key (keys %cfg) { - my $val = $cfg{$key}; - if(!defined($val)) { - $val = "undef"; - } - elsif(ref($val)) { - $val = '[' . join(",", - map { - my $v = "undef"; - if(defined $_) { - ($v = $_) =~ s/'/\'/sog; - $v = "'" . $v . "'"; - } - $v; - } @$val ) . ']'; - } - else { - $val =~ s/'/\'/sog; - $val = "'" . $val . "'" if $val =~ /\D/; - } - print $fh "\t'",$key,"' => ",$val,",\n"; -} - -print $fh "}\n"; - -$fh->close; - -############################################################################ -############################################################################ - -exit 0; diff --git a/bin/perl b/bin/perl deleted file mode 100755 index ae212f38..00000000 Binary files a/bin/perl and /dev/null differ diff --git a/bin/perl5.26.2 b/bin/perl5.26.2 deleted file mode 100755 index ae212f38..00000000 Binary files a/bin/perl5.26.2 and /dev/null differ diff --git a/bin/perlbug b/bin/perlbug deleted file mode 100755 index c8f99863..00000000 --- a/bin/perlbug +++ /dev/null @@ -1,1533 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; - -my $config_tag1 = '5.26.2 - Wed Jan 19 08:19:35 UTC 2022'; - -my $patchlevel_date = 1521920647; -my @patches = Config::local_patches(); -my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches; - -BEGIN { pop @INC if $INC[-1] eq '.' } -use warnings; -use strict; -use Config; -use File::Spec; # keep perlbug Perl 5.005 compatible -use Getopt::Std; -use File::Basename 'basename'; - -sub paraprint; - -BEGIN { - eval { require Mail::Send;}; - $::HaveSend = ($@ eq ""); - eval { require Mail::Util; } ; - $::HaveUtil = ($@ eq ""); - # use secure tempfiles wherever possible - eval { require File::Temp; }; - $::HaveTemp = ($@ eq ""); - eval { require Module::CoreList; }; - $::HaveCoreList = ($@ eq ""); - eval { require Text::Wrap; }; - $::HaveWrap = ($@ eq ""); -}; - -my $Version = "1.40"; - -#TODO: -# make sure failure (transmission-wise) of Mail::Send is accounted for. -# (This may work now. Unsure of the original author's issue -JESSE 2008-06-08) -# - Test -b option - -my( $file, $usefile, $cc, $address, $bugaddress, $testaddress, $thanksaddress, - $filename, $messageid, $domain, $subject, $from, $verbose, $ed, $outfile, - $fh, $me, $body, $andcc, %REP, $ok, $thanks, $progname, - $Is_MSWin32, $Is_Linux, $Is_VMS, $Is_OpenBSD, - $report_about_module, $category, $severity, - %opt, $have_attachment, $attachments, $has_patch, $mime_boundary -); - -my $running_noninteractively = !-t STDIN; - -my $perl_version = $^V ? sprintf("%vd", $^V) : $]; - -my $config_tag2 = "$perl_version - $Config{cf_time}"; - -Init(); - -if ($opt{h}) { Help(); exit; } -if ($opt{d}) { Dump(*STDOUT); exit; } -if ($running_noninteractively && !$opt{t} && !($ok and not $opt{n})) { - paraprint <<"EOF"; -Please use $progname interactively. If you want to -include a file, you can use the -f switch. -EOF - die "\n"; -} - -Query(); -Edit() unless $usefile || ($ok and not $opt{n}); -NowWhat(); -if ($outfile) { - save_message_to_disk($outfile); -} else { - Send(); - if ($thanks) { - print "\nThank you for taking the time to send a thank-you message!\n\n"; - - paraprint < { - 'default' => 'core', - 'ok' => 'install', - # Inevitably some of these will end up in RT whatever we do: - 'thanks' => 'thanks', - 'opts' => [qw(core docs install library utilities)], # patch, notabug - }, - 'severity' => { - 'default' => 'low', - 'ok' => 'none', - 'thanks' => 'none', - 'opts' => [qw(critical high medium low wishlist none)], # zero - }, - ); - die "Invalid alternative ($name) requested\n" unless grep(/^$name$/, keys %alts); - my $alt = ""; - my $what = $ok || $thanks; - if ($what) { - $alt = $alts{$name}{$what}; - } else { - my @alts = @{$alts{$name}{'opts'}}; - print "\n\n"; - paraprint < 5) { - die "Invalid $name: aborting.\n"; - } - $alt = _prompt('', "\u$name", $alts{$name}{'default'}); - $alt ||= $alts{$name}{'default'}; - } while !((($alt) = grep(/^$alt/i, @alts))); - } - lc $alt; -} - -sub Init { - # -------- Setup -------- - - $Is_MSWin32 = $^O eq 'MSWin32'; - $Is_VMS = $^O eq 'VMS'; - $Is_Linux = lc($^O) eq 'linux'; - $Is_OpenBSD = lc($^O) eq 'openbsd'; - - if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:T:p:", \%opt)) { Help(); exit; }; - - # This comment is needed to notify metaconfig that we are - # using the $perladmin, $cf_by, and $cf_time definitions. - - # -------- Configuration --------- - - # perlbug address - $bugaddress = 'perlbug@perl.org'; - - # Test address - $testaddress = 'perlbug-test@perl.org'; - - # Thanks address - $thanksaddress = 'perl-thanks@perl.org'; - - if (basename ($0) =~ /^perlthanks/i) { - # invoked as perlthanks - $opt{T} = 1; - $opt{C} = 1; # don't send a copy to the local admin - } - - if ($opt{T}) { - $thanks = 'thanks'; - } - - $progname = $thanks ? 'perlthanks' : 'perlbug'; - # Target address - $address = $opt{a} || ($opt{t} ? $testaddress - : $thanks ? $thanksaddress : $bugaddress); - - # Users address, used in message and in From and Reply-To headers - $from = $opt{r} || ""; - - # Include verbose configuration information - $verbose = $opt{v} || 0; - - # Subject of bug-report message - $subject = $opt{s} || ""; - - # Send a file - $usefile = ($opt{f} || 0); - - # File to send as report - $file = $opt{f} || ""; - - # We have one or more attachments - $have_attachment = ($opt{p} || 0); - $mime_boundary = ('-' x 12) . "$Version.perlbug" if $have_attachment; - - # Comma-separated list of attachments - $attachments = $opt{p} || ""; - $has_patch = 0; # TBD based on file type - - for my $attachment (split /\s*,\s*/, $attachments) { - unless (-f $attachment && -r $attachment) { - die "The attachment $attachment is not a readable file: $!\n"; - } - $has_patch = 1 if $attachment =~ m/\.(patch|diff)$/; - } - - # File to output to - $outfile = $opt{F} || ""; - - # Body of report - $body = $opt{b} || ""; - - # Editor - $ed = $opt{e} || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} - || ($Is_VMS && "edit/tpu") - || ($Is_MSWin32 && "notepad") - || "vi"; - - # Not OK - provide build failure template by finessing OK report - if ($opt{n}) { - if (substr($opt{n}, 0, 2) eq 'ok' ) { - $opt{o} = substr($opt{n}, 1); - } else { - Help(); - exit(); - } - } - - # OK - send "OK" report for build on this system - $ok = ''; - if ($opt{o}) { - if ($opt{o} eq 'k' or $opt{o} eq 'kay') { - my $age = time - $patchlevel_date; - if ($opt{o} eq 'k' and $age > 60 * 24 * 60 * 60 ) { - my $date = localtime $patchlevel_date; - print <<"EOF"; -"perlbug -ok" and "perlbug -nok" do not report on Perl versions which -are more than 60 days old. This Perl version was constructed on -$date. If you really want to report this, use -"perlbug -okay" or "perlbug -nokay". -EOF - exit(); - } - # force these options - unless ($opt{n}) { - $opt{S} = 1; # don't prompt for send - $opt{b} = 1; # we have a body - $body = "Perl reported to build OK on this system.\n"; - } - $opt{C} = 1; # don't send a copy to the local admin - $opt{s} = 1; # we have a subject line - $subject = ($opt{n} ? 'Not ' : '') - . "OK: perl $perl_version ${patch_tags}on" - ." $::Config{'archname'} $::Config{'osvers'} $subject"; - $ok = 'ok'; - } else { - Help(); - exit(); - } - } - - # Possible administrator addresses, in order of confidence - # (Note that cf_email is not mentioned to metaconfig, since - # we don't really want it. We'll just take it if we have to.) - # - # This has to be after the $ok stuff above because of the way - # that $opt{C} is forced. - $cc = $opt{C} ? "" : ( - $opt{c} || $::Config{'perladmin'} - || $::Config{'cf_email'} || $::Config{'cf_by'} - ); - - if ($::HaveUtil) { - $domain = Mail::Util::maildomain(); - } elsif ($Is_MSWin32) { - $domain = $ENV{'USERDOMAIN'}; - } else { - require Sys::Hostname; - $domain = Sys::Hostname::hostname(); - } - - # Message-Id - rjsf - $messageid = "<$::Config{'version'}_${$}_".time."\@$domain>"; - - # My username - $me = $Is_MSWin32 ? $ENV{'USERNAME'} - : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'} - : eval { getpwuid($<) }; # May be missing - - $from = $::Config{'cf_email'} - if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me && - ($me eq $::Config{'cf_by'}); -} # sub Init - -sub Query { - # Explain what perlbug is - unless ($ok) { - if ($thanks) { - paraprint <<'EOF'; -This program provides an easy way to send a thank-you message back to the -authors and maintainers of perl. - -If you wish to submit a bug report, please run it without the -T flag -(or run the program perlbug rather than perlthanks) -EOF - } else { - paraprint <<"EOF"; -This program provides an easy way to create a message reporting a -bug in the core perl distribution (along with tests or patches) -to the volunteers who maintain perl at $address. To send a thank-you -note to $thanksaddress instead of a bug report, please run 'perlthanks'. - -Please do not use $0 to send test messages, test whether perl -works, or to report bugs in perl modules from CPAN. - -Suggestions for how to find help using Perl can be found at -http://perldoc.perl.org/perlcommunity.html -EOF - } - } - - # Prompt for subject of message, if needed - - if ($subject && TrivialSubject($subject)) { - $subject = ''; - } - - unless ($subject) { - print -"First of all, please provide a subject for the message.\n"; - if ( not $thanks) { - paraprint <first_release($entry); - if ($entry and not $first_release) { - paraprint <:raw', $filename) or die "Unable to create report file '$filename': $!\n"; - binmode(REP, ':raw :crlf') if $Is_MSWin32; - - my $reptype = !$ok ? ($thanks ? 'thank-you' : 'bug') - : $opt{n} ? "build failure" : "success"; - - print REP <) { - print REP $_ - } - close(F) or die "Error closing '$file': $!"; - } else { - if ($thanks) { - print REP <<'EOF'; - ------------------------------------------------------------------ -[Please enter your thank-you message here] - - - -[You're welcome to delete anything below this line] ------------------------------------------------------------------ -EOF - } else { - print REP <<'EOF'; - ------------------------------------------------------------------ -[Please describe your issue here] - - - -[Please do not change anything below this line] ------------------------------------------------------------------ -EOF - } - } - Dump(*REP); - close(REP) or die "Error closing report file: $!"; - - # Set up an initial report fingerprint so we can compare it later - _fingerprint_lines_in_report(); - -} # sub Query - -sub Dump { - local(*OUT) = @_; - - # these won't have been set if run with -d - $category ||= 'core'; - $severity ||= 'low'; - - print OUT <etry dit - next; - } elsif ( $action =~ /^[cq]/i ) { # ancel, uit - Cancel(); # cancel exits - } - } - # Ok. the user did what they needed to; - return; - - } -} - - -sub Cancel { - 1 while unlink($filename); # remove all versions under VMS - print "\nQuitting without sending your message.\n"; - exit(0); -} - -sub NowWhat { - # Report is done, prompt for further action - if( !$opt{S} ) { - while(1) { - my $menu = <ile/ve - if ( SaveMessage() ) { exit } - } elsif ($action =~ /^(d|l|sh)/i ) { # isplay, ist, ow - # Display the message - print _read_report($filename); - if ($have_attachment) { - print "\n\n---\nAttachment(s):\n"; - for my $att (split /\s*,\s*/, $attachments) { print " $att\n"; } - } - } elsif ($action =~ /^su/i) { # bject - my $reply = _prompt( "Subject: $subject", "If the above subject is fine, press Enter. Otherwise, type a replacement now\nSubject"); - if ($reply ne '') { - unless (TrivialSubject($reply)) { - $subject = $reply; - print "Subject: $subject\n"; - } - } - } elsif ($action =~ /^se/i) { # end - # Send the message - my $reply = _prompt( "Are you certain you want to send this message?", 'Please type "yes" if you are','no'); - if ($reply =~ /^yes$/) { - last; - } else { - paraprint <dit, e-edit - # edit the message - Edit(); - } elsif ($action =~ /^[qc]/i) { # ancel, uit - Cancel(); - } elsif ($action =~ /^s/i) { - paraprint < 1); - close($fh); - return $filename; - } else { - # Bah. Fall back to doing things less securely. - my $dir = File::Spec->tmpdir(); - $filename = "bugrep0$$"; - $filename++ while -e File::Spec->catfile($dir, $filename); - $filename = File::Spec->catfile($dir, $filename); - } -} - -sub paraprint { - my @paragraphs = split /\n{2,}/, "@_"; - for (@paragraphs) { # implicit local $_ - s/(\S)\s*\n/$1 /g; - write; - print "\n"; - } -} - -sub _prompt { - my ($explanation, $prompt, $default) = (@_); - if ($explanation) { - print "\n\n"; - paraprint $explanation; - } - print $prompt. ($default ? " [$default]" :''). ": "; - my $result = scalar(<>); - return $default if !defined $result; # got eof - chomp($result); - $result =~ s/^\s*(.*?)\s*$/$1/s; - if ($default && $result eq '') { - return $default; - } else { - return $result; - } -} - -sub _build_header { - my %attr = (@_); - - my $head = ''; - for my $header (keys %attr) { - $head .= "$header: ".$attr{$header}."\n"; - } - return $head; -} - -sub _message_headers { - my %headers = ( To => $address, Subject => $subject ); - $headers{'Cc'} = $cc if ($cc); - $headers{'Message-Id'} = $messageid if ($messageid); - $headers{'Reply-To'} = $from if ($from); - $headers{'From'} = $from if ($from); - if ($have_attachment) { - $headers{'MIME-Version'} = '1.0'; - $headers{'Content-Type'} = qq{multipart/mixed; boundary=\"$mime_boundary\"}; - } - return \%headers; -} - -sub _add_body_start { - my $body_start = <<"BODY_START"; -This is a multi-part message in MIME format. ---$mime_boundary -Content-Type: text/plain; format=fixed -Content-Transfer-Encoding: 8bit - -BODY_START - return $body_start; -} - -sub _add_attachments { - my $attach = ''; - for my $attachment (split /\s*,\s*/, $attachments) { - my $attach_file = basename($attachment); - $attach .= <<"ATTACHMENT"; - ---$mime_boundary -Content-Type: text/x-patch; name="$attach_file" -Content-Transfer-Encoding: 8bit -Content-Disposition: attachment; filename="$attach_file" - -ATTACHMENT - - open my $attach_fh, '<:raw', $attachment - or die "Couldn't open attachment '$attachment': $!\n"; - while (<$attach_fh>) { $attach .= $_; } - close($attach_fh) or die "Error closing attachment '$attachment': $!"; - } - - $attach .= "\n--$mime_boundary--\n"; - return $attach; -} - -sub _read_report { - my $fname = shift; - my $content; - open( REP, "<:raw", $fname ) or die "Couldn't open file '$fname': $!\n"; - binmode(REP, ':raw :crlf') if $Is_MSWin32; - # wrap long lines to make sure the report gets delivered - local $Text::Wrap::columns = 900; - local $Text::Wrap::huge = 'overflow'; - while () { - if ($::HaveWrap && /\S/) { # wrap() would remove empty lines - $content .= Text::Wrap::wrap(undef, undef, $_); - } else { - $content .= $_; - } - } - close(REP) or die "Error closing report file '$fname': $!"; - return $content; -} - -sub build_complete_message { - my $content = _build_header(%{_message_headers()}) . "\n\n"; - $content .= _add_body_start() if $have_attachment; - $content .= _read_report($filename); - $content .= _add_attachments() if $have_attachment; - return $content; -} - -sub save_message_to_disk { - my $file = shift; - - open OUTFILE, '>:raw', $file or do { warn "Couldn't open '$file': $!\n"; return undef}; - binmode(OUTFILE, ':raw :crlf') if $Is_MSWin32; - - print OUTFILE build_complete_message(); - close(OUTFILE) or do { warn "Error closing $file: $!"; return undef }; - print "\nMessage saved.\n"; - return 1; -} - -sub _send_message_vms { - - my $mail_from = $from; - my $rcpt_to_to = $address; - my $rcpt_to_cc = $cc; - - map { $_ =~ s/^[^<]*[^>]*//; } ($mail_from, $rcpt_to_to, $rcpt_to_cc); - - if ( open my $sff_fh, '|-:raw', 'MCR TCPIP$SYSTEM:TCPIP$SMTP_SFF.EXE SYS$INPUT:' ) { - print $sff_fh "MAIL FROM:<$mail_from>\n"; - print $sff_fh "RCPT TO:<$rcpt_to_to>\n"; - print $sff_fh "RCPT TO:<$rcpt_to_cc>\n" if $rcpt_to_cc; - print $sff_fh "DATA\n"; - print $sff_fh build_complete_message(); - my $success = close $sff_fh; - if ($success ) { - print "\nMessage sent\n"; - return; - } - } - die "Mail transport failed (leaving bug report in $filename): $^E\n"; -} - -sub _send_message_mailsend { - my $msg = Mail::Send->new(); - my %headers = %{_message_headers()}; - for my $key ( keys %headers) { - $msg->add($key => $headers{$key}); - } - - $fh = $msg->open; - binmode($fh, ':raw'); - print $fh _add_body_start() if $have_attachment; - print $fh _read_report($filename); - print $fh _add_attachments() if $have_attachment; - $fh->close or die "Error sending mail: $!"; - - print "\nMessage sent.\n"; -} - -sub _probe_for_sendmail { - my $sendmail = ""; - for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) { - $sendmail = $_, last if -e $_; - } - if ( $^O eq 'os2' and $sendmail eq "" ) { - my $path = $ENV{PATH}; - $path =~ s:\\:/:; - my @path = split /$Config{'path_sep'}/, $path; - for (@path) { - $sendmail = "$_/sendmail", last if -e "$_/sendmail"; - $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe"; - } - } - return $sendmail; -} - -sub _send_message_sendmail { - my $sendmail = _probe_for_sendmail(); - unless ($sendmail) { - my $message_start = !$Is_Linux && !$Is_OpenBSD ? <<'EOT' : <<'EOT'; -It appears that there is no program which looks like "sendmail" on -your system and that the Mail::Send library from CPAN isn't available. -EOT -It appears that there is no program which looks like "sendmail" on -your system. -EOT - paraprint(<<"EOF"), die "\n"; -$message_start -Because of this, there's no easy way to automatically send your -message. - -A copy of your message has been saved in '$filename' for you to -send to '$address' with your normal mail client. -EOF - } - - open( SENDMAIL, "|-:raw", $sendmail, "-t", "-oi", "-f", $from ) - || die "'|$sendmail -t -oi -f $from' failed: $!"; - print SENDMAIL build_complete_message(); - if ( close(SENDMAIL) ) { - print "\nMessage sent\n"; - } else { - warn "\nSendmail returned status '", $? >> 8, "'\n"; - } -} - - - -# a strange way to check whether any significant editing -# has been done: check whether any new non-empty lines -# have been added. - -sub _fingerprint_lines_in_report { - my $new_lines = 0; - # read in the report template once so that - # we can track whether the user does any editing. - # yes, *all* whitespace is ignored. - - open(REP, '<:raw', $filename) or die "Unable to open report file '$filename': $!\n"; - binmode(REP, ':raw :crlf') if $Is_MSWin32; - while (my $line = ) { - $line =~ s/\s+//g; - $new_lines++ if (!$REP{$line}); - - } - close(REP) or die "Error closing report file '$filename': $!"; - # returns the number of lines with content that wasn't there when last we looked - return $new_lines; -} - - - -format STDOUT = -^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~ -$_ -. - -__END__ - -=head1 NAME - -perlbug - how to submit bug reports on Perl - -=head1 SYNOPSIS - -B - -B S<[ B<-v> ]> S<[ B<-a> I
]> S<[ B<-s> I ]> -S<[ B<-b> I | B<-f> I ]> S<[ B<-F> I ]> -S<[ B<-r> I ]> -S<[ B<-e> I ]> S<[ B<-c> I | B<-C> ]> -S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> S<[ B<-T> ]> - -B S<[ B<-v> ]> S<[ B<-r> I ]> - S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> - -B - -=head1 DESCRIPTION - - -This program is designed to help you generate and send bug reports -(and thank-you notes) about perl5 and the modules which ship with it. - -In most cases, you can just run it interactively from a command -line without any special arguments and follow the prompts. - -If you have found a bug with a non-standard port (one that was not -part of the I), a binary distribution, or a -non-core module (such as Tk, DBI, etc), then please see the -documentation that came with that distribution to determine the -correct place to report bugs. - -If you are unable to send your report using B (most likely -because your system doesn't have a way to send mail that perlbug -recognizes), you may be able to use this tool to compose your report -and save it to a file which you can then send to B -using your regular mail client. - -In extreme cases, B may not work well enough on your system -to guide you through composing a bug report. In those cases, you -may be able to use B to get system configuration -information to include in a manually composed bug report to -B. - - -When reporting a bug, please run through this checklist: - -=over 4 - -=item What version of Perl you are running? - -Type C at the command line to find out. - -=item Are you running the latest released version of perl? - -Look at http://www.perl.org/ to find out. If you are not using the -latest released version, please try to replicate your bug on the -latest stable release. - -Note that reports about bugs in old versions of Perl, especially -those which indicate you haven't also tested the current stable -release of Perl, are likely to receive less attention from the -volunteers who build and maintain Perl than reports about bugs in -the current release. - -This tool isn't appropriate for reporting bugs in any version -prior to Perl 5.0. - -=item Are you sure what you have is a bug? - -A significant number of the bug reports we get turn out to be -documented features in Perl. Make sure the issue you've run into -isn't intentional by glancing through the documentation that comes -with the Perl distribution. - -Given the sheer volume of Perl documentation, this isn't a trivial -undertaking, but if you can point to documentation that suggests -the behaviour you're seeing is I, your issue is likely to -receive more attention. You may want to start with B -L for pointers to common traps that new (and experienced) -Perl programmers run into. - -If you're unsure of the meaning of an error message you've run -across, B L for an explanation. If the message -isn't in perldiag, it probably isn't generated by Perl. You may -have luck consulting your operating system documentation instead. - -If you are on a non-UNIX platform B L, as some -features may be unimplemented or work differently. - -You may be able to figure out what's going wrong using the Perl -debugger. For information about how to use the debugger B -L. - -=item Do you have a proper test case? - -The easier it is to reproduce your bug, the more likely it will be -fixed -- if nobody can duplicate your problem, it probably won't be -addressed. - -A good test case has most of these attributes: short, simple code; -few dependencies on external commands, modules, or libraries; no -platform-dependent code (unless it's a platform-specific bug); -clear, simple documentation. - -A good test case is almost always a good candidate to be included in -Perl's test suite. If you have the time, consider writing your test case so -that it can be easily included into the standard test suite. - -=item Have you included all relevant information? - -Be sure to include the B error messages, if any. -"Perl gave an error" is not an exact error message. - -If you get a core dump (or equivalent), you may use a debugger -(B, B, etc) to produce a stack trace to include in the bug -report. - -NOTE: unless your Perl has been compiled with debug info -(often B<-g>), the stack trace is likely to be somewhat hard to use -because it will most probably contain only the function names and not -their arguments. If possible, recompile your Perl with debug info and -reproduce the crash and the stack trace. - -=item Can you describe the bug in plain English? - -The easier it is to understand a reproducible bug, the more likely -it will be fixed. Any insight you can provide into the problem -will help a great deal. In other words, try to analyze the problem -(to the extent you can) and report your discoveries. - -=item Can you fix the bug yourself? - -If so, that's great news; bug reports with patches are likely to -receive significantly more attention and interest than those without -patches. Please attach your patch to the report using the C<-p> option. -When sending a patch, create it using C if possible, -though a unified diff created with C will do nearly as well. - -Your patch may be returned with requests for changes, or requests for more -detailed explanations about your fix. - -Here are a few hints for creating high-quality patches: - -Make sure the patch is not reversed (the first argument to diff is -typically the original file, the second argument your changed file). -Make sure you test your patch by applying it with C or the -C program before you send it on its way. Try to follow the -same style as the code you are trying to patch. Make sure your patch -really does work (C, if the thing you're patching is covered -by Perl's test suite). - -=item Can you use C to submit the report? - -B will, amongst other things, ensure your report includes -crucial information about your version of perl. If C is -unable to mail your report after you have typed it in, you may have -to compose the message yourself, add the output produced by C and email it to B. If, for some reason, you -cannot run C at all on your system, be sure to include the -entire output produced by running C (note the uppercase V). - -Whether you use C or send the email manually, please make -your Subject line informative. "a bug" is not informative. Neither -is "perl crashes" nor is "HELP!!!". These don't help. A compact -description of what's wrong is fine. - -=item Can you use C to submit a thank-you note? - -Yes, you can do this by either using the C<-T> option, or by invoking -the program as C. Thank-you notes are good. It makes people -smile. - -=back - -Having done your bit, please be prepared to wait, to be told the -bug is in your code, or possibly to get no reply at all. The -volunteers who maintain Perl are busy folks, so if your problem is -an obvious bug in your own code, is difficult to understand or is -a duplicate of an existing report, you may not receive a personal -reply. - -If it is important to you that your bug be fixed, do monitor the -perl5-porters@perl.org mailing list (mailing lists are moderated, your -message may take a while to show up) and the commit logs to development -versions of Perl, and encourage the maintainers with kind words or -offers of frosty beverages. (Please do be kind to the maintainers. -Harassing or flaming them is likely to have the opposite effect of the -one you want.) - -Feel free to update the ticket about your bug on http://rt.perl.org -if a new version of Perl is released and your bug is still present. - -=head1 OPTIONS - -=over 8 - -=item B<-a> - -Address to send the report to. Defaults to B. - -=item B<-A> - -Don't send a bug received acknowledgement to the reply address. -Generally it is only a sensible to use this option if you are a -perl maintainer actively watching perl porters for your message to -arrive. - -=item B<-b> - -Body of the report. If not included on the command line, or -in a file with B<-f>, you will get a chance to edit the message. - -=item B<-C> - -Don't send copy to administrator. - -=item B<-c> - -Address to send copy of report to. Defaults to the address of the -local perl administrator (recorded when perl was built). - -=item B<-d> - -Data mode (the default if you redirect or pipe output). This prints out -your configuration data, without mailing anything. You can use this -with B<-v> to get more complete data. - -=item B<-e> - -Editor to use. - -=item B<-f> - -File containing the body of the report. Use this to quickly send a -prepared message. - -=item B<-F> - -File to output the results to instead of sending as an email. Useful -particularly when running perlbug on a machine with no direct internet -connection. - -=item B<-h> - -Prints a brief summary of the options. - -=item B<-ok> - -Report successful build on this system to perl porters. Forces B<-S> -and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only -prompts for a return address if it cannot guess it (for use with -B). Honors return address specified with B<-r>. You can use this -with B<-v> to get more complete data. Only makes a report if this -system is less than 60 days old. - -=item B<-okay> - -As B<-ok> except it will report on older systems. - -=item B<-nok> - -Report unsuccessful build on this system. Forces B<-C>. Forces and -supplies a value for B<-s>, then requires you to edit the report -and say what went wrong. Alternatively, a prepared report may be -supplied using B<-f>. Only prompts for a return address if it -cannot guess it (for use with B). Honors return address -specified with B<-r>. You can use this with B<-v> to get more -complete data. Only makes a report if this system is less than 60 -days old. - -=item B<-nokay> - -As B<-nok> except it will report on older systems. - -=item B<-p> - -The names of one or more patch files or other text attachments to be -included with the report. Multiple files must be separated with commas. - -=item B<-r> - -Your return address. The program will ask you to confirm its default -if you don't use this option. - -=item B<-S> - -Send without asking for confirmation. - -=item B<-s> - -Subject to include with the message. You will be prompted if you don't -supply one on the command line. - -=item B<-t> - -Test mode. The target address defaults to B. -Also makes it possible to command perlbug from a pipe or file, for -testing purposes. - -=item B<-T> - -Send a thank-you note instead of a bug report. - -=item B<-v> - -Include verbose configuration data in the report. - -=back - -=head1 AUTHORS - -Kenneth Albanowski (Ekjahds@kjahds.comE), subsequently -Itored by Gurusamy Sarathy (Egsar@activestate.comE), -Tom Christiansen (Etchrist@perl.comE), Nathan Torkington -(Egnat@frii.comE), Charles F. Randall (Ecfr@pobox.comE), -Mike Guy (Emjtg@cam.ac.ukE), Dominic Dunlop -(Edomo@computer.orgE), Hugo van der Sanden (Ehv@crypt.orgE), -Jarkko Hietaniemi (Ejhi@iki.fiE), Chris Nandor -(Epudge@pobox.comE), Jon Orwant (Eorwant@media.mit.eduE, -Richard Foley (Erichard.foley@rfi.netE), Jesse Vincent -(Ejesse@bestpractical.comE), and Craig A. Berry (Ecraigberry@mac.comE). - -=head1 SEE ALSO - -perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1), -diff(1), patch(1), dbx(1), gdb(1) - -=head1 BUGS - -None known (guess what must have been used to report them?) - -=cut - diff --git a/bin/perldoc b/bin/perldoc deleted file mode 100755 index 3aed3b45..00000000 --- a/bin/perldoc +++ /dev/null @@ -1,14 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if 0; - -# This "perldoc" file was generated by "perldoc.PL" - -require 5; -BEGIN { - $^W = 1 if $ENV{'PERLDOCDEBUG'}; - pop @INC if $INC[-1] eq '.'; -} -use Pod::Perldoc; -exit( Pod::Perldoc->run() ); - diff --git a/bin/perlivp b/bin/perlivp deleted file mode 100755 index c218e2e3..00000000 --- a/bin/perlivp +++ /dev/null @@ -1,392 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; - -# perlivp v5.26.2 - -BEGIN { pop @INC if $INC[-1] eq '.' } - -sub usage { - warn "@_\n" if @_; - print << " EOUSAGE"; -Usage: - - $0 [-p] [-v] | [-h] - - -p Print a preface before each test telling what it will test. - -v Verbose mode in which extra information about test results - is printed. Test failures always print out some extra information - regardless of whether or not this switch is set. - -h Prints this help message. - EOUSAGE - exit; -} - -use vars qw(%opt); # allow testing with older versions (do not use our) - -@opt{ qw/? H h P p V v/ } = qw(0 0 0 0 0 0 0); - -while ($ARGV[0] =~ /^-/) { - $ARGV[0] =~ s/^-//; - for my $flag (split(//,$ARGV[0])) { - usage() if '?' =~ /\Q$flag/; - usage() if 'h' =~ /\Q$flag/; - usage() if 'H' =~ /\Q$flag/; - usage("unknown flag: '$flag'") unless 'HhPpVv' =~ /\Q$flag/; - warn "$0: '$flag' flag already set\n" if $opt{$flag}++; - } - shift; -} - -$opt{p}++ if $opt{P}; -$opt{v}++ if $opt{V}; - -my $pass__total = 0; -my $error_total = 0; -my $tests_total = 0; - -my $perlpath = '/home/git/binary-com/perl/bin/perl'; -my $useithreads = ''; - -print "## Checking Perl binary via variable '\$perlpath' = $perlpath.\n" if $opt{'p'}; - -my $label = 'Executable perl binary'; - -if (-x $perlpath) { - print "## Perl binary '$perlpath' appears executable.\n" if $opt{'v'}; - print "ok 1 $label\n"; - $pass__total++; -} -else { - print "# Perl binary '$perlpath' does not appear executable.\n"; - print "not ok 1 $label\n"; - $error_total++; -} -$tests_total++; - - -print "## Checking Perl version via variable '\$]'.\n" if $opt{'p'}; - -my $ivp_VERSION = "5.026002"; - - -$label = 'Perl version correct'; -if ($ivp_VERSION eq $]) { - print "## Perl version '$]' appears installed as expected.\n" if $opt{'v'}; - print "ok 2 $label\n"; - $pass__total++; -} -else { - print "# Perl version '$]' installed, expected $ivp_VERSION.\n"; - print "not ok 2 $label\n"; - $error_total++; -} -$tests_total++; - -# We have the right perl and version, so now reset @INC so we ignore -# PERL5LIB and '.' -{ - local $ENV{PERL5LIB}; - my $perl_V = qx($perlpath -V); - $perl_V =~ s{.*\@INC:\n}{}ms; - @INC = grep { length && $_ ne '.' } split ' ', $perl_V; -} - -print "## Checking roots of the Perl library directory tree via variable '\@INC'.\n" if $opt{'p'}; - -my $INC_total = 0; -my $INC_there = 0; -foreach (@INC) { - next if $_ eq '.'; # skip -d test here - if (-d $_) { - print "## Perl \@INC directory '$_' exists.\n" if $opt{'v'}; - $INC_there++; - } - else { - print "# Perl \@INC directory '$_' does not appear to exist.\n"; - } - $INC_total++; -} - -$label = '@INC directoreis exist'; -if ($INC_total == $INC_there) { - print "ok 3 $label\n"; - $pass__total++; -} -else { - print "not ok 3 $label\n"; - $error_total++; -} -$tests_total++; - - -print "## Checking installations of modules necessary for ivp.\n" if $opt{'p'}; - -my $needed_total = 0; -my $needed_there = 0; -foreach (qw(Config.pm ExtUtils/Installed.pm)) { - $@ = undef; - $needed_total++; - eval "require \"$_\";"; - if (!$@) { - print "## Module '$_' appears to be installed.\n" if $opt{'v'}; - $needed_there++; - } - else { - print "# Needed module '$_' does not appear to be properly installed.\n"; - } - $@ = undef; -} -$label = 'Modules needed for rest of perlivp exist'; -if ($needed_total == $needed_there) { - print "ok 4 $label\n"; - $pass__total++; -} -else { - print "not ok 4 $label\n"; - $error_total++; -} -$tests_total++; - - -print "## Checking installations of extensions built with perl.\n" if $opt{'p'}; - -use Config; - -my $extensions_total = 0; -my $extensions_there = 0; -if (defined($Config{'extensions'})) { - my @extensions = split(/\s+/,$Config{'extensions'}); - foreach (@extensions) { - next if ($_ eq ''); - if ( $useithreads !~ /define/i ) { - next if ($_ eq 'threads'); - next if ($_ eq 'threads/shared'); - } - # that's a distribution name, not a module name - next if $_ eq 'IO/Compress'; - next if $_ eq 'Devel/DProf'; - next if $_ eq 'libnet'; - next if $_ eq 'Locale/Codes'; - next if $_ eq 'podlators'; - next if $_ eq 'perlfaq'; - # test modules - next if $_ eq 'XS/APItest'; - next if $_ eq 'XS/Typemap'; - # VMS$ perl -e "eval ""require \""Devel/DProf.pm\"";"" print $@" - # \NT> perl -e "eval \"require './Devel/DProf.pm'\"; print $@" - # DProf: run perl with -d to use DProf. - # Compilation failed in require at (eval 1) line 1. - eval " require \"$_.pm\"; "; - if (!$@) { - print "## Module '$_' appears to be installed.\n" if $opt{'v'}; - $extensions_there++; - } - else { - print "# Required module '$_' does not appear to be properly installed.\n"; - $@ = undef; - } - $extensions_total++; - } - - # A silly name for a module (that hopefully won't ever exist). - # Note that this test serves more as a check of the validity of the - # actual required module tests above. - my $unnecessary = 'bLuRfle'; - - if (!grep(/$unnecessary/, @extensions)) { - $@ = undef; - eval " require \"$unnecessary.pm\"; "; - if ($@) { - print "## Unnecessary module '$unnecessary' does not appear to be installed.\n" if $opt{'v'}; - } - else { - print "# Unnecessary module '$unnecessary' appears to be installed.\n"; - $extensions_there++; - } - } - $@ = undef; -} -$label = 'All (and only) expected extensions installed'; -if ($extensions_total == $extensions_there) { - print "ok 5 $label\n"; - $pass__total++; -} -else { - print "not ok 5 $label\n"; - $error_total++; -} -$tests_total++; - - -print "## Checking installations of later additional extensions.\n" if $opt{'p'}; - -use ExtUtils::Installed; - -my $installed_total = 0; -my $installed_there = 0; -my $version_check = 0; -my $installed = ExtUtils::Installed -> new(); -my @modules = $installed -> modules(); -my @missing = (); -my $version = undef; -for (@modules) { - $installed_total++; - # Consider it there if it contains one or more files, - # and has zero missing files, - # and has a defined version - $version = undef; - $version = $installed -> version($_); - if ($version) { - print "## $_; $version\n" if $opt{'v'}; - $version_check++; - } - else { - print "# $_; NO VERSION\n" if $opt{'v'}; - } - $version = undef; - @missing = (); - @missing = $installed -> validate($_); - - # .bs files are optional - @missing = grep { ! /\.bs$/ } @missing; - # man files are often compressed - @missing = grep { ! ( -s "$_.gz" || -s "$_.bz2" ) } @missing; - - if ($#missing >= 0) { - print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n"; - print '# ',join(' ',@missing),"\n"; - } - elsif ($#missing == -1) { - $installed_there++; - } - @missing = (); -} -$label = 'Module files correctly installed'; -if (($installed_total == $installed_there) && - ($installed_total == $version_check)) { - print "ok 6 $label\n"; - $pass__total++; -} -else { - print "not ok 6 $label\n"; - $error_total++; -} -$tests_total++; - -# Final report (rather than feed ousrselves to Test::Harness::runtests() -# we simply format some output on our own to keep things simple and -# easier to "fix" - at least for now. - -if ($error_total == 0 && $tests_total) { - print "All tests successful.\n"; -} elsif ($tests_total==0){ - die "FAILED--no tests were run for some reason.\n"; -} else { - my $rate = 0.0; - if ($tests_total > 0) { $rate = sprintf "%.2f", 100.0 * ($pass__total / $tests_total); } - printf " %d/%d subtests failed, %.2f%% okay.\n", - $error_total, $tests_total, $rate; -} - -=head1 NAME - -perlivp - Perl Installation Verification Procedure - -=head1 SYNOPSIS - -B [B<-p>] [B<-v>] [B<-h>] - -=head1 DESCRIPTION - -The B program is set up at Perl source code build time to test the -Perl version it was built under. It can be used after running: - - make install - -(or your platform's equivalent procedure) to verify that B and its -libraries have been installed correctly. A correct installation is verified -by output that looks like: - - ok 1 - ok 2 - -etc. - -=head1 OPTIONS - -=over 5 - -=item B<-h> help - -Prints out a brief help message. - -=item B<-p> print preface - -Gives a description of each test prior to performing it. - -=item B<-v> verbose - -Gives more detailed information about each test, after it has been performed. -Note that any failed tests ought to print out some extra information whether -or not -v is thrown. - -=back - -=head1 DIAGNOSTICS - -=over 4 - -=item * print "# Perl binary '$perlpath' does not appear executable.\n"; - -Likely to occur for a perl binary that was not properly installed. -Correct by conducting a proper installation. - -=item * print "# Perl version '$]' installed, expected $ivp_VERSION.\n"; - -Likely to occur for a perl that was not properly installed. -Correct by conducting a proper installation. - -=item * print "# Perl \@INC directory '$_' does not appear to exist.\n"; - -Likely to occur for a perl library tree that was not properly installed. -Correct by conducting a proper installation. - -=item * print "# Needed module '$_' does not appear to be properly installed.\n"; - -One of the two modules that is used by perlivp was not present in the -installation. This is a serious error since it adversely affects perlivp's -ability to function. You may be able to correct this by performing a -proper perl installation. - -=item * print "# Required module '$_' does not appear to be properly installed.\n"; - -An attempt to C failed, even though the list of -extensions indicated that it should succeed. Correct by conducting a proper -installation. - -=item * print "# Unnecessary module 'bLuRfle' appears to be installed.\n"; - -This test not coming out ok could indicate that you have in fact installed -a bLuRfle.pm module or that the C -test may give misleading results with your installation of perl. If yours -is the latter case then please let the author know. - -=item * print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n"; - -One or more files turned up missing according to a run of -C validate()> over your installation. -Correct by conducting a proper installation. - -=back - -For further information on how to conduct a proper installation consult the -INSTALL file that comes with the perl source and the README file for your -platform. - -=head1 AUTHOR - -Peter Prymmer - -=cut - diff --git a/bin/perlthanks b/bin/perlthanks deleted file mode 100755 index c8f99863..00000000 --- a/bin/perlthanks +++ /dev/null @@ -1,1533 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; - -my $config_tag1 = '5.26.2 - Wed Jan 19 08:19:35 UTC 2022'; - -my $patchlevel_date = 1521920647; -my @patches = Config::local_patches(); -my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches; - -BEGIN { pop @INC if $INC[-1] eq '.' } -use warnings; -use strict; -use Config; -use File::Spec; # keep perlbug Perl 5.005 compatible -use Getopt::Std; -use File::Basename 'basename'; - -sub paraprint; - -BEGIN { - eval { require Mail::Send;}; - $::HaveSend = ($@ eq ""); - eval { require Mail::Util; } ; - $::HaveUtil = ($@ eq ""); - # use secure tempfiles wherever possible - eval { require File::Temp; }; - $::HaveTemp = ($@ eq ""); - eval { require Module::CoreList; }; - $::HaveCoreList = ($@ eq ""); - eval { require Text::Wrap; }; - $::HaveWrap = ($@ eq ""); -}; - -my $Version = "1.40"; - -#TODO: -# make sure failure (transmission-wise) of Mail::Send is accounted for. -# (This may work now. Unsure of the original author's issue -JESSE 2008-06-08) -# - Test -b option - -my( $file, $usefile, $cc, $address, $bugaddress, $testaddress, $thanksaddress, - $filename, $messageid, $domain, $subject, $from, $verbose, $ed, $outfile, - $fh, $me, $body, $andcc, %REP, $ok, $thanks, $progname, - $Is_MSWin32, $Is_Linux, $Is_VMS, $Is_OpenBSD, - $report_about_module, $category, $severity, - %opt, $have_attachment, $attachments, $has_patch, $mime_boundary -); - -my $running_noninteractively = !-t STDIN; - -my $perl_version = $^V ? sprintf("%vd", $^V) : $]; - -my $config_tag2 = "$perl_version - $Config{cf_time}"; - -Init(); - -if ($opt{h}) { Help(); exit; } -if ($opt{d}) { Dump(*STDOUT); exit; } -if ($running_noninteractively && !$opt{t} && !($ok and not $opt{n})) { - paraprint <<"EOF"; -Please use $progname interactively. If you want to -include a file, you can use the -f switch. -EOF - die "\n"; -} - -Query(); -Edit() unless $usefile || ($ok and not $opt{n}); -NowWhat(); -if ($outfile) { - save_message_to_disk($outfile); -} else { - Send(); - if ($thanks) { - print "\nThank you for taking the time to send a thank-you message!\n\n"; - - paraprint < { - 'default' => 'core', - 'ok' => 'install', - # Inevitably some of these will end up in RT whatever we do: - 'thanks' => 'thanks', - 'opts' => [qw(core docs install library utilities)], # patch, notabug - }, - 'severity' => { - 'default' => 'low', - 'ok' => 'none', - 'thanks' => 'none', - 'opts' => [qw(critical high medium low wishlist none)], # zero - }, - ); - die "Invalid alternative ($name) requested\n" unless grep(/^$name$/, keys %alts); - my $alt = ""; - my $what = $ok || $thanks; - if ($what) { - $alt = $alts{$name}{$what}; - } else { - my @alts = @{$alts{$name}{'opts'}}; - print "\n\n"; - paraprint < 5) { - die "Invalid $name: aborting.\n"; - } - $alt = _prompt('', "\u$name", $alts{$name}{'default'}); - $alt ||= $alts{$name}{'default'}; - } while !((($alt) = grep(/^$alt/i, @alts))); - } - lc $alt; -} - -sub Init { - # -------- Setup -------- - - $Is_MSWin32 = $^O eq 'MSWin32'; - $Is_VMS = $^O eq 'VMS'; - $Is_Linux = lc($^O) eq 'linux'; - $Is_OpenBSD = lc($^O) eq 'openbsd'; - - if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:T:p:", \%opt)) { Help(); exit; }; - - # This comment is needed to notify metaconfig that we are - # using the $perladmin, $cf_by, and $cf_time definitions. - - # -------- Configuration --------- - - # perlbug address - $bugaddress = 'perlbug@perl.org'; - - # Test address - $testaddress = 'perlbug-test@perl.org'; - - # Thanks address - $thanksaddress = 'perl-thanks@perl.org'; - - if (basename ($0) =~ /^perlthanks/i) { - # invoked as perlthanks - $opt{T} = 1; - $opt{C} = 1; # don't send a copy to the local admin - } - - if ($opt{T}) { - $thanks = 'thanks'; - } - - $progname = $thanks ? 'perlthanks' : 'perlbug'; - # Target address - $address = $opt{a} || ($opt{t} ? $testaddress - : $thanks ? $thanksaddress : $bugaddress); - - # Users address, used in message and in From and Reply-To headers - $from = $opt{r} || ""; - - # Include verbose configuration information - $verbose = $opt{v} || 0; - - # Subject of bug-report message - $subject = $opt{s} || ""; - - # Send a file - $usefile = ($opt{f} || 0); - - # File to send as report - $file = $opt{f} || ""; - - # We have one or more attachments - $have_attachment = ($opt{p} || 0); - $mime_boundary = ('-' x 12) . "$Version.perlbug" if $have_attachment; - - # Comma-separated list of attachments - $attachments = $opt{p} || ""; - $has_patch = 0; # TBD based on file type - - for my $attachment (split /\s*,\s*/, $attachments) { - unless (-f $attachment && -r $attachment) { - die "The attachment $attachment is not a readable file: $!\n"; - } - $has_patch = 1 if $attachment =~ m/\.(patch|diff)$/; - } - - # File to output to - $outfile = $opt{F} || ""; - - # Body of report - $body = $opt{b} || ""; - - # Editor - $ed = $opt{e} || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} - || ($Is_VMS && "edit/tpu") - || ($Is_MSWin32 && "notepad") - || "vi"; - - # Not OK - provide build failure template by finessing OK report - if ($opt{n}) { - if (substr($opt{n}, 0, 2) eq 'ok' ) { - $opt{o} = substr($opt{n}, 1); - } else { - Help(); - exit(); - } - } - - # OK - send "OK" report for build on this system - $ok = ''; - if ($opt{o}) { - if ($opt{o} eq 'k' or $opt{o} eq 'kay') { - my $age = time - $patchlevel_date; - if ($opt{o} eq 'k' and $age > 60 * 24 * 60 * 60 ) { - my $date = localtime $patchlevel_date; - print <<"EOF"; -"perlbug -ok" and "perlbug -nok" do not report on Perl versions which -are more than 60 days old. This Perl version was constructed on -$date. If you really want to report this, use -"perlbug -okay" or "perlbug -nokay". -EOF - exit(); - } - # force these options - unless ($opt{n}) { - $opt{S} = 1; # don't prompt for send - $opt{b} = 1; # we have a body - $body = "Perl reported to build OK on this system.\n"; - } - $opt{C} = 1; # don't send a copy to the local admin - $opt{s} = 1; # we have a subject line - $subject = ($opt{n} ? 'Not ' : '') - . "OK: perl $perl_version ${patch_tags}on" - ." $::Config{'archname'} $::Config{'osvers'} $subject"; - $ok = 'ok'; - } else { - Help(); - exit(); - } - } - - # Possible administrator addresses, in order of confidence - # (Note that cf_email is not mentioned to metaconfig, since - # we don't really want it. We'll just take it if we have to.) - # - # This has to be after the $ok stuff above because of the way - # that $opt{C} is forced. - $cc = $opt{C} ? "" : ( - $opt{c} || $::Config{'perladmin'} - || $::Config{'cf_email'} || $::Config{'cf_by'} - ); - - if ($::HaveUtil) { - $domain = Mail::Util::maildomain(); - } elsif ($Is_MSWin32) { - $domain = $ENV{'USERDOMAIN'}; - } else { - require Sys::Hostname; - $domain = Sys::Hostname::hostname(); - } - - # Message-Id - rjsf - $messageid = "<$::Config{'version'}_${$}_".time."\@$domain>"; - - # My username - $me = $Is_MSWin32 ? $ENV{'USERNAME'} - : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'} - : eval { getpwuid($<) }; # May be missing - - $from = $::Config{'cf_email'} - if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me && - ($me eq $::Config{'cf_by'}); -} # sub Init - -sub Query { - # Explain what perlbug is - unless ($ok) { - if ($thanks) { - paraprint <<'EOF'; -This program provides an easy way to send a thank-you message back to the -authors and maintainers of perl. - -If you wish to submit a bug report, please run it without the -T flag -(or run the program perlbug rather than perlthanks) -EOF - } else { - paraprint <<"EOF"; -This program provides an easy way to create a message reporting a -bug in the core perl distribution (along with tests or patches) -to the volunteers who maintain perl at $address. To send a thank-you -note to $thanksaddress instead of a bug report, please run 'perlthanks'. - -Please do not use $0 to send test messages, test whether perl -works, or to report bugs in perl modules from CPAN. - -Suggestions for how to find help using Perl can be found at -http://perldoc.perl.org/perlcommunity.html -EOF - } - } - - # Prompt for subject of message, if needed - - if ($subject && TrivialSubject($subject)) { - $subject = ''; - } - - unless ($subject) { - print -"First of all, please provide a subject for the message.\n"; - if ( not $thanks) { - paraprint <first_release($entry); - if ($entry and not $first_release) { - paraprint <:raw', $filename) or die "Unable to create report file '$filename': $!\n"; - binmode(REP, ':raw :crlf') if $Is_MSWin32; - - my $reptype = !$ok ? ($thanks ? 'thank-you' : 'bug') - : $opt{n} ? "build failure" : "success"; - - print REP <) { - print REP $_ - } - close(F) or die "Error closing '$file': $!"; - } else { - if ($thanks) { - print REP <<'EOF'; - ------------------------------------------------------------------ -[Please enter your thank-you message here] - - - -[You're welcome to delete anything below this line] ------------------------------------------------------------------ -EOF - } else { - print REP <<'EOF'; - ------------------------------------------------------------------ -[Please describe your issue here] - - - -[Please do not change anything below this line] ------------------------------------------------------------------ -EOF - } - } - Dump(*REP); - close(REP) or die "Error closing report file: $!"; - - # Set up an initial report fingerprint so we can compare it later - _fingerprint_lines_in_report(); - -} # sub Query - -sub Dump { - local(*OUT) = @_; - - # these won't have been set if run with -d - $category ||= 'core'; - $severity ||= 'low'; - - print OUT <etry dit - next; - } elsif ( $action =~ /^[cq]/i ) { # ancel, uit - Cancel(); # cancel exits - } - } - # Ok. the user did what they needed to; - return; - - } -} - - -sub Cancel { - 1 while unlink($filename); # remove all versions under VMS - print "\nQuitting without sending your message.\n"; - exit(0); -} - -sub NowWhat { - # Report is done, prompt for further action - if( !$opt{S} ) { - while(1) { - my $menu = <ile/ve - if ( SaveMessage() ) { exit } - } elsif ($action =~ /^(d|l|sh)/i ) { # isplay, ist, ow - # Display the message - print _read_report($filename); - if ($have_attachment) { - print "\n\n---\nAttachment(s):\n"; - for my $att (split /\s*,\s*/, $attachments) { print " $att\n"; } - } - } elsif ($action =~ /^su/i) { # bject - my $reply = _prompt( "Subject: $subject", "If the above subject is fine, press Enter. Otherwise, type a replacement now\nSubject"); - if ($reply ne '') { - unless (TrivialSubject($reply)) { - $subject = $reply; - print "Subject: $subject\n"; - } - } - } elsif ($action =~ /^se/i) { # end - # Send the message - my $reply = _prompt( "Are you certain you want to send this message?", 'Please type "yes" if you are','no'); - if ($reply =~ /^yes$/) { - last; - } else { - paraprint <dit, e-edit - # edit the message - Edit(); - } elsif ($action =~ /^[qc]/i) { # ancel, uit - Cancel(); - } elsif ($action =~ /^s/i) { - paraprint < 1); - close($fh); - return $filename; - } else { - # Bah. Fall back to doing things less securely. - my $dir = File::Spec->tmpdir(); - $filename = "bugrep0$$"; - $filename++ while -e File::Spec->catfile($dir, $filename); - $filename = File::Spec->catfile($dir, $filename); - } -} - -sub paraprint { - my @paragraphs = split /\n{2,}/, "@_"; - for (@paragraphs) { # implicit local $_ - s/(\S)\s*\n/$1 /g; - write; - print "\n"; - } -} - -sub _prompt { - my ($explanation, $prompt, $default) = (@_); - if ($explanation) { - print "\n\n"; - paraprint $explanation; - } - print $prompt. ($default ? " [$default]" :''). ": "; - my $result = scalar(<>); - return $default if !defined $result; # got eof - chomp($result); - $result =~ s/^\s*(.*?)\s*$/$1/s; - if ($default && $result eq '') { - return $default; - } else { - return $result; - } -} - -sub _build_header { - my %attr = (@_); - - my $head = ''; - for my $header (keys %attr) { - $head .= "$header: ".$attr{$header}."\n"; - } - return $head; -} - -sub _message_headers { - my %headers = ( To => $address, Subject => $subject ); - $headers{'Cc'} = $cc if ($cc); - $headers{'Message-Id'} = $messageid if ($messageid); - $headers{'Reply-To'} = $from if ($from); - $headers{'From'} = $from if ($from); - if ($have_attachment) { - $headers{'MIME-Version'} = '1.0'; - $headers{'Content-Type'} = qq{multipart/mixed; boundary=\"$mime_boundary\"}; - } - return \%headers; -} - -sub _add_body_start { - my $body_start = <<"BODY_START"; -This is a multi-part message in MIME format. ---$mime_boundary -Content-Type: text/plain; format=fixed -Content-Transfer-Encoding: 8bit - -BODY_START - return $body_start; -} - -sub _add_attachments { - my $attach = ''; - for my $attachment (split /\s*,\s*/, $attachments) { - my $attach_file = basename($attachment); - $attach .= <<"ATTACHMENT"; - ---$mime_boundary -Content-Type: text/x-patch; name="$attach_file" -Content-Transfer-Encoding: 8bit -Content-Disposition: attachment; filename="$attach_file" - -ATTACHMENT - - open my $attach_fh, '<:raw', $attachment - or die "Couldn't open attachment '$attachment': $!\n"; - while (<$attach_fh>) { $attach .= $_; } - close($attach_fh) or die "Error closing attachment '$attachment': $!"; - } - - $attach .= "\n--$mime_boundary--\n"; - return $attach; -} - -sub _read_report { - my $fname = shift; - my $content; - open( REP, "<:raw", $fname ) or die "Couldn't open file '$fname': $!\n"; - binmode(REP, ':raw :crlf') if $Is_MSWin32; - # wrap long lines to make sure the report gets delivered - local $Text::Wrap::columns = 900; - local $Text::Wrap::huge = 'overflow'; - while () { - if ($::HaveWrap && /\S/) { # wrap() would remove empty lines - $content .= Text::Wrap::wrap(undef, undef, $_); - } else { - $content .= $_; - } - } - close(REP) or die "Error closing report file '$fname': $!"; - return $content; -} - -sub build_complete_message { - my $content = _build_header(%{_message_headers()}) . "\n\n"; - $content .= _add_body_start() if $have_attachment; - $content .= _read_report($filename); - $content .= _add_attachments() if $have_attachment; - return $content; -} - -sub save_message_to_disk { - my $file = shift; - - open OUTFILE, '>:raw', $file or do { warn "Couldn't open '$file': $!\n"; return undef}; - binmode(OUTFILE, ':raw :crlf') if $Is_MSWin32; - - print OUTFILE build_complete_message(); - close(OUTFILE) or do { warn "Error closing $file: $!"; return undef }; - print "\nMessage saved.\n"; - return 1; -} - -sub _send_message_vms { - - my $mail_from = $from; - my $rcpt_to_to = $address; - my $rcpt_to_cc = $cc; - - map { $_ =~ s/^[^<]*[^>]*//; } ($mail_from, $rcpt_to_to, $rcpt_to_cc); - - if ( open my $sff_fh, '|-:raw', 'MCR TCPIP$SYSTEM:TCPIP$SMTP_SFF.EXE SYS$INPUT:' ) { - print $sff_fh "MAIL FROM:<$mail_from>\n"; - print $sff_fh "RCPT TO:<$rcpt_to_to>\n"; - print $sff_fh "RCPT TO:<$rcpt_to_cc>\n" if $rcpt_to_cc; - print $sff_fh "DATA\n"; - print $sff_fh build_complete_message(); - my $success = close $sff_fh; - if ($success ) { - print "\nMessage sent\n"; - return; - } - } - die "Mail transport failed (leaving bug report in $filename): $^E\n"; -} - -sub _send_message_mailsend { - my $msg = Mail::Send->new(); - my %headers = %{_message_headers()}; - for my $key ( keys %headers) { - $msg->add($key => $headers{$key}); - } - - $fh = $msg->open; - binmode($fh, ':raw'); - print $fh _add_body_start() if $have_attachment; - print $fh _read_report($filename); - print $fh _add_attachments() if $have_attachment; - $fh->close or die "Error sending mail: $!"; - - print "\nMessage sent.\n"; -} - -sub _probe_for_sendmail { - my $sendmail = ""; - for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) { - $sendmail = $_, last if -e $_; - } - if ( $^O eq 'os2' and $sendmail eq "" ) { - my $path = $ENV{PATH}; - $path =~ s:\\:/:; - my @path = split /$Config{'path_sep'}/, $path; - for (@path) { - $sendmail = "$_/sendmail", last if -e "$_/sendmail"; - $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe"; - } - } - return $sendmail; -} - -sub _send_message_sendmail { - my $sendmail = _probe_for_sendmail(); - unless ($sendmail) { - my $message_start = !$Is_Linux && !$Is_OpenBSD ? <<'EOT' : <<'EOT'; -It appears that there is no program which looks like "sendmail" on -your system and that the Mail::Send library from CPAN isn't available. -EOT -It appears that there is no program which looks like "sendmail" on -your system. -EOT - paraprint(<<"EOF"), die "\n"; -$message_start -Because of this, there's no easy way to automatically send your -message. - -A copy of your message has been saved in '$filename' for you to -send to '$address' with your normal mail client. -EOF - } - - open( SENDMAIL, "|-:raw", $sendmail, "-t", "-oi", "-f", $from ) - || die "'|$sendmail -t -oi -f $from' failed: $!"; - print SENDMAIL build_complete_message(); - if ( close(SENDMAIL) ) { - print "\nMessage sent\n"; - } else { - warn "\nSendmail returned status '", $? >> 8, "'\n"; - } -} - - - -# a strange way to check whether any significant editing -# has been done: check whether any new non-empty lines -# have been added. - -sub _fingerprint_lines_in_report { - my $new_lines = 0; - # read in the report template once so that - # we can track whether the user does any editing. - # yes, *all* whitespace is ignored. - - open(REP, '<:raw', $filename) or die "Unable to open report file '$filename': $!\n"; - binmode(REP, ':raw :crlf') if $Is_MSWin32; - while (my $line = ) { - $line =~ s/\s+//g; - $new_lines++ if (!$REP{$line}); - - } - close(REP) or die "Error closing report file '$filename': $!"; - # returns the number of lines with content that wasn't there when last we looked - return $new_lines; -} - - - -format STDOUT = -^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~ -$_ -. - -__END__ - -=head1 NAME - -perlbug - how to submit bug reports on Perl - -=head1 SYNOPSIS - -B - -B S<[ B<-v> ]> S<[ B<-a> I
]> S<[ B<-s> I ]> -S<[ B<-b> I | B<-f> I ]> S<[ B<-F> I ]> -S<[ B<-r> I ]> -S<[ B<-e> I ]> S<[ B<-c> I | B<-C> ]> -S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> S<[ B<-T> ]> - -B S<[ B<-v> ]> S<[ B<-r> I ]> - S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> - -B - -=head1 DESCRIPTION - - -This program is designed to help you generate and send bug reports -(and thank-you notes) about perl5 and the modules which ship with it. - -In most cases, you can just run it interactively from a command -line without any special arguments and follow the prompts. - -If you have found a bug with a non-standard port (one that was not -part of the I), a binary distribution, or a -non-core module (such as Tk, DBI, etc), then please see the -documentation that came with that distribution to determine the -correct place to report bugs. - -If you are unable to send your report using B (most likely -because your system doesn't have a way to send mail that perlbug -recognizes), you may be able to use this tool to compose your report -and save it to a file which you can then send to B -using your regular mail client. - -In extreme cases, B may not work well enough on your system -to guide you through composing a bug report. In those cases, you -may be able to use B to get system configuration -information to include in a manually composed bug report to -B. - - -When reporting a bug, please run through this checklist: - -=over 4 - -=item What version of Perl you are running? - -Type C at the command line to find out. - -=item Are you running the latest released version of perl? - -Look at http://www.perl.org/ to find out. If you are not using the -latest released version, please try to replicate your bug on the -latest stable release. - -Note that reports about bugs in old versions of Perl, especially -those which indicate you haven't also tested the current stable -release of Perl, are likely to receive less attention from the -volunteers who build and maintain Perl than reports about bugs in -the current release. - -This tool isn't appropriate for reporting bugs in any version -prior to Perl 5.0. - -=item Are you sure what you have is a bug? - -A significant number of the bug reports we get turn out to be -documented features in Perl. Make sure the issue you've run into -isn't intentional by glancing through the documentation that comes -with the Perl distribution. - -Given the sheer volume of Perl documentation, this isn't a trivial -undertaking, but if you can point to documentation that suggests -the behaviour you're seeing is I, your issue is likely to -receive more attention. You may want to start with B -L for pointers to common traps that new (and experienced) -Perl programmers run into. - -If you're unsure of the meaning of an error message you've run -across, B L for an explanation. If the message -isn't in perldiag, it probably isn't generated by Perl. You may -have luck consulting your operating system documentation instead. - -If you are on a non-UNIX platform B L, as some -features may be unimplemented or work differently. - -You may be able to figure out what's going wrong using the Perl -debugger. For information about how to use the debugger B -L. - -=item Do you have a proper test case? - -The easier it is to reproduce your bug, the more likely it will be -fixed -- if nobody can duplicate your problem, it probably won't be -addressed. - -A good test case has most of these attributes: short, simple code; -few dependencies on external commands, modules, or libraries; no -platform-dependent code (unless it's a platform-specific bug); -clear, simple documentation. - -A good test case is almost always a good candidate to be included in -Perl's test suite. If you have the time, consider writing your test case so -that it can be easily included into the standard test suite. - -=item Have you included all relevant information? - -Be sure to include the B error messages, if any. -"Perl gave an error" is not an exact error message. - -If you get a core dump (or equivalent), you may use a debugger -(B, B, etc) to produce a stack trace to include in the bug -report. - -NOTE: unless your Perl has been compiled with debug info -(often B<-g>), the stack trace is likely to be somewhat hard to use -because it will most probably contain only the function names and not -their arguments. If possible, recompile your Perl with debug info and -reproduce the crash and the stack trace. - -=item Can you describe the bug in plain English? - -The easier it is to understand a reproducible bug, the more likely -it will be fixed. Any insight you can provide into the problem -will help a great deal. In other words, try to analyze the problem -(to the extent you can) and report your discoveries. - -=item Can you fix the bug yourself? - -If so, that's great news; bug reports with patches are likely to -receive significantly more attention and interest than those without -patches. Please attach your patch to the report using the C<-p> option. -When sending a patch, create it using C if possible, -though a unified diff created with C will do nearly as well. - -Your patch may be returned with requests for changes, or requests for more -detailed explanations about your fix. - -Here are a few hints for creating high-quality patches: - -Make sure the patch is not reversed (the first argument to diff is -typically the original file, the second argument your changed file). -Make sure you test your patch by applying it with C or the -C program before you send it on its way. Try to follow the -same style as the code you are trying to patch. Make sure your patch -really does work (C, if the thing you're patching is covered -by Perl's test suite). - -=item Can you use C to submit the report? - -B will, amongst other things, ensure your report includes -crucial information about your version of perl. If C is -unable to mail your report after you have typed it in, you may have -to compose the message yourself, add the output produced by C and email it to B. If, for some reason, you -cannot run C at all on your system, be sure to include the -entire output produced by running C (note the uppercase V). - -Whether you use C or send the email manually, please make -your Subject line informative. "a bug" is not informative. Neither -is "perl crashes" nor is "HELP!!!". These don't help. A compact -description of what's wrong is fine. - -=item Can you use C to submit a thank-you note? - -Yes, you can do this by either using the C<-T> option, or by invoking -the program as C. Thank-you notes are good. It makes people -smile. - -=back - -Having done your bit, please be prepared to wait, to be told the -bug is in your code, or possibly to get no reply at all. The -volunteers who maintain Perl are busy folks, so if your problem is -an obvious bug in your own code, is difficult to understand or is -a duplicate of an existing report, you may not receive a personal -reply. - -If it is important to you that your bug be fixed, do monitor the -perl5-porters@perl.org mailing list (mailing lists are moderated, your -message may take a while to show up) and the commit logs to development -versions of Perl, and encourage the maintainers with kind words or -offers of frosty beverages. (Please do be kind to the maintainers. -Harassing or flaming them is likely to have the opposite effect of the -one you want.) - -Feel free to update the ticket about your bug on http://rt.perl.org -if a new version of Perl is released and your bug is still present. - -=head1 OPTIONS - -=over 8 - -=item B<-a> - -Address to send the report to. Defaults to B. - -=item B<-A> - -Don't send a bug received acknowledgement to the reply address. -Generally it is only a sensible to use this option if you are a -perl maintainer actively watching perl porters for your message to -arrive. - -=item B<-b> - -Body of the report. If not included on the command line, or -in a file with B<-f>, you will get a chance to edit the message. - -=item B<-C> - -Don't send copy to administrator. - -=item B<-c> - -Address to send copy of report to. Defaults to the address of the -local perl administrator (recorded when perl was built). - -=item B<-d> - -Data mode (the default if you redirect or pipe output). This prints out -your configuration data, without mailing anything. You can use this -with B<-v> to get more complete data. - -=item B<-e> - -Editor to use. - -=item B<-f> - -File containing the body of the report. Use this to quickly send a -prepared message. - -=item B<-F> - -File to output the results to instead of sending as an email. Useful -particularly when running perlbug on a machine with no direct internet -connection. - -=item B<-h> - -Prints a brief summary of the options. - -=item B<-ok> - -Report successful build on this system to perl porters. Forces B<-S> -and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only -prompts for a return address if it cannot guess it (for use with -B). Honors return address specified with B<-r>. You can use this -with B<-v> to get more complete data. Only makes a report if this -system is less than 60 days old. - -=item B<-okay> - -As B<-ok> except it will report on older systems. - -=item B<-nok> - -Report unsuccessful build on this system. Forces B<-C>. Forces and -supplies a value for B<-s>, then requires you to edit the report -and say what went wrong. Alternatively, a prepared report may be -supplied using B<-f>. Only prompts for a return address if it -cannot guess it (for use with B). Honors return address -specified with B<-r>. You can use this with B<-v> to get more -complete data. Only makes a report if this system is less than 60 -days old. - -=item B<-nokay> - -As B<-nok> except it will report on older systems. - -=item B<-p> - -The names of one or more patch files or other text attachments to be -included with the report. Multiple files must be separated with commas. - -=item B<-r> - -Your return address. The program will ask you to confirm its default -if you don't use this option. - -=item B<-S> - -Send without asking for confirmation. - -=item B<-s> - -Subject to include with the message. You will be prompted if you don't -supply one on the command line. - -=item B<-t> - -Test mode. The target address defaults to B. -Also makes it possible to command perlbug from a pipe or file, for -testing purposes. - -=item B<-T> - -Send a thank-you note instead of a bug report. - -=item B<-v> - -Include verbose configuration data in the report. - -=back - -=head1 AUTHORS - -Kenneth Albanowski (Ekjahds@kjahds.comE), subsequently -Itored by Gurusamy Sarathy (Egsar@activestate.comE), -Tom Christiansen (Etchrist@perl.comE), Nathan Torkington -(Egnat@frii.comE), Charles F. Randall (Ecfr@pobox.comE), -Mike Guy (Emjtg@cam.ac.ukE), Dominic Dunlop -(Edomo@computer.orgE), Hugo van der Sanden (Ehv@crypt.orgE), -Jarkko Hietaniemi (Ejhi@iki.fiE), Chris Nandor -(Epudge@pobox.comE), Jon Orwant (Eorwant@media.mit.eduE, -Richard Foley (Erichard.foley@rfi.netE), Jesse Vincent -(Ejesse@bestpractical.comE), and Craig A. Berry (Ecraigberry@mac.comE). - -=head1 SEE ALSO - -perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1), -diff(1), patch(1), dbx(1), gdb(1) - -=head1 BUGS - -None known (guess what must have been used to report them?) - -=cut - diff --git a/bin/piconv b/bin/piconv deleted file mode 100755 index 19812e13..00000000 --- a/bin/piconv +++ /dev/null @@ -1,322 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; -#!./perl -# $Id: piconv,v 2.8 2016/08/04 03:15:58 dankogai Exp $ -# -BEGIN { pop @INC if $INC[-1] eq '.' } -use 5.8.0; -use strict; -use Encode ; -use Encode::Alias; -my %Scheme = map {$_ => 1} qw(from_to decode_encode perlio); - -use File::Basename; -my $name = basename($0); - -use Getopt::Long qw(:config no_ignore_case); - -my %Opt; - -help() - unless - GetOptions(\%Opt, - 'from|f=s', - 'to|t=s', - 'list|l', - 'string|s=s', - 'check|C=i', - 'c', - 'perlqq|p', - 'htmlcref', - 'xmlcref', - 'debug|D', - 'scheme|S=s', - 'resolve|r=s', - 'help', - ); - -$Opt{help} and help(); -$Opt{list} and list_encodings(); -my $locale = $ENV{LC_CTYPE} || $ENV{LC_ALL} || $ENV{LANG}; -defined $Opt{resolve} and resolve_encoding($Opt{resolve}); -$Opt{from} || $Opt{to} || help(); -my $from = $Opt{from} || $locale or help("from_encoding unspecified"); -my $to = $Opt{to} || $locale or help("to_encoding unspecified"); -$Opt{string} and Encode::from_to($Opt{string}, $from, $to) and print $Opt{string} and exit; -my $scheme = do { - if (defined $Opt{scheme}) { - if (!exists $Scheme{$Opt{scheme}}) { - warn "Unknown scheme '$Opt{scheme}', fallback to 'from_to'.\n"; - 'from_to'; - } else { - $Opt{scheme}; - } - } else { - 'from_to'; - } -}; - -$Opt{check} ||= $Opt{c}; -$Opt{perlqq} and $Opt{check} = Encode::PERLQQ; -$Opt{htmlcref} and $Opt{check} = Encode::HTMLCREF; -$Opt{xmlcref} and $Opt{check} = Encode::XMLCREF; - -my $efrom = Encode->getEncoding($from) || die "Unknown encoding '$from'"; -my $eto = Encode->getEncoding($to) || die "Unknown encoding '$to'"; - -my $cfrom = $efrom->name; -my $cto = $eto->name; - -if ($Opt{debug}){ - print <<"EOT"; -Scheme: $scheme -From: $from => $cfrom -To: $to => $cto -EOT -} - -my %use_bom = - map { $_ => 1 } qw/UTF-16 UTF-16BE UTF-16LE UTF-32 UTF-32BE UTF-32LE/; - -# we do not use <> (or ARGV) for the sake of binmode() -@ARGV or push @ARGV, \*STDIN; - -unless ( $scheme eq 'perlio' ) { - binmode STDOUT; - my $need2slurp = $use_bom{ $eto } || $use_bom{ $efrom }; - for my $argv (@ARGV) { - my $ifh = ref $argv ? $argv : undef; - $ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next; - $ifh or open $ifh, "<", $argv or next; - binmode $ifh; - if ( $scheme eq 'from_to' ) { # default - if ($need2slurp){ - local $/; - $_ = <$ifh>; - Encode::from_to( $_, $from, $to, $Opt{check} ); - print; - }else{ - while (<$ifh>) { - Encode::from_to( $_, $from, $to, $Opt{check} ); - print; - } - } - } - elsif ( $scheme eq 'decode_encode' ) { # step-by-step - if ($need2slurp){ - local $/; - $_ = <$ifh>; - my $decoded = decode( $from, $_, $Opt{check} ); - my $encoded = encode( $to, $decoded ); - print $encoded; - }else{ - while (<$ifh>) { - my $decoded = decode( $from, $_, $Opt{check} ); - my $encoded = encode( $to, $decoded ); - print $encoded; - } - } - } - else { # won't reach - die "$name: unknown scheme: $scheme"; - } - } -} -else { - - # NI-S favorite - binmode STDOUT => "raw:encoding($to)"; - for my $argv (@ARGV) { - my $ifh = ref $argv ? $argv : undef; - $ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next; - $ifh or open $ifh, "<", $argv or next; - binmode $ifh => "raw:encoding($from)"; - print while (<$ifh>); - } -} - -sub list_encodings { - print join( "\n", Encode->encodings(":all") ), "\n"; - exit 0; -} - -sub resolve_encoding { - if ( my $alias = Encode::resolve_alias( $_[0] ) ) { - print $alias, "\n"; - exit 0; - } - else { - warn "$name: $_[0] is not known to Encode\n"; - exit 1; - } -} - -sub help { - my $message = shift; - $message and print STDERR "$name error: $message\n"; - print STDERR <<"EOT"; -$name [-f from_encoding] [-t to_encoding] - [-p|--perlqq|--htmlcref|--xmlcref] [-C N|-c] [-D] [-S scheme] - [-s string|file...] -$name -l -$name -r encoding_alias -$name -h -Common options: - -l,--list - lists all available encodings - -r,--resolve encoding_alias - resolve encoding to its (Encode) canonical name - -f,--from from_encoding - when omitted, the current locale will be used - -t,--to to_encoding - when omitted, the current locale will be used - -s,--string string - "string" will be the input instead of STDIN or files -The following are mainly of interest to Encode hackers: - -C N | -c check the validity of the input - -D,--debug show debug information - -S,--scheme scheme use the scheme for conversion -Those are handy when you can only see ASCII characters: - -p,--perlqq transliterate characters missing in encoding to \\x{HHHH} - where HHHH is the hexadecimal Unicode code point - --htmlcref transliterate characters missing in encoding to &#NNN; - where NNN is the decimal Unicode code point - --xmlcref transliterate characters missing in encoding to &#xHHHH; - where HHHH is the hexadecimal Unicode code point - -EOT - exit; -} - -__END__ - -=head1 NAME - -piconv -- iconv(1), reinvented in perl - -=head1 SYNOPSIS - - piconv [-f from_encoding] [-t to_encoding] - [-p|--perlqq|--htmlcref|--xmlcref] [-C N|-c] [-D] [-S scheme] - [-s string|file...] - piconv -l - piconv -r encoding_alias - piconv -h - -=head1 DESCRIPTION - -B is perl version of B, a character encoding converter -widely available for various Unixen today. This script was primarily -a technology demonstrator for Perl 5.8.0, but you can use piconv in the -place of iconv for virtually any case. - -piconv converts the character encoding of either STDIN or files -specified in the argument and prints out to STDOUT. - -Here is the list of options. Some options can be in short format (-f) -or long (--from) one. - -=over 4 - -=item -f,--from I - -Specifies the encoding you are converting from. Unlike B, -this option can be omitted. In such cases, the current locale is used. - -=item -t,--to I - -Specifies the encoding you are converting to. Unlike B, -this option can be omitted. In such cases, the current locale is used. - -Therefore, when both -f and -t are omitted, B just acts -like B. - -=item -s,--string I - -uses I instead of file for the source of text. - -=item -l,--list - -Lists all available encodings, one per line, in case-insensitive -order. Note that only the canonical names are listed; many aliases -exist. For example, the names are case-insensitive, and many standard -and common aliases work, such as "latin1" for "ISO-8859-1", or "ibm850" -instead of "cp850", or "winlatin1" for "cp1252". See L -for a full discussion. - -=item -r,--resolve I - -Resolve I to Encode canonical encoding name. - -=item -C,--check I - -Check the validity of the stream if I = 1. When I = -1, something -interesting happens when it encounters an invalid character. - -=item -c - -Same as C<-C 1>. - -=item -p,--perlqq - -Transliterate characters missing in encoding to \x{HHHH} where HHHH is the -hexadecimal Unicode code point. - -=item --htmlcref - -Transliterate characters missing in encoding to &#NNN; where NNN is the -decimal Unicode code point. - -=item --xmlcref - -Transliterate characters missing in encoding to &#xHHHH; where HHHH is the -hexadecimal Unicode code point. - -=item -h,--help - -Show usage. - -=item -D,--debug - -Invokes debugging mode. Primarily for Encode hackers. - -=item -S,--scheme I - -Selects which scheme is to be used for conversion. Available schemes -are as follows: - -=over 4 - -=item from_to - -Uses Encode::from_to for conversion. This is the default. - -=item decode_encode - -Input strings are decode()d then encode()d. A straight two-step -implementation. - -=item perlio - -The new perlIO layer is used. NI-S' favorite. - -You should use this option if you are using UTF-16 and others which -linefeed is not $/. - -=back - -Like the I<-D> option, this is also for Encode hackers. - -=back - -=head1 SEE ALSO - -L -L -L -L -L -L - -=cut diff --git a/bin/pl2pm b/bin/pl2pm deleted file mode 100755 index 49f57ac4..00000000 --- a/bin/pl2pm +++ /dev/null @@ -1,378 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; - -=head1 NAME - -pl2pm - Rough tool to translate Perl4 .pl files to Perl5 .pm modules. - -=head1 SYNOPSIS - -B F - -=head1 DESCRIPTION - -B is a tool to aid in the conversion of Perl4-style .pl -library files to Perl5-style library modules. Usually, your old .pl -file will still work fine and you should only use this tool if you -plan to update your library to use some of the newer Perl 5 features, -such as AutoLoading. - -=head1 LIMITATIONS - -It's just a first step, but it's usually a good first step. - -=head1 AUTHOR - -Larry Wall - -=cut - -use strict; -use warnings; - -my %keyword = (); - -while () { - chomp; - $keyword{$_} = 1; -} - -local $/; - -while (<>) { - my $newname = $ARGV; - $newname =~ s/\.pl$/.pm/ || next; - $newname =~ s#(.*/)?(\w+)#$1\u$2#; - if (-f $newname) { - warn "Won't overwrite existing $newname\n"; - next; - } - my $oldpack = $2; - my $newpack = "\u$2"; - my @export = (); - - s/\bstd(in|out|err)\b/\U$&/g; - s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig; - if (/sub\s+\w+'/) { - @export = m/sub\s+\w+'(\w+)/g; - s/(sub\s+)main'(\w+)/$1$2/g; - } - else { - @export = m/sub\s+([A-Za-z]\w*)/g; - } - my @export_ok = grep($keyword{$_}, @export); - @export = grep(!$keyword{$_}, @export); - - my %export = (); - @export{@export} = (1) x @export; - - s/(^\s*);#/$1#/g; - s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/; - s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig; - s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg; - s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg; - if (!/\$\[\s*\)?\s*=\s*[^0\s]/) { - s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g; - s/\$\[\s*\+\s*//g; - s/\s*\+\s*\$\[//g; - s/\$\[/0/g; - } - s/open\s+(\w+)/open($1)/g; - - my $export_ok = ''; - my $carp =''; - - - if (s/\bdie\b/croak/g) { - $carp = "use Carp;\n"; - s/croak "([^"]*)\\n"/croak "$1"/g; - } - - if (@export_ok) { - $export_ok = "\@EXPORT_OK = qw(@export_ok);\n"; - } - - if ( open(PM, ">", $newname) ) { - print PM <<"END"; -package $newpack; -use 5.006; -require Exporter; -$carp -\@ISA = qw(Exporter); -\@EXPORT = qw(@export); -$export_ok -$_ -END - } - else { - warn "Can't create $newname: $!\n"; - } -} - -sub xlate { - my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_; - - my $xlated ; - if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) { - $xlated = "${pack}'$ident"; - } - elsif ($pack eq '' || $pack eq 'main') { - if ($export->{$ident}) { - $xlated = "$prefix$ident"; - } - else { - $xlated = "$prefix${pack}::$ident"; - } - } - elsif ($pack eq $oldpack) { - $xlated = "$prefix${newpack}::$ident"; - } - else { - $xlated = "$prefix${pack}::$ident"; - } - - return $xlated; -} -__END__ -AUTOLOAD -BEGIN -CHECK -CORE -DESTROY -END -INIT -UNITCHECK -abs -accept -alarm -and -atan2 -bind -binmode -bless -caller -chdir -chmod -chomp -chop -chown -chr -chroot -close -closedir -cmp -connect -continue -cos -crypt -dbmclose -dbmopen -defined -delete -die -do -dump -each -else -elsif -endgrent -endhostent -endnetent -endprotoent -endpwent -endservent -eof -eq -eval -exec -exists -exit -exp -fcntl -fileno -flock -for -foreach -fork -format -formline -ge -getc -getgrent -getgrgid -getgrnam -gethostbyaddr -gethostbyname -gethostent -getlogin -getnetbyaddr -getnetbyname -getnetent -getpeername -getpgrp -getppid -getpriority -getprotobyname -getprotobynumber -getprotoent -getpwent -getpwnam -getpwuid -getservbyname -getservbyport -getservent -getsockname -getsockopt -glob -gmtime -goto -grep -gt -hex -if -index -int -ioctl -join -keys -kill -last -lc -lcfirst -le -length -link -listen -local -localtime -lock -log -lstat -lt -m -map -mkdir -msgctl -msgget -msgrcv -msgsnd -my -ne -next -no -not -oct -open -opendir -or -ord -our -pack -package -pipe -pop -pos -print -printf -prototype -push -q -qq -qr -quotemeta -qw -qx -rand -read -readdir -readline -readlink -readpipe -recv -redo -ref -rename -require -reset -return -reverse -rewinddir -rindex -rmdir -s -scalar -seek -seekdir -select -semctl -semget -semop -send -setgrent -sethostent -setnetent -setpgrp -setpriority -setprotoent -setpwent -setservent -setsockopt -shift -shmctl -shmget -shmread -shmwrite -shutdown -sin -sleep -socket -socketpair -sort -splice -split -sprintf -sqrt -srand -stat -study -sub -substr -symlink -syscall -sysopen -sysread -sysseek -system -syswrite -tell -telldir -tie -tied -time -times -tr -truncate -uc -ucfirst -umask -undef -unless -unlink -unpack -unshift -untie -until -use -utime -values -vec -wait -waitpid -wantarray -warn -while -write -x -xor -y diff --git a/bin/pod2html b/bin/pod2html deleted file mode 100755 index 90e57fe3..00000000 --- a/bin/pod2html +++ /dev/null @@ -1,225 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; -=pod - -=head1 NAME - -pod2html - convert .pod files to .html files - -=head1 SYNOPSIS - - pod2html --help --htmldir= --htmlroot= - --infile= --outfile= - --podpath=:...: --podroot= - --cachedir= --flush --recurse --norecurse - --quiet --noquiet --verbose --noverbose - --index --noindex --backlink --nobacklink - --header --noheader --poderrors --nopoderrors - --css= --title= - -=head1 DESCRIPTION - -Converts files from pod format (see L) to HTML format. - -=head1 ARGUMENTS - -pod2html takes the following arguments: - -=over 4 - -=item help - - --help - -Displays the usage message. - -=item htmldir - - --htmldir=name - -Sets the directory to which all cross references in the resulting HTML file -will be relative. Not passing this causes all links to be absolute since this -is the value that tells Pod::Html the root of the documentation tree. - -Do not use this and --htmlroot in the same call to pod2html; they are mutually -exclusive. - -=item htmlroot - - --htmlroot=URL - -Sets the base URL for the HTML files. When cross-references are made, the -HTML root is prepended to the URL. - -Do not use this if relative links are desired: use --htmldir instead. - -Do not pass both this and --htmldir to pod2html; they are mutually exclusive. - -=item infile - - --infile=name - -Specify the pod file to convert. Input is taken from STDIN if no -infile is specified. - -=item outfile - - --outfile=name - -Specify the HTML file to create. Output goes to STDOUT if no outfile -is specified. - -=item podroot - - --podroot=name - -Specify the base directory for finding library pods. - -=item podpath - - --podpath=name:...:name - -Specify which subdirectories of the podroot contain pod files whose -HTML converted forms can be linked-to in cross-references. - -=item cachedir - - --cachedir=name - -Specify which directory is used for storing cache. Default directory is the -current working directory. - -=item flush - - --flush - -Flush the cache. - -=item backlink - - --backlink - -Turn =head1 directives into links pointing to the top of the HTML file. - -=item nobacklink - - --nobacklink - -Do not turn =head1 directives into links pointing to the top of the HTML file -(default behaviour). - -=item header - - --header - -Create header and footer blocks containing the text of the "NAME" section. - -=item noheader - - --noheader - -Do not create header and footer blocks containing the text of the "NAME" -section (default behaviour). - -=item poderrors - - --poderrors - -Include a "POD ERRORS" section in the outfile if there were any POD errors in -the infile (default behaviour). - -=item nopoderrors - - --nopoderrors - -Do not include a "POD ERRORS" section in the outfile if there were any POD -errors in the infile. - -=item index - - --index - -Generate an index at the top of the HTML file (default behaviour). - -=item noindex - - --noindex - -Do not generate an index at the top of the HTML file. - - -=item recurse - - --recurse - -Recurse into subdirectories specified in podpath (default behaviour). - -=item norecurse - - --norecurse - -Do not recurse into subdirectories specified in podpath. - -=item css - - --css=URL - -Specify the URL of cascading style sheet to link from resulting HTML file. -Default is none style sheet. - -=item title - - --title=title - -Specify the title of the resulting HTML file. - -=item quiet - - --quiet - -Don't display mostly harmless warning messages. - -=item noquiet - - --noquiet - -Display mostly harmless warning messages (default behaviour). But this is not -the same as "verbose" mode. - -=item verbose - - --verbose - -Display progress messages. - -=item noverbose - - --noverbose - -Do not display progress messages (default behaviour). - -=back - -=head1 AUTHOR - -Tom Christiansen, Etchrist@perl.comE. - -=head1 BUGS - -See L for a list of known bugs in the translator. - -=head1 SEE ALSO - -L, L - -=head1 COPYRIGHT - -This program is distributed under the Artistic License. - -=cut - -BEGIN { pop @INC if $INC[-1] eq '.' } -use Pod::Html; - -pod2html @ARGV; diff --git a/bin/pod2man b/bin/pod2man deleted file mode 100755 index 4b8e3308..00000000 --- a/bin/pod2man +++ /dev/null @@ -1,394 +0,0 @@ -#!/home/git/binary-com/perl/bin/perl - eval 'exec /home/git/binary-com/perl/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; - -# pod2man -- Convert POD data to formatted *roff input. -# -# Copyright 1999, 2000, 2001, 2004, 2006, 2008, 2010, 2012, 2013, 2014, 2015, -# 2016 Russ Allbery -# -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. - -use 5.006; -use strict; -use warnings; - -use Getopt::Long qw(GetOptions); -use Pod::Man (); -use Pod::Usage qw(pod2usage); - -use strict; - -# Clean up $0 for error reporting. -$0 =~ s%.*/%%; - -# Insert -- into @ARGV before any single dash argument to hide it from -# Getopt::Long; we want to interpret it as meaning stdin. -my $stdin; -@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV; - -# Parse our options, trying to retain backward compatibility with pod2man but -# allowing short forms as well. --lax is currently ignored. -my %options; -Getopt::Long::config ('bundling_override'); -GetOptions (\%options, 'center|c=s', 'date|d=s', 'errors=s', 'fixed=s', - 'fixedbold=s', 'fixeditalic=s', 'fixedbolditalic=s', 'help|h', - 'lax|l', 'lquote=s', 'name|n=s', 'nourls', 'official|o', - 'quotes|q=s', 'release|r=s', 'rquote=s', 'section|s=s', 'stderr', - 'verbose|v', 'utf8|u') - or exit 1; -pod2usage (0) if $options{help}; - -# Official sets --center, but don't override things explicitly set. -if ($options{official} && !defined $options{center}) { - $options{center} = 'Perl Programmers Reference Guide'; -} - -# Verbose is only our flag, not a Pod::Man flag. -my $verbose = $options{verbose}; -delete $options{verbose}; - -# This isn't a valid Pod::Man option and is only accepted for backward -# compatibility. -delete $options{lax}; - -# If neither stderr nor errors is set, default to errors = die. -if (!defined $options{stderr} && !defined $options{errors}) { - $options{errors} = 'die'; -} - -# Initialize and run the formatter, pulling a pair of input and output off at -# a time. For each file, we check whether the document was completely empty -# and, if so, will remove the created file and exit with a non-zero exit -# status. -my $parser = Pod::Man->new (%options); -my $status = 0; -my @files; -do { - @files = splice (@ARGV, 0, 2); - print " $files[1]\n" if $verbose; - $parser->parse_from_file (@files); - if ($parser->{CONTENTLESS}) { - $status = 1; - warn "$0: unable to format $files[0]\n"; - if (defined ($files[1]) and $files[1] ne '-') { - unlink $files[1] unless (-s $files[1]); - } - } -} while (@ARGV); -exit $status; - -__END__ - -=for stopwords -en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris -URL troff troff-specific formatters uppercased Christiansen --nourls UTC -prepend lquote rquote - -=head1 NAME - -pod2man - Convert POD data to formatted *roff input - -=head1 SYNOPSIS - -pod2man [B<--center>=I] [B<--date>=I] [B<--errors>=I