From: Shiar Date: Sat, 19 Jan 2008 05:29:47 +0000 (+0100) Subject: Merge commit 'raz/master' X-Git-Url: http://git.shiar.net/perl/schtarr.git/commitdiff_plain/65b175df2569427fb67295c5e131c94668fecbf6?hp=d674225247c0e76e85899e5e2a5549fe0ad9c245 Merge commit 'raz/master' Conflicts: screp --- diff --git a/Archive-MoPaQ/.gitignore b/Archive-MoPaQ/.gitignore new file mode 100644 index 0000000..f60ea58 --- /dev/null +++ b/Archive-MoPaQ/.gitignore @@ -0,0 +1,6 @@ +/Makefile +*.o +/MoPaQ.bs +/MoPaQ.c +/pm_to_blib +/blib diff --git a/Archive-MoPaQ/Changes b/Archive-MoPaQ/Changes new file mode 100644 index 0000000..b77c9a5 --- /dev/null +++ b/Archive-MoPaQ/Changes @@ -0,0 +1,7 @@ +Revision history for Archive::MoPaQ + +0.01 2007-11-27 +- Preliminary interface to libmpq. +- Open an archive with open($filename). +- Can extract files with extract($number). + diff --git a/Archive-MoPaQ/MANIFEST b/Archive-MoPaQ/MANIFEST new file mode 100644 index 0000000..7ec6303 --- /dev/null +++ b/Archive-MoPaQ/MANIFEST @@ -0,0 +1,8 @@ +Changes +Makefile.PL +MANIFEST +MoPaQ.xs +ppport.h +README +t/Archive-MoPaQ.t +lib/Archive/MoPaQ.pm diff --git a/Archive-MoPaQ/Makefile.PL b/Archive-MoPaQ/Makefile.PL new file mode 100644 index 0000000..98d4da0 --- /dev/null +++ b/Archive-MoPaQ/Makefile.PL @@ -0,0 +1,12 @@ +use 5.008008; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Archive::MoPaQ', + VERSION_FROM => 'lib/Archive/MoPaQ.pm', # finds $VERSION + PREREQ_PM => {}, + ABSTRACT_FROM => 'lib/Archive/MoPaQ.pm', # retrieve abstract from module + AUTHOR => 'Mischa POSLAWSKY ', + LIBS => ['-lmpq -lz'], + INC => '-I.', # e.g., '-I. -I/usr/local/lib/mpq': +); diff --git a/Archive-MoPaQ/MoPaQ.xs b/Archive-MoPaQ/MoPaQ.xs new file mode 100644 index 0000000..4ec9358 --- /dev/null +++ b/Archive-MoPaQ/MoPaQ.xs @@ -0,0 +1,91 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "ppport.h" + +#include "libmpq/mpq.h" + +typedef PerlIO * OutputStream; +typedef mpq_archive * Archive__MoPaQ; + + +MODULE = Archive::MoPaQ PACKAGE = Archive::MoPaQ + +Archive::MoPaQ init(package) + char *package; + CODE: + RETVAL = malloc(sizeof(mpq_archive)); + memset(RETVAL, 0, sizeof(mpq_archive)); + OUTPUT: + RETVAL + +int open(mpqa,filename) + Archive::MoPaQ mpqa; + char *filename; + CODE: + RETVAL = libmpq_archive_open(mpqa, filename); + OUTPUT: + RETVAL + +int get_size(mpqa) + Archive::MoPaQ mpqa; + CODE: + RETVAL = libmpq_archive_info(mpqa, LIBMPQ_MPQ_ARCHIVE_SIZE); + OUTPUT: + RETVAL + +int get_numfiles(mpqa) + Archive::MoPaQ mpqa; + CODE: + RETVAL = libmpq_archive_info(mpqa, LIBMPQ_MPQ_NUMFILES); + OUTPUT: + RETVAL + +int listopen(mpqa,listfile) + Archive::MoPaQ mpqa; + char* listfile; + CODE: + RETVAL = 0; + switch (libmpq_listfile_open(mpqa, listfile)) { + case LIBMPQ_CONF_EFILE_OPEN: + warn("found filelist, but could not open, so disabling listfile\n"); + break; + case LIBMPQ_CONF_EFILE_CORRUPT: + warn("found filelist with errors, so disabling listfile\n"); + break; + case LIBMPQ_CONF_EFILE_LIST_CORRUPT: + warn("found filelist, header matches %s, but filelist is corrupt.\n", mpqa->mpq_l->mpq_name); + break; + case LIBMPQ_CONF_EFILE_VERSION: + warn("found filelist, but libmpq %s is required.\n", mpqa->mpq_l->mpq_version); + break; + case LIBMPQ_CONF_EFILE_NOT_FOUND: + warn("Filelist not found"); + break; + default: +// printf("game: %s, file: %s, version: %s\n", mpqa->mpq_l->mpq_game, mpqa->mpq_l->mpq_name, mpqa->mpq_l->mpq_game_version); + RETVAL = 1; + } + OUTPUT: + RETVAL + +int extract(mpqa,nr) + Archive::MoPaQ mpqa; + int nr; + CODE: + if (libmpq_file_check(mpqa, &nr, LIBMPQ_FILE_TYPE_INT)) { + warn("file %i not found\n", nr); + } else { + RETVAL = libmpq_file_extract(mpqa, nr); + } + OUTPUT: + RETVAL + +void DESTROY(mpqa) + Archive::MoPaQ mpqa; + CODE: + libmpq_listfile_close(mpqa); + libmpq_archive_close(mpqa); + free(mpqa); + diff --git a/Archive-MoPaQ/README b/Archive-MoPaQ/README new file mode 100644 index 0000000..039b7c1 --- /dev/null +++ b/Archive-MoPaQ/README @@ -0,0 +1,20 @@ +Archive-MoPaQ version 0.01 +========================== + +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: + + libmpq + zlib + + diff --git a/Archive-MoPaQ/lib/Archive/MoPaQ.pm b/Archive-MoPaQ/lib/Archive/MoPaQ.pm new file mode 100644 index 0000000..7e3cae2 --- /dev/null +++ b/Archive-MoPaQ/lib/Archive/MoPaQ.pm @@ -0,0 +1,49 @@ +package Archive::MoPaQ; + +use 5.008008; +use strict; +use warnings; + +our $VERSION = '0.01'; + +require XSLoader; +XSLoader::load('Archive::MoPaQ', $VERSION); + +sub new { + my $class = shift; + my $self = Archive::MoPaQ->init; + bless $self, $class; +} + +1; + +__END__ + +=head1 NAME + +Archive::MoPaQ - Interface to libmpq archive library + +=head1 SYNOPSIS + + use Archive::MoPaQ; + my $mpq = Archive::MoPaQ->new; + $mpq->open("ladder/(4)Lost Temple.scm" or die; + $mpq->extract(1); # write map to file000001.xxx + +=head1 DESCRIPTION + +Preliminary interface to libmpq, under development. + +=head1 SEE ALSO + +The I library. + +=head1 AUTHOR + +Mischa POSLAWSKY + +=head1 COPYRIGHT AND LICENSE + +Undefined. + +=cut diff --git a/Archive-MoPaQ/ppport.h b/Archive-MoPaQ/ppport.h new file mode 100644 index 0000000..8f0beaa --- /dev/null +++ b/Archive-MoPaQ/ppport.h @@ -0,0 +1,4954 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.06_01 + + Automatically created by Devel::PPPort running under + perl 5.008008 on Sat Nov 24 20:54:03 2007. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.06_01 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.9.3. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --patch=I + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C or a C program to be installed. + +=head2 --diff=I + +Manually set the diff program and options to use. The default +is to use C, when installed, and output unified +context diffs. + +=head2 --compat-version=I + +Tell F to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F if you intend to be backward compatible only +up to a certain Perl version. + +=head2 --cplusplus + +Usually, F will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I + +Show portability information for API elements matching I. +If I is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C prefix is deprecated. Also, +some API functions used to have a C prefix. Using this form is +also deprecated. You can safely use the supported API, as F +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions that were not present in earlier +versions of Perl, and that can't be provided using a macro, you have +to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F. + +These functions will be marked C in the list shown by +C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions, you want either C or global variants. + +For a C function, use: + + #define NEED_function + +For a global function, use: + + #define NEED_function_GLOBAL + +Note that you mustn't have more than one global request for one +function in your project. + + Function Static Request Global Request + ----------------------------------------------------------------------------------------- + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions using the C macro. +Just C<#define> the macro before including C: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C. + +=back + +The good thing is that most of the above can be checked by running +F on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +To display portability information for the C function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F is causing failure during +the compilation of this module, please check if newer versions +of either this module or C are available on CPAN +before sending a bug report. + +If F was generated using the latest version of +C and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2005, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L. + +=cut + +use strict; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +usage() if $opt{help}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +# Never use C comments in this file!!!!! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +AvFILLp|5.004050||p +AvFILL||| +CLASS|||n +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002||p +Copy||| +CvPADLIST||| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvSV||| +Gv_AMupdate||| +HEf_SVKEY||5.004000| +HeHASH||5.004000| +HeKEY||5.004000| +HeKLEN||5.004000| +HePV||5.004000| +HeSVKEY_force||5.004000| +HeSVKEY_set||5.004000| +HeSVKEY||5.004000| +HeVAL||5.004000| +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LVRET||| +MARK||| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002||p +Move||| +NEWSV||| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newc||| +Newz||| +New||| +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERL_BCDVERSION|5.009003||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_INT_MAX|5.004000||p +PERL_INT_MIN|5.004000||p +PERL_LONG_MAX|5.004000||p +PERL_LONG_MIN|5.004000||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.007002||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.007002||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.007002||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.007002||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_QUAD_MAX|5.004000||p +PERL_QUAD_MIN|5.004000||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.004000||p +PERL_SHORT_MIN|5.004000||p +PERL_SUBVERSION|5.006000||p +PERL_UCHAR_MAX|5.004000||p +PERL_UCHAR_MIN|5.004000||p +PERL_UINT_MAX|5.004000||p +PERL_UINT_MIN|5.004000||p +PERL_ULONG_MAX|5.004000||p +PERL_ULONG_MIN|5.004000||p +PERL_UNUSED_DECL|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||n +PL_Sv|5.005000||p +PL_compiling|5.004050||p +PL_copline|5.005000||p +PL_curcop|5.004050||p +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_last_in_gv|||n +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofs_sv|||n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rsfp_filters|5.004050||p +PL_rsfp|5.004050||p +PL_rs|||n +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Poison|5.008000||p +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +ST||| +SVt_IV||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVHV||| +SVt_PVMG||| +SVt_PV||| +Safefree||| +Slab_Alloc||| +Slab_Free||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set||5.009003| +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX||| +SvPV_force_nomg|5.007002||p +SvPV_force||| +SvPV_nolen|5.006000||p +SvPV_nomg|5.007002||p +SvPV_set||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec||| +SvREFCNT_inc||| +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set||5.009003| +SvRV||| +SvSETMAGIC||| +SvSHARE||5.007003| +SvSTASH_set||5.009003| +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK||5.007001| +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set||5.009003| +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +THIS|||n +UNDERBAR|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN||| +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_VERSION_BOOTCHECK||| +XS_VERSION||| +XS||| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_pMY_CXT|5.007003||p +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHX_|5.006000||p +aTHX|5.006000||p +add_data||| +allocmy||| +amagic_call||| +any_dup||| +ao||| +append_elem||| +append_list||| +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +asIV||| +asUV||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_delete||5.006000| +av_exists||5.006000| +av_extend||| +av_fake||| +av_fetch||| +av_fill||| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_undef||| +av_unshift||| +ax|||n +bad_type||| +bind_match||| +block_end||| +block_gimme||5.004000| +block_start||| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_xsutils||| +bytes_from_utf8||5.007001| +bytes_to_utf8||5.006001| +cache_re||| +call_argv|5.006000||p +call_atexit||5.006000| +call_body||| +call_list_body||| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +calloc||5.007002|n +cando||| +cast_i32||5.006000| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_uni||| +checkcomma||| +checkposixcc||| +ck_anoncode||| +ck_bitop||| +ck_concat||| +ck_defined||| +ck_delete||| +ck_die||| +ck_eof||| +ck_eval||| +ck_exec||| +ck_exists||| +ck_exit||| +ck_ftst||| +ck_fun||| +ck_glob||| +ck_grep||| +ck_index||| +ck_join||| +ck_lengthconst||| +ck_lfun||| +ck_listiob||| +ck_match||| +ck_method||| +ck_null||| +ck_open||| +ck_repeat||| +ck_require||| +ck_retarget||| +ck_return||| +ck_rfun||| +ck_rvconst||| +ck_sassign||| +ck_select||| +ck_shift||| +ck_sort||| +ck_spair||| +ck_split||| +ck_subr||| +ck_substr||| +ck_svconst||| +ck_trunc||| +ck_unpack||| +cl_and||| +cl_anything||| +cl_init_zero||| +cl_init||| +cl_is_anything||| +cl_or||| +closest_cop||| +convert||| +cop_free||| +cr_textfilter||| +croak_nocontext|||vn +croak|||v +csighandler||5.007001|n +custom_op_desc||5.007003| +custom_op_name||5.007003| +cv_ckproto||| +cv_clone||| +cv_const_sv||5.004000| +cv_dump||| +cv_undef||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAXMARK||5.009003| +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +deb||5.007003|v +del_he||| +del_sv||| +delimcpy||5.004000| +depcom||| +deprecate_old||| +deprecate||| +despatch_signals||5.007001| +die_nocontext|||vn +die_where||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_chop||| +do_close||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_kv||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_oddball||| +do_op_dump||5.006000| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pipe||| +do_pmop_dump||5.006000| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch_body||| +docatch||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptosub||| +dounwind||| +dowantarray||| +dump_all||5.006000| +dump_eval||5.006000| +dump_fds||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs||5.006000| +dump_sub||5.006000| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_eaccess||| +eval_pv|5.006000||p +eval_sv|5.006000||p +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +fd_on_nosuid_fs||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +find_beginning||| +find_byclass||| +find_in_my_stash||| +find_runcv||| +find_rundefsvoffset||5.009002| +find_script||| +find_uninit_var||| +fold_constants||| +forbid_setid||| +force_ident||| +force_list||| +force_next||| +force_version||| +force_word||| +form_nocontext|||vn +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_av|5.006000||p +get_context||5.006000|n +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +gp_dup||| +gp_free||| +gp_ref||| +grok_bin|5.007003||p +grok_hex|5.007003||p +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_autoload4||5.004000| +gv_check||| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags||5.009002| +gv_fetchpv||| +gv_fetchsv||5.009002| +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_sv||| +gv_init||| +gv_share||| +gv_stashpvn|5.006000||p +gv_stashpv||| +gv_stashsv||| +he_dup||| +hek_dup||| +hfreeentries||| +hsplit||| +hv_assert||5.009001| +hv_auxinit||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.004000| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_exists_ent||5.004000| +hv_exists||| +hv_fetch_common||| +hv_fetch_ent||5.004000| +hv_fetch||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.004000| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_ksplit||5.004000| +hv_magic_check||| +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||5.009003| +hv_placeholders_set||5.009003| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.004000| +hv_store_flags||5.008000| +hv_store||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incl_perldb||| +incline||| +incpush||| +ingroup||| +init_argv_symbols||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_lexer||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +instr||| +intro_my||| +intuit_method||| +intuit_more||| +invert||| +io_close||| +isALNUM||| +isALPHA||| +isDIGIT||| +isLOWER||| +isSPACE||| +isUPPER||| +is_an_int||| +is_gv_magical_sv||| +is_gv_magical||| +is_handle_constructor||| +is_list_assignment||| +is_lvalue_sub||5.007001| +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.006000| +is_uni_alnumc||5.006000| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.006000| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_char_slow||| +is_utf8_char||5.006000| +is_utf8_cntrl||5.006000| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003| +is_utf8_string_loc||5.008001| +is_utf8_string||5.006001| +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +isa_lookup||| +items|||n +ix|||n +jmaybe||| +keyword||| +leave_scope||| +lex_end||| +lex_start||| +linklist||| +listkids||| +list||| +load_module_nocontext|||vn +load_module||5.006000|v +localize||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHu|5.009002||p +magic_clear_all_env||| +magic_clearenv||| +magic_clearpack||| +magic_clearsig||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_freeregexp||| +magic_getarylen||| +magic_getdefelem||| +magic_getglob||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_len||| +magic_methcall||| +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setamagic||| +magic_setarylen||| +magic_setbm||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_setfm||| +magic_setglob||| +magic_setisa||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +magicname||| +make_trie||| +malloced_size|||n +malloc||5.007002|n +markstack_grow||| +measure_struct||| +memEQ|5.004000||p +memNE|5.004000||p +mem_collxfrm||| +mess_alloc||| +mess_nocontext|||vn +mess||5.006000|v +method_common||| +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find||| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +missingterm||| +mode_from_discipline||| +modkids||| +mod||| +moreswitches||| +mul128||| +mulexp10|||n +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_betoh16|||n +my_betoh32|||n +my_betoh64|||n +my_betohi|||n +my_betohl|||n +my_betohs|||n +my_bzero|||n +my_chsize||| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_htobe16|||n +my_htobe32|||n +my_htobe64|||n +my_htobei|||n +my_htobel|||n +my_htobes|||n +my_htole16|||n +my_htole32|||n +my_htole64|||n +my_htolei|||n +my_htolel|||n +my_htoles|||n +my_htonl||| +my_kid||| +my_letoh16|||n +my_letoh32|||n +my_letoh64|||n +my_letohi|||n +my_letohl|||n +my_letohs|||n +my_lstat||| +my_memcmp||5.004000|n +my_memset|||n +my_ntohl||| +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_socketpair||5.007003|n +my_stat||| +my_strftime||5.007002| +my_swabn|||n +my_swap||| +my_unexec||| +my||| +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB|5.006000||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||| +newGVOP||| +newGVREF||| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMYSUB||5.006000| +newNULLLIST||| +newOP||| +newPADOP||5.006000| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.006000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSUB||| +newSVOP||| +newSVREF||| +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_share||5.007001| +newSVpvn|5.006000||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newUNOP||| +newWHILEOP||5.009003| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +next_symbol||| +nextargv||| +nextchar||| +ninstr||| +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsCV||| +oopsHV||| +op_clear||| +op_const_sv||| +op_dump||5.006000| +op_free||| +op_null||5.007002| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +open_script||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +pack_cat||5.007003| +pack_rec||| +package||| +packlist||5.008001| +pad_add_anon||| +pad_add_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||| +pad_findlex||| +pad_findmy||| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||| +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||| +pad_undef||| +parse_body||| +parse_unicode_opts||| +path_is_absolute||| +peep||| +pending_ident||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pmflag||| +pmop_dump||5.006000| +pmruntime||| +pmtrans||| +pop_scope||| +pregcomp||| +pregexec||| +pregfree||| +prepend_elem||| +printf_nocontext|||vn +ptr_table_clear||| +ptr_table_fetch||| +ptr_table_free||| +ptr_table_new||| +ptr_table_split||| +ptr_table_store||| +push_scope||| +put_byte||| +pv_display||5.006000| +pv_uni_display||5.007003| +qerror||| +re_croak2||| +re_dup||| +re_intuit_start||5.006000| +re_intuit_string||5.006000| +realloc||5.007002|n +reentrant_free||| +reentrant_init||| +reentrant_retry|||vn +reentrant_size||| +refkids||| +refto||| +ref||| +reg_node||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.007003| +regclass||| +regcp_set_to||| +regcppop||| +regcppush||| +regcurly||| +regdump||5.005000| +regexec_flags||5.005000| +reghop3||| +reghopmaybe3||| +reghopmaybe||| +reghop||| +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regoptail||| +regpiece||| +regpposixcc||| +regprop||| +regrepeat_hard||| +regrepeat||| +regtail||| +regtry||| +reguni||| +regwhite||| +reg||| +repeatcpy||| +report_evil_fh||| +report_uninit||| +require_errno||| +require_pv||5.006000| +rninstr||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +runops_debug||5.005000| +runops_standard||5.005000| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_aelem||5.004050| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hek_flags||| +save_helem||5.004050| +save_hints||5.005000| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||| +save_padsv||5.007001| +save_pptr||| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_svref||| +save_threadsv||5.005000| +save_vptr||5.006000| +savepvn||| +savepv||| +savesharedpv||5.007003| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +sawparens||| +scalar_mod_type||| +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.008001| +scan_word||| +scope||| +screaminstr||5.005000| +seed||| +set_context||5.006000|n +set_csh||| +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +setdefout||| +setenv_getix||| +share_hek_flags||| +share_hek||| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace||| +sortsv||5.007003| +ss_dup||| +stack_grow||| +start_glob||| +start_subparse||5.004000| +stashpv_hvname_match||5.009003| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2nv||| +sv_2pv_flags||5.007002| +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen||| +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff||| +sv_bless||| +sv_cat_decode||5.008001| +sv_catpv_mg|5.006000||p +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.006000||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.006000||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm||| +sv_compile_2op||5.008001| +sv_copypv||5.007003| +sv_dec||| +sv_del_backref||| +sv_derived_from||5.004000| +sv_dump||| +sv_dup||| +sv_eq||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_gets||5.004000| +sv_grow||| +sv_inc||| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_len_utf8||5.006000| +sv_len||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||5.007003| +sv_nv||5.005000| +sv_peek||5.005000| +sv_pos_b2u||5.006000| +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags||5.007002| +sv_pvn_force|||p +sv_pvn_nomg|5.007003||p +sv_pvn|5.006000||p +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_release_COW||| +sv_release_IVX||| +sv_replace||| +sv_report_used||| +sv_reset||| +sv_rvweaken||5.006000| +sv_setiv_mg|5.006000||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.006000||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.006000||p +sv_setpvn||| +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.006000||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.006000||p +sv_setuv|5.006000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_mg|5.006000||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.006000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +taint_env||| +taint_proper||| +tmps_grow||5.006000| +toLOWER||| +toUPPER||| +to_byte_substr||| +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.007003| +to_utf8_lower||5.007003| +to_utf8_substr||| +to_utf8_title||5.007003| +to_utf8_upper||5.007003| +tokeq||| +tokereport||| +too_few_arguments||| +too_many_arguments||| +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.004000| +upg_version||5.009000| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf16rev_textfilter||| +utf8_distance||5.006000| +utf8_hop||5.006000| +utf8_length||5.007001| +utf8_mg_pos_init||| +utf8_mg_pos||| +utf8_to_bytes||5.006001| +utf8_to_uvchr||5.007001| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||5.007001| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||5.007001| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vdie||| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module||5.006000| +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warner_nocontext|||vn +warner||5.006000|v +warn|||v +watch||| +whichsig||| +write_to_stderr||| +yyerror||| +yylex||| +yyparse||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %depends); +my $replace = 0; +my $hint = ''; + +while () { + if ($hint) { + if (m{^\s*\*\s(.*?)\s*$}) { + $hints{$hint} ||= ''; # suppress warning with older perls + $hints{$hint} .= "$1\n"; + } + else { + $hint = ''; + } + } + $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "$hints{$f}" if exists $hints{$f}; + $info++; + } + unless ($info) { + print "No portability information available.\n"; + } + $count++; + } + if ($count > 0) { + print "\n"; + } + else { + print "Found no API matching '$opt{'api-info'}'.\n"; + } + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( xs c h cc cpp ); +my $srcext = join '|', @srcext; + +if (@ARGV) { + my %seen; + @files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV; +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /\.($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*.$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/\.($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +unless (@files) { + die "No input files given!\n"; +} + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; }; + close IN; + + my %file = (orig => $c, changes => 0); + + # temporarily remove C comments from the code + my @ccom; + $c =~ s{ + ( + [^"'/]+ + | + (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+ + | + (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+ + ) + | + (/ (?: + \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / + | + /[^\r\n]* + )) + }{ + defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce"; + }egsx; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/); + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + if (exists $need{$_}) { + $file{needs}{$_} = 'static'; + } + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { + warning("Possibly wrong #define $1 in $filename"); + } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses}}) { + next unless $file{uses}{$func}; # if it's only a dependency + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + elsif (exists $replace{$func}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + else { + diag("Uses $func"); + } + hint($func); + } + + for $func (sort keys %{$file{uses_todo}}) { + warning("Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo})); + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and can_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <
$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while () { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub can_use +{ + eval "use @_;"; + return $@ eq ''; +} + +sub rec_depend +{ + my $func = shift; + my %seen; + return () unless exists $depends{$func}; + grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +sub hint +{ + $opt{quiet} and return; + $opt{hints} or return; + my $func = shift; + exists $hints{$func} or return; + $given_hints{$func}++ and return; + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print < +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ + +#ifdef I_LIMITS +# include +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif + +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif + +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) +/* Replace: 1 */ +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_na na +# define PL_no_modify no_modify +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_ppaddr ppaddr +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +/* Replace: 0 */ +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif +#ifndef NOOP +# define NOOP (void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR + +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif + +# define NUM2PTR(any,d) (any)(PTRV)(d) +# define PTR2IV(p) INT2PTR(IV,p) +# define PTR2UV(p) INT2PTR(UV,p) +# define PTR2NV(p) NUM2PTR(NV,p) + +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif + +#endif /* !INT2PTR */ + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC) +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#undef STMT_START +#undef STMT_END +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d) +#endif + +#endif +#ifndef Poison +# define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t)) +#endif +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u)) +#endif +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ + +/* Replace perl_eval_pv with eval_pv */ +/* eval_pv depends on eval_sv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5)) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +void +DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))) + start_subparse(), +#elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22)) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvPV_nolen + +#if defined(NEED_sv_2pv_nolen) +static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); +static +#else +extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); +#endif + +#ifdef sv_2pv_nolen +# undef sv_2pv_nolen +#endif +#define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a) +#define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen) + +#if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL) + +char * +DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} + +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() macro instead of sv_2pv_nolen(). + */ + +/* SvPV_nolen depends on sv_2pv_nolen */ +#define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_nolen(sv)) + +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0))) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +/* SvPVbyte depends on sv_2pvbyte */ +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif + +/* sv_2pvbyte_nolen depends on sv_2pv_nolen */ +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen sv_2pv_nolen +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ +#ifndef sv_pvn +# define sv_pvn(sv, len) SvPV(sv, len) +#endif + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ +#ifndef sv_pvn_force +# define sv_pvn_force(sv, len) SvPV_force(sv, len) +#endif + +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +/* sv_vcatpvf depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_vsetpvf depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +/* sv_vcatpvf_mg depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +/* sv_vsetpvf_mg depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef SvPV_force_nomg +# define SvPV_force_nomg SvPV_force +#endif + +#ifndef SvPV_nomg +# define SvPV_nomg SvPV +#endif + +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif + +/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */ +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif /* PERL_VERSION */ +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +/* grok_number depends on grok_numeric_radix */ + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/Archive-MoPaQ/t/Archive-MoPaQ.t b/Archive-MoPaQ/t/Archive-MoPaQ.t new file mode 100644 index 0000000..3ab3b29 --- /dev/null +++ b/Archive-MoPaQ/t/Archive-MoPaQ.t @@ -0,0 +1,15 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl Archive-MoPaQ.t' + +######################### + +# change 'tests => 1' to 'tests => last_test_to_print'; + +use Test::More tests => 1; +BEGIN { use_ok('Archive::MoPaQ') }; + +######################### + +# Insert your test code below, the Test::More module is use()ed here so read +# its man page ( perldoc Test::More ) for help writing this test script. + diff --git a/Archive-MoPaQ/typemap b/Archive-MoPaQ/typemap new file mode 100644 index 0000000..dadb295 --- /dev/null +++ b/Archive-MoPaQ/typemap @@ -0,0 +1 @@ +Archive::MoPaQ T_PTROBJ diff --git a/Data-StarCraft/lib/Data/StarCraft/Map.pm b/Data-StarCraft/lib/Data/StarCraft/Map.pm new file mode 100644 index 0000000..4b9953c --- /dev/null +++ b/Data-StarCraft/lib/Data/StarCraft/Map.pm @@ -0,0 +1,672 @@ +package Data::StarCraft::Map; + +use strict; +use warnings; +use Data::Dumper; + +our $VERSION = "0.10"; +our $DEBUG = 0; + +sub new { + my ($class) = @_; + bless {}, $class; +} + +sub _read { + my $self = shift; + my ($fh, $size, $seek) = @_; + seek *$fh, $seek, 0 if $seek; + read(*$fh, my $in, $size) eq $size or return undef; + return $in; +} + +sub open { + my $self = shift; + my ($file) = @_; + + while (not eof $file) { + local $_ = $self->_read($file, 8) + and my ($type, $size) = unpack "a4V", $_ + or die "Couldn't chunk header\n"; + $type =~ s/ +$//; +#printf STDERR "%s: %s\n", $type, $size; + defined $self->{$type} and warn "duplicate map chunk $type\n"; + $self->{$type} = $self->_read($file, $size); + } + return $self; +} + +sub version { + my $self = shift; + return 'v' . ord $self->{VER}; +} + +sub info { + my $self = shift; + my ($x, $y) = unpack "vv", $self->{DIM}; + return { + x => $x, + y => $y, + }; +} + +sub width { + return $_[0]->info->{x}; +} + +sub tiles { + my $self = shift; + my @map = unpack 'v*', $self->{MTXM}; + @map == $#map + 1 or warn(sprintf + "couldn't parse map: only %d tiles\n", scalar @map + ), return; + return \@map; +} + +my @maptile = ( + '!' => [ 0.. 31], + 'd' => [ 32.. 62, 63], # dirt (verified) + 'h' => [ 64.. 94], # high dirt + "~" => [ 96..117, 118..127], # water + 'j' => [128..159], # jungle/crushed rock + 'o' => [160..186, 187..191], # rocky/shale (verified) + 'R' => [192..223], # raised jungle + 'l' => [224..252, 253..255], # lava/ruins (verified)/flagstones? + 'b' => [256..287], # basilica? + 'x' => [288..319], # high jungle +# 'x' => [3745..3792], # high jungle + 'q' => [320..351], # high ruins + ' ' => [352..383], + 'a' => [384..415], # high basilica + 'm' => [416..447], # mud + ' ' => [448..479], + ' ' => [480..511], + + ' ' => [512..543], + ' ' => [544..575], + '/' => [576..607], # high dirt -> dirt (top left) + '/' => [608..639], # dirt -> high dirt + '\\' => [640..671], # high dirt -> dirt (top right) + '\\' => [672..703], # dirt -> high dirt (bottom left) + '\\' => [704..735], # high dirt -> dirt (bottom left) + '\\' => [736..767], # dirt -> high dirt (top right) + '/' => [768..863], + '=' => [864..1055], # some edge (tmp) + '=' => [1056..1183], + '=' => [1184..1727], + 'D' => [1728..1780], # edge water + '/' => [1760..1791], # dirt -> water (top left) + '\\' => [1792..1823], # dirt -> water (top right) + + 'd' => [609..611], + 'W' => [2048..2303], + '/' => [2304..2559], + 'W' => [2560..2815], + 'j' => [2816..3071], + 'd' => [3072..3327], + 'j' => [3328..3583], + 'x' => [3648..3839], + 'h' => [3840..4095], +# 'x' => [4096..4351], + 'h' => [4096..4351], +# 'x' => [4352..4607], +# ' ' => [4608..4863], + 'l' => [4864..5311], + 'q' => [5312..5503], + 'x' => [5504..5631], + 'q' => [5632..5759], + 'j' => [5760..5823], +# ' ' => [5824..5887], + '=' => [5888..6143], # raised jungle -> jungle +# ' ' => [6144..6655], + '/' => [6656..7167], + '/' => [7168..7359], # basilica -> crushed rock + '/' => [7360..7551], + 'i' => [7552..7807], # high temple +# ' ' => [7808..8959], +# '=' => [8960..9087], +# 'd' => [9088..9215], +# ' ' => [9216..9727], +# 'm' => [9728..9983], +# # >= 9984 unencountered +# ' ' => [19968..20480], # something here on twilight +# ' ' => [20544..20736], # center thing on twilight +# '~' => [20896..21023], # something in the water on twilight +# 'x' => [23104..23231], # something on twilight (on X or H) +# +# 'm' => [9216..9776], # mud <-> dirt +# 'r' => [5792..5875, 5888..5904], # raised jungle edge +# +# 'd' => [3042..3250], # dirt<->grass +# 'P' => [4608..4977], # dirt<->shale (verified) [also seems to be rocks on mud] +# #'=' => [768..1731], # dirt<->lava ridge (verified) + + 'h' => [16389], + '1' => [16405, 16388], + '2' => [16421, 16404, 16387], + '3' => [16437, 16420, 16403, 16386], + '4' => [16453, 16436, 16419, 16402, 16385], + '5' => [ 16435, 16418, 16401, 16384], + '6' => [ 16434, 16417, 16400], + '7' => [ 16433, 16416], + 'd' => [16501, 16432], + '7' => [16485, 16500], # these ↕ aren't ramps in temple!! + '6' => [16469, 16484, 16499], + '5' => [16453, 16468, 16483, 16498], + '4' => [ 16452, 16467, 16482, 16497], + '3' => [ 16451, 16466, 16481, 16496], + '2' => [ 16450, 16465, 16480], + '1' => [ 16449, 16464], + 'h' => [17248, 16448], + '1' => [17264, 17249], + '1' => [17280, 17265, 17250], + '2' => [17296, 17281, 17266, 17251], + '3' => [17312, 17297, 17282, 17267, 17252], + '4' => [17328, 17313, 17298, 17283, 17268, 17253], + '5' => [ 17329, 17314, 17299, 17284, 17269], + '6' => [ 17330, 17315, 17300, 17285], + '7' => [ 17331, 17316, 17301], + '7' => [ 17332, 17317], + 'd' => [17232, 17333], + '7' => [17216, 17233], + '7' => [17200, 17217, 17234], + '6' => [17184, 17201, 17218, 17235], + '5' => [17168, 17185, 17202, 17219, 17236], + '4' => [17152, 17169, 17186, 17203, 17220, 17237], + '3' => [ 17153, 17170, 17187, 17204, 17221], + '2' => [ 17154, 17171, 17188, 17205], + '1' => [ 17155, 17172, 17189], + '1' => [ 17156, 17173], + 'h' => [ 17157], +); + +my %eratile = ( + 4 => [ + # Longinus (by KuKulZa, modified MBCgame/iCCup) + # SPRP: 6,0,1,0 + # TYPE: 82,65,87,66 + # VER: 205,0 + # SIDE: 5,5,5,1,2,0,1,2,7,7,7,4 + 'd' => [ + 19760..19761, 19792, 19793, 19680, 19681, 19712, 19713, 19664, 19665, 19728, 19729, # D→J + 19808,19809, 19776,19777, 19872,19873, 19920,19921, + 19744,19745, 19696,19697, 19632,19633, 19696,19697, 19952,19953, + 19568,19569, # below ridge + 3618,3634, 3586,3602, # D←J + 3601, # D→J(3585) + ], + 'j' => [ + 21968, 21969, 21984, 21985, + 21824,21825,21840,21841, 21856,21857,21872,21873, 21792,21793, + 21808,21809, 21888,21889,21904,21905, + 3616,3632,3584,3600,3616,3632, # J→D + 3585, # J→D(3601) + ], + 'l' => [ + 22608..22611, 22624..22627, 22640..22643, + ], + 'o' => [ + 24850, # besides ladder + 20832,20833,20848,20849, 20768,20769,20784,20785, + 20864,20865,20880,20881, + 20704,20705,20720,20721, # large rock + 4432,4433,4434,4448,4449,4464,4465, + 4545,4561,4577,4593, 4544,4560,4576,4592, + ], + 'h' => [ + 18000,18001, # H→X + 17952,17953, 17936,17937, 17920,17921, 17856,17857, 17888,17889, # H→X unsure + 17984,17985, 18160,18161, 18128,18129, 18048,18049, + 19648,19649,19616,19617, 18016,18017, + 17696,17697,17712,17713, # tree + 17872,17873,17904,17905, 18144,18145, + 18448,18449,18464,18465,18480,18481, + ], + 'm' => [ # mud hole + 9219,9235,9539,9555, + 9218,9234,9795,9235,9811,9571,9587, + 9472,9488,9250,9266,9635,9651,9280,9296, + 9504,9520,9665,9681,9344,9360,9760,9776,9539,9555, + 9475,9491,9889,9905,9376,9392,9440,9456,9571,9587, + 9507,9523,9377,9393, + + 9537,9553, + 9569,9585,9474,9490,9283,9299,9216,9232,9536,9552, + 9536,9552,9923,9939,9283,9299,9506,9522,9827,9843,9728,9744,9568,9584, + 9283,9299,9217,9233,9731,9747,9568,9584,9699,9715,9315,9331,9284,9300,9217,9233,9955,9971, + 9763,9779,9793,9809,9379,9395,9664,9680,9316,9332,9249,9265,9536,9552, + 9443,9459,9921,9937,9284,9300,9216,9232,9284,9300,9216,9232,9696,9712,9345,9361,9409,9425,9604,9620,9568,9584, + 9216,9232,9764,9780,9248,9264,9316,9332,9248,9264,9346,9362,9441,9457,9860,9876,9537,9553, + 9728,9744,9444,9460,9667,9683,9348,9364,9411,9427,9602,9618,9378,9394,9444,9460,9569,9585, + 9891,9907,9380,9396,9443,9459,9858,9874,9540,9556, + 9379,9395,9442,9458,9572,9588, + ], + '/' => [ + # Longinus (by KuKulZa, modified MBCgame/iCCup) + 9125, 9141, 9126, 9142, # D→~ + 9120, 9136, # H→D + 9059,9075, 9189,9205, # D→~ + 19824,19825, # D→~ + 19200,19201,19216,19217, # object on D + ], + '/' => [ + 17632,17633,17648,17649, # H rotating thing + 18208,18209, # H skull thing + 18224,18225,18240,18241, # H statuey thing + ], + 'q' => [ + 23872,23873,23874,23875,23888,23889,23890,23891,23904,23905,23906,23907, # Q crater + 23680,23681,23696,23697,23712,23713, + ], + 'x' => [ + 24336,24337,24352,24353, 24272,24273,24288,24289, + 24272,24273,24288,24289, 24368,24369,24384,24385, + 4353,4369, 4385,4401,4353,4369, 4386,4402, 4385,4401, + 4386,4402,4354,4370,4386,4402, + ], + '/' => [ + 19856,19857,20144,20145, # D skeleton + ], + '/' => [21184], 'W' => [21185,21200,21201,21216,21217], # standing rock + '/' => [21232], 'W' => [21233,21248,21249,21264,21265], # standing rock + '7' => [25011, 25010], # M»H + '7' => [24699, 25143], 6 => [24716], # M»H + 'W' => # island o' rocks + [21120..21125, 21136..21141, 21152..21157, 21168..21173], + '/' => [21121,21122,21136..21139,21152..21154], + '~' => [21120,21124,21125,21141,21157,21171..21173], + '/' => [ + # D→~ coast + 8997,9013,8963,8979, 8996,9012,8963,8979,8993,9009, 8997,9013, + 8998,9014, 8993,9009, 9187,9203, 9121,9137, 9131,9147, 8992,9008, + 9190,9206, 9062,9078, 8996,9012, 9090,9106,9194,9210, + 9061,9077,9029,9045,9184,9200,8998,9014, 9024,9040,8997,9013, + ], + + # Lost Temple (default?) + # SPRP: 4,0,5,0 + # VER: 59,0 + # SIDE: 5,5,5,5,0,2,1,0,7,7,7,4 + '/' => [ + 9089,9105, # H←D + 9196,9212, # H←D→~ + 8966,8982, 8962,8978, # H→~ + 9088,9104, # D→D/~ + 16832..16835,16848..16851,16864..16867,16880..16883, # H→D ridge (ramp elsewhere?) + 16384..16389, 16400..16405, 16416..16421, 16432..16437, # idem + 8961,8977,9155,9171, # H←D→~ + 20160,20161,19984,19985,19986,19987,20000,20001,20002,20003, # D→H + 9124,9140, 9122,9138, 9002,9018, 8960,8976, 9168,9152, 8995,9011, # H→D→~ + 9057,9073, # H→D→~ temple.6 + 8968,8984, # D↔H + ], + 'j' => [ + 21952,21953, + ], + 'x' => [ + 4384,4400, 4352,4368, # X→H + ], + 'h' => [ + 18096,18097, 17968,17969, 18032,18033,18176,18177, + ], + 'd' => [ + 9347,9363,9953,9969,9473,9489,9251,9267,9633,9649,9505,9521,9410,9426, + 9347,9363, 19840,19841, 19888,19889, 20208,20209,20224,20225, + 20240,20241,20256,20257, 20272,20273,20288,20289, 19601,19600, + 20304,20305,20320,20321, # tree + ], + 'o' => [ + 4673,4689,4737,4753,4705,4721,4769,4785, # rocks on D + 4674,4690,4706,4722,4674,4690,4480,4496,4706,4722,4832,4848,4640,4656, + 4736,4752,4768,4784, + 4482,4498, 4834,4850, 4642,4658, + ], 'd' => [4498,4642], + 'm' => [ + # M→D mud holes + 9281,9297,9313,9329, 9281,9297,9313,9329, 9538,9554,9570,9586, + 9282,9298,9282,9298,9220,9236,9476,9492,9314,9330,9729,9745,9412,9428,9476,9492,9314,9330,9538,9554,9476,9492,9252,9268, + 9508,9524,9668,9684,9600,9616,9508,9524,9666,9682,9601,9617,9570,9586,9508,9524,9408,9424,9700,9716,9632,9648,9698,9714,9282,9298,9314,9330, + 9312,9328, 9412,9428, 9636,9652, 9634,9650, + 9730,9746, 9761,9777,9762,9778, 9794,9810, + 9732,9748, # temple.5 + 9603,9619, # temple.6 + ], + 'r' => [ + 5859,5875, 5858,5874, # top edge + ], + 'O' => # temple center ornament + [ + 22320,22321,22336,22337,22352,22353, + 22368,22369,22384,22385,22400,22401, + 22464..22467,22480..22483,22496..22499, + 22800,22801,22802,22803,22816,22817,22818,22819,22832,22833,22834,22835, + 22752,22753,22754,22755,22768,22769,22770,22771,22784,22785,22786,22787, + ], + 'l' => [ # cut out shapes + 22464,22467,22496,22499, 22321,22353, 22368,22400, + 22800,22802,22803,22832,22835, 22819, + 22752,22753,22755,22787,22784, 22768, + ], + 'D' => # underwater cave + [ + 21440,21441,21442,21443, 21456,21457,21458,21459, + 21472,21473,21474,21475, 21488,21489,21490,21491, + ], + 'W' => [21456, 21472,21473,21474,21475], + 'o' => [21442,21443], + '~' => [21488,21489, 21490,21491], + 'i' => [ + 23632,23633,23648,23649,23664,23665, 23584,23585,23600,23601,23616,23617, # statue things on Q + ], + 'D' => [1824..1839], 'W' => [1840..1855], # D→~ bright transition + 'D' => [1856..1871], 'd' => [1872..1887], # D→~ bleft ridge + 'W' => [1888..1903], 'D' => [1904..1919], # D→~ bleft transition + '~' => [1920..1935], 'W' => [1936..1951], # w→~ bleft transition + 'd' => [1952..1967], 'D' => [1968..1983], + 'D' => [1984..1999], 'W' => [2000..2015], + 'W' => [2016..2031], '~' => [2032..2047], + 'D' => [8965,8981, 8964,8980, 9174,9158, 9010,8994], # H→D→~ + 'd' => [19936,19937], # D→~ + '/' => [19905], 'd' => [19904], # H→D + 'r' => [ + 5825,5841, 5857,5873, # J→R→map edge + 5826,5842, # J↔R + ], + 'q' => [ + # gap + 23456,23457,23458,23459, 23472,23473,23474,23475, + 23488,23489,23490,23491, 23504,23505,23506,23507, + # towery thing + 23824,23825,23826,23827, 23840,23841,23842,23843, 23856,23857,23858,23859, + ], + + # Plains to Hill (v2.00 by Sir.Lupin) + # VER: 59,0 + # SPRP: 1,0,2,0 + # SIDE: 5,5,5,5,0,2,1,0,7,7,7,4 + # FORC: 0,0,0,0,1,1,1,1,31,0,30,0,29,0,28,0,1,11,0,0 + '/' => [ + # H→D bottom left side (may be a ramp elsewhere) + 16768,16769,16770,16771, 16784,16785,16786,16787, + 16800,16801,16802,16803, 16816,16817,16818,16819, + # idem bottom right side + 16960,16961,16962,16963, 16976,16977,16978,16979, + 16992,16993,16994,16995, 17008,17009,17010,17011, + # idem + 17088,17089,17090,17091, 17104,17105,17106,17107, + 17120,17121,17122,17123, 17136,17137,17138,17139, + ], + + # Python (v1.3 by Terrance, modified by Forgotten_/KeSPA) + # ERA: 100,0 + # TYPE: 82,65,87,66 + # VER: 205,0 + # SPRP: 1,0,7,0 + # SIDE: 5,5,5,5,0,2,1,0,7,7,7,4 + # FORC: 0,0,0,0,1,1,1,1,2,0,4,0,5,0,6,0,1,14,15,15 + 'x' => [ + 24464,24465, 24448,24449 + ], + 'h' => [ + 18064,18065, + ], + '/' => [ + 9186,9202, + 18112,18113, # H→D + 9154,9170,9027,9043,9157,9173, # H↔D + ], + 'O' => + [19504,19505,19520,19521, 18720,18721,18736,18737], # rock things + 'h' => [18737], + 'O' => # hole + [17488..17491,17504..17507,17520..17523,17536..17539], + 'h' => [17490,17491,17507,17523,17536..17539], + 'o' => [ + 4610, 4610,4626, 4481,4497,4513,4529, 4514,4530, + 4417,4608,4624,4418, 4512,4528, 4450,4466, + 4609,4625,4546,4562, 4833,4849, 4801,4817, 4800,4816, + ], + 'd' => [ + 4672,4688,4704,4720, # D↔O + 19584,19585, + 4416, # D→O + 4641,4657,4578,4594, 4802,4818, # O→D + ], + 'm' => [ + 9824,9840,9952,9968,9920,9936,9888,9904, 9796,9812,9924,9940, + 9697,9713, 9890,9906, 9922,9938, 9792,9808,9856,9872,9826,9842, + ], + 'o' => [4738,4770], 'd' => [4754,4786], + '/' => [18256,18257,18272,18273], 'h' => [18288,18289], # obelisk + '/' => # sunken temple + [21024..21029, 21040..21045, 21056..21061, 21072..21077, 21088..21093,21104..21109], + '~' => [21024,21104,21109,21027,21059,21076,21072,21093,], + 'W' => [21029, 21060,21045,21073,21090,21106,21092,21107,21075,21108,21058, 21056,21088,21105,21077], + 'O' => # ruins similar to 22464 + [22512..22515, 22528..22531, 22544..22547], + 'l' => [22512,22515, 22544,22547], + 'Q' => [17664,17665,17680,17681], # rock thing + 'Q' => [17728,17729,17744,17745], # tree + '/' => [17808,17824,17840], 'h' => [17809,17825,17841], + '6' => [25025], # D»H ramp (between D and 17328 = level 4) + +#}, 2 => { + # Twilight Star (default) + # (all guessed from low res thumb) + 'h' => [17584,17585], # H→D + 'r' => [5827,5843, 5824,5840,5856,5872], + 'W' => [ + # water objects + 20912,20913,20928,20929, 20896,20897, 20944, + 19440,19441,19456,19457, 20945,20960,20961, + 20816,20817, + ], + 'h' => [17760,17761,17776,17777, 17600,17601], + 'D' => [9093,9109], + 'o' => [19472..19475, 19488..19491], + 'o' => [ + 21728,21729, 21744,21745, 21760,21761, + 21776,21777, 19536,19537, 19538,19539, 19552..19555, + ], + 'j' => [3587,3603], + 'O' => [19232..19235, 19248..19251], 'j' => [19218,19219], + 'O' => [19938,19939,19954,19955], + 'h' => [17792,17793], + 'x' => [4356,4372], + 'O' => [ # exotic/shiny things and other objects + 18656,18657,18672,18673, 18496,18497,18512,18513, + 18560..18563, 18576..18579, 18592..18595, + 18528,18529,18544,18545, 18864,18865, + 18608..18611,18624..18627,18640..18643, + 18912..18915,18928..18931,18944..18947, + 18816..18819,18832..18835,18848..18851, + 18960..18963,18976..18979,18992..18995, + 19008..19011,19024..19027, + 19040..19043,19056..19059, + ], + 'A' => [ # X→A + 7811,7827,7873,7889,7809,7825,7875,7891, + 8707,8723,8737,8753,7874,7890,7808,7824,7872,7888,7904, + 8003,8019,8160,8176,7810,7826, + ], + 'a' => [ # A←X + 7843,7859,7905,7921,7841,7857,7907,7923, + 8705,8721,7971,7987,8065,8081,8738,8754,7840,7856, + 7920,7906,7922,7938,7954,7969,7985,8066,8082,8035,8051, + 7970,7986,8032,8048, + 8034,8050,7936,7952,8033,8049,7937,7953, + ], + 'R' => [6177,6193], + '/' => [18080,18081], + 'a' => [8032..8047], 'a' => [8048..8063], # #3 bottom left + 'A' => [7841..7843], 'a' => [7857..7859], # #2 top left + 'A' => [8000..8003], 'x' => [8016..8019], # #1 bottom right + 'A' => [8064..8067], 'a' => [8080..8083], # #2 bottom left + 'A' => [8224..8227], 'x' => [8240..8243], # #1 top right + 'A' => [8288..8291], 'x' => [8304..8307], # #1 bottom right + 'a' => [8355], 'A' => [8371], # #2 top right + 'a' => [8322], 'A' => [8338], # #2 top right + 'A' => [8512], 'x' => [8528], # #1 top right + 'x' => [7811], 'A' => [7827], + 'x' => [8096..8099], 'A' => [8112..8115], + 'x' => [8163], 'a' => [8179], + 'x' => [8192..8195], 'A' => [8208..8211], + 'x' => [8128..8131], 'A' => [8144..8147], + 'A' => [8258,8274], + 'a' => [7939,7955], # #3 bottom right + 'a' => [7968..7971], 'A' => [7984..7987], + 'A' => [8256,8272], + 'A' => [8257,8273, 8259,8275, 8162,8178], + + '!' => [], + + # tau cross (v1.1 by Rose.Of.Dream/BW4eVeR) + # ERA: 6 + # FORC: 0,0,0,1,1,1,1,1,7,0,6,0,5,0,4,0,1,15,15,15 + # SIDE: 5,5,5,1,0,2,1,0,7,7,7,4 + # SPRP: 1,0,2,0 + # TYPE: 82,65,87,66 + # VER: 205 + '?' => [ + 6176,6192, 20976,20977, 20592,20593, 21392,21393, 20800,20801, + 20608,20609, 20624,20625, 20640,20641, 20992,20993, 21008,21009, + 19922,19923,22070,22071, 19968..19971, 22230, + 22133,22137,22272,22157,22288,22313, + 20592,20593,21392,21393,20800,20801,20608,20609,20624,20625,20640,20641,20992,20993,21008,21009,19922,19923, + 22070,22071,19968,19969,19970,19971,22230,22272,22157,22288,22313,6147,6163,6178,6194,3589,3605,22147,22162,22163,22164, + 22180,22315,18400,18401,18336,18337,18192,18193,17730,17731,17826,17827,17746,17747,17842,17843, + 17762,17763,17794,17795,17778,17779,17810,17811,17616,17617, + 20688,20689,6145,6161,20736,20737,21408,21409,21410,21411, + 20752,20753,21424,21425,21426,21427,21376,21377,20656,20657, + 21312,21313,21314,21315,20672,20673,21328,21329,21330,21331, + 6146,6162,21344,21345,21346,21347,21360,21361,21362,21363,6144, + 6160, + ], + '2' => # bridges + [ + 22231..22235, 22246..22253, 22260..22269, + 22273..22285, 22289..22301, 22306..22312, 22324..22328, + ], + '4' => [22246..22253, 22273..22285, 22306..22312], + '2' => [ + 22084..22086, 22096..22103, 22112..22121, 22128..22139, + 22144..22156, 22165..22171, 22181..22199, + ], + '4' => [22084..22086, 22112..22121, 22144..22156, 22181..22199], + 'r' => [22342,22343], + + # Nostalgia (WGT13, v1.3 by Rose.of.Dream) + # ERA: 0,0 + # FORC: 0,0,0,0,1,1,1,1,12,0,11,0,10,0,9,0,1,14,0,0 + # SIDE: 5,5,5,5,0,2,1,0,7,7,7,4 + # SPRP: 1,0,4,0 + # TYPE: 82,65,87,66 + # VER: 205 + '!' => [], + ], # jungle +); + +our %tilechar; +while (my ($char, $matches) = splice @maptile, 0, 2) { + $tilechar{$_} = $char for @$matches; +} +while (my ($char, $matches) = splice @{$eratile{4}}, 0, 2) { + $tilechar{$_} = $char for @$matches; +} + +my @mapunit = ( # character => width, height, ids + '$' => [2,1, 176..178], # minerals + '*' => [2,1, 188], # gas + '@' => [2,2, 214], # start pos +); + +our %unitchar; +while (my ($char, $matches) = splice @mapunit, 0, 2) { + my @charinfo = ($char, splice @$matches, 0, 2); + $unitchar{$_} = \@charinfo for @$matches; +} + +sub tiles_parsed { + my $self = shift; + my $map = $self->tiles or return; + if ($self->{DEBUG}) { + use Tie::IxHash; + tie my %unknown, 'Tie::IxHash'; + defined $tilechar{$map->[$_]} or warn(sprintf + "unknown tile %d at (%d,%d)\n", + $map->[$_], $_ % $self->width, $_ / $self->width + ), $unknown{$map->[$_]} = $_ for 0 .. $#$map; + warn sprintf "unknown: %s\n", join ",", keys %unknown if keys %unknown; + } + $_ = defined $tilechar{$_} ? $tilechar{$_} : '?' for @$map; + for ($self->units) { + my ($chr, $width, $height) = defined $unitchar{$_->{id}} ? + @{ $unitchar{$_->{id}} } : ('#', 1, 1); + for my $x ($_->{x} .. $_->{x} + $width - 1) { + for my $y ($_->{y} .. $_->{y} + $height - 1) { + $map->[$x + $y * $self->width] = $chr; + } + } + } + return $map; +} + +sub units { + my $self = shift; + my @units; + for (my $i = 0; $i < length $self->{UNIT}; $i += 36) { + # d1, d2, x*32, y*32, unitid, bytes1, playerid, bytes2, mineral, bytes3 + my @pack = unpack "v5x6Cx3vx14", substr $self->{UNIT}, $i, 36; + push @units, { + id => $pack[4], + player => $pack[5], + amount => $pack[6], + x => $pack[2] >> 5, + y => $pack[3] >> 5, +# d1 => $pack[0], +# d2 => $pack[1], + }; + } + return @units; +} + +sub units_parsed { + my $self = shift; + my @units; + for ($self->units) { + my ($chr, $width, $height) = defined $unitchar{$_->{id}} ? + @{ $unitchar{delete $_->{id}} } : ('#', 1, 1); + $_->{chr} = $chr; + $_->{width} = $width; + push @units, $_; + } + return @units; +} + +sub colors { + my $self = shift; + my @colormap = ( + qw( + FF0000 0000FF 209070 88409C E87824 5C2C14 FFFFFF DCDC3C + 0F930F FCFC8F EFCEBD 547CDC + ), + 12 => "pale green", "gray", "pale yellow", "cyan", + 17 => "black", "neon blue", + 21 => "lavender", "black", + 30 => "sky blue", + 33 => "purple", + ); + my @players; + for (unpack "C*", $self->{COLR}) { + push @players, $colormap[$_] || "? (#$_)"; + } + return \@players; +} + +sub era { + my $self = shift; + return unpack "v", $self->{ERA}; +} + +1; + diff --git a/Data-StarCraft/lib/Data/StarCraft/Replay.pm b/Data-StarCraft/lib/Data/StarCraft/Replay.pm new file mode 100644 index 0000000..507f7d6 --- /dev/null +++ b/Data-StarCraft/lib/Data/StarCraft/Replay.pm @@ -0,0 +1,402 @@ +package Data::StarCraft::Replay; + +use strict; +use warnings; +use Data::Dumper; + +use constant { + CMD_REPEAT => 4, +}; + +my %build = ( + 0x19 => "morph", + 0x1E => "build", + 0x1F => "warp", + 0x24 => "add-on", + 0x2E => "evolve", + 0x47 => "land", +); +my %unit = ( + 0x00 => "Marine", + 0x01 => "Ghost", + 0x02 => "Vulture", + 0x03 => "Goliath", + # undef, + 0x05 => "Siege Tank", + # undef, + 0x07 => "SCV", + 0x08 => "Wraith", + 0x09 => "Science Vessel", + # undef, + 0x0B => "Dropship", + 0x0C => "Battlecruiser", + # undef, + 0x0E => "Nuke", + # (undef) x 0x11, + 0x20 => "Firebat", + # undef, + 0x22 => "Medic", + # undef, + # undef, + 0x25 => "Zergling", + 0x26 => "Hydralisk", + 0x27 => "Ultralisk", + # undef, + 0x29 => "Drone", + 0x2A => "Overlord", + 0x2B => "Mutalisk", + 0x2C => "Guardian", + 0x2D => "Queen", + 0x2E => "Defiler", + 0x2F => "Scourge", + # undef, + # undef, + 0x32 => "Infested Terran", + # (undef) x 7, + 0x3A => "Valkyrie", + # undef, + 0x3C => "Corsair", + 0x3D => "Dark Templar", + 0x3E => "Devourer", + # undef, + 0x40 => "Probe", + 0x41 => "Zealot", + 0x42 => "Dragoon", + 0x43 => "High Templar", + # undef, + 0x45 => "Shuttle", + 0x46 => "Scout", + 0x47 => "Arbiter", + 0x48 => "Carrier", + # (undef) x 0x0A, + 0x53 => "Reaver", + 0x54 => "Observer", + # (undef) x 0x12, + 0x67 => "Lurker", + # undef, + # undef, + 0x6A => "Command Center", + 0x6B => "ComSat", + 0x6C => "Nuclear Silo", + 0x6D => "Supply Depot", + 0x6E => "Refinery", # refinery? + 0x6F => "Barracks", + 0x70 => "Academy", # Academy? + 0x71 => "Factory", + 0x72 => "Starport", + 0x73 => "Control Tower", + 0x74 => "Science Facility", + 0x75 => "Covert Ops", + 0x76 => "Physics Lab", + # undef, + 0x78 => "Machine Shop", + # undef, + 0x7A => "Engineering Bay", + 0x7B => "Armory", + 0x7C => "Missile Turret", + 0x7D => "Bunker", + # (undef) x 4, + 0x82 => "Infested CC", + 0x83 => "Hatchery", + 0x84 => "Lair", + 0x85 => "Hive", + 0x86 => "Nydus Canal", + 0x87 => "Hydralisk Den", + 0x88 => "Defiler Mound", + 0x89 => "Greater Spire", + 0x8A => "Queens Nest", + 0x8B => "Evolution Chamber", + 0x8C => "Ultralisk Cavern", + 0x8D => "Spire", + 0x8E => "Spawning Pool", + 0x8F => "Creep Colony", + 0x90 => "Spore Colony", + # undef, + 0x92 => "Sunken Colony", + # undef, + # undef, + 0x95 => "Extractor", + # (undef) x 4, + 0x9A => "Nexus", + 0x9B => "Robotics Facility", + 0x9C => "Pylon", + 0x9D => "Assimilator", + # undef, + 0x9F => "Observatory", + 0xA0 => "Gateway", + # undef, + 0xA2 => "Photon Cannon", + 0xA3 => "Citadel of Adun", + 0xA4 => "Cybernetics Core", + 0xA5 => "Templar Archives", + 0xA6 => "Forge", + 0xA7 => "Stargate", + # undef, + 0xA9 => "Fleet Beacon", + 0xAA => "Arbiter Tribunal", + 0xAB => "Robotics Support Bay", + 0xAC => "Shield Battery", + # (undef) x 0x14, + 0xC0 => "Larva", + 0xC1 => "Rine/Bat", + 0xC2 => "Dark Archon", + 0xC3 => "Archon", + 0xC4 => "Scarab", + 0xC5 => "Interceptor", + 0xC6 => "Interceptor/Scarab", +); +my @upgrade = ( + "Terran Infantry Armor", + "Terran Vehicle Plating", + "Terran Ship Plating", + "Zerg Carapace", + "Zerg Flyer Carapace", + "Protoss Ground Armor", + "Protoss Air Armor", + "Terran Infantry Weapons", + "Terran Vehicle Weapons", + "Terran Ship Weapons", + "Zerg Melee Attacks", + "Zerg Missile Attacks", + "Zerg Flyer Attacks", + "Protoss Ground Weapons", + "Protoss Air Weapons", + "Protoss Plasma Shields", + # 0x10 + "U-238 Shells (Marine Range)", + "Ion Thrusters (Vulture Speed)", + undef, + "Titan Reactor (Science Vessel Energy)", + "Ocular Implants (Ghost Sight)", + "Moebius Reactor (Ghost Energy)", + "Apollo Reactor (Wraith Energy)", + "Colossus Reactor (Battle Cruiser Energy)", + "Ventral Sacs (Overlord Transport)", + "Antennae (Overlord Sight)", + "Pneumatized Carapace (Overlord Speed)", + "Metabolic Boost (Zergling Speed)", + "Adrenal Glands (Zergling Attack)", + "Muscular Augments (Hydralisk Speed)", + "Grooved Spines (Hydralisk Range)", + "Gamete Meiosis (Queen Energy)", + # 0x20 + "Defiler Energy", + "Singularity Charge (Dragoon Range)", + "Leg Enhancement (Zealot Speed)", + "Scarab Damage", + "Reaver Capacity", + "Gravitic Drive (Shuttle Speed)", + "Sensor Array (Observer Sight)", + "Gravitic Booster (Observer Speed)", + "Khaydarin Amulet (Templar Energy)", + "Apial Sensors (Scout Sight)", + "Gravitic Thrusters (Scout Speed)", + "Carrier Capacity", + "Khaydarin Core (Arbiter Energy)", + undef, + undef, + "Argus Jewel (Corsair Energy)", + # 0x30 + undef, + "Argus Talisman (Dark Archon Energy)", + "Caduceus Reactor (Medic Energy)", + "Chitinous Plating (Ultralisk Armor)", + "Anabolic Synthesis (Ultralisk Speed)", + "Charon Boosters (Goliath Range)", +); +my @research = ( + "Stim Pack", + "Lockdown", + "EMP Shockwave", + "Spider Mines", + undef, + "Siege Tank", + undef, + "Irradiate", + "Yamato Gun", + "Cloaking Field (wraith)", + "Personal Cloaking (ghost)", + "Burrow", + undef, + "Spawn Broodling", + undef, + "Plague", + # 0x10 + "Consume", + "Ensnare", + undef, + "Psionic Storm", + "Hallucination", + "Recall", + "Stasis Field", + undef, + "Restoration", + "Disruption Web", + undef, + "Mind Control", + undef, + undef, + "Optical Flare", + "Maelstrom", + # 0x20 + "Lurker Aspect", +); +my %action = ( + 0x00 => "Move", + 0x02 => "Unallowed Move?", + 0x06 => "Force move", + 0x08 => "Attack", + 0x09 => "Gather", + 0x0E => "Attack Move", + 0x13 => "Failed Casting (?)", + 0x17 => "#23 (?)", + 0x1B => "Infest CC", + 0x22 => "Repair", + 0x27 => "Clear Rally", + 0x28 => "Set Rally", + 0x4F => "Gather", + 0x50 => "Gather", + 0x70 => "Unload", + 0x71 => "Yamato", + 0x73 => "Lockdown", + 0x77 => "Dark Swarm", + 0x78 => "Parasite", + 0x79 => "Spawn Broodling", + 0x7A => "EMP", + 0x7E => "Launch Nuke", + 0x84 => "Lay Mine", + 0x8B => "ComSat Scan", + 0x8D => "Defense Matrix", + 0x8E => "Psionic Storm", + 0x8F => "Recall", + 0x90 => "Plague", + 0x91 => "Consume", + 0x92 => "Ensnare", + 0x93 => "Stasis", + 0x94 => "Hallucination", + 0x98 => "Patrol", + 0xB1 => "Heal", + 0xB4 => "Restore", + 0xB5 => "Disruption Web", + 0xB6 => "Mind Control", + 0xB8 => "Feedback", + 0xB9 => "Optic Flare", + 0xBA => "Maelstrom", + 0xC0 => "Irradiate", +); + +my %cmdread = ( + 0x09 => ["select", 1, 2 | CMD_REPEAT], + 0x0A => ["add", 1, 2 | CMD_REPEAT], + 0x0B => ["deselect", 1, 2 | CMD_REPEAT], + 0x0C => ["build", 1, \%build, 2, 2, 2, \%unit], + 0x0D => ["vision", 2], + 0x0E => ["ally", 2, 2], + 0x13 => ["hotkey", 1, [qw"assign select"], 1], + 0x14 => ["move", 2, 2, 2, 2, 1], # 1 = queued? + 0x15 => ["action", 2, 2, 2, 2, 1, \%action, 1, [qw"normal queued"]], + 0x18 => ["cancel"], + 0x19 => ["cancel hatch"], + 0x1A => ["stop", 1], +# 0x1B => ["move-thing??"], # tim: after hotkey (unit, reaver??) select; soon after reselected and moved + 0x1E => ["return cargo", 1], + 0x1F => ["train", 2, \%unit], + 0x20 => ["cancel train", 2], # == 254 + 0x21 => ["cloak", 1], + 0x22 => ["decloak", 1], + 0x23 => ["hatch", 2, \%unit], + 0x25 => ["unsiege", 1], + 0x26 => ["siege", 1], + 0x27 => ["arm", 0], # scarab/interceptor + 0x28 => ["unload all", 1], + 0x29 => ["unload", 2], + 0x2A => ["merge archon", 0], + 0x2B => ["hold position", 1], + 0x2C => ["burrow", 1], + 0x2D => ["unburrow", 1], + 0x2E => ["cancel nuke", 0], + 0x2F => ["lift", 2, 2], + 0x30 => ["research", 1, \@research], + 0x31 => ["cancel research", 0], + 0x32 => ["upgrade", 1, \@upgrade], +# 0x33 => ["forge-thing??"], # right after forge select: probably unpowered, iirc cancel research + 0x35 => ["morph", 2, \%unit], + 0x36 => ["stim", 0], + 0x57 => ["part", 1, {qw"1 quit 6 drop"}], + 0x5A => ["merge dark archon", 0], +); + +sub new { + my ($class) = @_; + bless [], $class; +} + +sub _read { + my $self = shift; + my ($fh, $size, $seek) = @_; + seek *$fh, $seek, 0 if $seek; + read(*$fh, my $in, $size) eq $size or return undef; + return $in; +} + +sub open { + my $self = shift; + my ($file) = @_; + + while (not eof $file) { + local $_ = $self->_read($file, 5) + and my ($time, $size) = unpack "VC", $_ + or die "Couldn't read time block head\n"; + local $_ = $self->_read($file, $size) + and my @block = unpack "C*", $_ + or die "Couldn't read time block data\n"; + while (@block) { + my $player = shift @block; + my $cmd = shift @block; + if (not defined $cmdread{$cmd}) { + warn sprintf "command #%X not defined: %d bytes ignored\n", + $cmd, scalar @block; + push @$self, [$time, $player, "??? $cmd"] if $SHOWWARN; + last; + } + + sub readbyte { + my ($data, $byte) = @_; + my $out = shift @$data; + if (($byte & 3) == 2) { + @$data ? ($out += shift(@$data) << 8) + : warn "high byte not present\n"; + } + return $out; + } + + my @format = @{ $cmdread{$cmd} }; + my $desc = shift @format; + my @data; + for my $bit (@format) { + if (ref $bit) { + if (ref $bit eq "ARRAY") { + $data[-1] = defined $bit->[$data[-1]] ? $bit->[$data[-1]] + : "? ($data[-1])"; + } else { + $data[-1] = defined $bit->{$data[-1]} ? $bit->{$data[-1]} + : "? ($data[-1])"; + } + next; + } + $bit & 3 or next; + if ($bit & CMD_REPEAT) { + push @data, readbyte(\@block, $bit) for 1 .. shift @data; + } else { + push @data, readbyte(\@block, $bit); + } + } + $desc eq "move" and $data[2] == 0 and $desc = "rally"; + push @$self, [$time, $player, $desc, @data]; + } + } + return $self; +} + +1; + diff --git a/scmap b/scmap index e052c76..cd564d3 100755 --- a/scmap +++ b/scmap @@ -14,674 +14,9 @@ GetOptions( "color|c" => \$SHOWCOL, ); -{ - -package Data::StarCraft::Map; - -sub new { - my ($class) = @_; - bless {}, $class; -} - -sub _read { - my $self = shift; - my ($fh, $size, $seek) = @_; - seek *$fh, $seek, 0 if $seek; - read(*$fh, my $in, $size) eq $size or return undef; - return $in; -} - -sub open { - my $self = shift; - my ($file) = @_; - - while (not eof $file) { - local $_ = $self->_read($file, 8) - and my ($type, $size) = unpack "a4V", $_ - or die "Couldn't chunk header\n"; - $type =~ s/ +$//; -#printf STDERR "%s: %s\n", $type, $size; - defined $self->{$type} and warn "duplicate map chunk $type\n"; - $self->{$type} = $self->_read($file, $size); - } - return $self; -} - -sub version { - my $self = shift; - return 'v' . ord $self->{VER}; -} - -sub info { - my $self = shift; - my ($x, $y) = unpack "vv", $self->{DIM}; - return { - x => $x, - y => $y, - }; -} - -sub width { - return $_[0]->info->{x}; -} - -sub tiles { - my $self = shift; - my @map = unpack 'v*', $self->{MTXM}; - @map == $#map + 1 or warn(sprintf - "couldn't parse map: only %d tiles\n", scalar @map - ), return; - return \@map; -} - -my @maptile = ( - '!' => [ 0.. 31], - 'd' => [ 32.. 62, 63], # dirt (verified) - 'h' => [ 64.. 94], # high dirt - "~" => [ 96..117, 118..127], # water - 'j' => [128..159], # jungle/crushed rock - 'o' => [160..186, 187..191], # rocky/shale (verified) - 'R' => [192..223], # raised jungle - 'l' => [224..252, 253..255], # lava/ruins (verified)/flagstones? - 'b' => [256..287], # basilica? - 'x' => [288..319], # high jungle -# 'x' => [3745..3792], # high jungle - 'q' => [320..351], # high ruins - ' ' => [352..383], - 'a' => [384..415], # high basilica - 'm' => [416..447], # mud - ' ' => [448..479], - ' ' => [480..511], - - ' ' => [512..543], - ' ' => [544..575], - '/' => [576..607], # high dirt -> dirt (top left) - '/' => [608..639], # dirt -> high dirt - '\\' => [640..671], # high dirt -> dirt (top right) - '\\' => [672..703], # dirt -> high dirt (bottom left) - '\\' => [704..735], # high dirt -> dirt (bottom left) - '\\' => [736..767], # dirt -> high dirt (top right) - '/' => [768..863], - '=' => [864..1055], # some edge (tmp) - '=' => [1056..1183], - '=' => [1184..1727], - 'D' => [1728..1780], # edge water - '/' => [1760..1791], # dirt -> water (top left) - '\\' => [1792..1823], # dirt -> water (top right) - - 'd' => [609..611], - 'W' => [2048..2303], - '/' => [2304..2559], - 'W' => [2560..2815], - 'j' => [2816..3071], - 'd' => [3072..3327], - 'j' => [3328..3583], - 'x' => [3648..3839], - 'h' => [3840..4095], -# 'x' => [4096..4351], - 'h' => [4096..4351], -# 'x' => [4352..4607], -# ' ' => [4608..4863], - 'l' => [4864..5311], - 'q' => [5312..5503], - 'x' => [5504..5631], - 'q' => [5632..5759], - 'j' => [5760..5823], -# ' ' => [5824..5887], - '=' => [5888..6143], # raised jungle -> jungle -# ' ' => [6144..6655], - '/' => [6656..7167], - '/' => [7168..7359], # basilica -> crushed rock - '/' => [7360..7551], - 'i' => [7552..7807], # high temple -# ' ' => [7808..8959], -# '=' => [8960..9087], -# 'd' => [9088..9215], -# ' ' => [9216..9727], -# 'm' => [9728..9983], -# # >= 9984 unencountered -# ' ' => [19968..20480], # something here on twilight -# ' ' => [20544..20736], # center thing on twilight -# '~' => [20896..21023], # something in the water on twilight -# 'x' => [23104..23231], # something on twilight (on X or H) -# -# 'm' => [9216..9776], # mud <-> dirt -# 'r' => [5792..5875, 5888..5904], # raised jungle edge -# -# 'd' => [3042..3250], # dirt<->grass -# 'P' => [4608..4977], # dirt<->shale (verified) [also seems to be rocks on mud] -# #'=' => [768..1731], # dirt<->lava ridge (verified) - - 'h' => [16389], - '1' => [16405, 16388], - '2' => [16421, 16404, 16387], - '3' => [16437, 16420, 16403, 16386], - '4' => [16453, 16436, 16419, 16402, 16385], - '5' => [ 16435, 16418, 16401, 16384], - '6' => [ 16434, 16417, 16400], - '7' => [ 16433, 16416], - 'd' => [16501, 16432], - '7' => [16485, 16500], # these ↕ aren't ramps in temple!! - '6' => [16469, 16484, 16499], - '5' => [16453, 16468, 16483, 16498], - '4' => [ 16452, 16467, 16482, 16497], - '3' => [ 16451, 16466, 16481, 16496], - '2' => [ 16450, 16465, 16480], - '1' => [ 16449, 16464], - 'h' => [17248, 16448], - '1' => [17264, 17249], - '1' => [17280, 17265, 17250], - '2' => [17296, 17281, 17266, 17251], - '3' => [17312, 17297, 17282, 17267, 17252], - '4' => [17328, 17313, 17298, 17283, 17268, 17253], - '5' => [ 17329, 17314, 17299, 17284, 17269], - '6' => [ 17330, 17315, 17300, 17285], - '7' => [ 17331, 17316, 17301], - '7' => [ 17332, 17317], - 'd' => [17232, 17333], - '7' => [17216, 17233], - '7' => [17200, 17217, 17234], - '6' => [17184, 17201, 17218, 17235], - '5' => [17168, 17185, 17202, 17219, 17236], - '4' => [17152, 17169, 17186, 17203, 17220, 17237], - '3' => [ 17153, 17170, 17187, 17204, 17221], - '2' => [ 17154, 17171, 17188, 17205], - '1' => [ 17155, 17172, 17189], - '1' => [ 17156, 17173], - 'h' => [ 17157], -); - -my %eratile = ( - 4 => [ - # Longinus (by KuKulZa, modified MBCgame/iCCup) - # SPRP: 6,0,1,0 - # TYPE: 82,65,87,66 - # VER: 205,0 - # SIDE: 5,5,5,1,2,0,1,2,7,7,7,4 - 'd' => [ - 19760..19761, 19792, 19793, 19680, 19681, 19712, 19713, 19664, 19665, 19728, 19729, # D→J - 19808,19809, 19776,19777, 19872,19873, 19920,19921, - 19744,19745, 19696,19697, 19632,19633, 19696,19697, 19952,19953, - 19568,19569, # below ridge - 3618,3634, 3586,3602, # D←J - 3601, # D→J(3585) - ], - 'j' => [ - 21968, 21969, 21984, 21985, - 21824,21825,21840,21841, 21856,21857,21872,21873, 21792,21793, - 21808,21809, 21888,21889,21904,21905, - 3616,3632,3584,3600,3616,3632, # J→D - 3585, # J→D(3601) - ], - 'l' => [ - 22608..22611, 22624..22627, 22640..22643, - ], - 'o' => [ - 24850, # besides ladder - 20832,20833,20848,20849, 20768,20769,20784,20785, - 20864,20865,20880,20881, - 20704,20705,20720,20721, # large rock - 4432,4433,4434,4448,4449,4464,4465, - 4545,4561,4577,4593, 4544,4560,4576,4592, - ], - 'h' => [ - 18000,18001, # H→X - 17952,17953, 17936,17937, 17920,17921, 17856,17857, 17888,17889, # H→X unsure - 17984,17985, 18160,18161, 18128,18129, 18048,18049, - 19648,19649,19616,19617, 18016,18017, - 17696,17697,17712,17713, # tree - 17872,17873,17904,17905, 18144,18145, - 18448,18449,18464,18465,18480,18481, - ], - 'm' => [ # mud hole - 9219,9235,9539,9555, - 9218,9234,9795,9235,9811,9571,9587, - 9472,9488,9250,9266,9635,9651,9280,9296, - 9504,9520,9665,9681,9344,9360,9760,9776,9539,9555, - 9475,9491,9889,9905,9376,9392,9440,9456,9571,9587, - 9507,9523,9377,9393, - - 9537,9553, - 9569,9585,9474,9490,9283,9299,9216,9232,9536,9552, - 9536,9552,9923,9939,9283,9299,9506,9522,9827,9843,9728,9744,9568,9584, - 9283,9299,9217,9233,9731,9747,9568,9584,9699,9715,9315,9331,9284,9300,9217,9233,9955,9971, - 9763,9779,9793,9809,9379,9395,9664,9680,9316,9332,9249,9265,9536,9552, - 9443,9459,9921,9937,9284,9300,9216,9232,9284,9300,9216,9232,9696,9712,9345,9361,9409,9425,9604,9620,9568,9584, - 9216,9232,9764,9780,9248,9264,9316,9332,9248,9264,9346,9362,9441,9457,9860,9876,9537,9553, - 9728,9744,9444,9460,9667,9683,9348,9364,9411,9427,9602,9618,9378,9394,9444,9460,9569,9585, - 9891,9907,9380,9396,9443,9459,9858,9874,9540,9556, - 9379,9395,9442,9458,9572,9588, - ], - '/' => [ - # Longinus (by KuKulZa, modified MBCgame/iCCup) - 9125, 9141, 9126, 9142, # D→~ - 9120, 9136, # H→D - 9059,9075, 9189,9205, # D→~ - 19824,19825, # D→~ - 19200,19201,19216,19217, # object on D - ], - '/' => [ - 17632,17633,17648,17649, # H rotating thing - 18208,18209, # H skull thing - 18224,18225,18240,18241, # H statuey thing - ], - 'q' => [ - 23872,23873,23874,23875,23888,23889,23890,23891,23904,23905,23906,23907, # Q crater - 23680,23681,23696,23697,23712,23713, - ], - 'x' => [ - 24336,24337,24352,24353, 24272,24273,24288,24289, - 24272,24273,24288,24289, 24368,24369,24384,24385, - 4353,4369, 4385,4401,4353,4369, 4386,4402, 4385,4401, - 4386,4402,4354,4370,4386,4402, - ], - '/' => [ - 19856,19857,20144,20145, # D skeleton - ], - '/' => [21184], 'W' => [21185,21200,21201,21216,21217], # standing rock - '/' => [21232], 'W' => [21233,21248,21249,21264,21265], # standing rock - '7' => [25011, 25010], # M»H - '7' => [24699, 25143], 6 => [24716], # M»H - 'W' => # island o' rocks - [21120..21125, 21136..21141, 21152..21157, 21168..21173], - '/' => [21121,21122,21136..21139,21152..21154], - '~' => [21120,21124,21125,21141,21157,21171..21173], - '/' => [ - # D→~ coast - 8997,9013,8963,8979, 8996,9012,8963,8979,8993,9009, 8997,9013, - 8998,9014, 8993,9009, 9187,9203, 9121,9137, 9131,9147, 8992,9008, - 9190,9206, 9062,9078, 8996,9012, 9090,9106,9194,9210, - 9061,9077,9029,9045,9184,9200,8998,9014, 9024,9040,8997,9013, - ], - - # Lost Temple (default?) - # SPRP: 4,0,5,0 - # VER: 59,0 - # SIDE: 5,5,5,5,0,2,1,0,7,7,7,4 - '/' => [ - 9089,9105, # H←D - 9196,9212, # H←D→~ - 8966,8982, 8962,8978, # H→~ - 9088,9104, # D→D/~ - 16832..16835,16848..16851,16864..16867,16880..16883, # H→D ridge (ramp elsewhere?) - 16384..16389, 16400..16405, 16416..16421, 16432..16437, # idem - 8961,8977,9155,9171, # H←D→~ - 20160,20161,19984,19985,19986,19987,20000,20001,20002,20003, # D→H - 9124,9140, 9122,9138, 9002,9018, 8960,8976, 9168,9152, 8995,9011, # H→D→~ - 9057,9073, # H→D→~ temple.6 - 8968,8984, # D↔H - ], - 'j' => [ - 21952,21953, - ], - 'x' => [ - 4384,4400, 4352,4368, # X→H - ], - 'h' => [ - 18096,18097, 17968,17969, 18032,18033,18176,18177, - ], - 'd' => [ - 9347,9363,9953,9969,9473,9489,9251,9267,9633,9649,9505,9521,9410,9426, - 9347,9363, 19840,19841, 19888,19889, 20208,20209,20224,20225, - 20240,20241,20256,20257, 20272,20273,20288,20289, 19601,19600, - 20304,20305,20320,20321, # tree - ], - 'o' => [ - 4673,4689,4737,4753,4705,4721,4769,4785, # rocks on D - 4674,4690,4706,4722,4674,4690,4480,4496,4706,4722,4832,4848,4640,4656, - 4736,4752,4768,4784, - 4482,4498, 4834,4850, 4642,4658, - ], 'd' => [4498,4642], - 'm' => [ - # M→D mud holes - 9281,9297,9313,9329, 9281,9297,9313,9329, 9538,9554,9570,9586, - 9282,9298,9282,9298,9220,9236,9476,9492,9314,9330,9729,9745,9412,9428,9476,9492,9314,9330,9538,9554,9476,9492,9252,9268, - 9508,9524,9668,9684,9600,9616,9508,9524,9666,9682,9601,9617,9570,9586,9508,9524,9408,9424,9700,9716,9632,9648,9698,9714,9282,9298,9314,9330, - 9312,9328, 9412,9428, 9636,9652, 9634,9650, - 9730,9746, 9761,9777,9762,9778, 9794,9810, - 9732,9748, # temple.5 - 9603,9619, # temple.6 - ], - 'r' => [ - 5859,5875, 5858,5874, # top edge - ], - 'O' => # temple center ornament - [ - 22320,22321,22336,22337,22352,22353, - 22368,22369,22384,22385,22400,22401, - 22464..22467,22480..22483,22496..22499, - 22800,22801,22802,22803,22816,22817,22818,22819,22832,22833,22834,22835, - 22752,22753,22754,22755,22768,22769,22770,22771,22784,22785,22786,22787, - ], - 'l' => [ # cut out shapes - 22464,22467,22496,22499, 22321,22353, 22368,22400, - 22800,22802,22803,22832,22835, 22819, - 22752,22753,22755,22787,22784, 22768, - ], - 'D' => # underwater cave - [ - 21440,21441,21442,21443, 21456,21457,21458,21459, - 21472,21473,21474,21475, 21488,21489,21490,21491, - ], - 'W' => [21456, 21472,21473,21474,21475], - 'o' => [21442,21443], - '~' => [21488,21489, 21490,21491], - 'i' => [ - 23632,23633,23648,23649,23664,23665, 23584,23585,23600,23601,23616,23617, # statue things on Q - ], - 'D' => [1824..1839], 'W' => [1840..1855], # D→~ bright transition - 'D' => [1856..1871], 'd' => [1872..1887], # D→~ bleft ridge - 'W' => [1888..1903], 'D' => [1904..1919], # D→~ bleft transition - '~' => [1920..1935], 'W' => [1936..1951], # w→~ bleft transition - 'd' => [1952..1967], 'D' => [1968..1983], - 'D' => [1984..1999], 'W' => [2000..2015], - 'W' => [2016..2031], '~' => [2032..2047], - 'D' => [8965,8981, 8964,8980, 9174,9158, 9010,8994], # H→D→~ - 'd' => [19936,19937], # D→~ - '/' => [19905], 'd' => [19904], # H→D - 'r' => [ - 5825,5841, 5857,5873, # J→R→map edge - 5826,5842, # J↔R - ], - 'q' => [ - # gap - 23456,23457,23458,23459, 23472,23473,23474,23475, - 23488,23489,23490,23491, 23504,23505,23506,23507, - # towery thing - 23824,23825,23826,23827, 23840,23841,23842,23843, 23856,23857,23858,23859, - ], - - # Plains to Hill (v2.00 by Sir.Lupin) - # VER: 59,0 - # SPRP: 1,0,2,0 - # SIDE: 5,5,5,5,0,2,1,0,7,7,7,4 - # FORC: 0,0,0,0,1,1,1,1,31,0,30,0,29,0,28,0,1,11,0,0 - '/' => [ - # H→D bottom left side (may be a ramp elsewhere) - 16768,16769,16770,16771, 16784,16785,16786,16787, - 16800,16801,16802,16803, 16816,16817,16818,16819, - # idem bottom right side - 16960,16961,16962,16963, 16976,16977,16978,16979, - 16992,16993,16994,16995, 17008,17009,17010,17011, - # idem - 17088,17089,17090,17091, 17104,17105,17106,17107, - 17120,17121,17122,17123, 17136,17137,17138,17139, - ], - - # Python (v1.3 by Terrance, modified by Forgotten_/KeSPA) - # ERA: 100,0 - # TYPE: 82,65,87,66 - # VER: 205,0 - # SPRP: 1,0,7,0 - # SIDE: 5,5,5,5,0,2,1,0,7,7,7,4 - # FORC: 0,0,0,0,1,1,1,1,2,0,4,0,5,0,6,0,1,14,15,15 - 'x' => [ - 24464,24465, 24448,24449 - ], - 'h' => [ - 18064,18065, - ], - '/' => [ - 9186,9202, - 18112,18113, # H→D - 9154,9170,9027,9043,9157,9173, # H↔D - ], - 'O' => - [19504,19505,19520,19521, 18720,18721,18736,18737], # rock things - 'h' => [18737], - 'O' => # hole - [17488..17491,17504..17507,17520..17523,17536..17539], - 'h' => [17490,17491,17507,17523,17536..17539], - 'o' => [ - 4610, 4610,4626, 4481,4497,4513,4529, 4514,4530, - 4417,4608,4624,4418, 4512,4528, 4450,4466, - 4609,4625,4546,4562, 4833,4849, 4801,4817, 4800,4816, - ], - 'd' => [ - 4672,4688,4704,4720, # D↔O - 19584,19585, - 4416, # D→O - 4641,4657,4578,4594, 4802,4818, # O→D - ], - 'm' => [ - 9824,9840,9952,9968,9920,9936,9888,9904, 9796,9812,9924,9940, - 9697,9713, 9890,9906, 9922,9938, 9792,9808,9856,9872,9826,9842, - ], - 'o' => [4738,4770], 'd' => [4754,4786], - '/' => [18256,18257,18272,18273], 'h' => [18288,18289], # obelisk - '/' => # sunken temple - [21024..21029, 21040..21045, 21056..21061, 21072..21077, 21088..21093,21104..21109], - '~' => [21024,21104,21109,21027,21059,21076,21072,21093,], - 'W' => [21029, 21060,21045,21073,21090,21106,21092,21107,21075,21108,21058, 21056,21088,21105,21077], - 'O' => # ruins similar to 22464 - [22512..22515, 22528..22531, 22544..22547], - 'l' => [22512,22515, 22544,22547], - 'Q' => [17664,17665,17680,17681], # rock thing - 'Q' => [17728,17729,17744,17745], # tree - '/' => [17808,17824,17840], 'h' => [17809,17825,17841], - '6' => [25025], # D»H ramp (between D and 17328 = level 4) - -#}, 2 => { - # Twilight Star (default) - # (all guessed from low res thumb) - 'h' => [17584,17585], # H→D - 'r' => [5827,5843, 5824,5840,5856,5872], - 'W' => [ - # water objects - 20912,20913,20928,20929, 20896,20897, 20944, - 19440,19441,19456,19457, 20945,20960,20961, - 20816,20817, - ], - 'h' => [17760,17761,17776,17777, 17600,17601], - 'D' => [9093,9109], - 'o' => [19472..19475, 19488..19491], - 'o' => [ - 21728,21729, 21744,21745, 21760,21761, - 21776,21777, 19536,19537, 19538,19539, 19552..19555, - ], - 'j' => [3587,3603], - 'O' => [19232..19235, 19248..19251], 'j' => [19218,19219], - 'O' => [19938,19939,19954,19955], - 'h' => [17792,17793], - 'x' => [4356,4372], - 'O' => [ # exotic/shiny things and other objects - 18656,18657,18672,18673, 18496,18497,18512,18513, - 18560..18563, 18576..18579, 18592..18595, - 18528,18529,18544,18545, 18864,18865, - 18608..18611,18624..18627,18640..18643, - 18912..18915,18928..18931,18944..18947, - 18816..18819,18832..18835,18848..18851, - 18960..18963,18976..18979,18992..18995, - 19008..19011,19024..19027, - 19040..19043,19056..19059, - ], - 'A' => [ # X→A - 7811,7827,7873,7889,7809,7825,7875,7891, - 8707,8723,8737,8753,7874,7890,7808,7824,7872,7888,7904, - 8003,8019,8160,8176,7810,7826, - ], - 'a' => [ # A←X - 7843,7859,7905,7921,7841,7857,7907,7923, - 8705,8721,7971,7987,8065,8081,8738,8754,7840,7856, - 7920,7906,7922,7938,7954,7969,7985,8066,8082,8035,8051, - 7970,7986,8032,8048, - 8034,8050,7936,7952,8033,8049,7937,7953, - ], - 'R' => [6177,6193], - '/' => [18080,18081], - 'a' => [8032..8047], 'a' => [8048..8063], # #3 bottom left - 'A' => [7841..7843], 'a' => [7857..7859], # #2 top left - 'A' => [8000..8003], 'x' => [8016..8019], # #1 bottom right - 'A' => [8064..8067], 'a' => [8080..8083], # #2 bottom left - 'A' => [8224..8227], 'x' => [8240..8243], # #1 top right - 'A' => [8288..8291], 'x' => [8304..8307], # #1 bottom right - 'a' => [8355], 'A' => [8371], # #2 top right - 'a' => [8322], 'A' => [8338], # #2 top right - 'A' => [8512], 'x' => [8528], # #1 top right - 'x' => [7811], 'A' => [7827], - 'x' => [8096..8099], 'A' => [8112..8115], - 'x' => [8163], 'a' => [8179], - 'x' => [8192..8195], 'A' => [8208..8211], - 'x' => [8128..8131], 'A' => [8144..8147], - 'A' => [8258,8274], - 'a' => [7939,7955], # #3 bottom right - 'a' => [7968..7971], 'A' => [7984..7987], - 'A' => [8256,8272], - 'A' => [8257,8273, 8259,8275, 8162,8178], - - '!' => [], - - # tau cross (v1.1 by Rose.Of.Dream/BW4eVeR) - # ERA: 6 - # FORC: 0,0,0,1,1,1,1,1,7,0,6,0,5,0,4,0,1,15,15,15 - # SIDE: 5,5,5,1,0,2,1,0,7,7,7,4 - # SPRP: 1,0,2,0 - # TYPE: 82,65,87,66 - # VER: 205 - '?' => [ - 6176,6192, 20976,20977, 20592,20593, 21392,21393, 20800,20801, - 20608,20609, 20624,20625, 20640,20641, 20992,20993, 21008,21009, - 19922,19923,22070,22071, 19968..19971, 22230, - 22133,22137,22272,22157,22288,22313, - 20592,20593,21392,21393,20800,20801,20608,20609,20624,20625,20640,20641,20992,20993,21008,21009,19922,19923, - 22070,22071,19968,19969,19970,19971,22230,22272,22157,22288,22313,6147,6163,6178,6194,3589,3605,22147,22162,22163,22164, - 22180,22315,18400,18401,18336,18337,18192,18193,17730,17731,17826,17827,17746,17747,17842,17843, - 17762,17763,17794,17795,17778,17779,17810,17811,17616,17617, - 20688,20689,6145,6161,20736,20737,21408,21409,21410,21411, - 20752,20753,21424,21425,21426,21427,21376,21377,20656,20657, - 21312,21313,21314,21315,20672,20673,21328,21329,21330,21331, - 6146,6162,21344,21345,21346,21347,21360,21361,21362,21363,6144, - 6160, - ], - '2' => # bridges - [ - 22231..22235, 22246..22253, 22260..22269, - 22273..22285, 22289..22301, 22306..22312, 22324..22328, - ], - '4' => [22246..22253, 22273..22285, 22306..22312], - '2' => [ - 22084..22086, 22096..22103, 22112..22121, 22128..22139, - 22144..22156, 22165..22171, 22181..22199, - ], - '4' => [22084..22086, 22112..22121, 22144..22156, 22181..22199], - 'r' => [22342,22343], - - # Nostalgia (WGT13, v1.3 by Rose.of.Dream) - # ERA: 0,0 - # FORC: 0,0,0,0,1,1,1,1,12,0,11,0,10,0,9,0,1,14,0,0 - # SIDE: 5,5,5,5,0,2,1,0,7,7,7,4 - # SPRP: 1,0,4,0 - # TYPE: 82,65,87,66 - # VER: 205 - '!' => [], - ], # jungle -); - -our %tilechar; -while (my ($char, $matches) = splice @maptile, 0, 2) { - $tilechar{$_} = $char for @$matches; -} -while (my ($char, $matches) = splice @{$eratile{4}}, 0, 2) { - $tilechar{$_} = $char for @$matches; -} - -my @mapunit = ( # character => width, height, ids - '$' => [2,1, 176..178], # minerals - '*' => [2,1, 188], # gas - '@' => [2,2, 214], # start pos -); - -our %unitchar; -while (my ($char, $matches) = splice @mapunit, 0, 2) { - my @charinfo = ($char, splice @$matches, 0, 2); - $unitchar{$_} = \@charinfo for @$matches; -} - -sub tiles_parsed { - my $self = shift; - my $map = $self->tiles or return; - if ($SHOWWARN) { - use Tie::IxHash; - tie my %unknown, 'Tie::IxHash'; - defined $tilechar{$map->[$_]} or warn(sprintf - "unknown tile %d at (%d,%d)\n", - $map->[$_], $_ % $self->width, $_ / $self->width - ), $unknown{$map->[$_]} = $_ for 0 .. $#$map; - warn sprintf "unknown: %s\n", join ",", keys %unknown if keys %unknown; - } - $_ = defined $tilechar{$_} ? $tilechar{$_} : '?' for @$map; - for ($self->units) { - my ($chr, $width, $height) = defined $unitchar{$_->{id}} ? - @{ $unitchar{$_->{id}} } : ('#', 1, 1); - for my $x ($_->{x} .. $_->{x} + $width - 1) { - for my $y ($_->{y} .. $_->{y} + $height - 1) { - $map->[$x + $y * $self->width] = $chr; - } - } - } - return $map; -} - -sub units { - my $self = shift; - my @units; - for (my $i = 0; $i < length $self->{UNIT}; $i += 36) { - # d1, d2, x*32, y*32, unitid, bytes1, playerid, bytes2, mineral, bytes3 - my @pack = unpack "v5x6Cx3vx14", substr $self->{UNIT}, $i, 36; - push @units, { - id => $pack[4], - player => $pack[5], - amount => $pack[6], - x => $pack[2] >> 5, - y => $pack[3] >> 5, -# d1 => $pack[0], -# d2 => $pack[1], - }; - } - return @units; -} - -sub units_parsed { - my $self = shift; - my @units; - for ($self->units) { - my ($chr, $width, $height) = defined $unitchar{$_->{id}} ? - @{ $unitchar{delete $_->{id}} } : ('#', 1, 1); - $_->{chr} = $chr; - $_->{width} = $width; - push @units, $_; - } - return @units; -} - -sub colors { - my $self = shift; - my @colormap = ( - qw( - FF0000 0000FF 209070 88409C E87824 5C2C14 FFFFFF DCDC3C - 0F930F FCFC8F EFCEBD 547CDC - ), - 12 => "pale green", "gray", "pale yellow", "cyan", - 17 => "black", "neon blue", - 21 => "lavender", "black", - 30 => "sky blue", - 33 => "purple", - ); - my @players; - for (unpack "C*", $self->{COLR}) { - push @players, $colormap[$_] || "? (#$_)"; - } - return \@players; -} - -sub era { - my $self = shift; - return unpack "v", $self->{ERA}; -} - -} - +use Data::StarCraft::Map; my $map = Data::StarCraft::Map->new->open(\*STDIN); +$map->{DEBUG} = 1 if $SHOWWARN; if ($SHOWMAP ne "ppm") { printf("%s size %dx%d, %d player\n", diff --git a/scmtomap b/scmtomap new file mode 100755 index 0000000..1c24020 --- /dev/null +++ b/scmtomap @@ -0,0 +1,14 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Archive::MoPaQ; + +@ARGV or die "Usage: $0 filename.scm\n"; + +my $mpq = Archive::MoPaQ->new or die; +print $mpq->open($ARGV[0]); +$mpq->listopen(""); +$mpq->extract(1); + diff --git a/screp b/screp index 8fb41f5..dc24f05 100755 --- a/screp +++ b/screp @@ -2,10 +2,12 @@ use strict; use warnings; use Data::Dumper; +use Data::StarCraft::Replay; our $VERSION = '1.01'; my $SHOWWARN = 0; +my $ACTGIF = undef; my $APMSVG = undef; my $DBNAME = undef; my $DBGAME = undef; @@ -14,414 +16,13 @@ use Getopt::Long qw(:config bundling auto_version auto_help); GetOptions( "verbose|v!" => \$SHOWWARN, "apm|a=s" => \$APMSVG, + "act" => \$ACTGIF, "dbname|D=s" => \$DBNAME, "dbid|d=s" => \$DBGAME, ); use constant { APM_FIRSTFRAME => 80 / .042 }; -{ - -package Data::StarCraft::Replay; - -use Data::Dumper; - -use constant { - CMD_REPEAT => 4, -}; - -my %build = ( - 0x19 => "morph", - 0x1E => "build", - 0x1F => "warp", - 0x24 => "add-on", - 0x2E => "evolve", - 0x47 => "land", -); -my %unit = ( - 0x00 => "Marine", - 0x01 => "Ghost", - 0x02 => "Vulture", - 0x03 => "Goliath", - # undef, - 0x05 => "Siege Tank", - # undef, - 0x07 => "SCV", - 0x08 => "Wraith", - 0x09 => "Science Vessel", - # undef, - 0x0B => "Dropship", - 0x0C => "Battlecruiser", - # undef, - 0x0E => "Nuke", - # (undef) x 0x11, - 0x20 => "Firebat", - # undef, - 0x22 => "Medic", - # undef, - # undef, - 0x25 => "Zergling", - 0x26 => "Hydralisk", - 0x27 => "Ultralisk", - # undef, - 0x29 => "Drone", - 0x2A => "Overlord", - 0x2B => "Mutalisk", - 0x2C => "Guardian", - 0x2D => "Queen", - 0x2E => "Defiler", - 0x2F => "Scourge", - # undef, - # undef, - 0x32 => "Infested Terran", - # (undef) x 7, - 0x3A => "Valkyrie", - # undef, - 0x3C => "Corsair", - 0x3D => "Dark Templar", - 0x3E => "Devourer", - # undef, - 0x40 => "Probe", - 0x41 => "Zealot", - 0x42 => "Dragoon", - 0x43 => "High Templar", - # undef, - 0x45 => "Shuttle", - 0x46 => "Scout", - 0x47 => "Arbiter", - 0x48 => "Carrier", - # (undef) x 0x0A, - 0x53 => "Reaver", - 0x54 => "Observer", - # (undef) x 0x12, - 0x67 => "Lurker", - # undef, - # undef, - 0x6A => "Command Center", - 0x6B => "ComSat", - 0x6C => "Nuclear Silo", - 0x6D => "Supply Depot", - 0x6E => "Refinery", # refinery? - 0x6F => "Barracks", - 0x70 => "Academy", # Academy? - 0x71 => "Factory", - 0x72 => "Starport", - 0x73 => "Control Tower", - 0x74 => "Science Facility", - 0x75 => "Covert Ops", - 0x76 => "Physics Lab", - # undef, - 0x78 => "Machine Shop", - # undef, - 0x7A => "Engineering Bay", - 0x7B => "Armory", - 0x7C => "Missile Turret", - 0x7D => "Bunker", - # (undef) x 4, - 0x82 => "Infested CC", - 0x83 => "Hatchery", - 0x84 => "Lair", - 0x85 => "Hive", - 0x86 => "Nydus Canal", - 0x87 => "Hydralisk Den", - 0x88 => "Defiler Mound", - 0x89 => "Greater Spire", - 0x8A => "Queens Nest", - 0x8B => "Evolution Chamber", - 0x8C => "Ultralisk Cavern", - 0x8D => "Spire", - 0x8E => "Spawning Pool", - 0x8F => "Creep Colony", - 0x90 => "Spore Colony", - # undef, - 0x92 => "Sunken Colony", - # undef, - # undef, - 0x95 => "Extractor", - # (undef) x 4, - 0x9A => "Nexus", - 0x9B => "Robotics Facility", - 0x9C => "Pylon", - 0x9D => "Assimilator", - # undef, - 0x9F => "Observatory", - 0xA0 => "Gateway", - # undef, - 0xA2 => "Photon Cannon", - 0xA3 => "Citadel of Adun", - 0xA4 => "Cybernetics Core", - 0xA5 => "Templar Archives", - 0xA6 => "Forge", - 0xA7 => "Stargate", - # undef, - 0xA9 => "Fleet Beacon", - 0xAA => "Arbiter Tribunal", - 0xAB => "Robotics Support Bay", - 0xAC => "Shield Battery", - # (undef) x 0x14, - 0xC0 => "Larva", - 0xC1 => "Rine/Bat", - 0xC2 => "Dark Archon", - 0xC3 => "Archon", - 0xC4 => "Scarab", - 0xC5 => "Interceptor", - 0xC6 => "Interceptor/Scarab", -); -my @upgrade = ( - "Terran Infantry Armor", - "Terran Vehicle Plating", - "Terran Ship Plating", - "Zerg Carapace", - "Zerg Flyer Carapace", - "Protoss Ground Armor", - "Protoss Air Armor", - "Terran Infantry Weapons", - "Terran Vehicle Weapons", - "Terran Ship Weapons", - "Zerg Melee Attacks", - "Zerg Missile Attacks", - "Zerg Flyer Attacks", - "Protoss Ground Weapons", - "Protoss Air Weapons", - "Protoss Plasma Shields", - # 0x10 - "U-238 Shells (Marine Range)", - "Ion Thrusters (Vulture Speed)", - undef, - "Titan Reactor (Science Vessel Energy)", - "Ocular Implants (Ghost Sight)", - "Moebius Reactor (Ghost Energy)", - "Apollo Reactor (Wraith Energy)", - "Colossus Reactor (Battle Cruiser Energy)", - "Ventral Sacs (Overlord Transport)", - "Antennae (Overlord Sight)", - "Pneumatized Carapace (Overlord Speed)", - "Metabolic Boost (Zergling Speed)", - "Adrenal Glands (Zergling Attack)", - "Muscular Augments (Hydralisk Speed)", - "Grooved Spines (Hydralisk Range)", - "Gamete Meiosis (Queen Energy)", - # 0x20 - "Defiler Energy", - "Singularity Charge (Dragoon Range)", - "Leg Enhancement (Zealot Speed)", - "Scarab Damage", - "Reaver Capacity", - "Gravitic Drive (Shuttle Speed)", - "Sensor Array (Observer Sight)", - "Gravitic Booster (Observer Speed)", - "Khaydarin Amulet (Templar Energy)", - "Apial Sensors (Scout Sight)", - "Gravitic Thrusters (Scout Speed)", - "Carrier Capacity", - "Khaydarin Core (Arbiter Energy)", - undef, - undef, - "Argus Jewel (Corsair Energy)", - # 0x30 - undef, - "Argus Talisman (Dark Archon Energy)", - "Caduceus Reactor (Medic Energy)", - "Chitinous Plating (Ultralisk Armor)", - "Anabolic Synthesis (Ultralisk Speed)", - "Charon Boosters (Goliath Range)", -); -my @research = ( - "Stim Pack", - "Lockdown", - "EMP Shockwave", - "Spider Mines", - undef, - "Siege Tank", - undef, - "Irradiate", - "Yamato Gun", - "Cloaking Field (wraith)", - "Personal Cloaking (ghost)", - "Burrow", - undef, - "Spawn Broodling", - undef, - "Plague", - # 0x10 - "Consume", - "Ensnare", - undef, - "Psionic Storm", - "Hallucination", - "Recall", - "Stasis Field", - undef, - "Restoration", - "Disruption Web", - undef, - "Mind Control", - undef, - undef, - "Optical Flare", - "Maelstrom", - # 0x20 - "Lurker Aspect", -); -my %action = ( - 0x00 => "Move", - 0x02 => "Unallowed Move?", - 0x06 => "Force move", - 0x08 => "Attack", - 0x09 => "Gather", - 0x0E => "Attack Move", - 0x13 => "Failed Casting (?)", - 0x17 => "#23 (?)", - 0x1B => "Infest CC", - 0x22 => "Repair", - 0x27 => "Clear Rally", - 0x28 => "Set Rally", - 0x4F => "Gather", - 0x50 => "Gather", - 0x70 => "Unload", - 0x71 => "Yamato", - 0x73 => "Lockdown", - 0x77 => "Dark Swarm", - 0x78 => "Parasite", - 0x79 => "Spawn Broodling", - 0x7A => "EMP", - 0x7E => "Launch Nuke", - 0x84 => "Lay Mine", - 0x8B => "ComSat Scan", - 0x8D => "Defense Matrix", - 0x8E => "Psionic Storm", - 0x8F => "Recall", - 0x90 => "Plague", - 0x91 => "Consume", - 0x92 => "Ensnare", - 0x93 => "Stasis", - 0x94 => "Hallucination", - 0x98 => "Patrol", - 0xB1 => "Heal", - 0xB4 => "Restore", - 0xB5 => "Disruption Web", - 0xB6 => "Mind Control", - 0xB8 => "Feedback", - 0xB9 => "Optic Flare", - 0xBA => "Maelstrom", - 0xC0 => "Irradiate", -); - -my %cmdread = ( - 0x09 => ["select", 1, 2 | CMD_REPEAT], - 0x0A => ["add", 1, 2 | CMD_REPEAT], - 0x0B => ["deselect", 1, 2 | CMD_REPEAT], - 0x0C => ["build", 1, \%build, 2, 2, 2, \%unit], - 0x0D => ["vision", 2], - 0x0E => ["ally", 2, 2], - 0x13 => ["hotkey", 1, [qw"assign select"], 1], - 0x14 => ["move", 2, 2, 2, 2, 1], # 1 = queued? - 0x15 => ["action", 2, 2, 2, 2, 1, \%action, 1, [qw"normal queued"]], - 0x18 => ["cancel"], - 0x19 => ["cancel hatch"], - 0x1A => ["stop", 1], -# 0x1B => ["move-thing??"], # tim: after hotkey (unit, reaver??) select; soon after reselected and moved - 0x1E => ["return cargo", 1], - 0x1F => ["train", 2, \%unit], - 0x20 => ["cancel train", 2], # == 254 - 0x21 => ["cloak", 1], - 0x22 => ["decloak", 1], - 0x23 => ["hatch", 2, \%unit], - 0x25 => ["unsiege", 1], - 0x26 => ["siege", 1], - 0x27 => ["arm", 0], # scarab/interceptor - 0x28 => ["unload all", 1], - 0x29 => ["unload", 2], - 0x2A => ["merge archon", 0], - 0x2B => ["hold position", 1], - 0x2C => ["burrow", 1], - 0x2D => ["unburrow", 1], - 0x2E => ["cancel nuke", 0], - 0x2F => ["lift", 2, 2], - 0x30 => ["research", 1, \@research], - 0x31 => ["cancel research", 0], - 0x32 => ["upgrade", 1, \@upgrade], -# 0x33 => ["forge-thing??"], # right after forge select: probably unpowered, iirc cancel research - 0x35 => ["morph", 2, \%unit], - 0x36 => ["stim", 0], - 0x57 => ["part", 1, {qw"1 quit 6 drop"}], - 0x5A => ["merge dark archon", 0], -); - -sub new { - my ($class) = @_; - bless [], $class; -} - -sub _read { - my $self = shift; - my ($fh, $size, $seek) = @_; - seek *$fh, $seek, 0 if $seek; - read(*$fh, my $in, $size) eq $size or return undef; - return $in; -} - -sub open { - my $self = shift; - my ($file) = @_; - - while (not eof $file) { - local $_ = $self->_read($file, 5) - and my ($time, $size) = unpack "VC", $_ - or die "Couldn't read time block head\n"; - local $_ = $self->_read($file, $size) - and my @block = unpack "C*", $_ - or die "Couldn't read time block data\n"; - while (@block) { - my $player = shift @block; - my $cmd = shift @block; - if (not defined $cmdread{$cmd}) { - warn sprintf "command #%X not defined: %d bytes ignored\n", - $cmd, scalar @block; - push @$self, [$time, $player, "??? $cmd"] if $SHOWWARN; - last; - } - - sub readbyte { - my ($data, $byte) = @_; - my $out = shift @$data; - if (($byte & 3) == 2) { - @$data ? ($out += shift(@$data) << 8) - : warn "high byte not present\n"; - } - return $out; - } - - my @format = @{ $cmdread{$cmd} }; - my $desc = shift @format; - my @data; - for my $bit (@format) { - if (ref $bit) { - if (ref $bit eq "ARRAY") { - $data[-1] = defined $bit->[$data[-1]] ? $bit->[$data[-1]] - : "? ($data[-1])"; - } else { - $data[-1] = defined $bit->{$data[-1]} ? $bit->{$data[-1]} - : "? ($data[-1])"; - } - next; - } - $bit & 3 or next; - if ($bit & CMD_REPEAT) { - push @data, readbyte(\@block, $bit) for 1 .. shift @data; - } else { - push @data, readbyte(\@block, $bit); - } - } - $desc eq "move" and $data[2] == 0 and $desc = "rally"; - push @$self, [$time, $player, $desc, @data]; - } - } - return $self; -} - -} - my @race = (qw(Z T P), (undef) x 3, '-'); sub showtime { @@ -568,6 +169,53 @@ for my $player (sort keys %stats) { ) if 0; } +if ($ACTGIF) { + open my $imgfile, '>', "test.gif" or die; + binmode $imgfile; + select $imgfile; + + use GD; + my $ani = GD::Image->new($head->{width}, $head->{height}); + my $bg = $ani->colorAllocate(0, 0, 0); + my @plot = ( + $ani->colorAllocate(255, 0, 0), + $ani->colorAllocate(255, 255, 0), + $ani->colorAllocate(0, 255, 0), + $ani->colorAllocate(0, 255, 255), + $ani->colorAllocate(0, 0, 255), + $ani->colorAllocate(255, 0, 255), + ); + + print $ani->gifanimbegin; +# print $ani->gifanimadd; + { + my $frame = GD::Image->new($ani->getBounds); + print $frame->gifanimadd; + my $length = 30 / .042; + my $last = 0; + for (@$map) { + my ($time, $player, $cmd, @data) = @$_; +#$time < $length * 10 or last; + while ($time > $last + $length) { + $last += $length; + print $frame->gifanimadd(0, 0, 0, 32); +# $frame = GD::Image->new($ani->getBounds); + } + if ($cmd eq "build") { + $frame->setPixel($data[1]>>5, $data[2]>>5, $plot[$player]); + } + elsif ($cmd eq "move" or $cmd eq "attack") { + $frame->setPixel($data[0]>>5, $data[1]>>5, $plot[$player]); +# if $data[2] == 0xFFFF_FFFF; + } + } +# add_frame_data($frame); + print $frame->gifanimadd; + } + print $ani->gifanimend; + select STDOUT; +} + use Games::StarCraft::DB; my $Db = Games::StarCraft::DB->connect({RaiseError => 1}) or die "No database: $DBI::errstr\n"; @@ -727,6 +375,7 @@ screp [options] < [replay data] Options: --verbose --apm + --act --dbname --dbid