diff --git a/msys/mingw/bin/c2ph.bat b/msys/mingw/bin/c2ph.bat new file mode 100644 index 000000000..8e3725611 --- /dev/null +++ b/msys/mingw/bin/c2ph.bat @@ -0,0 +1,1383 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + eval 'exec C:\perl-5.24.0\bin\perl.exe -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 $'; + +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; + } + } +} + +__END__ +:endofperl diff --git a/msys/mingw/bin/config_data b/msys/mingw/bin/config_data new file mode 100644 index 000000000..4ad4e8cca --- /dev/null +++ b/msys/mingw/bin/config_data @@ -0,0 +1,249 @@ +#!C:\perl-5.24.0\bin\perl.exe + +use strict; +use Module::Build 0.25; +use Getopt::Long; + +my %opt_defs = ( + module => {type => '=s', + desc => 'The name of the module to configure (required)'}, + feature => {type => ':s', + desc => 'Print the value of a feature or all features'}, + config => {type => ':s', + desc => 'Print the value of a config option'}, + set_feature => {type => '=s%', + desc => "Set a feature to 'true' or 'false'"}, + set_config => {type => '=s%', + desc => 'Set a config option to the given value'}, + eval => {type => '', + desc => 'eval() config values before setting'}, + help => {type => '', + desc => 'Print a help message and exit'}, + ); + +my %opts; +GetOptions( \%opts, map "$_$opt_defs{$_}{type}", keys %opt_defs ) or die usage(%opt_defs); +print usage(%opt_defs) and exit(0) + if $opts{help}; + +my @exclusive = qw(feature config set_feature set_config); +die "Exactly one of the options '" . join("', '", @exclusive) . "' must be specified\n" . usage(%opt_defs) + unless grep(exists $opts{$_}, @exclusive) == 1; + +die "Option --module is required\n" . usage(%opt_defs) + unless $opts{module}; + +my $cf = load_config($opts{module}); + +if (exists $opts{feature}) { + + if (length $opts{feature}) { + print $cf->feature($opts{feature}); + } else { + my %auto; + # note: need to support older ConfigData.pm's + @auto{$cf->auto_feature_names} = () if $cf->can("auto_feature_names"); + + print " Features defined in $cf:\n"; + foreach my $name (sort $cf->feature_names) { + print " $name => ", $cf->feature($name), (exists $auto{$name} ? " (dynamic)" : ""), "\n"; + } + } + +} elsif (exists $opts{config}) { + + require Data::Dumper; + local $Data::Dumper::Terse = 1; + + if (length $opts{config}) { + print Data::Dumper::Dumper($cf->config($opts{config})), "\n"; + } else { + print " Configuration defined in $cf:\n"; + foreach my $name (sort $cf->config_names) { + print " $name => ", Data::Dumper::Dumper($cf->config($name)), "\n"; + } + } + +} elsif (exists $opts{set_feature}) { + my %to_set = %{$opts{set_feature}}; + while (my ($k, $v) = each %to_set) { + die "Feature value must be 0 or 1\n" unless $v =~ /^[01]$/; + $cf->set_feature($k, 0+$v); # Cast to a number, not a string + } + $cf->write; + print "Feature" . 's'x(keys(%to_set)>1) . " saved\n"; + +} elsif (exists $opts{set_config}) { + + my %to_set = %{$opts{set_config}}; + while (my ($k, $v) = each %to_set) { + if ($opts{eval}) { + $v = eval($v); + die $@ if $@; + } + $cf->set_config($k, $v); + } + $cf->write; + print "Config value" . 's'x(keys(%to_set)>1) . " saved\n"; +} + +sub load_config { + my $mod = shift; + + $mod =~ /^([\w:]+)$/ + or die "Invalid module name '$mod'"; + + my $cf = $mod . "::ConfigData"; + eval "require $cf"; + die $@ if $@; + + return $cf; +} + +sub usage { + my %defs = @_; + + my $out = "\nUsage: $0 [options]\n\n Options include:\n"; + + foreach my $name (sort keys %defs) { + $out .= " --$name"; + + for ($defs{$name}{type}) { + /^=s$/ and $out .= " "; + /^=s%$/ and $out .= " ="; + } + + pad_line($out, 35); + $out .= "$defs{$name}{desc}\n"; + } + + $out .= < tool provides a command-line interface to the +configuration of Perl modules. By "configuration", we mean something +akin to "user preferences" or "local settings". This is a +formalization and abstraction of the systems that people like Andreas +Koenig (C), Jon Swartz (C), Andy +Wardley (C), and Larry Wall (perl's own Config.pm) +have developed independently. + +The configuration system employed here was developed in the context of +C. Under this system, configuration information for a +module C, for example, is stored in a module called +C) (I would have called it C, but that +was taken by all those other systems mentioned in the previous +paragraph...). These C<...::ConfigData> modules contain the +configuration data, as well as publicly accessible methods for +querying and setting (yes, actually re-writing) the configuration +data. The C script (whose docs you are currently +reading) is merely a front-end for those methods. If you wish, you +may create alternate front-ends. + +The two types of data that may be stored are called C values +and C values. A C value may be any perl scalar, +including references to complex data structures. It must, however, be +serializable using C. A C is a boolean (1 or +0) value. + +=head1 USAGE + +This script functions as a basic getter/setter wrapper around the +configuration of a single module. On the command line, specify which +module's configuration you're interested in, and pass options to get +or set C or C values. The following options are +supported: + +=over 4 + +=item module + +Specifies the name of the module to configure (required). + +=item feature + +When passed the name of a C, shows its value. The value will +be 1 if the feature is enabled, 0 if the feature is not enabled, or +empty if the feature is unknown. When no feature name is supplied, +the names and values of all known features will be shown. + +=item config + +When passed the name of a C entry, shows its value. The value +will be displayed using C (or similar) as perl code. +When no config name is supplied, the names and values of all known +config entries will be shown. + +=item set_feature + +Sets the given C to the given boolean value. Specify the value +as either 1 or 0. + +=item set_config + +Sets the given C entry to the given value. + +=item eval + +If the C<--eval> option is used, the values in C will be +evaluated as perl code before being stored. This allows moderately +complicated data structures to be stored. For really complicated +structures, you probably shouldn't use this command-line interface, +just use the Perl API instead. + +=item help + +Prints a help message, including a few examples, and exits. + +=back + +=head1 AUTHOR + +Ken Williams, kwilliams@cpan.org + +=head1 COPYRIGHT + +Copyright (c) 1999, Ken Williams. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +Module::Build(3), perl(1). + +=cut diff --git a/msys/mingw/bin/config_data.bat b/msys/mingw/bin/config_data.bat new file mode 100644 index 000000000..78dc7c1d4 --- /dev/null +++ b/msys/mingw/bin/config_data.bat @@ -0,0 +1,265 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!C:\perl-5.24.0\bin\perl.exe +#line 15 + +use strict; +use Module::Build 0.25; +use Getopt::Long; + +my %opt_defs = ( + module => {type => '=s', + desc => 'The name of the module to configure (required)'}, + feature => {type => ':s', + desc => 'Print the value of a feature or all features'}, + config => {type => ':s', + desc => 'Print the value of a config option'}, + set_feature => {type => '=s%', + desc => "Set a feature to 'true' or 'false'"}, + set_config => {type => '=s%', + desc => 'Set a config option to the given value'}, + eval => {type => '', + desc => 'eval() config values before setting'}, + help => {type => '', + desc => 'Print a help message and exit'}, + ); + +my %opts; +GetOptions( \%opts, map "$_$opt_defs{$_}{type}", keys %opt_defs ) or die usage(%opt_defs); +print usage(%opt_defs) and exit(0) + if $opts{help}; + +my @exclusive = qw(feature config set_feature set_config); +die "Exactly one of the options '" . join("', '", @exclusive) . "' must be specified\n" . usage(%opt_defs) + unless grep(exists $opts{$_}, @exclusive) == 1; + +die "Option --module is required\n" . usage(%opt_defs) + unless $opts{module}; + +my $cf = load_config($opts{module}); + +if (exists $opts{feature}) { + + if (length $opts{feature}) { + print $cf->feature($opts{feature}); + } else { + my %auto; + # note: need to support older ConfigData.pm's + @auto{$cf->auto_feature_names} = () if $cf->can("auto_feature_names"); + + print " Features defined in $cf:\n"; + foreach my $name (sort $cf->feature_names) { + print " $name => ", $cf->feature($name), (exists $auto{$name} ? " (dynamic)" : ""), "\n"; + } + } + +} elsif (exists $opts{config}) { + + require Data::Dumper; + local $Data::Dumper::Terse = 1; + + if (length $opts{config}) { + print Data::Dumper::Dumper($cf->config($opts{config})), "\n"; + } else { + print " Configuration defined in $cf:\n"; + foreach my $name (sort $cf->config_names) { + print " $name => ", Data::Dumper::Dumper($cf->config($name)), "\n"; + } + } + +} elsif (exists $opts{set_feature}) { + my %to_set = %{$opts{set_feature}}; + while (my ($k, $v) = each %to_set) { + die "Feature value must be 0 or 1\n" unless $v =~ /^[01]$/; + $cf->set_feature($k, 0+$v); # Cast to a number, not a string + } + $cf->write; + print "Feature" . 's'x(keys(%to_set)>1) . " saved\n"; + +} elsif (exists $opts{set_config}) { + + my %to_set = %{$opts{set_config}}; + while (my ($k, $v) = each %to_set) { + if ($opts{eval}) { + $v = eval($v); + die $@ if $@; + } + $cf->set_config($k, $v); + } + $cf->write; + print "Config value" . 's'x(keys(%to_set)>1) . " saved\n"; +} + +sub load_config { + my $mod = shift; + + $mod =~ /^([\w:]+)$/ + or die "Invalid module name '$mod'"; + + my $cf = $mod . "::ConfigData"; + eval "require $cf"; + die $@ if $@; + + return $cf; +} + +sub usage { + my %defs = @_; + + my $out = "\nUsage: $0 [options]\n\n Options include:\n"; + + foreach my $name (sort keys %defs) { + $out .= " --$name"; + + for ($defs{$name}{type}) { + /^=s$/ and $out .= " "; + /^=s%$/ and $out .= " ="; + } + + pad_line($out, 35); + $out .= "$defs{$name}{desc}\n"; + } + + $out .= < tool provides a command-line interface to the +configuration of Perl modules. By "configuration", we mean something +akin to "user preferences" or "local settings". This is a +formalization and abstraction of the systems that people like Andreas +Koenig (C), Jon Swartz (C), Andy +Wardley (C), and Larry Wall (perl's own Config.pm) +have developed independently. + +The configuration system employed here was developed in the context of +C. Under this system, configuration information for a +module C, for example, is stored in a module called +C) (I would have called it C, but that +was taken by all those other systems mentioned in the previous +paragraph...). These C<...::ConfigData> modules contain the +configuration data, as well as publicly accessible methods for +querying and setting (yes, actually re-writing) the configuration +data. The C script (whose docs you are currently +reading) is merely a front-end for those methods. If you wish, you +may create alternate front-ends. + +The two types of data that may be stored are called C values +and C values. A C value may be any perl scalar, +including references to complex data structures. It must, however, be +serializable using C. A C is a boolean (1 or +0) value. + +=head1 USAGE + +This script functions as a basic getter/setter wrapper around the +configuration of a single module. On the command line, specify which +module's configuration you're interested in, and pass options to get +or set C or C values. The following options are +supported: + +=over 4 + +=item module + +Specifies the name of the module to configure (required). + +=item feature + +When passed the name of a C, shows its value. The value will +be 1 if the feature is enabled, 0 if the feature is not enabled, or +empty if the feature is unknown. When no feature name is supplied, +the names and values of all known features will be shown. + +=item config + +When passed the name of a C entry, shows its value. The value +will be displayed using C (or similar) as perl code. +When no config name is supplied, the names and values of all known +config entries will be shown. + +=item set_feature + +Sets the given C to the given boolean value. Specify the value +as either 1 or 0. + +=item set_config + +Sets the given C entry to the given value. + +=item eval + +If the C<--eval> option is used, the values in C will be +evaluated as perl code before being stored. This allows moderately +complicated data structures to be stored. For really complicated +structures, you probably shouldn't use this command-line interface, +just use the Perl API instead. + +=item help + +Prints a help message, including a few examples, and exits. + +=back + +=head1 AUTHOR + +Ken Williams, kwilliams@cpan.org + +=head1 COPYRIGHT + +Copyright (c) 1999, Ken Williams. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +Module::Build(3), perl(1). + +=cut + +__END__ +:endofperl diff --git a/msys/mingw/bin/corelist.bat b/msys/mingw/bin/corelist.bat new file mode 100644 index 000000000..c5d205fe9 --- /dev/null +++ b/msys/mingw/bin/corelist.bat @@ -0,0 +1,507 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + eval 'exec C:\perl-5.24.0\bin\perl.exe -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 + +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 $upsream = $Module::CoreList::upstream{$mod}; + $upsream = 'undef' unless $upsream; + print "upstream: $upsream\n"; + if ( $upsream 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 + +__END__ +:endofperl diff --git a/msys/mingw/bin/cpan.bat b/msys/mingw/bin/cpan.bat new file mode 100644 index 000000000..92e0f7b8b --- /dev/null +++ b/msys/mingw/bin/cpan.bat @@ -0,0 +1,340 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + eval 'exec C:\perl-5.24.0\bin\perl.exe -S $0 ${1+"$@"}' + if $running_under_some_shell; +#!/usr/local/bin/perl + +use strict; +use vars qw($VERSION); + +use App::Cpan '1.60_02'; +$VERSION = '1.61'; + +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 [-cfgimtTw] module_name [ module_name ... ] + + # with just the dot, install from the distribution in the + # current directory + cpan . + + # without arguments, starts CPAN.pm shell + cpan + + # force install modules (usually those that fail tests) + cpan -f module_name [ module_name ... ] + + # install modules but without testing them + cpan -T module_name [ module_name ... ] + + # dump the configuration + cpan -J + + # load a different configuration to install Module::Foo + cpan -j some/other/file Module::Foo + + # without arguments, but some switches + cpan [-ahrvACDlLO] + +=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. + +=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 + +Install the specified modules. + +=item -I + +Load C (think like C<-I> for loading lib paths). + +=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 -O + +Show the out-of-date modules. + +=item -p + +Ping the configured mirrors + +=item -P + +Find the best mirrors you could be using (but doesn't configure them just yet) + +=item -r + +Recompiles dynamically loaded modules with CPAN::Shell->recompile. + +=item -t + +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. + +=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 + +=head1 ENVIRONMENT VARIABLES + +=over 4 + +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 CPAN_OPTS + +C splits this variable on whitespace and prepends that list to C<@ARGV> +before it processes the command-line arguments. For instance, if you always +want to use C, you can set C to C<-I>. + +=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. + +=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). + +=back + +=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-2014, brian d foy, All Rights Reserved. + +You may redistribute this under the same terms as Perl itself. + +=cut + +1; + +__END__ +:endofperl diff --git a/msys/mingw/bin/crc32 b/msys/mingw/bin/crc32 new file mode 100644 index 000000000..c129ee749 --- /dev/null +++ b/msys/mingw/bin/crc32 @@ -0,0 +1,48 @@ +#!/usr/bin/perl + +# Computes and prints to stdout the CRC-32 values of the given files + +use 5.006; +use strict; +use lib qw( blib/lib lib ); +use Archive::Zip; +use FileHandle; + +use vars qw( $VERSION ); +BEGIN { + $VERSION = '1.51'; +} + +my $totalFiles = scalar(@ARGV); +foreach my $file (@ARGV) { + if ( -d $file ) { + warn "$0: ${file}: Is a directory\n"; + next; + } + my $fh = FileHandle->new(); + if ( !$fh->open( $file, 'r' ) ) { + warn "$0: $!\n"; + next; + } + binmode($fh); + my $buffer; + my $bytesRead; + my $crc = 0; + while ( $bytesRead = $fh->read( $buffer, 32768 ) ) { + $crc = Archive::Zip::computeCRC32( $buffer, $crc ); + } + my $fileCrc = sprintf("%08x", $crc); + printf("$fileCrc"); + print("\t$file") if ( $totalFiles > 1 ); + + if ( $file =~ /[^[:xdigit:]]([[:xdigit:]]{8})[^[:xdigit:]]/ ) { + my $filenameCrc = $1; + if ( lc($filenameCrc) eq lc($fileCrc) ) { + print("\tOK") + } else { + print("\tBAD $fileCrc != $filenameCrc"); + } + } + + print("\n"); +} diff --git a/msys/mingw/bin/crc32.bat b/msys/mingw/bin/crc32.bat new file mode 100644 index 000000000..46084c0f7 --- /dev/null +++ b/msys/mingw/bin/crc32.bat @@ -0,0 +1,64 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!/usr/bin/perl +#line 15 + +# Computes and prints to stdout the CRC-32 values of the given files + +use 5.006; +use strict; +use lib qw( blib/lib lib ); +use Archive::Zip; +use FileHandle; + +use vars qw( $VERSION ); +BEGIN { + $VERSION = '1.51'; +} + +my $totalFiles = scalar(@ARGV); +foreach my $file (@ARGV) { + if ( -d $file ) { + warn "$0: ${file}: Is a directory\n"; + next; + } + my $fh = FileHandle->new(); + if ( !$fh->open( $file, 'r' ) ) { + warn "$0: $!\n"; + next; + } + binmode($fh); + my $buffer; + my $bytesRead; + my $crc = 0; + while ( $bytesRead = $fh->read( $buffer, 32768 ) ) { + $crc = Archive::Zip::computeCRC32( $buffer, $crc ); + } + my $fileCrc = sprintf("%08x", $crc); + printf("$fileCrc"); + print("\t$file") if ( $totalFiles > 1 ); + + if ( $file =~ /[^[:xdigit:]]([[:xdigit:]]{8})[^[:xdigit:]]/ ) { + my $filenameCrc = $1; + if ( lc($filenameCrc) eq lc($fileCrc) ) { + print("\tOK") + } else { + print("\tBAD $fileCrc != $filenameCrc"); + } + } + + print("\n"); +} + +__END__ +:endofperl diff --git a/msys/mingw/bin/dbilogstrip b/msys/mingw/bin/dbilogstrip new file mode 100644 index 000000000..9aa833121 --- /dev/null +++ b/msys/mingw/bin/dbilogstrip @@ -0,0 +1,50 @@ +#!perl + +=head1 NAME + +dbilogstrip - filter to normalize DBI trace logs for diff'ing + +=head1 SYNOPSIS + +Read DBI trace file C and write out a stripped version to C + + dbilogstrip dbitrace.log > dbitrace_stripped.log + +Run C twice, each with different sets of arguments, with +DBI_TRACE enabled. Filter the output and trace through C into a +separate file for each run. Then compare using diff. (This example assumes +you're using a standard shell.) + + DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log + DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log + diff -u dbitrace1.log dbitrace2.log + +=head1 DESCRIPTION + +Replaces any hex addresses, e.g, C<0x128f72ce> with C<0xN>. + +Replaces any references to process id or thread id, like C with C. + +So a DBI trace line like this: + + -> STORE for DBD::DBM::st (DBI::st=HASH(0x19162a0)~0x191f9c8 'f_params' ARRAY(0x1922018)) thr#1800400 + +will look like this: + + -> STORE for DBD::DBM::st (DBI::st=HASH(0xN)~0xN 'f_params' ARRAY(0xN)) thrN + +=cut + +use strict; + +while (<>) { + # normalize hex addresses: 0xDEADHEAD => 0xN + s/ \b 0x [0-9a-f]+ /0xN/gx; + # normalize process and thread id number + s/ \b (pid|tid|thr) \W? \d+ /${1}N/gx; + +} continue { + print or die "-p destination: $!\n"; +} + + diff --git a/msys/mingw/bin/dbilogstrip.bat b/msys/mingw/bin/dbilogstrip.bat new file mode 100644 index 000000000..34dd75b03 --- /dev/null +++ b/msys/mingw/bin/dbilogstrip.bat @@ -0,0 +1,66 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + +=head1 NAME + +dbilogstrip - filter to normalize DBI trace logs for diff'ing + +=head1 SYNOPSIS + +Read DBI trace file C and write out a stripped version to C + + dbilogstrip dbitrace.log > dbitrace_stripped.log + +Run C twice, each with different sets of arguments, with +DBI_TRACE enabled. Filter the output and trace through C into a +separate file for each run. Then compare using diff. (This example assumes +you're using a standard shell.) + + DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log + DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log + diff -u dbitrace1.log dbitrace2.log + +=head1 DESCRIPTION + +Replaces any hex addresses, e.g, C<0x128f72ce> with C<0xN>. + +Replaces any references to process id or thread id, like C with C. + +So a DBI trace line like this: + + -> STORE for DBD::DBM::st (DBI::st=HASH(0x19162a0)~0x191f9c8 'f_params' ARRAY(0x1922018)) thr#1800400 + +will look like this: + + -> STORE for DBD::DBM::st (DBI::st=HASH(0xN)~0xN 'f_params' ARRAY(0xN)) thrN + +=cut + +use strict; + +while (<>) { + # normalize hex addresses: 0xDEADHEAD => 0xN + s/ \b 0x [0-9a-f]+ /0xN/gx; + # normalize process and thread id number + s/ \b (pid|tid|thr) \W? \d+ /${1}N/gx; + +} continue { + print or die "-p destination: $!\n"; +} + + + +__END__ +:endofperl diff --git a/msys/mingw/bin/dbiprof b/msys/mingw/bin/dbiprof new file mode 100644 index 000000000..ba81c12b7 --- /dev/null +++ b/msys/mingw/bin/dbiprof @@ -0,0 +1,263 @@ +#!perl + +use strict; + +my $VERSION = sprintf("1.%06d", q$Revision$ =~ /(\d+)/o); + +use Data::Dumper; +use DBI::ProfileData; +use Getopt::Long; + +# default options +my $number = 10; +my $sort = 'total'; +my $filename = 'dbi.prof'; +my $reverse = 0; +my $case_sensitive = 0; +my (%match, %exclude); + +# get options from command line +GetOptions( + 'version' => sub { die "dbiprof $VERSION\n" }, + 'help' => sub { exit usage() }, + 'number=i' => \$number, + 'sort=s' => \$sort, + 'dumpnodes!' => \my $dumpnodes, + 'reverse' => \$reverse, + 'match=s' => \%match, + 'exclude=s' => \%exclude, + 'case-sensitive' => \$case_sensitive, + 'delete!' => \my $opt_delete, +) or exit usage(); + +sub usage { + print <new( + Files => \@files, + DeleteFiles => $opt_delete, + ); +}; +die "Unable to load profile data: $@\n" if $@; + +if (%match) { # handle matches + while (my ($key, $val) = each %match) { + if ($val =~ m!^/(.+)/$!) { + $val = $case_sensitive ? qr/$1/ : qr/$1/i; + } + $prof->match($key, $val, case_sensitive => $case_sensitive); + } +} + +if (%exclude) { # handle excludes + while (my ($key, $val) = each %exclude) { + if ($val =~ m!^/(.+)/$!) { + $val = $case_sensitive ? qr/$1/ : qr/$1/i; + } + $prof->exclude($key, $val, case_sensitive => $case_sensitive); + } +} + +# sort the data +$prof->sort(field => $sort, reverse => $reverse); + +# all done, print it out +if ($dumpnodes) { + $Data::Dumper::Indent = 1; + $Data::Dumper::Terse = 1; + $Data::Dumper::Useqq = 1; + $Data::Dumper::Deparse = 0; + print Dumper($prof->nodes); +} +else { + print $prof->report(number => $number); +} +exit 0; + +__END__ + +=head1 NAME + +dbiprof - command-line client for DBI::ProfileData + +=head1 SYNOPSIS + +See a report of the ten queries with the longest total runtime in the +profile dump file F: + + dbiprof prof1.out + +See the top 10 most frequently run queries in the profile file +F (the default): + + dbiprof --sort count + +See the same report with 15 entries: + + dbiprof --sort count --number 15 + +=head1 DESCRIPTION + +This tool is a command-line client for the DBI::ProfileData. It +allows you to analyze the profile data file produced by +DBI::ProfileDumper and produce various useful reports. + +=head1 OPTIONS + +This program accepts the following options: + +=over 4 + +=item --number N + +Produce this many items in the report. Defaults to 10. If set to +"all" then all results are shown. + +=item --sort field + +Sort results by the given field. Sorting by multiple fields isn't currently +supported (patches welcome). The available sort fields are: + +=over 4 + +=item total + +Sorts by total time run time across all runs. This is the default +sort. + +=item longest + +Sorts by the longest single run. + +=item count + +Sorts by total number of runs. + +=item first + +Sorts by the time taken in the first run. + +=item shortest + +Sorts by the shortest single run. + +=item key1 + +Sorts by the value of the first element in the Path, which should be numeric. +You can also sort by C and C. + +=back + +=item --reverse + +Reverses the selected sort. For example, to see a report of the +shortest overall time: + + dbiprof --sort total --reverse + +=item --match keyN=value + +Consider only items where the specified key matches the given value. +Keys are numbered from 1. For example, let's say you used a +DBI::Profile Path of: + + [ DBIprofile_Statement, DBIprofile_Methodname ] + +And called dbiprof as in: + + dbiprof --match key2=execute + +Your report would only show execute queries, leaving out prepares, +fetches, etc. + +If the value given starts and ends with slashes (C) then it will be +treated as a regular expression. For example, to only include SELECT +queries where key1 is the statement: + + dbiprof --match key1=/^SELECT/ + +By default the match expression is matched case-insensitively, but +this can be changed with the --case-sensitive option. + +=item --exclude keyN=value + +Remove items for where the specified key matches the given value. For +example, to exclude all prepare entries where key2 is the method name: + + dbiprof --exclude key2=prepare + +Like C<--match>, If the value given starts and ends with slashes +(C) then it will be treated as a regular expression. For example, +to exclude UPDATE queries where key1 is the statement: + + dbiprof --match key1=/^UPDATE/ + +By default the exclude expression is matched case-insensitively, but +this can be changed with the --case-sensitive option. + +=item --case-sensitive + +Using this option causes --match and --exclude to work +case-sensitively. Defaults to off. + +=item --delete + +Sets the C option to L which causes the +files to be deleted after reading. See L for more details. + +=item --dumpnodes + +Print the list of nodes in the form of a perl data structure. +Use the C<-sort> option if you want the list sorted. + +=item --version + +Print the dbiprof version number and exit. + +=back + +=head1 AUTHOR + +Sam Tregar + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2002 Sam Tregar + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl 5 itself. + +=head1 SEE ALSO + +L, +L, L. + +=cut + diff --git a/msys/mingw/bin/dbiprof.bat b/msys/mingw/bin/dbiprof.bat new file mode 100644 index 000000000..8c5bce392 --- /dev/null +++ b/msys/mingw/bin/dbiprof.bat @@ -0,0 +1,279 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + +use strict; + +my $VERSION = sprintf("1.%06d", q$Revision$ =~ /(\d+)/o); + +use Data::Dumper; +use DBI::ProfileData; +use Getopt::Long; + +# default options +my $number = 10; +my $sort = 'total'; +my $filename = 'dbi.prof'; +my $reverse = 0; +my $case_sensitive = 0; +my (%match, %exclude); + +# get options from command line +GetOptions( + 'version' => sub { die "dbiprof $VERSION\n" }, + 'help' => sub { exit usage() }, + 'number=i' => \$number, + 'sort=s' => \$sort, + 'dumpnodes!' => \my $dumpnodes, + 'reverse' => \$reverse, + 'match=s' => \%match, + 'exclude=s' => \%exclude, + 'case-sensitive' => \$case_sensitive, + 'delete!' => \my $opt_delete, +) or exit usage(); + +sub usage { + print <new( + Files => \@files, + DeleteFiles => $opt_delete, + ); +}; +die "Unable to load profile data: $@\n" if $@; + +if (%match) { # handle matches + while (my ($key, $val) = each %match) { + if ($val =~ m!^/(.+)/$!) { + $val = $case_sensitive ? qr/$1/ : qr/$1/i; + } + $prof->match($key, $val, case_sensitive => $case_sensitive); + } +} + +if (%exclude) { # handle excludes + while (my ($key, $val) = each %exclude) { + if ($val =~ m!^/(.+)/$!) { + $val = $case_sensitive ? qr/$1/ : qr/$1/i; + } + $prof->exclude($key, $val, case_sensitive => $case_sensitive); + } +} + +# sort the data +$prof->sort(field => $sort, reverse => $reverse); + +# all done, print it out +if ($dumpnodes) { + $Data::Dumper::Indent = 1; + $Data::Dumper::Terse = 1; + $Data::Dumper::Useqq = 1; + $Data::Dumper::Deparse = 0; + print Dumper($prof->nodes); +} +else { + print $prof->report(number => $number); +} +exit 0; + +__END__ + +=head1 NAME + +dbiprof - command-line client for DBI::ProfileData + +=head1 SYNOPSIS + +See a report of the ten queries with the longest total runtime in the +profile dump file F: + + dbiprof prof1.out + +See the top 10 most frequently run queries in the profile file +F (the default): + + dbiprof --sort count + +See the same report with 15 entries: + + dbiprof --sort count --number 15 + +=head1 DESCRIPTION + +This tool is a command-line client for the DBI::ProfileData. It +allows you to analyze the profile data file produced by +DBI::ProfileDumper and produce various useful reports. + +=head1 OPTIONS + +This program accepts the following options: + +=over 4 + +=item --number N + +Produce this many items in the report. Defaults to 10. If set to +"all" then all results are shown. + +=item --sort field + +Sort results by the given field. Sorting by multiple fields isn't currently +supported (patches welcome). The available sort fields are: + +=over 4 + +=item total + +Sorts by total time run time across all runs. This is the default +sort. + +=item longest + +Sorts by the longest single run. + +=item count + +Sorts by total number of runs. + +=item first + +Sorts by the time taken in the first run. + +=item shortest + +Sorts by the shortest single run. + +=item key1 + +Sorts by the value of the first element in the Path, which should be numeric. +You can also sort by C and C. + +=back + +=item --reverse + +Reverses the selected sort. For example, to see a report of the +shortest overall time: + + dbiprof --sort total --reverse + +=item --match keyN=value + +Consider only items where the specified key matches the given value. +Keys are numbered from 1. For example, let's say you used a +DBI::Profile Path of: + + [ DBIprofile_Statement, DBIprofile_Methodname ] + +And called dbiprof as in: + + dbiprof --match key2=execute + +Your report would only show execute queries, leaving out prepares, +fetches, etc. + +If the value given starts and ends with slashes (C) then it will be +treated as a regular expression. For example, to only include SELECT +queries where key1 is the statement: + + dbiprof --match key1=/^SELECT/ + +By default the match expression is matched case-insensitively, but +this can be changed with the --case-sensitive option. + +=item --exclude keyN=value + +Remove items for where the specified key matches the given value. For +example, to exclude all prepare entries where key2 is the method name: + + dbiprof --exclude key2=prepare + +Like C<--match>, If the value given starts and ends with slashes +(C) then it will be treated as a regular expression. For example, +to exclude UPDATE queries where key1 is the statement: + + dbiprof --match key1=/^UPDATE/ + +By default the exclude expression is matched case-insensitively, but +this can be changed with the --case-sensitive option. + +=item --case-sensitive + +Using this option causes --match and --exclude to work +case-sensitively. Defaults to off. + +=item --delete + +Sets the C option to L which causes the +files to be deleted after reading. See L for more details. + +=item --dumpnodes + +Print the list of nodes in the form of a perl data structure. +Use the C<-sort> option if you want the list sorted. + +=item --version + +Print the dbiprof version number and exit. + +=back + +=head1 AUTHOR + +Sam Tregar + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2002 Sam Tregar + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl 5 itself. + +=head1 SEE ALSO + +L, +L, L. + +=cut + + +__END__ +:endofperl diff --git a/msys/mingw/bin/dbiproxy b/msys/mingw/bin/dbiproxy new file mode 100644 index 000000000..10cd68c65 --- /dev/null +++ b/msys/mingw/bin/dbiproxy @@ -0,0 +1,184 @@ +#!perl + +use strict; + +my $VERSION = sprintf("1.%06d", q$Revision$ =~ /(\d+)/o); + +my $arg_test = shift(@ARGV) if $ARGV[0] eq '--test'; +$ENV{DBI_TRACE} = shift(@ARGV) || 2 if $ARGV[0] =~ s/^--dbitrace=?//; + +require DBI::ProxyServer; + +# XXX these should probably be moved into DBI::ProxyServer +delete $ENV{IFS}; +delete $ENV{CDPATH}; +delete $ENV{ENV}; +delete $ENV{BASH_ENV}; + +if ($arg_test) { + require RPC::PlServer::Test; + @DBI::ProxyServer::ISA = qw(RPC::PlServer::Test DBI); +} + +DBI::ProxyServer::main(@ARGV); + +exit(0); + + +__END__ + +=head1 NAME + +dbiproxy - A proxy server for the DBD::Proxy driver + +=head1 SYNOPSIS + + dbiproxy --localport= + + +=head1 DESCRIPTION + +This tool is just a front end for the DBI::ProxyServer package. All it +does is picking options from the command line and calling +DBI::ProxyServer::main(). See L for details. + +Available options include: + +=over 4 + +=item B<--chroot=dir> + +(UNIX only) After doing a bind(), change root directory to the given +directory by doing a chroot(). This is useful for security, but it +restricts the environment a lot. For example, you need to load DBI +drivers in the config file or you have to create hard links to Unix +sockets, if your drivers are using them. For example, with MySQL, a +config file might contain the following lines: + + my $rootdir = '/var/dbiproxy'; + my $unixsockdir = '/tmp'; + my $unixsockfile = 'mysql.sock'; + foreach $dir ($rootdir, "$rootdir$unixsockdir") { + mkdir 0755, $dir; + } + link("$unixsockdir/$unixsockfile", + "$rootdir$unixsockdir/$unixsockfile"); + require DBD::mysql; + + { + 'chroot' => $rootdir, + ... + } + +If you don't know chroot(), think of an FTP server where you can see a +certain directory tree only after logging in. See also the --group and +--user options. + +=item B<--configfile=file> + +Config files are assumed to return a single hash ref that overrides the +arguments of the new method. However, command line arguments in turn take +precedence over the config file. See the "CONFIGURATION FILE" section +in the L documentation for details on the config file. + +=item B<--debug> + +Turn debugging mode on. Mainly this asserts that logging messages of +level "debug" are created. + +=item B<--facility=mode> + +(UNIX only) Facility to use for L. The default is +B. + +=item B<--group=gid> + +After doing a bind(), change the real and effective GID to the given. +This is useful, if you want your server to bind to a privileged port +(<1024), but don't want the server to execute as root. See also +the --user option. + +GID's can be passed as group names or numeric values. + +=item B<--localaddr=ip> + +By default a daemon is listening to any IP number that a machine +has. This attribute allows one to restrict the server to the given +IP number. + +=item B<--localport=port> + +This attribute sets the port on which the daemon is listening. It +must be given somehow, as there's no default. + +=item B<--logfile=file> + +Be default logging messages will be written to the syslog (Unix) or +to the event log (Windows NT). On other operating systems you need to +specify a log file. The special value "STDERR" forces logging to +stderr. See L for details. + +=item B<--mode=modename> + +The server can run in three different modes, depending on the environment. + +If you are running Perl 5.005 and did compile it for threads, then the +server will create a new thread for each connection. The thread will +execute the server's Run() method and then terminate. This mode is the +default, you can force it with "--mode=threads". + +If threads are not available, but you have a working fork(), then the +server will behave similar by creating a new process for each connection. +This mode will be used automatically in the absence of threads or if +you use the "--mode=fork" option. + +Finally there's a single-connection mode: If the server has accepted a +connection, he will enter the Run() method. No other connections are +accepted until the Run() method returns (if the client disconnects). +This operation mode is useful if you have neither threads nor fork(), +for example on the Macintosh. For debugging purposes you can force this +mode with "--mode=single". + +=item B<--pidfile=file> + +(UNIX only) If this option is present, a PID file will be created at the +given location. Default is to not create a pidfile. + +=item B<--user=uid> + +After doing a bind(), change the real and effective UID to the given. +This is useful, if you want your server to bind to a privileged port +(<1024), but don't want the server to execute as root. See also +the --group and the --chroot options. + +UID's can be passed as group names or numeric values. + +=item B<--version> + +Suppresses startup of the server; instead the version string will +be printed and the program exits immediately. + +=back + + +=head1 AUTHOR + + Copyright (c) 1997 Jochen Wiedmann + Am Eisteich 9 + 72555 Metzingen + Germany + + Email: joe@ispsoft.de + Phone: +49 7123 14881 + +The DBI::ProxyServer module is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. In particular +permission is granted to Tim Bunce for distributing this as a part of +the DBI. + + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/msys/mingw/bin/dbiproxy.bat b/msys/mingw/bin/dbiproxy.bat new file mode 100644 index 000000000..822665934 --- /dev/null +++ b/msys/mingw/bin/dbiproxy.bat @@ -0,0 +1,200 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + +use strict; + +my $VERSION = sprintf("1.%06d", q$Revision$ =~ /(\d+)/o); + +my $arg_test = shift(@ARGV) if $ARGV[0] eq '--test'; +$ENV{DBI_TRACE} = shift(@ARGV) || 2 if $ARGV[0] =~ s/^--dbitrace=?//; + +require DBI::ProxyServer; + +# XXX these should probably be moved into DBI::ProxyServer +delete $ENV{IFS}; +delete $ENV{CDPATH}; +delete $ENV{ENV}; +delete $ENV{BASH_ENV}; + +if ($arg_test) { + require RPC::PlServer::Test; + @DBI::ProxyServer::ISA = qw(RPC::PlServer::Test DBI); +} + +DBI::ProxyServer::main(@ARGV); + +exit(0); + + +__END__ + +=head1 NAME + +dbiproxy - A proxy server for the DBD::Proxy driver + +=head1 SYNOPSIS + + dbiproxy --localport= + + +=head1 DESCRIPTION + +This tool is just a front end for the DBI::ProxyServer package. All it +does is picking options from the command line and calling +DBI::ProxyServer::main(). See L for details. + +Available options include: + +=over 4 + +=item B<--chroot=dir> + +(UNIX only) After doing a bind(), change root directory to the given +directory by doing a chroot(). This is useful for security, but it +restricts the environment a lot. For example, you need to load DBI +drivers in the config file or you have to create hard links to Unix +sockets, if your drivers are using them. For example, with MySQL, a +config file might contain the following lines: + + my $rootdir = '/var/dbiproxy'; + my $unixsockdir = '/tmp'; + my $unixsockfile = 'mysql.sock'; + foreach $dir ($rootdir, "$rootdir$unixsockdir") { + mkdir 0755, $dir; + } + link("$unixsockdir/$unixsockfile", + "$rootdir$unixsockdir/$unixsockfile"); + require DBD::mysql; + + { + 'chroot' => $rootdir, + ... + } + +If you don't know chroot(), think of an FTP server where you can see a +certain directory tree only after logging in. See also the --group and +--user options. + +=item B<--configfile=file> + +Config files are assumed to return a single hash ref that overrides the +arguments of the new method. However, command line arguments in turn take +precedence over the config file. See the "CONFIGURATION FILE" section +in the L documentation for details on the config file. + +=item B<--debug> + +Turn debugging mode on. Mainly this asserts that logging messages of +level "debug" are created. + +=item B<--facility=mode> + +(UNIX only) Facility to use for L. The default is +B. + +=item B<--group=gid> + +After doing a bind(), change the real and effective GID to the given. +This is useful, if you want your server to bind to a privileged port +(<1024), but don't want the server to execute as root. See also +the --user option. + +GID's can be passed as group names or numeric values. + +=item B<--localaddr=ip> + +By default a daemon is listening to any IP number that a machine +has. This attribute allows one to restrict the server to the given +IP number. + +=item B<--localport=port> + +This attribute sets the port on which the daemon is listening. It +must be given somehow, as there's no default. + +=item B<--logfile=file> + +Be default logging messages will be written to the syslog (Unix) or +to the event log (Windows NT). On other operating systems you need to +specify a log file. The special value "STDERR" forces logging to +stderr. See L for details. + +=item B<--mode=modename> + +The server can run in three different modes, depending on the environment. + +If you are running Perl 5.005 and did compile it for threads, then the +server will create a new thread for each connection. The thread will +execute the server's Run() method and then terminate. This mode is the +default, you can force it with "--mode=threads". + +If threads are not available, but you have a working fork(), then the +server will behave similar by creating a new process for each connection. +This mode will be used automatically in the absence of threads or if +you use the "--mode=fork" option. + +Finally there's a single-connection mode: If the server has accepted a +connection, he will enter the Run() method. No other connections are +accepted until the Run() method returns (if the client disconnects). +This operation mode is useful if you have neither threads nor fork(), +for example on the Macintosh. For debugging purposes you can force this +mode with "--mode=single". + +=item B<--pidfile=file> + +(UNIX only) If this option is present, a PID file will be created at the +given location. Default is to not create a pidfile. + +=item B<--user=uid> + +After doing a bind(), change the real and effective UID to the given. +This is useful, if you want your server to bind to a privileged port +(<1024), but don't want the server to execute as root. See also +the --group and the --chroot options. + +UID's can be passed as group names or numeric values. + +=item B<--version> + +Suppresses startup of the server; instead the version string will +be printed and the program exits immediately. + +=back + + +=head1 AUTHOR + + Copyright (c) 1997 Jochen Wiedmann + Am Eisteich 9 + 72555 Metzingen + Germany + + Email: joe@ispsoft.de + Phone: +49 7123 14881 + +The DBI::ProxyServer module is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. In particular +permission is granted to Tim Bunce for distributing this as a part of +the DBI. + + +=head1 SEE ALSO + +L, L, L + +=cut + +__END__ +:endofperl diff --git a/msys/mingw/bin/dmake.exe b/msys/mingw/bin/dmake.exe new file mode 100644 index 000000000..943084b0c Binary files /dev/null and b/msys/mingw/bin/dmake.exe differ diff --git a/msys/mingw/bin/enc2xs.bat b/msys/mingw/bin/enc2xs.bat new file mode 100644 index 000000000..2e056a491 --- /dev/null +++ b/msys/mingw/bin/enc2xs.bat @@ -0,0 +1,1486 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + eval 'exec C:\perl-5.24.0\bin\perl.exe -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; +} +use strict; +use warnings; +use Getopt::Std; +use Config; +my @orig_ARGV = @ARGV; +our $VERSION = do { my @r = (q$Revision: 2.18 $ =~ /\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 +eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32'); + +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. +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 = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV); +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"; + 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 $var = $static ? 'static const' : 'extern'; + my $count = $sized ? scalar(@{$a->{'Entries'}}) : ''; + print $fh "$var 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 $var = $static ? 'static const ' : ''; + print $fh "\n${var}encpage_t $name\[", + scalar(@{$a->{'Entries'}}), "] = {\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 :-) + +__END__ +:endofperl diff --git a/msys/mingw/bin/encguess.bat b/msys/mingw/bin/encguess.bat new file mode 100644 index 000000000..e4b6f6c1d --- /dev/null +++ b/msys/mingw/bin/encguess.bat @@ -0,0 +1,164 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + eval 'exec C:\perl-5.24.0\bin\perl.exe -S $0 ${1+"$@"}' + if $running_under_some_shell; +#!./perl +use 5.008001; +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.1 2015/02/05 10:34:19 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 + +__END__ +:endofperl diff --git a/msys/mingw/bin/exetype.bat b/msys/mingw/bin/exetype.bat new file mode 100644 index 000000000..fdd447211 --- /dev/null +++ b/msys/mingw/bin/exetype.bat @@ -0,0 +1,124 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl -w +#line 15 +use strict; + +# All the IMAGE_* structures are defined in the WINNT.H file +# of the Microsoft Platform SDK. + +my %subsys = (NATIVE => 1, + WINDOWS => 2, + CONSOLE => 3, + POSIX => 7, + WINDOWSCE => 9); + +unless (0 < @ARGV && @ARGV < 3) { + printf "Usage: $0 exefile [%s]\n", join '|', sort keys %subsys; + exit; +} + +$ARGV[1] = uc $ARGV[1] if $ARGV[1]; +unless (@ARGV == 1 || defined $subsys{$ARGV[1]}) { + (my $subsys = join(', ', sort keys %subsys)) =~ s/, (\w+)$/ or $1/; + print "Invalid subsystem $ARGV[1], please use $subsys\n"; + exit; +} + +my ($record,$magic,$signature,$offset,$size); +open EXE, "+< $ARGV[0]" or die "Cannot open $ARGV[0]: $!\n"; +binmode EXE; + +# read IMAGE_DOS_HEADER structure +read EXE, $record, 64; +($magic,$offset) = unpack "Sx58L", $record; + +die "$ARGV[0] is not an MSDOS executable file.\n" + unless $magic == 0x5a4d; # "MZ" + +# read signature, IMAGE_FILE_HEADER and first WORD of IMAGE_OPTIONAL_HEADER +seek EXE, $offset, 0; +read EXE, $record, 4+20+2; +($signature,$size,$magic) = unpack "Lx16Sx2S", $record; + +die "PE header not found" unless $signature == 0x4550; # "PE\0\0" + +die "Optional header is neither in NT32 nor in NT64 format" + unless ($size == 224 && $magic == 0x10b) || # IMAGE_NT_OPTIONAL_HDR32_MAGIC + ($size == 240 && $magic == 0x20b); # IMAGE_NT_OPTIONAL_HDR64_MAGIC + +# Offset 68 in the IMAGE_OPTIONAL_HEADER(32|64) is the 16 bit subsystem code +seek EXE, $offset+4+20+68, 0; +if (@ARGV == 1) { + read EXE, $record, 2; + my ($subsys) = unpack "S", $record; + $subsys = {reverse %subsys}->{$subsys} || "UNKNOWN($subsys)"; + print "$ARGV[0] uses the $subsys subsystem.\n"; +} +else { + print EXE pack "S", $subsys{$ARGV[1]}; +} +close EXE; +__END__ + +=head1 NAME + +exetype - Change executable subsystem type between "Console" and "Windows" + +=head1 SYNOPSIS + + C:\perl\bin> copy perl.exe guiperl.exe + C:\perl\bin> exetype guiperl.exe windows + +=head1 DESCRIPTION + +This program edits an executable file to indicate which subsystem the +operating system must invoke for execution. + +You can specify any of the following subsystems: + +=over + +=item CONSOLE + +The CONSOLE subsystem handles a Win32 character-mode application that +use a console supplied by the operating system. + +=item WINDOWS + +The WINDOWS subsystem handles an application that does not require a +console and creates its own windows, if required. + +=item NATIVE + +The NATIVE subsystem handles a Windows NT device driver. + +=item WINDOWSCE + +The WINDOWSCE subsystem handles Windows CE consumer electronics +applications. + +=item POSIX + +The POSIX subsystem handles a POSIX application in Windows NT. + +=back + +=head1 AUTHOR + +Jan Dubois + +=cut + +__END__ +:endofperl diff --git a/msys/mingw/bin/findrule b/msys/mingw/bin/findrule new file mode 100644 index 000000000..6aa37d64f --- /dev/null +++ b/msys/mingw/bin/findrule @@ -0,0 +1,138 @@ +#!perl -w +use strict; +use File::Find::Rule; +use File::Spec::Functions qw(catdir); + +# bootstrap extensions +for (@INC) { + my $dir = catdir($_, qw( File Find Rule ) ); + next unless -d $dir; + my @pm = find( name => '*.pm', maxdepth => 1, + exec => sub { (my $name = $_) =~ s/\.pm$//; + eval "require File::Find::Rule::$name"; }, + in => $dir ); +} + +# what directories are we searching in? +my @where; +while (@ARGV) { + local $_ = shift @ARGV; + if (/^-/) { + unshift @ARGV, $_; + last; + } + push @where, $_; +} + +# parse arguments, build a rule object +my $rule = new File::Find::Rule; +while (@ARGV) { + my $clause = shift @ARGV; + + unless ( $clause =~ s/^-// && $rule->can( $clause ) ) { + # not a known rule - complain about this + die "unknown option '$clause'\n" + } + + # it was the last switch + unless (@ARGV) { + $rule->$clause(); + next; + } + + # consume the parameters + my $param = shift @ARGV; + + if ($param =~ /^-/) { + # it's the next switch - put it back, and add one with no params + unshift @ARGV, $param; + $rule->$clause(); + next; + } + + if ($param eq '(') { + # multiple values - just look for the closing parenthesis + my @p; + while (@ARGV) { + my $val = shift @ARGV; + last if $val eq ')'; + push @p, $val; + } + $rule->$clause( @p ); + next; + } + + # a single argument + $rule->$clause( $param ); +} + +# add a print rule so things happen faster +$rule->exec( sub { print "$_[2]\n"; return; } ); + +# profit +$rule->in( @where ? @where : '.' ); +exit 0; + +__END__ + +=head1 NAME + +findrule - command line wrapper to File::Find::Rule + +=head1 USAGE + + findrule [path...] [expression] + +=head1 DESCRIPTION + +C mostly borrows the interface from GNU find(1) to provide a +command-line interface onto the File::Find::Rule heirarchy of modules. + +The syntax for expressions is the rule name, preceded by a dash, +followed by an optional argument. If the argument is an opening +parenthesis it is taken as a list of arguments, terminated by a +closing parenthesis. + +Some examples: + + find -file -name ( foo bar ) + +files named C or C, below the current directory. + + find -file -name foo -bar + +files named C, that have pubs (for this is what our ficticious +C clause specifies), below the current directory. + + find -file -name ( -bar ) + +files named C<-bar>, below the current directory. In this case if +we'd have omitted the parenthesis it would have parsed as a call to +name with no arguments, followed by a call to -bar. + +=head2 Supported switches + +I'm very slack. Please consult the File::Find::Rule manpage for now, +and prepend - to the commands that you want. + +=head2 Extra bonus switches + +findrule automatically loads all of your installed File::Find::Rule::* +extension modules, so check the documentation to see what those would be. + +=head1 AUTHOR + +Richard Clamp from a suggestion by Tatsuhiko Miyagawa + +=head1 COPYRIGHT + +Copyright (C) 2002 Richard Clamp. All Rights Reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +=cut diff --git a/msys/mingw/bin/findrule.bat b/msys/mingw/bin/findrule.bat new file mode 100644 index 000000000..46d0bf7d1 --- /dev/null +++ b/msys/mingw/bin/findrule.bat @@ -0,0 +1,154 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl -w +#line 15 +use strict; +use File::Find::Rule; +use File::Spec::Functions qw(catdir); + +# bootstrap extensions +for (@INC) { + my $dir = catdir($_, qw( File Find Rule ) ); + next unless -d $dir; + my @pm = find( name => '*.pm', maxdepth => 1, + exec => sub { (my $name = $_) =~ s/\.pm$//; + eval "require File::Find::Rule::$name"; }, + in => $dir ); +} + +# what directories are we searching in? +my @where; +while (@ARGV) { + local $_ = shift @ARGV; + if (/^-/) { + unshift @ARGV, $_; + last; + } + push @where, $_; +} + +# parse arguments, build a rule object +my $rule = new File::Find::Rule; +while (@ARGV) { + my $clause = shift @ARGV; + + unless ( $clause =~ s/^-// && $rule->can( $clause ) ) { + # not a known rule - complain about this + die "unknown option '$clause'\n" + } + + # it was the last switch + unless (@ARGV) { + $rule->$clause(); + next; + } + + # consume the parameters + my $param = shift @ARGV; + + if ($param =~ /^-/) { + # it's the next switch - put it back, and add one with no params + unshift @ARGV, $param; + $rule->$clause(); + next; + } + + if ($param eq '(') { + # multiple values - just look for the closing parenthesis + my @p; + while (@ARGV) { + my $val = shift @ARGV; + last if $val eq ')'; + push @p, $val; + } + $rule->$clause( @p ); + next; + } + + # a single argument + $rule->$clause( $param ); +} + +# add a print rule so things happen faster +$rule->exec( sub { print "$_[2]\n"; return; } ); + +# profit +$rule->in( @where ? @where : '.' ); +exit 0; + +__END__ + +=head1 NAME + +findrule - command line wrapper to File::Find::Rule + +=head1 USAGE + + findrule [path...] [expression] + +=head1 DESCRIPTION + +C mostly borrows the interface from GNU find(1) to provide a +command-line interface onto the File::Find::Rule heirarchy of modules. + +The syntax for expressions is the rule name, preceded by a dash, +followed by an optional argument. If the argument is an opening +parenthesis it is taken as a list of arguments, terminated by a +closing parenthesis. + +Some examples: + + find -file -name ( foo bar ) + +files named C or C, below the current directory. + + find -file -name foo -bar + +files named C, that have pubs (for this is what our ficticious +C clause specifies), below the current directory. + + find -file -name ( -bar ) + +files named C<-bar>, below the current directory. In this case if +we'd have omitted the parenthesis it would have parsed as a call to +name with no arguments, followed by a call to -bar. + +=head2 Supported switches + +I'm very slack. Please consult the File::Find::Rule manpage for now, +and prepend - to the commands that you want. + +=head2 Extra bonus switches + +findrule automatically loads all of your installed File::Find::Rule::* +extension modules, so check the documentation to see what those would be. + +=head1 AUTHOR + +Richard Clamp from a suggestion by Tatsuhiko Miyagawa + +=head1 COPYRIGHT + +Copyright (C) 2002 Richard Clamp. All Rights Reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +=cut + +__END__ +:endofperl diff --git a/msys/mingw/bin/h2ph.bat b/msys/mingw/bin/h2ph.bat new file mode 100644 index 000000000..05756d89c --- /dev/null +++ b/msys/mingw/bin/h2ph.bat @@ -0,0 +1,1002 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + eval 'exec C:\perl-5.24.0\bin\perl.exe -S $0 ${1+"$@"}' + if $running_under_some_shell; + +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 + + +__END__ +:endofperl diff --git a/msys/mingw/bin/h2xs.bat b/msys/mingw/bin/h2xs.bat new file mode 100644 index 000000000..c71d1a370 --- /dev/null +++ b/msys/mingw/bin/h2xs.bat @@ -0,0 +1,2221 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + eval 'exec C:\perl-5.24.0\bin\perl.exe -S $0 ${1+"$@"}' + if $running_under_some_shell; + +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; + +__END__ +:endofperl diff --git a/msys/mingw/bin/instmodsh.bat b/msys/mingw/bin/instmodsh.bat new file mode 100644 index 000000000..a9e67f13e --- /dev/null +++ b/msys/mingw/bin/instmodsh.bat @@ -0,0 +1,211 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + eval 'exec C:\perl-5.24.0\bin\perl.exe -S $0 ${1+"$@"}' + if $running_under_some_shell; +#!/usr/bin/perl -w + +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(); + +############################################################################### + +__END__ +:endofperl diff --git a/msys/mingw/bin/json_pp.bat b/msys/mingw/bin/json_pp.bat new file mode 100644 index 000000000..fe7ed43e6 --- /dev/null +++ b/msys/mingw/bin/json_pp.bat @@ -0,0 +1,224 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + eval 'exec C:\perl-5.24.0\bin\perl.exe -S $0 ${1+"$@"}' + if $running_under_some_shell; +#!/usr/bin/perl + +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 invalid json opttion" } 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 + + +__END__ +:endofperl diff --git a/msys/mingw/bin/libnetcfg.bat b/msys/mingw/bin/libnetcfg.bat new file mode 100644 index 000000000..525284fb5 --- /dev/null +++ b/msys/mingw/bin/libnetcfg.bat @@ -0,0 +1,737 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!perl +#line 15 + eval 'exec C:\perl-5.24.0\bin\perl.exe -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 $ + +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 = ( %{ 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; + +__END__ +:endofperl diff --git a/msys/mingw/bin/lwp-download b/msys/mingw/bin/lwp-download new file mode 100644 index 000000000..199aa0a77 --- /dev/null +++ b/msys/mingw/bin/lwp-download @@ -0,0 +1,330 @@ +#!/usr/bin/perl -w + +=head1 NAME + +lwp-download - Fetch large files from the web + +=head1 SYNOPSIS + +B [B<-a>] [B<-s>] > [>] + +=head1 DESCRIPTION + +The B program will save the file at I to a local +file. + +If I is not specified, then the current directory is +assumed. + +If I is a directory, then the last segment of the path of the +I is appended to form a local filename. If the I path ends with +slash the name "index" is used. With the B<-s> option pick up the last segment +of the filename from server provided sources like the Content-Disposition +header or any redirect URLs. A file extension to match the server reported +Content-Type might also be appended. If a file with the produced filename +already exists, then B will prompt before it overwrites and will +fail if its standard input is not a terminal. This form of invocation will +also fail is no acceptable filename can be derived from the sources mentioned +above. + +If I is not a directory, then it is simply used as the +path to save into. If the file already exists it's overwritten. + +The I program is implemented using the I +library. It is better suited to down load big files than the +I program because it does not store the file in memory. +Another benefit is that it will keep you updated about its progress +and that you don't have much options to worry about. + +Use the C<-a> option to save the file in text (ascii) mode. Might +make a difference on DOSish systems. + +=head1 EXAMPLE + +Fetch the newest and greatest perl version: + + $ lwp-download http://www.perl.com/CPAN/src/latest.tar.gz + Saving to 'latest.tar.gz'... + 11.4 MB received in 8 seconds (1.43 MB/sec) + +=head1 AUTHOR + +Gisle Aas + +=cut + +#' get emacs out of quote mode + +use strict; + +use LWP::UserAgent (); +use LWP::MediaTypes qw(guess_media_type media_suffix); +use URI (); +use HTTP::Date (); +use Encode; +use Encode::Locale; + +my $progname = $0; +$progname =~ s,.*/,,; # only basename left in progname +$progname =~ s,.*\\,, if $^O eq "MSWin32"; +$progname =~ s/\.\w*$//; # strip extension if any + +#parse option +use Getopt::Std; +my %opt; +unless (getopts('as', \%opt)) { + usage(); +} + +my $url = URI->new(decode(locale => shift) || usage()); +my $argfile = encode(locale_fs => decode(locale => shift)); +usage() if defined($argfile) && !length($argfile); +my $VERSION = "6.15"; + +my $ua = LWP::UserAgent->new( + agent => "lwp-download/$VERSION ", + keep_alive => 1, + env_proxy => 1, +); + +my $file; # name of file we download into +my $length; # total number of bytes to download +my $flength; # formatted length +my $size = 0; # number of bytes received +my $start_t; # start time of download +my $last_dur; # time of last callback + +my $shown = 0; # have we called the show() function yet + +$SIG{INT} = sub { die "Interrupted\n"; }; + +$| = 1; # autoflush + +my $res = $ua->request(HTTP::Request->new(GET => $url), + sub { + unless(defined $file) { + my $res = $_[1]; + + my $directory; + if (defined $argfile && -d $argfile) { + ($directory, $argfile) = ($argfile, undef); + } + + unless (defined $argfile) { + # find a suitable name to use + $file = $opt{s} && $res->filename; + + # if this fails we try to make something from the URL + unless ($file) { + $file = ($url->path_segments)[-1]; + if (!defined($file) || !length($file)) { + $file = "index"; + my $suffix = media_suffix($res->content_type); + $file .= ".$suffix" if $suffix; + } + elsif ($url->scheme eq 'ftp' || + $file =~ /\.t[bg]z$/ || + $file =~ /\.tar(\.(Z|gz|bz2?))?$/ + ) { + # leave the filename as it was + } + else { + my $ct = guess_media_type($file); + unless ($ct eq $res->content_type) { + # need a better suffix for this type + my $suffix = media_suffix($res->content_type); + $file .= ".$suffix" if $suffix; + } + } + } + + # validate that we don't have a harmful filename now. The server + # might try to trick us into doing something bad. + if (!length($file) || + $file =~ s/([^a-zA-Z0-9_\.\-\+\~])/sprintf "\\x%02x", ord($1)/ge || + $file =~ /^\./ + ) + { + die "Will not save <$url> as \"$file\".\nPlease override file name on the command line.\n"; + } + + if (defined $directory) { + require File::Spec; + $file = File::Spec->catfile($directory, $file); + } + + # Check if the file is already present + if (-l $file) { + die "Will not save <$url> to link \"$file\".\nPlease override file name on the command line.\n"; + } + elsif (-f _) { + die "Will not save <$url> as \"$file\" without verification.\nEither run from terminal or override file name on the command line.\n" + unless -t; + $shown = 1; + print "Overwrite $file? [y] "; + my $ans = ; + unless (defined($ans) && $ans =~ /^y?\n/) { + if (defined $ans) { + print "Ok, aborting.\n"; + } + else { + print "\nAborting.\n"; + } + exit 1; + } + $shown = 0; + } + elsif (-e _) { + die "Will not save <$url> as \"$file\". Path exists.\n"; + } + else { + print "Saving to '$file'...\n"; + use Fcntl qw(O_WRONLY O_EXCL O_CREAT); + sysopen(FILE, $file, O_WRONLY|O_EXCL|O_CREAT) || + die "Can't open $file: $!"; + } + } + else { + $file = $argfile; + } + unless (fileno(FILE)) { + open(FILE, ">", $file) || die "Can't open $file: $!\n"; + } + binmode FILE unless $opt{a}; + $length = $res->content_length; + $flength = fbytes($length) if defined $length; + $start_t = time; + $last_dur = 0; + } + + print FILE $_[0] or die "Can't write to $file: $!\n"; + $size += length($_[0]); + + if (defined $length) { + my $dur = time - $start_t; + if ($dur != $last_dur) { # don't update too often + $last_dur = $dur; + my $perc = $size / $length; + my $speed; + $speed = fbytes($size/$dur) . "/sec" if $dur > 3; + my $secs_left = fduration($dur/$perc - $dur); + $perc = int($perc*100); + my $show = "$perc% of $flength"; + $show .= " (at $speed, $secs_left remaining)" if $speed; + show($show, 1); + } + } + else { + show( fbytes($size) . " received"); + } + } +); + +if (fileno(FILE)) { + close(FILE) || die "Can't write to $file: $!\n"; + + show(""); # clear text + print "\r"; + print fbytes($size); + print " of ", fbytes($length) if defined($length) && $length != $size; + print " received"; + my $dur = time - $start_t; + if ($dur) { + my $speed = fbytes($size/$dur) . "/sec"; + print " in ", fduration($dur), " ($speed)"; + } + print "\n"; + + if (my $mtime = $res->last_modified) { + utime time, $mtime, $file; + } + + if ($res->header("X-Died") || !$res->is_success) { + if (my $died = $res->header("X-Died")) { + print "$died\n"; + } + if (-t) { + print "Transfer aborted. Delete $file? [n] "; + my $ans = ; + if (defined($ans) && $ans =~ /^y\n/) { + unlink($file) && print "Deleted.\n"; + } + elsif ($length > $size) { + print "Truncated file kept: ", fbytes($length - $size), " missing\n"; + } + else { + print "File kept.\n"; + } + exit 1; + } + else { + print "Transfer aborted, $file kept\n"; + } + } + exit 0; +} + +# Did not manage to create any file +print "\n" if $shown; +if (my $xdied = $res->header("X-Died")) { + print "$progname: Aborted\n$xdied\n"; +} +else { + print "$progname: ", $res->status_line, "\n"; +} +exit 1; + + +sub fbytes +{ + my $n = int(shift); + if ($n >= 1024 * 1024) { + return sprintf "%.3g MB", $n / (1024.0 * 1024); + } + elsif ($n >= 1024) { + return sprintf "%.3g KB", $n / 1024.0; + } + else { + return "$n bytes"; + } +} + +sub fduration +{ + use integer; + my $secs = int(shift); + my $hours = $secs / (60*60); + $secs -= $hours * 60*60; + my $mins = $secs / 60; + $secs %= 60; + if ($hours) { + return "$hours hours $mins minutes"; + } + elsif ($mins >= 2) { + return "$mins minutes"; + } + else { + $secs += $mins * 60; + return "$secs seconds"; + } +} + + +BEGIN { + my @ani = qw(- \ | /); + my $ani = 0; + + sub show + { + my($mess, $show_ani) = @_; + print "\r$mess" . (" " x (75 - length $mess)); + print $show_ani ? "$ani[$ani++]\b" : " "; + $ani %= @ani; + $shown++; + } +} + +sub usage +{ + die "Usage: $progname [-a] []\n"; +} diff --git a/msys/mingw/bin/lwp-download.bat b/msys/mingw/bin/lwp-download.bat new file mode 100644 index 000000000..9457840ae --- /dev/null +++ b/msys/mingw/bin/lwp-download.bat @@ -0,0 +1,346 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!/usr/bin/perl -w +#line 15 + +=head1 NAME + +lwp-download - Fetch large files from the web + +=head1 SYNOPSIS + +B [B<-a>] [B<-s>] > [>] + +=head1 DESCRIPTION + +The B program will save the file at I to a local +file. + +If I is not specified, then the current directory is +assumed. + +If I is a directory, then the last segment of the path of the +I is appended to form a local filename. If the I path ends with +slash the name "index" is used. With the B<-s> option pick up the last segment +of the filename from server provided sources like the Content-Disposition +header or any redirect URLs. A file extension to match the server reported +Content-Type might also be appended. If a file with the produced filename +already exists, then B will prompt before it overwrites and will +fail if its standard input is not a terminal. This form of invocation will +also fail is no acceptable filename can be derived from the sources mentioned +above. + +If I is not a directory, then it is simply used as the +path to save into. If the file already exists it's overwritten. + +The I program is implemented using the I +library. It is better suited to down load big files than the +I program because it does not store the file in memory. +Another benefit is that it will keep you updated about its progress +and that you don't have much options to worry about. + +Use the C<-a> option to save the file in text (ascii) mode. Might +make a difference on DOSish systems. + +=head1 EXAMPLE + +Fetch the newest and greatest perl version: + + $ lwp-download http://www.perl.com/CPAN/src/latest.tar.gz + Saving to 'latest.tar.gz'... + 11.4 MB received in 8 seconds (1.43 MB/sec) + +=head1 AUTHOR + +Gisle Aas + +=cut + +#' get emacs out of quote mode + +use strict; + +use LWP::UserAgent (); +use LWP::MediaTypes qw(guess_media_type media_suffix); +use URI (); +use HTTP::Date (); +use Encode; +use Encode::Locale; + +my $progname = $0; +$progname =~ s,.*/,,; # only basename left in progname +$progname =~ s,.*\\,, if $^O eq "MSWin32"; +$progname =~ s/\.\w*$//; # strip extension if any + +#parse option +use Getopt::Std; +my %opt; +unless (getopts('as', \%opt)) { + usage(); +} + +my $url = URI->new(decode(locale => shift) || usage()); +my $argfile = encode(locale_fs => decode(locale => shift)); +usage() if defined($argfile) && !length($argfile); +my $VERSION = "6.15"; + +my $ua = LWP::UserAgent->new( + agent => "lwp-download/$VERSION ", + keep_alive => 1, + env_proxy => 1, +); + +my $file; # name of file we download into +my $length; # total number of bytes to download +my $flength; # formatted length +my $size = 0; # number of bytes received +my $start_t; # start time of download +my $last_dur; # time of last callback + +my $shown = 0; # have we called the show() function yet + +$SIG{INT} = sub { die "Interrupted\n"; }; + +$| = 1; # autoflush + +my $res = $ua->request(HTTP::Request->new(GET => $url), + sub { + unless(defined $file) { + my $res = $_[1]; + + my $directory; + if (defined $argfile && -d $argfile) { + ($directory, $argfile) = ($argfile, undef); + } + + unless (defined $argfile) { + # find a suitable name to use + $file = $opt{s} && $res->filename; + + # if this fails we try to make something from the URL + unless ($file) { + $file = ($url->path_segments)[-1]; + if (!defined($file) || !length($file)) { + $file = "index"; + my $suffix = media_suffix($res->content_type); + $file .= ".$suffix" if $suffix; + } + elsif ($url->scheme eq 'ftp' || + $file =~ /\.t[bg]z$/ || + $file =~ /\.tar(\.(Z|gz|bz2?))?$/ + ) { + # leave the filename as it was + } + else { + my $ct = guess_media_type($file); + unless ($ct eq $res->content_type) { + # need a better suffix for this type + my $suffix = media_suffix($res->content_type); + $file .= ".$suffix" if $suffix; + } + } + } + + # validate that we don't have a harmful filename now. The server + # might try to trick us into doing something bad. + if (!length($file) || + $file =~ s/([^a-zA-Z0-9_\.\-\+\~])/sprintf "\\x%02x", ord($1)/ge || + $file =~ /^\./ + ) + { + die "Will not save <$url> as \"$file\".\nPlease override file name on the command line.\n"; + } + + if (defined $directory) { + require File::Spec; + $file = File::Spec->catfile($directory, $file); + } + + # Check if the file is already present + if (-l $file) { + die "Will not save <$url> to link \"$file\".\nPlease override file name on the command line.\n"; + } + elsif (-f _) { + die "Will not save <$url> as \"$file\" without verification.\nEither run from terminal or override file name on the command line.\n" + unless -t; + $shown = 1; + print "Overwrite $file? [y] "; + my $ans = ; + unless (defined($ans) && $ans =~ /^y?\n/) { + if (defined $ans) { + print "Ok, aborting.\n"; + } + else { + print "\nAborting.\n"; + } + exit 1; + } + $shown = 0; + } + elsif (-e _) { + die "Will not save <$url> as \"$file\". Path exists.\n"; + } + else { + print "Saving to '$file'...\n"; + use Fcntl qw(O_WRONLY O_EXCL O_CREAT); + sysopen(FILE, $file, O_WRONLY|O_EXCL|O_CREAT) || + die "Can't open $file: $!"; + } + } + else { + $file = $argfile; + } + unless (fileno(FILE)) { + open(FILE, ">", $file) || die "Can't open $file: $!\n"; + } + binmode FILE unless $opt{a}; + $length = $res->content_length; + $flength = fbytes($length) if defined $length; + $start_t = time; + $last_dur = 0; + } + + print FILE $_[0] or die "Can't write to $file: $!\n"; + $size += length($_[0]); + + if (defined $length) { + my $dur = time - $start_t; + if ($dur != $last_dur) { # don't update too often + $last_dur = $dur; + my $perc = $size / $length; + my $speed; + $speed = fbytes($size/$dur) . "/sec" if $dur > 3; + my $secs_left = fduration($dur/$perc - $dur); + $perc = int($perc*100); + my $show = "$perc% of $flength"; + $show .= " (at $speed, $secs_left remaining)" if $speed; + show($show, 1); + } + } + else { + show( fbytes($size) . " received"); + } + } +); + +if (fileno(FILE)) { + close(FILE) || die "Can't write to $file: $!\n"; + + show(""); # clear text + print "\r"; + print fbytes($size); + print " of ", fbytes($length) if defined($length) && $length != $size; + print " received"; + my $dur = time - $start_t; + if ($dur) { + my $speed = fbytes($size/$dur) . "/sec"; + print " in ", fduration($dur), " ($speed)"; + } + print "\n"; + + if (my $mtime = $res->last_modified) { + utime time, $mtime, $file; + } + + if ($res->header("X-Died") || !$res->is_success) { + if (my $died = $res->header("X-Died")) { + print "$died\n"; + } + if (-t) { + print "Transfer aborted. Delete $file? [n] "; + my $ans = ; + if (defined($ans) && $ans =~ /^y\n/) { + unlink($file) && print "Deleted.\n"; + } + elsif ($length > $size) { + print "Truncated file kept: ", fbytes($length - $size), " missing\n"; + } + else { + print "File kept.\n"; + } + exit 1; + } + else { + print "Transfer aborted, $file kept\n"; + } + } + exit 0; +} + +# Did not manage to create any file +print "\n" if $shown; +if (my $xdied = $res->header("X-Died")) { + print "$progname: Aborted\n$xdied\n"; +} +else { + print "$progname: ", $res->status_line, "\n"; +} +exit 1; + + +sub fbytes +{ + my $n = int(shift); + if ($n >= 1024 * 1024) { + return sprintf "%.3g MB", $n / (1024.0 * 1024); + } + elsif ($n >= 1024) { + return sprintf "%.3g KB", $n / 1024.0; + } + else { + return "$n bytes"; + } +} + +sub fduration +{ + use integer; + my $secs = int(shift); + my $hours = $secs / (60*60); + $secs -= $hours * 60*60; + my $mins = $secs / 60; + $secs %= 60; + if ($hours) { + return "$hours hours $mins minutes"; + } + elsif ($mins >= 2) { + return "$mins minutes"; + } + else { + $secs += $mins * 60; + return "$secs seconds"; + } +} + + +BEGIN { + my @ani = qw(- \ | /); + my $ani = 0; + + sub show + { + my($mess, $show_ani) = @_; + print "\r$mess" . (" " x (75 - length $mess)); + print $show_ani ? "$ani[$ani++]\b" : " "; + $ani %= @ani; + $shown++; + } +} + +sub usage +{ + die "Usage: $progname [-a] []\n"; +} + +__END__ +:endofperl diff --git a/msys/mingw/bin/lwp-dump b/msys/mingw/bin/lwp-dump new file mode 100644 index 000000000..e23a3783c --- /dev/null +++ b/msys/mingw/bin/lwp-dump @@ -0,0 +1,120 @@ +#!/usr/bin/perl -w + +use strict; +use LWP::UserAgent (); +use Getopt::Long qw(GetOptions); +use Encode; +use Encode::Locale; + +my $VERSION = "6.15"; + +GetOptions(\my %opt, + 'parse-head', + 'max-length=n', + 'keep-client-headers', + 'method=s', + 'agent=s', + 'request', +) || usage(); + +my $url = shift || usage(); +@ARGV && usage(); + +sub usage { + (my $progname = $0) =~ s,.*/,,; + die <<"EOT"; +Usage: $progname [options] + +Recognized options are: + --agent + --keep-client-headers + --max-length + --method + --parse-head + --request + +EOT +} + +my $ua = LWP::UserAgent->new( + parse_head => $opt{'parse-head'} || 0, + keep_alive => 1, + env_proxy => 1, + agent => $opt{agent} || "lwp-dump/$VERSION ", +); + +my $req = HTTP::Request->new($opt{method} || 'GET' => decode(locale => $url)); +my $res = $ua->simple_request($req); +$res->remove_header(grep /^Client-/, $res->header_field_names) + unless $opt{'keep-client-headers'} or + ($res->header("Client-Warning") || "") eq "Internal response"; + +if ($opt{request}) { + $res->request->dump; + print "\n"; +} + +$res->dump(maxlength => $opt{'max-length'}); + +__END__ + +=head1 NAME + +lwp-dump - See what headers and content is returned for a URL + +=head1 SYNOPSIS + +B [ I ] I + +=head1 DESCRIPTION + +The B program will get the resource identified by the URL and then +dump the response object to STDOUT. This will display the headers returned and +the initial part of the content, escaped so that it's safe to display even +binary content. The escapes syntax used is the same as for Perl's double +quoted strings. If there is no content the string "(no content)" is shown in +its place. + +The following options are recognized: + +=over + +=item B<--agent> I + +Override the user agent string passed to the server. + +=item B<--keep-client-headers> + +LWP internally generate various C headers that are stripped by +B in order to show the headers exactly as the server provided them. +This option will suppress this. + +=item B<--max-length> I + +How much of the content to show. The default is 512. Set this +to 0 for unlimited. + +If the content is longer then the string is chopped at the +limit and the string "...\n(### more bytes not shown)" +appended. + +=item B<--method> I + +Use the given method for the request instead of the default "GET". + +=item B<--parse-head> + +By default B will not try to initialize headers by looking at the +head section of HTML documents. This option enables this. This corresponds to +L. + +=item B<--request> + +Also dump the request sent. + +=back + +=head1 SEE ALSO + +L, L, L + diff --git a/msys/mingw/bin/lwp-dump.bat b/msys/mingw/bin/lwp-dump.bat new file mode 100644 index 000000000..39082dc8d --- /dev/null +++ b/msys/mingw/bin/lwp-dump.bat @@ -0,0 +1,136 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!/usr/bin/perl -w +#line 15 + +use strict; +use LWP::UserAgent (); +use Getopt::Long qw(GetOptions); +use Encode; +use Encode::Locale; + +my $VERSION = "6.15"; + +GetOptions(\my %opt, + 'parse-head', + 'max-length=n', + 'keep-client-headers', + 'method=s', + 'agent=s', + 'request', +) || usage(); + +my $url = shift || usage(); +@ARGV && usage(); + +sub usage { + (my $progname = $0) =~ s,.*/,,; + die <<"EOT"; +Usage: $progname [options] + +Recognized options are: + --agent + --keep-client-headers + --max-length + --method + --parse-head + --request + +EOT +} + +my $ua = LWP::UserAgent->new( + parse_head => $opt{'parse-head'} || 0, + keep_alive => 1, + env_proxy => 1, + agent => $opt{agent} || "lwp-dump/$VERSION ", +); + +my $req = HTTP::Request->new($opt{method} || 'GET' => decode(locale => $url)); +my $res = $ua->simple_request($req); +$res->remove_header(grep /^Client-/, $res->header_field_names) + unless $opt{'keep-client-headers'} or + ($res->header("Client-Warning") || "") eq "Internal response"; + +if ($opt{request}) { + $res->request->dump; + print "\n"; +} + +$res->dump(maxlength => $opt{'max-length'}); + +__END__ + +=head1 NAME + +lwp-dump - See what headers and content is returned for a URL + +=head1 SYNOPSIS + +B [ I ] I + +=head1 DESCRIPTION + +The B program will get the resource identified by the URL and then +dump the response object to STDOUT. This will display the headers returned and +the initial part of the content, escaped so that it's safe to display even +binary content. The escapes syntax used is the same as for Perl's double +quoted strings. If there is no content the string "(no content)" is shown in +its place. + +The following options are recognized: + +=over + +=item B<--agent> I + +Override the user agent string passed to the server. + +=item B<--keep-client-headers> + +LWP internally generate various C headers that are stripped by +B in order to show the headers exactly as the server provided them. +This option will suppress this. + +=item B<--max-length> I + +How much of the content to show. The default is 512. Set this +to 0 for unlimited. + +If the content is longer then the string is chopped at the +limit and the string "...\n(### more bytes not shown)" +appended. + +=item B<--method> I + +Use the given method for the request instead of the default "GET". + +=item B<--parse-head> + +By default B will not try to initialize headers by looking at the +head section of HTML documents. This option enables this. This corresponds to +L. + +=item B<--request> + +Also dump the request sent. + +=back + +=head1 SEE ALSO + +L, L, L + + +__END__ +:endofperl diff --git a/msys/mingw/bin/lwp-mirror b/msys/mingw/bin/lwp-mirror new file mode 100644 index 000000000..b19db17f3 --- /dev/null +++ b/msys/mingw/bin/lwp-mirror @@ -0,0 +1,105 @@ +#!/usr/bin/perl -w + +# Simple mirror utility using LWP + +=head1 NAME + +lwp-mirror - Simple mirror utility + +=head1 SYNOPSIS + + lwp-mirror [-v] [-t timeout] + +=head1 DESCRIPTION + +This program can be used to mirror a document from a WWW server. The +document is only transferred if the remote copy is newer than the local +copy. If the local copy is newer nothing happens. + +Use the C<-v> option to print the version number of this program. + +The timeout value specified with the C<-t> option. The timeout value +is the time that the program will wait for response from the remote +server before it fails. The default unit for the timeout value is +seconds. You might append "m" or "h" to the timeout value to make it +minutes or hours, respectively. + +Because this program is implemented using the LWP library, it only +supports the protocols that LWP supports. + +=head1 SEE ALSO + +L, L + +=head1 AUTHOR + +Gisle Aas + +=cut + + +use LWP::Simple qw(mirror is_success status_message $ua); +use Getopt::Std; +use Encode; +use Encode::Locale; + +$progname = $0; +$progname =~ s,.*/,,; # use basename only +$progname =~ s/\.\w*$//; #strip extension if any + +$VERSION = "6.15"; + +$opt_h = undef; # print usage +$opt_v = undef; # print version +$opt_t = undef; # timeout + +unless (getopts("hvt:")) { + usage(); +} + +if ($opt_v) { + require LWP; + my $DISTNAME = 'libwww-perl-' . LWP::Version(); + die <<"EOT"; +This is lwp-mirror version $VERSION ($DISTNAME) + +Copyright 1995-1999, Gisle Aas. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. +EOT +} + +$url = decode(locale => shift) or usage(); +$file = encode(locale_fs => decode(locale => shift)) or usage(); +usage() if $opt_h or @ARGV; + +if (defined $opt_t) { + $opt_t =~ /^(\d+)([smh])?/; + die "$progname: Illegal timeout value!\n" unless defined $1; + $timeout = $1; + $timeout *= 60 if ($2 eq "m"); + $timeout *= 3600 if ($2 eq "h"); + $ua->timeout($timeout); +} + +$rc = mirror($url, $file); + +if ($rc == 304) { + print STDERR "$progname: $file is up to date\n" +} +elsif (!is_success($rc)) { + print STDERR "$progname: $rc ", status_message($rc), " ($url)\n"; + exit 1; +} +exit; + + +sub usage +{ + die <<"EOT"; +Usage: $progname [-options] + -v print version number of program + -t Set timeout value +EOT +} diff --git a/msys/mingw/bin/lwp-mirror.bat b/msys/mingw/bin/lwp-mirror.bat new file mode 100644 index 000000000..57810f23a --- /dev/null +++ b/msys/mingw/bin/lwp-mirror.bat @@ -0,0 +1,121 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!/usr/bin/perl -w +#line 15 + +# Simple mirror utility using LWP + +=head1 NAME + +lwp-mirror - Simple mirror utility + +=head1 SYNOPSIS + + lwp-mirror [-v] [-t timeout] + +=head1 DESCRIPTION + +This program can be used to mirror a document from a WWW server. The +document is only transferred if the remote copy is newer than the local +copy. If the local copy is newer nothing happens. + +Use the C<-v> option to print the version number of this program. + +The timeout value specified with the C<-t> option. The timeout value +is the time that the program will wait for response from the remote +server before it fails. The default unit for the timeout value is +seconds. You might append "m" or "h" to the timeout value to make it +minutes or hours, respectively. + +Because this program is implemented using the LWP library, it only +supports the protocols that LWP supports. + +=head1 SEE ALSO + +L, L + +=head1 AUTHOR + +Gisle Aas + +=cut + + +use LWP::Simple qw(mirror is_success status_message $ua); +use Getopt::Std; +use Encode; +use Encode::Locale; + +$progname = $0; +$progname =~ s,.*/,,; # use basename only +$progname =~ s/\.\w*$//; #strip extension if any + +$VERSION = "6.15"; + +$opt_h = undef; # print usage +$opt_v = undef; # print version +$opt_t = undef; # timeout + +unless (getopts("hvt:")) { + usage(); +} + +if ($opt_v) { + require LWP; + my $DISTNAME = 'libwww-perl-' . LWP::Version(); + die <<"EOT"; +This is lwp-mirror version $VERSION ($DISTNAME) + +Copyright 1995-1999, Gisle Aas. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. +EOT +} + +$url = decode(locale => shift) or usage(); +$file = encode(locale_fs => decode(locale => shift)) or usage(); +usage() if $opt_h or @ARGV; + +if (defined $opt_t) { + $opt_t =~ /^(\d+)([smh])?/; + die "$progname: Illegal timeout value!\n" unless defined $1; + $timeout = $1; + $timeout *= 60 if ($2 eq "m"); + $timeout *= 3600 if ($2 eq "h"); + $ua->timeout($timeout); +} + +$rc = mirror($url, $file); + +if ($rc == 304) { + print STDERR "$progname: $file is up to date\n" +} +elsif (!is_success($rc)) { + print STDERR "$progname: $rc ", status_message($rc), " ($url)\n"; + exit 1; +} +exit; + + +sub usage +{ + die <<"EOT"; +Usage: $progname [-options] + -v print version number of program + -t Set timeout value +EOT +} + +__END__ +:endofperl diff --git a/msys/mingw/bin/lwp-request b/msys/mingw/bin/lwp-request new file mode 100644 index 000000000..9aa03ce39 --- /dev/null +++ b/msys/mingw/bin/lwp-request @@ -0,0 +1,552 @@ +#!/usr/bin/perl -w + +# Simple user agent using LWP library. + +=head1 NAME + +lwp-request, GET, POST, HEAD - Simple command line user agent + +=head1 SYNOPSIS + +B [B<-afPuUsSedvhx>] [B<-m> I] [B<-b> I] [B<-t> I] + [B<-i> I] [B<-c> I] + [B<-C> I] [B<-p> I] [B<-o> I] I... + +=head1 DESCRIPTION + +This program can be used to send requests to WWW servers and your +local file system. The request content for POST and PUT +methods is read from stdin. The content of the response is printed on +stdout. Error messages are printed on stderr. The program returns a +status value indicating the number of URLs that failed. + +The options are: + +=over 4 + +=item -m + +Set which method to use for the request. If this option is not used, +then the method is derived from the name of the program. + +=item -f + +Force request through, even if the program believes that the method is +illegal. The server might reject the request eventually. + +=item -b + +This URI will be used as the base URI for resolving all relative URIs +given as argument. + +=item -t + +Set the timeout value for the requests. The timeout is the amount of +time that the program will wait for a response from the remote server +before it fails. The default unit for the timeout value is seconds. +You might append "m" or "h" to the timeout value to make it minutes or +hours, respectively. The default timeout is '3m', i.e. 3 minutes. + +=item -i