Revision history for Perl extension Devel::Size.
+0.71 2008-10-14 BrowserUk 70 tests
+ * Added bit-vector pointer tracking mechanism.
+ - new fatal error (64-bit platforms only)
+ * Added exception handling
+ - 4 new warnings (disabled by default)
+ * Updated POD to reflect above
+ * Added basic.t test 13
+ * replaced Module::Install with hand crafted EU::MM Makefile.pl
+ (With many thanks to Sisyphus)
+ because we couldn't work out how to add C++ options to allow
+ exception handling.
+
0.71 2008-08-24 Tels 69 tests
* adapt patch from Reini Urban to fix failing RV under 5.10 and 5.11. AV
and HV were pushed directly onto the pending_array, and not the RV,
0.64 Mon Dec 19 18:46:00 2005
- Patch to make Devel::Size compile on bleadperl (Courtesy of
- Nick Clark)
- - Fix up the PVIV string size calcs (Courtesy of Andrew Shirrayev)
+ Nick Clark)
+ - Fix up the PVIV string size calcs (Courtesy of Andrew Shirrayev)
0.63 Thu Jun 30 14:29:43 2005
- Turns out that OP_TRANS is a basic op, not a loop op. This
- is a bug in versions of perl 5.8.x before 5.8.7. Work around
- it.
+ is a bug in versions of perl 5.8.x before 5.8.7. Work around
+ it.
0.62 Tue Jun 28 11:59:00 2005
- Took out // comments
- - Added in copyright notice
- - Some small amount of regex parsing
- - Suppress multiple copies of each warning on each call
+ - Added in copyright notice
+ - Some small amount of regex parsing
+ - Suppress multiple copies of each warning on each call
0.61 Mon Jun 27 16:19:00 2005
- Added more checks for formats
- - Got CVs sizing right
+ - Got CVs sizing right
0.59 Sat Nov 27 16:42:42 2004
- Applied documentation and sane warning patch from Nigel Sandever
0.58 Fri Jul 18 11:42:32 2003
- Fix for problems triggered by perl 5.8.0 and up, more tests, and
- removal of an "our" for better backwards compatibility. (Courtesy
- of Marcus Holland-Moritz <mhx-perl@gmx.net>)
+ removal of an "our" for better backwards compatibility. (Courtesy
+ of Marcus Holland-Moritz <mhx-perl@gmx.net>)
0.57 Thu Mar 20 13:21:14 2003
- setting $Devel::Size::warn to 0 disables not complete warnings
0.55 Sat Feb 22 17:21:00 2003
- Fixed a bad size calculation (we were overestimating by one byte)
- - Updated the docs to show some of the places that there might be 'dark'
- memory that Devel::Size can't see.
- - Added in tests from Ken Williams
+ - Updated the docs to show some of the places that there might be 'dark'
+ memory that Devel::Size can't see.
+ - Added in tests from Ken Williams
0.54 Sat Oct 12 14:11:00 2002
- - Applied a patch to get it working on 5.8.0 under Tru64
+ - Applied a patch to get it working on 5.8.0 under Tru64
0.53 Thu Oct 10 12:30:00 2002
- Finally started updating Changes file
- - Applied doc patch from Ann Barcomb
- - Got globs sizing right
+ - Applied doc patch from Ann Barcomb
+ - Got globs sizing right
0.01 Mon Oct 7 01:05:32 2002
- - original version; created by h2xs 1.2 with options
- -A -n Devel::Size
+ - original version; created by h2xs 1.2 with options
+ -A -n Devel::Size
CHANGES
-inc/Module/Install.pm
-inc/Module/Install/Base.pm
-inc/Module/Install/Can.pm
-inc/Module/Install/Fetch.pm
-inc/Module/Install/Makefile.pm
-inc/Module/Install/Metadata.pm
-inc/Module/Install/Win32.pm
-inc/Module/Install/WriteAll.pm
lib/Devel/Size.pm
Makefile.PL
MANIFEST
MANIFEST.SKIP
-META.yml Module meta-data (added by MakeMaker)
+META.yml Module meta-data (added by MakeMaker)
README
SIGNATURE
Size.xs
----
-abstract: 'Perl extension for finding the memory usage of Perl variables'
-author:
- - 'Tels <nospam-abuse@bloodgate.com>'
-build_requires:
- Test::More: 0.42
-distribution_type: module
-generated_by: 'Module::Install version 0.77'
-license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-name: Devel-Size
-no_index:
- directory:
- - examples
- - inc
- - t
-recommends:
- Devel::Size::Report: 0.11
-requires:
- DynaLoader: 0
- perl: 5.006
-resources:
- license: http://dev.perl.org/licenses/
-version: 0.71
+# http://module-build.sourceforge.net/META-spec.html\r
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#\r
+name: Devel-Size\r
+version: 0.72\r
+version_from: lib/Devel/Size.pm\r
+installdirs: site\r
+requires:\r
+\r
+distribution_type: module\r
+generated_by: ExtUtils::MakeMaker version 6.17\r
-
-use strict;
-# require at least 5.006, it doesn't even compile under 5.005
-require 5.006;
-
-# Load the Module::Install bundled in ./inc/
-use inc::Module::Install;
-
-name 'Devel-Size';
-
-# Get most of the details from the primary module
-all_from 'lib/Devel/Size.pm';
-
-requires 'DynaLoader' => 0;
-requires 'perl' => 5.006;
-
-recommends 'Devel::Size::Report' => 0.11;
-
-test_requires 'Test::More' => 0.42;
-
-license 'perl'; # from 5.8.8
-
-# It seems not to be possible to specifiy two authors here :/
-# Nor does a "maintainer" property exist
-author 'Tels <nospam-abuse@bloodgate.com>';
-
-# Do not index these
-no_index directory => 'examples';
-
-# Generate the Makefile
-WriteAll;
+use ExtUtils::MakeMaker;\r
+use Config;\r
+\r
+my %options = ( \r
+ NAME => 'Devel::Size',\r
+ LIBS => $Config{cc} eq 'gcc' || $Config{cc} eq 'cc' ? ['-lstdc++'] : '',\r
+ VERSION_FROM => 'lib/Devel/Size.pm',\r
+ CC => $Config{cc} eq 'cl' ? 'cl' : 'g++',\r
+);\r
+\r
+WriteMakefile(%options);\r
my $other_size = size(\@foo);
my $foo = {a => [1, 2, 3],
- b => {a => [1, 3, 4]}
+ b => {a => [1, 3, 4]}
};
my $total_size = total_size($foo);
To build and install this module, you need:
- Perl
- a working C or C++ compiler
- a make (or namke on Windows) utility
+ Perl
+ a working C or C++ compiler
+ a make (or namke on Windows) utility
Follow these steps:
On Linux, Cygwin, or Unix:
- perl Makefile.PL
- make
- make test
- sudo make install
+ perl Makefile.PL
+ make
+ make test
+ sudo make install
+
+On most systems, it is necessary to link to libstdc++. On such systems,
+libstdc++ should be found automatically (by default).
+If libstdc++ is *not* being found automatically (in which case you'll get
+link errors),then instead of running 'perl Makefile.PL', you'll need to run:
+
+ perl Makefile.pl LIBS="-L/path/to/libstdc++ -lstdc++"
On Windows:
- perl Makefile.PL
- nmake
- nmake test
- nmake install
+ perl Makefile.PL
+ nmake
+ nmake test
+ nmake install
=head1 BUGREPORTS
Please report bugs to:
- http://rt.cpan.org/NoAuth/Bugs.html?Dist=Devel-Size
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=Devel-Size
=head1 COPYRIGHT
SHA1 ae5f28dcf99f4e2880611ba504ba94bcbd5fdde9 Makefile.PL
SHA1 92434a102aaa3096b9bf747caeed1d97b0551f55 README
SHA1 5c399dee208b899e84659477127b19514b63b1ca Size.xs
-SHA1 5c9e093b0facca46d50e3c69d5569aa7a98db0b8 inc/Module/Install.pm
-SHA1 465acb50b9006ce61f58a7bd02d0bb029ddceaa6 inc/Module/Install/Base.pm
-SHA1 8356d82167fc00550b4a3ceea8bd852a374d7509 inc/Module/Install/Can.pm
-SHA1 b47ce07fa6d6e38e3daa6cfc752b23f59a64754c inc/Module/Install/Fetch.pm
-SHA1 37ed4ccd7aba10119e6f2993b8082674ce2e5961 inc/Module/Install/Makefile.pm
-SHA1 4aa1c578faad51f31e62bed7b28d3d42b88219c3 inc/Module/Install/Metadata.pm
-SHA1 d7529d795a1304c88253b26a9089913edf31ae5e inc/Module/Install/Win32.pm
-SHA1 2a74aba5a78e7ab2776382e42106ebe941c2ac28 inc/Module/Install/WriteAll.pm
SHA1 a18728b3efcecd37f62797a39ff9dd913bbb0e47 lib/Devel/Size.pm
SHA1 d0d8d563949313e09479186343c4107616abcab9 t/basic.t
SHA1 dc638392e64661dd07deeba11f67e35650a6384a t/pod.t
#include "perl.h"
#include "XSUB.h"
+
+#ifdef _MSC_VER
+# include <excpt.h>
+# define try __try
+# define catch __except
+# define EXCEPTION EXCEPTION_EXECUTE_HANDLER
+#else
+# define EXCEPTION ...
+#endif
+
+#ifdef __GNUC__
+# define __attribute__(x)
+#endif
+
static int regex_whine;
static int fm_whine;
+static int dangle_whine = 0;
#if 0 && defined(DEBUGGING)
#define dbg_printf(x) printf x
#define dbg_printf(x)
#endif
+#define TAG //printf( "# %s(%d)\n", __FILE__, __LINE__ )
#define carp puts
-UV thing_size(SV *, HV *);
+
+#define ALIGN_BITS ( sizeof(void*) >> 1 )
+#define BIT_BITS 3
+#define BYTE_BITS 14
+#define SLOT_BITS ( sizeof( void*) * 8 ) - ( ALIGN_BITS + BIT_BITS + BYTE_BITS )
+#define BYTES_PER_SLOT 1 << BYTE_BITS
+#define TRACKING_SLOTS 8192 // max. 8192 for 4GB/32-bit machine
+
+typedef char* TRACKING[ TRACKING_SLOTS ];
+
+/*
+ Checks to see if thing is in the bitstring.
+ Returns true or false, and
+ notes thing in the segmented bitstring.
+ */
+IV check_new( TRACKING *tv, void *p ) {
+ unsigned long slot = (unsigned long)p >> (SLOT_BITS + BIT_BITS + ALIGN_BITS);
+ unsigned int byte = ((unsigned long)p >> (ALIGN_BITS + BIT_BITS)) & 0x00003fffU;
+ unsigned int bit = ((unsigned long)p >> ALIGN_BITS) & 0x00000007U;
+ unsigned int nop = (unsigned long)p & 0x3U;
+
+ if (NULL == p || NULL == tv) return FALSE;
+ try {
+ char c = *(char *)p;
+ }
+ catch ( EXCEPTION ) {
+ if( dangle_whine )
+ warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
+ return FALSE;
+ }
+ dbg_printf((
+ "address: %p slot: %p byte: %4x bit: %4x nop:%x\n",
+ p, slot, byte, bit, nop
+ ));
+ TAG;
+ if( slot >= TRACKING_SLOTS ) {
+ die( "Devel::Size: Please rebuild D::S with TRACKING_SLOTS > %u\n", slot );
+ }
+ TAG;
+ if( (*tv)[ slot ] == NULL ) {
+ Newz( 0xfc0ff, (*tv)[ slot ], BYTES_PER_SLOT, char );
+ }
+ TAG;
+ if( (*tv)[ slot ][ byte ] & ( 1 << bit ) ) {
+ return FALSE;
+ }
+ TAG;
+ (*tv)[ slot ][ byte ] |= ( 1 << bit );
+ TAG;
+ return TRUE;
+}
+
+UV thing_size(const SV *const, TRACKING *);
typedef enum {
- OPc_NULL, /* 0 */
- OPc_BASEOP, /* 1 */
- OPc_UNOP, /* 2 */
- OPc_BINOP, /* 3 */
- OPc_LOGOP, /* 4 */
- OPc_LISTOP, /* 5 */
- OPc_PMOP, /* 6 */
- OPc_SVOP, /* 7 */
- OPc_PADOP, /* 8 */
- OPc_PVOP, /* 9 */
- OPc_LOOP, /* 10 */
- OPc_COP /* 11 */
+ OPc_NULL, /* 0 */
+ OPc_BASEOP, /* 1 */
+ OPc_UNOP, /* 2 */
+ OPc_BINOP, /* 3 */
+ OPc_LOGOP, /* 4 */
+ OPc_LISTOP, /* 5 */
+ OPc_PMOP, /* 6 */
+ OPc_SVOP, /* 7 */
+ OPc_PADOP, /* 8 */
+ OPc_PVOP, /* 9 */
+ OPc_LOOP, /* 10 */
+ OPc_COP /* 11 */
} opclass;
static opclass
-cc_opclass(OP *o)
+cc_opclass(const OP * const o)
{
if (!o)
- return OPc_NULL;
+ return OPc_NULL;
+ try {
+ if (o->op_type == 0)
+ return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
- if (o->op_type == 0)
- return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+ if (o->op_type == OP_SASSIGN)
+ return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
- if (o->op_type == OP_SASSIGN)
- return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
+ #ifdef USE_ITHREADS
+ if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
+ return OPc_PADOP;
+ #endif
-#ifdef USE_ITHREADS
- if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
- return OPc_PADOP;
-#endif
+ if ((o->op_type == OP_TRANS)) {
+ return OPc_BASEOP;
+ }
- if ((o->op_type = OP_TRANS)) {
- return OPc_BASEOP;
- }
+ switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
+ case OA_BASEOP: TAG;
+ return OPc_BASEOP;
+
+ case OA_UNOP: TAG;
+ return OPc_UNOP;
+
+ case OA_BINOP: TAG;
+ return OPc_BINOP;
- switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
- case OA_BASEOP:
- return OPc_BASEOP;
+ case OA_LOGOP: TAG;
+ return OPc_LOGOP;
- case OA_UNOP:
- return OPc_UNOP;
+ case OA_LISTOP: TAG;
+ return OPc_LISTOP;
- case OA_BINOP:
- return OPc_BINOP;
+ case OA_PMOP: TAG;
+ return OPc_PMOP;
- case OA_LOGOP:
- return OPc_LOGOP;
+ case OA_SVOP: TAG;
+ return OPc_SVOP;
- case OA_LISTOP:
- return OPc_LISTOP;
+ case OA_PADOP: TAG;
+ return OPc_PADOP;
- case OA_PMOP:
- return OPc_PMOP;
+ case OA_PVOP_OR_SVOP: TAG;
+ /*
+ * Character translations (tr///) are usually a PVOP, keeping a
+ * pointer to a table of shorts used to look up translations.
+ * Under utf8, however, a simple table isn't practical; instead,
+ * the OP is an SVOP, and the SV is a reference to a swash
+ * (i.e., an RV pointing to an HV).
+ */
+ return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+ ? OPc_SVOP : OPc_PVOP;
- case OA_SVOP:
- return OPc_SVOP;
+ case OA_LOOP: TAG;
+ return OPc_LOOP;
- case OA_PADOP:
- return OPc_PADOP;
+ case OA_COP: TAG;
+ return OPc_COP;
- case OA_PVOP_OR_SVOP:
+ case OA_BASEOP_OR_UNOP: TAG;
/*
- * Character translations (tr///) are usually a PVOP, keeping a
- * pointer to a table of shorts used to look up translations.
- * Under utf8, however, a simple table isn't practical; instead,
- * the OP is an SVOP, and the SV is a reference to a swash
- * (i.e., an RV pointing to an HV).
+ * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
+ * whether parens were seen. perly.y uses OPf_SPECIAL to
+ * signal whether a BASEOP had empty parens or none.
+ * Some other UNOPs are created later, though, so the best
+ * test is OPf_KIDS, which is set in newUNOP.
*/
- return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
- ? OPc_SVOP : OPc_PVOP;
-
- case OA_LOOP:
- return OPc_LOOP;
-
- case OA_COP:
- return OPc_COP;
-
- case OA_BASEOP_OR_UNOP:
- /*
- * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
- * whether parens were seen. perly.y uses OPf_SPECIAL to
- * signal whether a BASEOP had empty parens or none.
- * Some other UNOPs are created later, though, so the best
- * test is OPf_KIDS, which is set in newUNOP.
- */
- return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
-
- case OA_FILESTATOP:
- /*
- * The file stat OPs are created via UNI(OP_foo) in toke.c but use
- * the OPf_REF flag to distinguish between OP types instead of the
- * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
- * return OPc_UNOP so that walkoptree can find our children. If
- * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
- * (no argument to the operator) it's an OP; with OPf_REF set it's
- * an SVOP (and op_sv is the GV for the filehandle argument).
- */
- return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
-#ifdef USE_ITHREADS
- (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
-#else
- (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
-#endif
- case OA_LOOPEXOP:
- /*
- * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
- * label was omitted (in which case it's a BASEOP) or else a term was
- * seen. In this last case, all except goto are definitely PVOP but
- * goto is either a PVOP (with an ordinary constant label), an UNOP
- * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
- * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
- * get set.
- */
- if (o->op_flags & OPf_STACKED)
- return OPc_UNOP;
- else if (o->op_flags & OPf_SPECIAL)
- return OPc_BASEOP;
- else
- return OPc_PVOP;
- }
- warn("can't determine class of operator %s, assuming BASEOP\n",
- PL_op_name[o->op_type]);
+ return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+
+ case OA_FILESTATOP: TAG;
+ /*
+ * The file stat OPs are created via UNI(OP_foo) in toke.c but use
+ * the OPf_REF flag to distinguish between OP types instead of the
+ * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
+ * return OPc_UNOP so that walkoptree can find our children. If
+ * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
+ * (no argument to the operator) it's an OP; with OPf_REF set it's
+ * an SVOP (and op_sv is the GV for the filehandle argument).
+ */
+ return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
+ #ifdef USE_ITHREADS
+ (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
+ #else
+ (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
+ #endif
+ case OA_LOOPEXOP: TAG;
+ /*
+ * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
+ * label was omitted (in which case it's a BASEOP) or else a term was
+ * seen. In this last case, all except goto are definitely PVOP but
+ * goto is either a PVOP (with an ordinary constant label), an UNOP
+ * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
+ * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
+ * get set.
+ */
+ if (o->op_flags & OPf_STACKED)
+ return OPc_UNOP;
+ else if (o->op_flags & OPf_SPECIAL)
+ return OPc_BASEOP;
+ else
+ return OPc_PVOP;
+ }
+ warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
+ PL_op_name[o->op_type]);
+ }
+ catch( EXCEPTION ) { }
return OPc_BASEOP;
}
static int go_yell = 1;
-/* Checks to see if thing is in the hash. Returns true or false, and
- notes thing in the hash.
-
- This code does one Evil Thing. Since we're tracking pointers, we
- tell perl that the string key is the address in the pointer. We do this by
- passing in the address of the address, along with the size of a
- pointer as the length. Perl then uses the four (or eight, on
- 64-bit machines) bytes of the address as the string we're using as
- the key */
-IV check_new(HV *tracking_hash, const void *thing) {
- if (NULL == thing || NULL == tracking_hash) {
- return FALSE;
- }
- if (hv_exists(tracking_hash, (char *)&thing, sizeof(void *))) {
- return FALSE;
- }
- hv_store(tracking_hash, (char *)&thing, sizeof(void *), &PL_sv_yes, 0);
- return TRUE;
-}
-
/* Figure out how much magic is attached to the SV and return the
size */
-IV magic_size(SV *thing, HV *tracking_hash) {
+IV magic_size(const SV * const thing, TRACKING *tv) {
IV total_size = 0;
MAGIC *magic_pointer;
magic_pointer = SvMAGIC(thing);
/* Have we seen the magic pointer? */
- while (magic_pointer && check_new(tracking_hash, magic_pointer)) {
+ while (magic_pointer && check_new(tv, magic_pointer)) {
total_size += sizeof(MAGIC);
- /* Have we seen the magic vtable? */
- if (magic_pointer->mg_virtual &&
- check_new(tracking_hash, magic_pointer->mg_virtual)) {
- total_size += sizeof(MGVTBL);
- }
+ try {
+ /* Have we seen the magic vtable? */
+ if (magic_pointer->mg_virtual &&
+ check_new(tv, magic_pointer->mg_virtual)) {
+ total_size += sizeof(MGVTBL);
+ }
- /* Get the next in the chain */
- magic_pointer = magic_pointer->mg_moremagic;
+ /* Get the next in the chain */ // ?try
+ magic_pointer = magic_pointer->mg_moremagic;
+ }
+ catch( EXCEPTION ) {
+ if( dangle_whine )
+ warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
+ }
}
-
return total_size;
}
-UV regex_size(REGEXP *baseregex, HV *tracking_hash) {
+UV regex_size(const REGEXP * const baseregex, TRACKING *tv) {
UV total_size = 0;
total_size += sizeof(REGEXP);
-#if (PERL_VERSION < 11)
+#if (PERL_VERSION < 11)
/* Note the size of the paren offset thing */
total_size += sizeof(I32) * baseregex->nparens * 2;
total_size += strlen(baseregex->precomp);
return total_size;
}
-UV op_size(OP *baseop, HV *tracking_hash) {
+UV op_size(const OP * const baseop, TRACKING *tv) {
UV total_size = 0;
-
- if (check_new(tracking_hash, baseop->op_next)) {
- total_size += op_size(baseop->op_next, tracking_hash);
- }
-
- switch (cc_opclass(baseop)) {
- case OPc_BASEOP:
- total_size += sizeof(struct op);
- break;
- case OPc_UNOP:
- total_size += sizeof(struct unop);
- if (check_new(tracking_hash, cUNOPx(baseop)->op_first)) {
- total_size += op_size(cUNOPx(baseop)->op_first, tracking_hash);
- }
- break;
- case OPc_BINOP:
- total_size += sizeof(struct binop);
- if (check_new(tracking_hash, cBINOPx(baseop)->op_first)) {
- total_size += op_size(cBINOPx(baseop)->op_first, tracking_hash);
- }
- if (check_new(tracking_hash, cBINOPx(baseop)->op_last)) {
- total_size += op_size(cBINOPx(baseop)->op_last, tracking_hash);
- }
- break;
- case OPc_LOGOP:
- total_size += sizeof(struct logop);
- if (check_new(tracking_hash, cLOGOPx(baseop)->op_first)) {
- total_size += op_size(cBINOPx(baseop)->op_first, tracking_hash);
- }
- if (check_new(tracking_hash, cLOGOPx(baseop)->op_other)) {
- total_size += op_size(cLOGOPx(baseop)->op_other, tracking_hash);
- }
- break;
- case OPc_LISTOP:
- total_size += sizeof(struct listop);
- if (check_new(tracking_hash, cLISTOPx(baseop)->op_first)) {
- total_size += op_size(cLISTOPx(baseop)->op_first, tracking_hash);
- }
- if (check_new(tracking_hash, cLISTOPx(baseop)->op_last)) {
- total_size += op_size(cLISTOPx(baseop)->op_last, tracking_hash);
- }
- break;
- case OPc_PMOP:
- total_size += sizeof(struct pmop);
- if (check_new(tracking_hash, cPMOPx(baseop)->op_first)) {
- total_size += op_size(cPMOPx(baseop)->op_first, tracking_hash);
- }
- if (check_new(tracking_hash, cPMOPx(baseop)->op_last)) {
- total_size += op_size(cPMOPx(baseop)->op_last, tracking_hash);
- }
+ try {
+ TAG;
+ if (check_new(tv, baseop->op_next)) {
+ total_size += op_size(baseop->op_next, tv);
+ }
+ TAG;
+ switch (cc_opclass(baseop)) {
+ case OPc_BASEOP: TAG;
+ total_size += sizeof(struct op);
+ TAG;break;
+ case OPc_UNOP: TAG;
+ total_size += sizeof(struct unop);
+ if (check_new(tv, cUNOPx(baseop)->op_first)) {
+ total_size += op_size(cUNOPx(baseop)->op_first, tv);
+ }
+ TAG;break;
+ case OPc_BINOP: TAG;
+ total_size += sizeof(struct binop);
+ if (check_new(tv, cBINOPx(baseop)->op_first)) {
+ total_size += op_size(cBINOPx(baseop)->op_first, tv);
+ }
+ if (check_new(tv, cBINOPx(baseop)->op_last)) {
+ total_size += op_size(cBINOPx(baseop)->op_last, tv);
+ }
+ TAG;break;
+ case OPc_LOGOP: TAG;
+ total_size += sizeof(struct logop);
+ if (check_new(tv, cLOGOPx(baseop)->op_first)) {
+ total_size += op_size(cBINOPx(baseop)->op_first, tv);
+ }
+ if (check_new(tv, cLOGOPx(baseop)->op_other)) {
+ total_size += op_size(cLOGOPx(baseop)->op_other, tv);
+ }
+ TAG;break;
+ case OPc_LISTOP: TAG;
+ total_size += sizeof(struct listop);
+ if (check_new(tv, cLISTOPx(baseop)->op_first)) {
+ total_size += op_size(cLISTOPx(baseop)->op_first, tv);
+ }
+ if (check_new(tv, cLISTOPx(baseop)->op_last)) {
+ total_size += op_size(cLISTOPx(baseop)->op_last, tv);
+ }
+ TAG;break;
+ case OPc_PMOP: TAG;
+ total_size += sizeof(struct pmop);
+ if (check_new(tv, cPMOPx(baseop)->op_first)) {
+ total_size += op_size(cPMOPx(baseop)->op_first, tv);
+ }
+ if (check_new(tv, cPMOPx(baseop)->op_last)) {
+ total_size += op_size(cPMOPx(baseop)->op_last, tv);
+ }
#if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
- if (check_new(tracking_hash, cPMOPx(baseop)->op_pmreplroot)) {
- total_size += op_size(cPMOPx(baseop)->op_pmreplroot, tracking_hash);
- }
- if (check_new(tracking_hash, cPMOPx(baseop)->op_pmreplstart)) {
- total_size += op_size(cPMOPx(baseop)->op_pmreplstart, tracking_hash);
- }
- if (check_new(tracking_hash, cPMOPx(baseop)->op_pmnext)) {
- total_size += op_size((OP *)cPMOPx(baseop)->op_pmnext, tracking_hash);
- }
+ if (check_new(tv, cPMOPx(baseop)->op_pmreplroot)) {
+ total_size += op_size(cPMOPx(baseop)->op_pmreplroot, tv);
+ }
+ if (check_new(tv, cPMOPx(baseop)->op_pmreplstart)) {
+ total_size += op_size(cPMOPx(baseop)->op_pmreplstart, tv);
+ }
+ if (check_new(tv, cPMOPx(baseop)->op_pmnext)) {
+ total_size += op_size((OP *)cPMOPx(baseop)->op_pmnext, tv);
+ }
#endif
- /* This is defined away in perl 5.8.x, but it is in there for
- 5.6.x */
+ /* This is defined away in perl 5.8.x, but it is in there for
+ 5.6.x */
#ifdef PM_GETRE
- if (check_new(tracking_hash, PM_GETRE((cPMOPx(baseop))))) {
- total_size += regex_size(PM_GETRE(cPMOPx(baseop)), tracking_hash);
- }
+ if (check_new(tv, PM_GETRE((cPMOPx(baseop))))) {
+ total_size += regex_size(PM_GETRE(cPMOPx(baseop)), tv);
+ }
#else
- if (check_new(tracking_hash, cPMOPx(baseop)->op_pmregexp)) {
- total_size += regex_size(cPMOPx(baseop)->op_pmregexp, tracking_hash);
- }
+ if (check_new(tv, cPMOPx(baseop)->op_pmregexp)) {
+ total_size += regex_size(cPMOPx(baseop)->op_pmregexp, tv);
+ }
#endif
- break;
- case OPc_SVOP:
- total_size += sizeof(struct pmop);
- if (check_new(tracking_hash, cSVOPx(baseop)->op_sv)) {
- total_size += thing_size(cSVOPx(baseop)->op_sv, tracking_hash);
- }
- break;
- case OPc_PADOP:
- total_size += sizeof(struct padop);
- break;
- case OPc_PVOP:
- if (check_new(tracking_hash, cPVOPx(baseop)->op_pv)) {
- total_size += strlen(cPVOPx(baseop)->op_pv);
- }
- case OPc_LOOP:
- total_size += sizeof(struct loop);
- if (check_new(tracking_hash, cLOOPx(baseop)->op_first)) {
- total_size += op_size(cLOOPx(baseop)->op_first, tracking_hash);
- }
- if (check_new(tracking_hash, cLOOPx(baseop)->op_last)) {
- total_size += op_size(cLOOPx(baseop)->op_last, tracking_hash);
- }
- if (check_new(tracking_hash, cLOOPx(baseop)->op_redoop)) {
- total_size += op_size(cLOOPx(baseop)->op_redoop, tracking_hash);
- }
- if (check_new(tracking_hash, cLOOPx(baseop)->op_nextop)) {
- total_size += op_size(cLOOPx(baseop)->op_nextop, tracking_hash);
- }
- /* Not working for some reason, but the code's here for later
- fixing
- if (check_new(tracking_hash, cLOOPx(baseop)->op_lastop)) {
- total_size += op_size(cLOOPx(baseop)->op_lastop, tracking_hash);
- }
- */
- break;
- case OPc_COP:
- {
- COP *basecop;
- basecop = (COP *)baseop;
- total_size += sizeof(struct cop);
-
- /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
- Eliminate cop_label from struct cop by storing a label as the first
- entry in the hints hash. Most statements don't have labels, so this
- will save memory. Not sure how much.
- The check below will be incorrect fail on bleadperls
- before 5.11 @33656, but later than 5.10, producing slightly too
- small memory sizes on these Perls. */
+ TAG;break;
+ case OPc_SVOP: TAG;
+ total_size += sizeof(struct pmop);
+ if (check_new(tv, cSVOPx(baseop)->op_sv)) {
+ total_size += thing_size(cSVOPx(baseop)->op_sv, tv);
+ }
+ TAG;break;
+ case OPc_PADOP: TAG;
+ total_size += sizeof(struct padop);
+ TAG;break;
+ case OPc_PVOP: TAG;
+ if (check_new(tv, cPVOPx(baseop)->op_pv)) {
+ total_size += strlen(cPVOPx(baseop)->op_pv);
+ }
+ case OPc_LOOP: TAG;
+ total_size += sizeof(struct loop);
+ if (check_new(tv, cLOOPx(baseop)->op_first)) {
+ total_size += op_size(cLOOPx(baseop)->op_first, tv);
+ }
+ if (check_new(tv, cLOOPx(baseop)->op_last)) {
+ total_size += op_size(cLOOPx(baseop)->op_last, tv);
+ }
+ if (check_new(tv, cLOOPx(baseop)->op_redoop)) {
+ total_size += op_size(cLOOPx(baseop)->op_redoop, tv);
+ }
+ if (check_new(tv, cLOOPx(baseop)->op_nextop)) {
+ total_size += op_size(cLOOPx(baseop)->op_nextop, tv);
+ }
+ if (check_new(tv, cLOOPx(baseop)->op_lastop)) {
+ total_size += op_size(cLOOPx(baseop)->op_lastop, tv);
+ }
+
+ TAG;break;
+ case OPc_COP: TAG;
+ {
+ COP *basecop;
+ basecop = (COP *)baseop;
+ total_size += sizeof(struct cop);
+
+ /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
+ Eliminate cop_label from struct cop by storing a label as the first
+ entry in the hints hash. Most statements don't have labels, so this
+ will save memory. Not sure how much.
+ The check below will be incorrect fail on bleadperls
+ before 5.11 @33656, but later than 5.10, producing slightly too
+ small memory sizes on these Perls. */
#if (PERL_VERSION < 11)
- if (check_new(tracking_hash, basecop->cop_label)) {
- total_size += strlen(basecop->cop_label);
- }
+ if (check_new(tv, basecop->cop_label)) {
+ total_size += strlen(basecop->cop_label);
+ }
#endif
#ifdef USE_ITHREADS
- if (check_new(tracking_hash, basecop->cop_file)) {
- total_size += strlen(basecop->cop_file);
- }
- if (check_new(tracking_hash, basecop->cop_stashpv)) {
- total_size += strlen(basecop->cop_stashpv);
- }
+ if (check_new(tv, basecop->cop_file)) {
+ total_size += strlen(basecop->cop_file);
+ }
+ if (check_new(tv, basecop->cop_stashpv)) {
+ total_size += strlen(basecop->cop_stashpv);
+ }
#else
- if (check_new(tracking_hash, basecop->cop_stash)) {
- total_size += thing_size((SV *)basecop->cop_stash, tracking_hash);
- }
- if (check_new(tracking_hash, basecop->cop_filegv)) {
- total_size += thing_size((SV *)basecop->cop_filegv, tracking_hash);
- }
+ if (check_new(tv, basecop->cop_stash)) {
+ total_size += thing_size((SV *)basecop->cop_stash, tv);
+ }
+ if (check_new(tv, basecop->cop_filegv)) {
+ total_size += thing_size((SV *)basecop->cop_filegv, tv);
+ }
#endif
- }
- break;
- default:
- break;
+ }
+ TAG;break;
+ default:
+ TAG;break;
+ }
+ }
+ catch( EXCEPTION ) {
+ if( dangle_whine )
+ warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
}
return total_size;
}
# define NEW_HEAD_LAYOUT
#endif
-UV thing_size(SV *orig_thing, HV *tracking_hash) {
- SV *thing = orig_thing;
+UV thing_size(const SV * const orig_thing, TRACKING *tv) {
+ const SV *thing = orig_thing;
UV total_size = sizeof(SV);
switch (SvTYPE(thing)) {
/* Is it undef? */
- case SVt_NULL:
- break;
+ case SVt_NULL: TAG;
+ TAG;break;
/* Just a plain integer. This will be differently sized depending
on whether purify's been compiled in */
- case SVt_IV:
+ case SVt_IV: TAG;
#ifndef NEW_HEAD_LAYOUT
# ifdef PURIFY
total_size += sizeof(sizeof(XPVIV));
total_size += sizeof(IV);
# endif
#endif
- break;
+ TAG;break;
/* Is it a float? Like the int, it depends on purify */
- case SVt_NV:
+ case SVt_NV: TAG;
#ifdef PURIFY
total_size += sizeof(sizeof(XPVNV));
#else
total_size += sizeof(NV);
#endif
- break;
-#if (PERL_VERSION < 11)
+ TAG;break;
+#if (PERL_VERSION < 11)
/* Is it a reference? */
- case SVt_RV:
+ case SVt_RV: TAG;
#ifndef NEW_HEAD_LAYOUT
total_size += sizeof(XRV);
#endif
- break;
+ TAG;break;
#endif
/* How about a plain string? In which case we need to add in how
much has been allocated */
- case SVt_PV:
+ case SVt_PV: TAG;
total_size += sizeof(XPV);
#if (PERL_VERSION < 11)
- total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
+ total_size += SvROK(thing) ? thing_size( SvRV(thing), tv) : SvLEN(thing);
#else
total_size += SvLEN(thing);
#endif
- break;
+ TAG;break;
/* A string with an integer part? */
- case SVt_PVIV:
+ case SVt_PVIV: TAG;
total_size += sizeof(XPVIV);
#if (PERL_VERSION < 11)
- total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
+ total_size += SvROK(thing) ? thing_size( SvRV(thing), tv) : SvLEN(thing);
#else
total_size += SvLEN(thing);
#endif
if(SvOOK(thing)) {
total_size += SvIVX(thing);
- }
- break;
+ }
+ TAG;break;
/* A scalar/string/reference with a float part? */
- case SVt_PVNV:
+ case SVt_PVNV: TAG;
total_size += sizeof(XPVNV);
#if (PERL_VERSION < 11)
- total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
+ total_size += SvROK(thing) ? thing_size( SvRV(thing), tv) : SvLEN(thing);
#else
total_size += SvLEN(thing);
#endif
- break;
- case SVt_PVMG:
+ TAG;break;
+ case SVt_PVMG: TAG;
total_size += sizeof(XPVMG);
#if (PERL_VERSION < 11)
- total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
+ total_size += SvROK(thing) ? thing_size( SvRV(thing), tv) : SvLEN(thing);
#else
total_size += SvLEN(thing);
#endif
- total_size += magic_size(thing, tracking_hash);
- break;
+ total_size += magic_size(thing, tv);
+ TAG;break;
#if PERL_VERSION <= 8
- case SVt_PVBM:
+ case SVt_PVBM: TAG;
total_size += sizeof(XPVBM);
#if (PERL_VERSION < 11)
- total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
+ total_size += SvROK(thing) ? thing_size( SvRV(thing), tv) : SvLEN(thing);
#else
total_size += SvLEN(thing);
#endif
- total_size += magic_size(thing, tracking_hash);
- break;
+ total_size += magic_size(thing, tv);
+ TAG;break;
#endif
- case SVt_PVLV:
+ case SVt_PVLV: TAG;
total_size += sizeof(XPVLV);
#if (PERL_VERSION < 11)
- total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
+ total_size += SvROK(thing) ? thing_size( SvRV(thing), tv) : SvLEN(thing);
#else
total_size += SvLEN(thing);
#endif
- total_size += magic_size(thing, tracking_hash);
- break;
+ total_size += magic_size(thing, tv);
+ TAG;break;
/* How much space is dedicated to the array? Not counting the
elements in the array, mind, just the array itself */
- case SVt_PVAV:
+ case SVt_PVAV: TAG;
total_size += sizeof(XPVAV);
/* Is there anything in the array? */
if (AvMAX(thing) != -1) {
/* Add in the bits on the other side of the beginning */
dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
- total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
+ total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
/* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
}
/* Is there something hanging off the arylen element? */
if (AvARYLEN(thing)) {
- if (check_new(tracking_hash, AvARYLEN(thing))) {
- total_size += thing_size(AvARYLEN(thing), tracking_hash);
+ if (check_new(tv, AvARYLEN(thing))) {
+ total_size += thing_size(AvARYLEN(thing), tv);
}
}
- total_size += magic_size(thing, tracking_hash);
- break;
- case SVt_PVHV:
+ total_size += magic_size(thing, tv);
+ TAG;break;
+ case SVt_PVHV: TAG;
/* First the base struct */
total_size += sizeof(XPVHV);
/* Now the array of buckets */
/* Now walk the bucket chain */
if (HvARRAY(thing)) {
HE *cur_entry;
- IV cur_bucket = 0;
+ UV cur_bucket = 0;
for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
- cur_entry = *(HvARRAY(thing) + cur_bucket);
- while (cur_entry) {
- total_size += sizeof(HE);
- if (cur_entry->hent_hek) {
- /* Hash keys can be shared. Have we seen this before? */
- if (check_new(tracking_hash, cur_entry->hent_hek)) {
- total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
- }
- }
- cur_entry = cur_entry->hent_next;
- }
+ cur_entry = *(HvARRAY(thing) + cur_bucket);
+ while (cur_entry) {
+ total_size += sizeof(HE);
+ if (cur_entry->hent_hek) {
+ /* Hash keys can be shared. Have we seen this before? */
+ if (check_new(tv, cur_entry->hent_hek)) {
+ total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
+ }
+ }
+ cur_entry = cur_entry->hent_next;
+ }
}
}
- total_size += magic_size(thing, tracking_hash);
- break;
- case SVt_PVCV:
+ total_size += magic_size(thing, tv);
+ TAG;break;
+ case SVt_PVCV: TAG;
total_size += sizeof(XPVCV);
- total_size += magic_size(thing, tracking_hash);
+ total_size += magic_size(thing, tv);
total_size += ((XPVIO *) SvANY(thing))->xpv_len;
- if (check_new(tracking_hash, CvSTASH(thing))) {
- total_size += thing_size((SV *)CvSTASH(thing), tracking_hash);
+ if (check_new(tv, CvSTASH(thing))) {
+ total_size += thing_size((SV *)CvSTASH(thing), tv);
}
- if (check_new(tracking_hash, SvSTASH(thing))) {
- total_size += thing_size((SV *)SvSTASH(thing), tracking_hash);
+ if (check_new(tv, SvSTASH(thing))) {
+ total_size += thing_size( (SV *)SvSTASH(thing), tv);
}
- if (check_new(tracking_hash, CvGV(thing))) {
- total_size += thing_size((SV *)CvGV(thing), tracking_hash);
+ if (check_new(tv, CvGV(thing))) {
+ total_size += thing_size((SV *)CvGV(thing), tv);
}
- if (check_new(tracking_hash, CvPADLIST(thing))) {
- total_size += thing_size((SV *)CvPADLIST(thing), tracking_hash);
+ if (check_new(tv, CvPADLIST(thing))) {
+ total_size += thing_size((SV *)CvPADLIST(thing), tv);
}
- if (check_new(tracking_hash, CvOUTSIDE(thing))) {
- total_size += thing_size((SV *)CvOUTSIDE(thing), tracking_hash);
+ if (check_new(tv, CvOUTSIDE(thing))) {
+ total_size += thing_size((SV *)CvOUTSIDE(thing), tv);
}
-
- if (check_new(tracking_hash, CvSTART(thing))) {
- total_size += op_size(CvSTART(thing), tracking_hash);
+ if (check_new(tv, CvSTART(thing))) {
+ total_size += op_size(CvSTART(thing), tv);
}
- if (check_new(tracking_hash, CvROOT(thing))) {
- total_size += op_size(CvROOT(thing), tracking_hash);
+ if (check_new(tv, CvROOT(thing))) {
+ total_size += op_size(CvROOT(thing), tv);
}
- break;
- case SVt_PVGV:
- total_size += magic_size(thing, tracking_hash);
+ TAG;break;
+ case SVt_PVGV: TAG;
+ total_size += magic_size(thing, tv);
total_size += sizeof(XPVGV);
total_size += GvNAMELEN(thing);
#ifdef GvFILE
/* Is there a file? */
if (GvFILE(thing)) {
- if (check_new(tracking_hash, GvFILE(thing))) {
- total_size += strlen(GvFILE(thing));
+ if (check_new(tv, GvFILE(thing))) {
+ total_size += strlen(GvFILE(thing));
}
}
#endif
/* Is there something hanging off the glob? */
if (GvGP(thing)) {
- if (check_new(tracking_hash, GvGP(thing))) {
- total_size += sizeof(GP);
- {
- SV *generic_thing;
- if ((generic_thing = (SV *)(GvGP(thing)->gp_sv))) {
- total_size += thing_size(generic_thing, tracking_hash);
- }
- if ((generic_thing = (SV *)(GvGP(thing)->gp_form))) {
- total_size += thing_size(generic_thing, tracking_hash);
- }
- if ((generic_thing = (SV *)(GvGP(thing)->gp_av))) {
- total_size += thing_size(generic_thing, tracking_hash);
- }
- if ((generic_thing = (SV *)(GvGP(thing)->gp_hv))) {
- total_size += thing_size(generic_thing, tracking_hash);
- }
- if ((generic_thing = (SV *)(GvGP(thing)->gp_egv))) {
- total_size += thing_size(generic_thing, tracking_hash);
- }
- if ((generic_thing = (SV *)(GvGP(thing)->gp_cv))) {
- total_size += thing_size(generic_thing, tracking_hash);
- }
- }
+ if (check_new(tv, GvGP(thing))) {
+ total_size += sizeof(GP);
+ {
+ SV *generic_thing;
+ if ((generic_thing = (SV *)(GvGP(thing)->gp_sv))) {
+ total_size += thing_size(generic_thing, tv);
+ }
+ if ((generic_thing = (SV *)(GvGP(thing)->gp_form))) {
+ total_size += thing_size(generic_thing, tv);
+ }
+ if ((generic_thing = (SV *)(GvGP(thing)->gp_av))) {
+ total_size += thing_size(generic_thing, tv);
+ }
+ if ((generic_thing = (SV *)(GvGP(thing)->gp_hv))) {
+ total_size += thing_size(generic_thing, tv);
+ }
+ if ((generic_thing = (SV *)(GvGP(thing)->gp_egv))) {
+ total_size += thing_size(generic_thing, tv);
+ }
+ if ((generic_thing = (SV *)(GvGP(thing)->gp_cv))) {
+ total_size += thing_size(generic_thing, tv);
+ }
+ }
}
}
- break;
- case SVt_PVFM:
+ TAG;break;
+ case SVt_PVFM: TAG;
total_size += sizeof(XPVFM);
- total_size += magic_size(thing, tracking_hash);
+ total_size += magic_size(thing, tv);
total_size += ((XPVIO *) SvANY(thing))->xpv_len;
- if (check_new(tracking_hash, CvPADLIST(thing))) {
- total_size += thing_size((SV *)CvPADLIST(thing), tracking_hash);
+ if (check_new(tv, CvPADLIST(thing))) {
+ total_size += thing_size((SV *)CvPADLIST(thing), tv);
}
- if (check_new(tracking_hash, CvOUTSIDE(thing))) {
- total_size += thing_size((SV *)CvOUTSIDE(thing), tracking_hash);
+ if (check_new(tv, CvOUTSIDE(thing))) {
+ total_size += thing_size((SV *)CvOUTSIDE(thing), tv);
}
if (go_yell && !fm_whine) {
carp("Devel::Size: Calculated sizes for FMs are incomplete");
fm_whine = 1;
}
- break;
- case SVt_PVIO:
+ TAG;break;
+ case SVt_PVIO: TAG;
total_size += sizeof(XPVIO);
- total_size += magic_size(thing, tracking_hash);
- if (check_new(tracking_hash, (SvPVX(thing)))) {
+ total_size += magic_size(thing, tv);
+ if (check_new(tv, (SvPVX(thing)))) {
total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
}
/* Some embedded char pointers */
- if (check_new(tracking_hash, ((XPVIO *) SvANY(thing))->xio_top_name)) {
+ if (check_new(tv, ((XPVIO *) SvANY(thing))->xio_top_name)) {
total_size += strlen(((XPVIO *) SvANY(thing))->xio_top_name);
}
- if (check_new(tracking_hash, ((XPVIO *) SvANY(thing))->xio_fmt_name)) {
+ if (check_new(tv, ((XPVIO *) SvANY(thing))->xio_fmt_name)) {
total_size += strlen(((XPVIO *) SvANY(thing))->xio_fmt_name);
}
- if (check_new(tracking_hash, ((XPVIO *) SvANY(thing))->xio_bottom_name)) {
+ if (check_new(tv, ((XPVIO *) SvANY(thing))->xio_bottom_name)) {
total_size += strlen(((XPVIO *) SvANY(thing))->xio_bottom_name);
}
/* Throw the GVs on the list to be walked if they're not-null */
if (((XPVIO *) SvANY(thing))->xio_top_gv) {
total_size += thing_size((SV *)((XPVIO *) SvANY(thing))->xio_top_gv,
- tracking_hash);
+ tv);
}
if (((XPVIO *) SvANY(thing))->xio_bottom_gv) {
total_size += thing_size((SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv,
- tracking_hash);
+ tv);
}
if (((XPVIO *) SvANY(thing))->xio_fmt_gv) {
total_size += thing_size((SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv,
- tracking_hash);
+ tv);
}
/* Only go trotting through the IO structures if they're really
not... we can't, so we don't even try */
#ifdef USE_PERLIO
/* Dig into xio_ifp and xio_ofp here */
- croak("Devel::Size: Can't size up perlio layers yet");
+ warn("Devel::Size: Can't size up perlio layers yet\n");
#endif
- break;
+ TAG;break;
default:
- croak("Devel::Size: Unknown variable type");
+ warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
}
return total_size;
}
-MODULE = Devel::Size PACKAGE = Devel::Size
+MODULE = Devel::Size PACKAGE = Devel::Size
PROTOTYPES: DISABLE
SV *orig_thing
CODE:
{
+ int i;
SV *thing = orig_thing;
/* Hash to track our seen pointers */
- HV *tracking_hash = newHV();
+ //HV *tracking_hash = newHV();
SV *warn_flag;
+ TRACKING *tv;
+ Newz( 0xfc0ff, tv, 1, TRACKING );
/* Check warning status */
go_yell = 0;
fm_whine = 0;
if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
- go_yell = SvIV(warn_flag);
+ dangle_whine = go_yell = SvIV(warn_flag);
+ }
+ if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
+ dangle_whine = SvIV(warn_flag);
}
/* If they passed us a reference then dereference it. This is the
}
#endif
- RETVAL = thing_size(thing, tracking_hash);
+ RETVAL = thing_size(thing, tv);
/* Clean up after ourselves */
- SvREFCNT_dec(tracking_hash);
+ //SvREFCNT_dec(tracking_hash);
+ for( i = 0; i < TRACKING_SLOTS; ++i ) {
+ if( (*tv)[ i ] )
+ Safefree( (*tv)[ i ] );
+ }
+ Safefree( tv );
}
OUTPUT:
RETVAL
SV *orig_thing
CODE:
{
+ int i;
SV *thing = orig_thing;
/* Hash to track our seen pointers */
- HV *tracking_hash;
+ //HV *tracking_hash;
+ TRACKING *tv;
/* Array with things we still need to do */
AV *pending_array;
IV size = 0;
fm_whine = 0;
if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
- go_yell = SvIV(warn_flag);
+ dangle_whine = go_yell = SvIV(warn_flag);
+ }
+ if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
+ dangle_whine = SvIV(warn_flag);
}
/* init these after the go_yell above */
- tracking_hash = newHV();
+ //tracking_hash = newHV();
+ Newz( 0xfc0ff, tv, 1, TRACKING );
pending_array = newAV();
/* We cannot push HV/AV directly, only the RV. So deref it
while (av_len(pending_array) >= 0) {
thing = av_pop(pending_array);
/* Process it if we've not seen it */
- if (check_new(tracking_hash, thing)) {
+ if (check_new(tv, thing)) {
dbg_printf(("# Found type %i at %p\n", SvTYPE(thing), thing));
/* Is it valid? */
if (thing) {
- /* Yes, it is. So let's check the type */
- switch (SvTYPE(thing)) {
- /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
- case SVt_PVNV:
- if (SvROK(thing))
- {
- av_push(pending_array, SvRV(thing));
- }
- break;
-
- /* this is the "*** dereference later" part - see above */
+ /* Yes, it is. So let's check the type */
+ switch (SvTYPE(thing)) {
+ /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
+ case SVt_PVNV: TAG;
+ if (SvROK(thing))
+ {
+ av_push(pending_array, SvRV(thing));
+ }
+ TAG;break;
+
+ /* this is the "*** dereference later" part - see above */
#if (PERL_VERSION < 11)
- case SVt_RV:
+ case SVt_RV: TAG;
#else
- case SVt_IV:
+ case SVt_IV: TAG;
#endif
dbg_printf(("# Found RV\n"));
if (SvROK(thing)) {
dbg_printf(("# Found RV\n"));
av_push(pending_array, SvRV(thing));
}
- break;
-
- case SVt_PVAV:
- {
- dbg_printf(("# Found type AV\n"));
- /* Quick alias to cut down on casting */
- AV *tempAV = (AV *)thing;
- SV **tempSV;
-
- /* Any elements? */
- if (av_len(tempAV) != -1) {
- IV index;
- /* Run through them all */
- for (index = 0; index <= av_len(tempAV); index++) {
- /* Did we get something? */
- if ((tempSV = av_fetch(tempAV, index, 0))) {
- /* Was it undef? */
- if (*tempSV != &PL_sv_undef) {
- /* Apparently not. Save it for later */
- av_push(pending_array, *tempSV);
- }
- }
- }
- }
- }
- break;
-
- case SVt_PVHV:
- dbg_printf(("# Found type HV\n"));
- /* Is there anything in here? */
- if (hv_iterinit((HV *)thing)) {
- HE *temp_he;
- while ((temp_he = hv_iternext((HV *)thing))) {
- av_push(pending_array, hv_iterval((HV *)thing, temp_he));
- }
- }
- break;
-
- case SVt_PVGV:
- dbg_printf(("# Found type GV\n"));
- /* Run through all the pieces and push the ones with bits */
- if (GvSV(thing)) {
- av_push(pending_array, (SV *)GvSV(thing));
- }
- if (GvFORM(thing)) {
- av_push(pending_array, (SV *)GvFORM(thing));
- }
- if (GvAV(thing)) {
- av_push(pending_array, (SV *)GvAV(thing));
- }
- if (GvHV(thing)) {
- av_push(pending_array, (SV *)GvHV(thing));
- }
- if (GvCV(thing)) {
- av_push(pending_array, (SV *)GvCV(thing));
- }
- break;
- default:
- break;
- }
+ TAG;break;
+
+ case SVt_PVAV: TAG;
+ {
+ AV *tempAV = (AV *)thing;
+ SV **tempSV;
+
+ dbg_printf(("# Found type AV\n"));
+ /* Quick alias to cut down on casting */
+
+ /* Any elements? */
+ if (av_len(tempAV) != -1) {
+ IV index;
+ /* Run through them all */
+ for (index = 0; index <= av_len(tempAV); index++) {
+ /* Did we get something? */
+ if ((tempSV = av_fetch(tempAV, index, 0))) {
+ /* Was it undef? */
+ if (*tempSV != &PL_sv_undef) {
+ /* Apparently not. Save it for later */
+ av_push(pending_array, *tempSV);
+ }
+ }
+ }
+ }
+ }
+ TAG;break;
+
+ case SVt_PVHV: TAG;
+ dbg_printf(("# Found type HV\n"));
+ /* Is there anything in here? */
+ if (hv_iterinit((HV *)thing)) {
+ HE *temp_he;
+ while ((temp_he = hv_iternext((HV *)thing))) {
+ av_push(pending_array, hv_iterval((HV *)thing, temp_he));
+ }
+ }
+ TAG;break;
+
+ case SVt_PVGV: TAG;
+ dbg_printf(("# Found type GV\n"));
+ /* Run through all the pieces and push the ones with bits */
+ if (GvSV(thing)) {
+ av_push(pending_array, (SV *)GvSV(thing));
+ }
+ if (GvFORM(thing)) {
+ av_push(pending_array, (SV *)GvFORM(thing));
+ }
+ if (GvAV(thing)) {
+ av_push(pending_array, (SV *)GvAV(thing));
+ }
+ if (GvHV(thing)) {
+ av_push(pending_array, (SV *)GvHV(thing));
+ }
+ if (GvCV(thing)) {
+ av_push(pending_array, (SV *)GvCV(thing));
+ }
+ TAG;break;
+ default:
+ TAG;break;
+ }
}
-
- size = thing_size(thing, tracking_hash);
+ size = thing_size(thing, tv);
RETVAL += size;
} else {
/* check_new() returned false: */
} /* end while */
/* Clean up after ourselves */
- SvREFCNT_dec(tracking_hash);
+ //SvREFCNT_dec(tracking_hash);
+ for( i = 0; i < TRACKING_SLOTS; ++i ) {
+ if( (*tv)[ i ] )
+ Safefree( (*tv)[ i ] );
+ }
+ Safefree( tv );
SvREFCNT_dec(pending_array);
}
OUTPUT:
+++ /dev/null
-#line 1
-package Module::Install;
-
-# For any maintainers:
-# The load order for Module::Install is a bit magic.
-# It goes something like this...
-#
-# IF ( host has Module::Install installed, creating author mode ) {
-# 1. Makefile.PL calls "use inc::Module::Install"
-# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
-# 3. The installed version of inc::Module::Install loads
-# 4. inc::Module::Install calls "require Module::Install"
-# 5. The ./inc/ version of Module::Install loads
-# } ELSE {
-# 1. Makefile.PL calls "use inc::Module::Install"
-# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
-# 3. The ./inc/ version of Module::Install loads
-# }
-
-BEGIN {
- require 5.004;
-}
-use strict 'vars';
-
-use vars qw{$VERSION};
-BEGIN {
- # All Module::Install core packages now require synchronised versions.
- # This will be used to ensure we don't accidentally load old or
- # different versions of modules.
- # This is not enforced yet, but will be some time in the next few
- # releases once we can make sure it won't clash with custom
- # Module::Install extensions.
- $VERSION = '0.77';
-
- *inc::Module::Install::VERSION = *VERSION;
- @inc::Module::Install::ISA = __PACKAGE__;
-
-}
-
-
-
-
-
-# Whether or not inc::Module::Install is actually loaded, the
-# $INC{inc/Module/Install.pm} is what will still get set as long as
-# the caller loaded module this in the documented manner.
-# If not set, the caller may NOT have loaded the bundled version, and thus
-# they may not have a MI version that works with the Makefile.PL. This would
-# result in false errors or unexpected behaviour. And we don't want that.
-my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
-unless ( $INC{$file} ) { die <<"END_DIE" }
-
-Please invoke ${\__PACKAGE__} with:
-
- use inc::${\__PACKAGE__};
-
-not:
-
- use ${\__PACKAGE__};
-
-END_DIE
-
-
-
-
-
-# If the script that is loading Module::Install is from the future,
-# then make will detect this and cause it to re-run over and over
-# again. This is bad. Rather than taking action to touch it (which
-# is unreliable on some platforms and requires write permissions)
-# for now we should catch this and refuse to run.
-if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
-
-Your installer $0 has a modification time in the future.
-
-This is known to create infinite loops in make.
-
-Please correct this, then run $0 again.
-
-END_DIE
-
-
-
-
-
-# Build.PL was formerly supported, but no longer is due to excessive
-# difficulty in implementing every single feature twice.
-if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
-
-Module::Install no longer supports Build.PL.
-
-It was impossible to maintain duel backends, and has been deprecated.
-
-Please remove all Build.PL files and only use the Makefile.PL installer.
-
-END_DIE
-
-
-
-
-
-# To save some more typing in Module::Install installers, every...
-# use inc::Module::Install
-# ...also acts as an implicit use strict.
-$^H |= strict::bits(qw(refs subs vars));
-
-
-
-
-
-use Cwd ();
-use File::Find ();
-use File::Path ();
-use FindBin;
-
-sub autoload {
- my $self = shift;
- my $who = $self->_caller;
- my $cwd = Cwd::cwd();
- my $sym = "${who}::AUTOLOAD";
- $sym->{$cwd} = sub {
- my $pwd = Cwd::cwd();
- if ( my $code = $sym->{$pwd} ) {
- # delegate back to parent dirs
- goto &$code unless $cwd eq $pwd;
- }
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- unless ( uc($1) eq $1 ) {
- unshift @_, ( $self, $1 );
- goto &{$self->can('call')};
- }
- };
-}
-
-sub import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- unless ( -f $self->{file} ) {
- require "$self->{path}/$self->{dispatch}.pm";
- File::Path::mkpath("$self->{prefix}/$self->{author}");
- $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
- $self->{admin}->init;
- @_ = ($class, _self => $self);
- goto &{"$self->{name}::import"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
-
- return 1;
-}
-
-sub preload {
- my $self = shift;
- unless ( $self->{extensions} ) {
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- );
- }
-
- my @exts = @{$self->{extensions}};
- unless ( @exts ) {
- my $admin = $self->{admin};
- @exts = $admin->load_all_extensions;
- }
-
- my %seen;
- foreach my $obj ( @exts ) {
- while (my ($method, $glob) = each %{ref($obj) . '::'}) {
- next unless $obj->can($method);
- next if $method =~ /^_/;
- next if $method eq uc($method);
- $seen{$method}++;
- }
- }
-
- my $who = $self->_caller;
- foreach my $name ( sort keys %seen ) {
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
-}
-
-sub new {
- my ($class, %args) = @_;
-
- # ignore the prefix on extension modules built from top level.
- my $base_path = Cwd::abs_path($FindBin::Bin);
- unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
- delete $args{prefix};
- }
-
- return $args{_self} if $args{_self};
-
- $args{dispatch} ||= 'Admin';
- $args{prefix} ||= 'inc';
- $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
- $args{bundle} ||= 'inc/BUNDLES';
- $args{base} ||= $base_path;
- $class =~ s/^\Q$args{prefix}\E:://;
- $args{name} ||= $class;
- $args{version} ||= $class->VERSION;
- unless ( $args{path} ) {
- $args{path} = $args{name};
- $args{path} =~ s!::!/!g;
- }
- $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
- $args{wrote} = 0;
-
- bless( \%args, $class );
-}
-
-sub call {
- my ($self, $method) = @_;
- my $obj = $self->load($method) or return;
- splice(@_, 0, 2, $obj);
- goto &{$obj->can($method)};
-}
-
-sub load {
- my ($self, $method) = @_;
-
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- ) unless $self->{extensions};
-
- foreach my $obj (@{$self->{extensions}}) {
- return $obj if $obj->can($method);
- }
-
- my $admin = $self->{admin} or die <<"END_DIE";
-The '$method' method does not exist in the '$self->{prefix}' path!
-Please remove the '$self->{prefix}' directory and run $0 again to load it.
-END_DIE
-
- my $obj = $admin->load($method, 1);
- push @{$self->{extensions}}, $obj;
-
- $obj;
-}
-
-sub load_extensions {
- my ($self, $path, $top) = @_;
-
- unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} = delete $INC{$file};
- push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
- }
-
- $self->{extensions} ||= [];
-}
-
-sub find_extensions {
- my ($self, $path) = @_;
-
- my @found;
- File::Find::find( sub {
- my $file = $File::Find::name;
- return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
- my $subpath = $1;
- return if lc($subpath) eq lc($self->{dispatch});
-
- $file = "$self->{path}/$subpath.pm";
- my $pkg = "$self->{name}::$subpath";
- $pkg =~ s!/!::!g;
-
- # If we have a mixed-case package name, assume case has been preserved
- # correctly. Otherwise, root through the file to locate the case-preserved
- # version of the package name.
- if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
- my $content = Module::Install::_read($subpath . '.pm');
- my $in_pod = 0;
- foreach ( split //, $content ) {
- $in_pod = 1 if /^=\w/;
- $in_pod = 0 if /^=cut/;
- next if ($in_pod || /^=cut/); # skip pod text
- next if /^\s*#/; # and comments
- if ( m/^\s*package\s+($pkg)\s*;/i ) {
- $pkg = $1;
- last;
- }
- }
- }
-
- push @found, [ $file, $pkg ];
- }, $path ) if -d $path;
-
- @found;
-}
-
-
-
-
-
-#####################################################################
-# Utility Functions
-
-sub _caller {
- my $depth = 0;
- my $call = caller($depth);
- while ( $call eq __PACKAGE__ ) {
- $depth++;
- $call = caller($depth);
- }
- return $call;
-}
-
-sub _read {
- local *FH;
- open FH, "< $_[0]" or die "open($_[0]): $!";
- my $str = do { local $/; <FH> };
- close FH or die "close($_[0]): $!";
- return $str;
-}
-
-sub _write {
- local *FH;
- open FH, "> $_[0]" or die "open($_[0]): $!";
- foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
- close FH or die "close($_[0]): $!";
-}
-
-# _version is for processing module versions (eg, 1.03_05) not
-# Perl versions (eg, 5.8.1).
-
-sub _version ($) {
- my $s = shift || 0;
- $s =~ s/^(\d+)\.?//;
- my $l = $1 || 0;
- my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
- $l = $l . '.' . join '', @v if @v;
- return $l + 0;
-}
-
-# Cloned from Params::Util::_CLASS
-sub _CLASS ($) {
- (
- defined $_[0]
- and
- ! ref $_[0]
- and
- $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
- ) ? $_[0] : undef;
-}
-
-1;
-
-# Copyright 2008 Adam Kennedy.
+++ /dev/null
-#line 1
-package Module::Install::Base;
-
-$VERSION = '0.77';
-
-# Suspend handler for "redefined" warnings
-BEGIN {
- my $w = $SIG{__WARN__};
- $SIG{__WARN__} = sub { $w };
-}
-
-### This is the ONLY module that shouldn't have strict on
-# use strict;
-
-#line 41
-
-sub new {
- my ($class, %args) = @_;
-
- foreach my $method ( qw(call load) ) {
- *{"$class\::$method"} = sub {
- shift()->_top->$method(@_);
- } unless defined &{"$class\::$method"};
- }
-
- bless( \%args, $class );
-}
-
-#line 61
-
-sub AUTOLOAD {
- my $self = shift;
- local $@;
- my $autoload = eval { $self->_top->autoload } or return;
- goto &$autoload;
-}
-
-#line 76
-
-sub _top { $_[0]->{_top} }
-
-#line 89
-
-sub admin {
- $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
-}
-
-#line 101
-
-sub is_admin {
- $_[0]->admin->VERSION;
-}
-
-sub DESTROY {}
-
-package Module::Install::Base::FakeAdmin;
-
-my $Fake;
-sub new { $Fake ||= bless(\@_, $_[0]) }
-
-sub AUTOLOAD {}
-
-sub DESTROY {}
-
-# Restore warning handler
-BEGIN {
- $SIG{__WARN__} = $SIG{__WARN__}->();
-}
-
-1;
-
-#line 146
+++ /dev/null
-#line 1
-package Module::Install::Can;
-
-use strict;
-use Module::Install::Base;
-use Config ();
-### This adds a 5.005 Perl version dependency.
-### This is a bug and will be fixed.
-use File::Spec ();
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.77';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-# check if we can load some module
-### Upgrade this to not have to load the module if possible
-sub can_use {
- my ($self, $mod, $ver) = @_;
- $mod =~ s{::|\\}{/}g;
- $mod .= '.pm' unless $mod =~ /\.pm$/i;
-
- my $pkg = $mod;
- $pkg =~ s{/}{::}g;
- $pkg =~ s{\.pm$}{}i;
-
- local $@;
- eval { require $mod; $pkg->VERSION($ver || 0); 1 };
-}
-
-# check if we can run some command
-sub can_run {
- my ($self, $cmd) = @_;
-
- my $_cmd = $cmd;
- return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
-
- for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
- next if $dir eq '';
- my $abs = File::Spec->catfile($dir, $_[1]);
- return $abs if (-x $abs or $abs = MM->maybe_command($abs));
- }
-
- return;
-}
-
-# can we locate a (the) C compiler
-sub can_cc {
- my $self = shift;
- my @chunks = split(/ /, $Config::Config{cc}) or return;
-
- # $Config{cc} may contain args; try to find out the program part
- while (@chunks) {
- return $self->can_run("@chunks") || (pop(@chunks), next);
- }
-
- return;
-}
-
-# Fix Cygwin bug on maybe_command();
-if ( $^O eq 'cygwin' ) {
- require ExtUtils::MM_Cygwin;
- require ExtUtils::MM_Win32;
- if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
- *ExtUtils::MM_Cygwin::maybe_command = sub {
- my ($self, $file) = @_;
- if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
- ExtUtils::MM_Win32->maybe_command($file);
- } else {
- ExtUtils::MM_Unix->maybe_command($file);
- }
- }
- }
-}
-
-1;
-
-__END__
-
-#line 158
+++ /dev/null
-#line 1
-package Module::Install::Fetch;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.77';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-sub get_file {
- my ($self, %args) = @_;
- my ($scheme, $host, $path, $file) =
- $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
-
- if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
- $args{url} = $args{ftp_url}
- or (warn("LWP support unavailable!\n"), return);
- ($scheme, $host, $path, $file) =
- $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
- }
-
- $|++;
- print "Fetching '$file' from $host... ";
-
- unless (eval { require Socket; Socket::inet_aton($host) }) {
- warn "'$host' resolve failed!\n";
- return;
- }
-
- return unless $scheme eq 'ftp' or $scheme eq 'http';
-
- require Cwd;
- my $dir = Cwd::getcwd();
- chdir $args{local_dir} or return if exists $args{local_dir};
-
- if (eval { require LWP::Simple; 1 }) {
- LWP::Simple::mirror($args{url}, $file);
- }
- elsif (eval { require Net::FTP; 1 }) { eval {
- # use Net::FTP to get past firewall
- my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
- $ftp->login("anonymous", 'anonymous@example.com');
- $ftp->cwd($path);
- $ftp->binary;
- $ftp->get($file) or (warn("$!\n"), return);
- $ftp->quit;
- } }
- elsif (my $ftp = $self->can_run('ftp')) { eval {
- # no Net::FTP, fallback to ftp.exe
- require FileHandle;
- my $fh = FileHandle->new;
-
- local $SIG{CHLD} = 'IGNORE';
- unless ($fh->open("|$ftp -n")) {
- warn "Couldn't open ftp: $!\n";
- chdir $dir; return;
- }
-
- my @dialog = split(/\n/, <<"END_FTP");
-open $host
-user anonymous anonymous\@example.com
-cd $path
-binary
-get $file $file
-quit
-END_FTP
- foreach (@dialog) { $fh->print("$_\n") }
- $fh->close;
- } }
- else {
- warn "No working 'ftp' program available!\n";
- chdir $dir; return;
- }
-
- unless (-f $file) {
- warn "Fetching failed: $@\n";
- chdir $dir; return;
- }
-
- return if exists $args{size} and -s $file != $args{size};
- system($args{run}) if exists $args{run};
- unlink($file) if $args{remove};
-
- print(((!exists $args{check_for} or -e $args{check_for})
- ? "done!" : "failed! ($!)"), "\n");
- chdir $dir; return !$?;
-}
-
-1;
+++ /dev/null
-#line 1
-package Module::Install::Makefile;
-
-use strict 'vars';
-use Module::Install::Base;
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.77';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-sub Makefile { $_[0] }
-
-my %seen = ();
-
-sub prompt {
- shift;
-
- # Infinite loop protection
- my @c = caller();
- if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
- die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
- }
-
- # In automated testing, always use defaults
- if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
- local $ENV{PERL_MM_USE_DEFAULT} = 1;
- goto &ExtUtils::MakeMaker::prompt;
- } else {
- goto &ExtUtils::MakeMaker::prompt;
- }
-}
-
-sub makemaker_args {
- my $self = shift;
- my $args = ( $self->{makemaker_args} ||= {} );
- %$args = ( %$args, @_ );
- return $args;
-}
-
-# For mm args that take multiple space-seperated args,
-# append an argument to the current list.
-sub makemaker_append {
- my $self = sShift;
- my $name = shift;
- my $args = $self->makemaker_args;
- $args->{name} = defined $args->{$name}
- ? join( ' ', $args->{name}, @_ )
- : join( ' ', @_ );
-}
-
-sub build_subdirs {
- my $self = shift;
- my $subdirs = $self->makemaker_args->{DIR} ||= [];
- for my $subdir (@_) {
- push @$subdirs, $subdir;
- }
-}
-
-sub clean_files {
- my $self = shift;
- my $clean = $self->makemaker_args->{clean} ||= {};
- %$clean = (
- %$clean,
- FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
- );
-}
-
-sub realclean_files {
- my $self = shift;
- my $realclean = $self->makemaker_args->{realclean} ||= {};
- %$realclean = (
- %$realclean,
- FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
- );
-}
-
-sub libs {
- my $self = shift;
- my $libs = ref $_[0] ? shift : [ shift ];
- $self->makemaker_args( LIBS => $libs );
-}
-
-sub inc {
- my $self = shift;
- $self->makemaker_args( INC => shift );
-}
-
-my %test_dir = ();
-
-sub _wanted_t {
- /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
-}
-
-sub tests_recursive {
- my $self = shift;
- if ( $self->tests ) {
- die "tests_recursive will not work if tests are already defined";
- }
- my $dir = shift || 't';
- unless ( -d $dir ) {
- die "tests_recursive dir '$dir' does not exist";
- }
- %test_dir = ();
- require File::Find;
- File::Find::find( \&_wanted_t, $dir );
- $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
-}
-
-sub write {
- my $self = shift;
- die "&Makefile->write() takes no arguments\n" if @_;
-
- # Make sure we have a new enough
- require ExtUtils::MakeMaker;
-
- # MakeMaker can complain about module versions that include
- # an underscore, even though its own version may contain one!
- # Hence the funny regexp to get rid of it. See RT #35800
- # for details.
-
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
-
- # Generate the
- my $args = $self->makemaker_args;
- $args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name;
- $args->{VERSION} = $self->version;
- $args->{NAME} =~ s/-/::/g;
- if ( $self->tests ) {
- $args->{test} = { TESTS => $self->tests };
- }
- if ($] >= 5.005) {
- $args->{ABSTRACT} = $self->abstract;
- $args->{AUTHOR} = $self->author;
- }
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
- $args->{NO_META} = 1;
- }
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
- $args->{SIGN} = 1;
- }
- unless ( $self->is_admin ) {
- delete $args->{SIGN};
- }
-
- # merge both kinds of requires into prereq_pm
- my $prereq = ($args->{PREREQ_PM} ||= {});
- %$prereq = ( %$prereq,
- map { @$_ }
- map { @$_ }
- grep $_,
- ($self->configure_requires, $self->build_requires, $self->requires)
- );
-
- # Remove any reference to perl, PREREQ_PM doesn't support it
- delete $args->{PREREQ_PM}->{perl};
-
- # merge both kinds of requires into prereq_pm
- my $subdirs = ($args->{DIR} ||= []);
- if ($self->bundles) {
- foreach my $bundle (@{ $self->bundles }) {
- my ($file, $dir) = @$bundle;
- push @$subdirs, $dir if -d $dir;
- delete $prereq->{$file};
- }
- }
-
- if ( my $perl_version = $self->perl_version ) {
- eval "use $perl_version; 1"
- or die "ERROR: perl: Version $] is installed, "
- . "but we need version >= $perl_version";
- }
-
- $args->{INSTALLDIRS} = $self->installdirs;
-
- my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
-
- my $user_preop = delete $args{dist}->{PREOP};
- if (my $preop = $self->admin->preop($user_preop)) {
- foreach my $key ( keys %$preop ) {
- $args{dist}->{$key} = $preop->{$key};
- }
- }
-
- my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
- $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
-}
-
-sub fix_up_makefile {
- my $self = shift;
- my $makefile_name = shift;
- my $top_class = ref($self->_top) || '';
- my $top_version = $self->_top->VERSION || '';
-
- my $preamble = $self->preamble
- ? "# Preamble by $top_class $top_version\n"
- . $self->preamble
- : '';
- my $postamble = "# Postamble by $top_class $top_version\n"
- . ($self->postamble || '');
-
- local *MAKEFILE;
- open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
- my $makefile = do { local $/; <MAKEFILE> };
- close MAKEFILE or die $!;
-
- $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
- $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
- $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
- $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
- $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
-
- # Module::Install will never be used to build the Core Perl
- # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
- # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
- $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
- #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
-
- # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
- $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
-
- # XXX - This is currently unused; not sure if it breaks other MM-users
- # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
-
- open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
- print MAKEFILE "$preamble$makefile$postamble" or die $!;
- close MAKEFILE or die $!;
-
- 1;
-}
-
-sub preamble {
- my ($self, $text) = @_;
- $self->{preamble} = $text . $self->{preamble} if defined $text;
- $self->{preamble};
-}
-
-sub postamble {
- my ($self, $text) = @_;
- $self->{postamble} ||= $self->admin->postamble;
- $self->{postamble} .= $text if defined $text;
- $self->{postamble}
-}
-
-1;
-
-__END__
-
-#line 379
+++ /dev/null
-#line 1
-package Module::Install::Metadata;
-
-use strict 'vars';
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.77';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-my @scalar_keys = qw{
- name
- module_name
- abstract
- author
- version
- distribution_type
- tests
- installdirs
-};
-
-my @tuple_keys = qw{
- configure_requires
- build_requires
- requires
- recommends
- bundles
- resources
-};
-
-my @resource_keys = qw{
- homepage
- bugtracker
- repository
-};
-
-sub Meta { shift }
-sub Meta_ScalarKeys { @scalar_keys }
-sub Meta_TupleKeys { @tuple_keys }
-sub Meta_ResourceKeys { @resource_keys }
-
-foreach my $key ( @scalar_keys ) {
- *$key = sub {
- my $self = shift;
- return $self->{values}{$key} if defined wantarray and !@_;
- $self->{values}{$key} = shift;
- return $self;
- };
-}
-
-foreach my $key ( @resource_keys ) {
- *$key = sub {
- my $self = shift;
- unless ( @_ ) {
- return () unless $self->{values}{resources};
- return map { $_->[1] }
- grep { $_->[0] eq $key }
- @{ $self->{values}{resources} };
- }
- return $self->{values}{resources}{$key} unless @_;
- my $uri = shift or die(
- "Did not provide a value to $key()"
- );
- $self->resources( $key => $uri );
- return 1;
- };
-}
-
-sub requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{requires} }, [ $module, $version ];
- }
- $self->{values}{requires};
-}
-
-sub build_requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{build_requires} }, [ $module, $version ];
- }
- $self->{values}{build_requires};
-}
-
-sub configure_requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{configure_requires} }, [ $module, $version ];
- }
- $self->{values}{configure_requires};
-}
-
-sub recommends {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{recommends} }, [ $module, $version ];
- }
- $self->{values}{recommends};
-}
-
-sub bundles {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{bundles} }, [ $module, $version ];
- }
- $self->{values}{bundles};
-}
-
-# Resource handling
-my %lc_resource = map { $_ => 1 } qw{
- homepage
- license
- bugtracker
- repository
-};
-
-sub resources {
- my $self = shift;
- while ( @_ ) {
- my $name = shift or last;
- my $value = shift or next;
- if ( $name eq lc $name and ! $lc_resource{$name} ) {
- die("Unsupported reserved lowercase resource '$name'");
- }
- $self->{values}{resources} ||= [];
- push @{ $self->{values}{resources} }, [ $name, $value ];
- }
- $self->{values}{resources};
-}
-
-# Aliases for build_requires that will have alternative
-# meanings in some future version of META.yml.
-sub test_requires { shift->build_requires(@_) }
-sub install_requires { shift->build_requires(@_) }
-
-# Aliases for installdirs options
-sub install_as_core { $_[0]->installdirs('perl') }
-sub install_as_cpan { $_[0]->installdirs('site') }
-sub install_as_site { $_[0]->installdirs('site') }
-sub install_as_vendor { $_[0]->installdirs('vendor') }
-
-sub sign {
- my $self = shift;
- return $self->{values}{sign} if defined wantarray and ! @_;
- $self->{values}{sign} = ( @_ ? $_[0] : 1 );
- return $self;
-}
-
-sub dynamic_config {
- my $self = shift;
- unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config\n";
- return $self;
- }
- $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
- return 1;
-}
-
-sub perl_version {
- my $self = shift;
- return $self->{values}{perl_version} unless @_;
- my $version = shift or die(
- "Did not provide a value to perl_version()"
- );
-
- # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
- # numbers (eg, 5.006001 or 5.008009).
-
- $version =~ s/^(\d+)\.(\d+)\.(\d+)$/sprintf("%d.%03d%03d",$1,$2,$3)/e;
-
- $version =~ s/_.+$//;
- $version = $version + 0; # Numify
- unless ( $version >= 5.005 ) {
- die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
- }
- $self->{values}{perl_version} = $version;
- return 1;
-}
-
-sub license {
- my $self = shift;
- return $self->{values}{license} unless @_;
- my $license = shift or die(
- 'Did not provide a value to license()'
- );
- $self->{values}{license} = $license;
-
- # Automatically fill in license URLs
- if ( $license eq 'perl' ) {
- $self->resources( license => 'http://dev.perl.org/licenses/' );
- }
-
- return 1;
-}
-
-sub all_from {
- my ( $self, $file ) = @_;
-
- unless ( defined($file) ) {
- my $name = $self->name or die(
- "all_from called with no args without setting name() first"
- );
- $file = join('/', 'lib', split(/-/, $name)) . '.pm';
- $file =~ s{.*/}{} unless -e $file;
- unless ( -e $file ) {
- die("all_from cannot find $file from $name");
- }
- }
- unless ( -f $file ) {
- die("The path '$file' does not exist, or is not a file");
- }
-
- # Some methods pull from POD instead of code.
- # If there is a matching .pod, use that instead
- my $pod = $file;
- $pod =~ s/\.pm$/.pod/i;
- $pod = $file unless -e $pod;
-
- # Pull the different values
- $self->name_from($file) unless $self->name;
- $self->version_from($file) unless $self->version;
- $self->perl_version_from($file) unless $self->perl_version;
- $self->author_from($pod) unless $self->author;
- $self->license_from($pod) unless $self->license;
- $self->abstract_from($pod) unless $self->abstract;
-
- return 1;
-}
-
-sub provides {
- my $self = shift;
- my $provides = ( $self->{values}{provides} ||= {} );
- %$provides = (%$provides, @_) if @_;
- return $provides;
-}
-
-sub auto_provides {
- my $self = shift;
- return $self unless $self->is_admin;
- unless (-e 'MANIFEST') {
- warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
- return $self;
- }
- # Avoid spurious warnings as we are not checking manifest here.
- local $SIG{__WARN__} = sub {1};
- require ExtUtils::Manifest;
- local *ExtUtils::Manifest::manicheck = sub { return };
-
- require Module::Build;
- my $build = Module::Build->new(
- dist_name => $self->name,
- dist_version => $self->version,
- license => $self->license,
- );
- $self->provides( %{ $build->find_dist_packages || {} } );
-}
-
-sub feature {
- my $self = shift;
- my $name = shift;
- my $features = ( $self->{values}{features} ||= [] );
- my $mods;
-
- if ( @_ == 1 and ref( $_[0] ) ) {
- # The user used ->feature like ->features by passing in the second
- # argument as a reference. Accomodate for that.
- $mods = $_[0];
- } else {
- $mods = \@_;
- }
-
- my $count = 0;
- push @$features, (
- $name => [
- map {
- ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
- } @$mods
- ]
- );
-
- return @$features;
-}
-
-sub features {
- my $self = shift;
- while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
- $self->feature( $name, @$mods );
- }
- return $self->{values}{features}
- ? @{ $self->{values}{features} }
- : ();
-}
-
-sub no_index {
- my $self = shift;
- my $type = shift;
- push @{ $self->{values}{no_index}{$type} }, @_ if $type;
- return $self->{values}{no_index};
-}
-
-sub read {
- my $self = shift;
- $self->include_deps( 'YAML::Tiny', 0 );
-
- require YAML::Tiny;
- my $data = YAML::Tiny::LoadFile('META.yml');
-
- # Call methods explicitly in case user has already set some values.
- while ( my ( $key, $value ) = each %$data ) {
- next unless $self->can($key);
- if ( ref $value eq 'HASH' ) {
- while ( my ( $module, $version ) = each %$value ) {
- $self->can($key)->($self, $module => $version );
- }
- } else {
- $self->can($key)->($self, $value);
- }
- }
- return $self;
-}
-
-sub write {
- my $self = shift;
- return $self unless $self->is_admin;
- $self->admin->write_meta;
- return $self;
-}
-
-sub version_from {
- require ExtUtils::MM_Unix;
- my ( $self, $file ) = @_;
- $self->version( ExtUtils::MM_Unix->parse_version($file) );
-}
-
-sub abstract_from {
- require ExtUtils::MM_Unix;
- my ( $self, $file ) = @_;
- $self->abstract(
- bless(
- { DISTNAME => $self->name },
- 'ExtUtils::MM_Unix'
- )->parse_abstract($file)
- );
-}
-
-# Add both distribution and module name
-sub name_from {
- my ($self, $file) = @_;
- if (
- Module::Install::_read($file) =~ m/
- ^ \s*
- package \s*
- ([\w:]+)
- \s* ;
- /ixms
- ) {
- my ($name, $module_name) = ($1, $1);
- $name =~ s{::}{-}g;
- $self->name($name);
- unless ( $self->module_name ) {
- $self->module_name($module_name);
- }
- } else {
- die("Cannot determine name from $file\n");
- }
-}
-
-sub perl_version_from {
- my $self = shift;
- if (
- Module::Install::_read($_[0]) =~ m/
- ^
- (?:use|require) \s*
- v?
- ([\d_\.]+)
- \s* ;
- /ixms
- ) {
- my $perl_version = $1;
- $perl_version =~ s{_}{}g;
- $self->perl_version($perl_version);
- } else {
- warn "Cannot determine perl version info from $_[0]\n";
- return;
- }
-}
-
-sub author_from {
- my $self = shift;
- my $content = Module::Install::_read($_[0]);
- if ($content =~ m/
- =head \d \s+ (?:authors?)\b \s*
- ([^\n]*)
- |
- =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
- .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
- ([^\n]*)
- /ixms) {
- my $author = $1 || $2;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- $self->author($author);
- } else {
- warn "Cannot determine author info from $_[0]\n";
- }
-}
-
-sub license_from {
- my $self = shift;
- if (
- Module::Install::_read($_[0]) =~ m/
- (
- =head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
- .*?
- )
- (=head\\d.*|=cut.*|)
- \z
- /ixms ) {
- my $license_text = $1;
- my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl', 1,
- 'GNU general public license' => 'gpl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser general public license' => 'lgpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'GNU library general public license' => 'lgpl', 1,
- 'GNU library public license' => 'lgpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
- );
- while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
- if ( $license_text =~ /\b$pattern\b/i ) {
- if ( $osi and $license_text =~ /All rights reserved/i ) {
- print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
- }
- $self->license($license);
- return 1;
- }
- }
- }
-
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
-}
-
-sub bugtracker_from {
- my $self = shift;
- my $content = Module::Install::_read($_[0]);
- my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
- unless ( @links ) {
- warn "Cannot determine bugtracker info from $_[0]\n";
- return 0;
- }
- if ( @links > 1 ) {
- warn "Found more than on rt.cpan.org link in $_[0]\n";
- return 0;
- }
-
- # Set the bugtracker
- bugtracker( $links[0] );
- return 1;
-}
-
-sub install_script {
- my $self = shift;
- my $args = $self->makemaker_args;
- my $exe = $args->{EXE_FILES} ||= [];
- foreach ( @_ ) {
- if ( -f $_ ) {
- push @$exe, $_;
- } elsif ( -d 'script' and -f "script/$_" ) {
- push @$exe, "script/$_";
- } else {
- die("Cannot find script '$_'");
- }
- }
-}
-
-1;
+++ /dev/null
-#line 1
-package Module::Install::Win32;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.77';
- @ISA = qw{Module::Install::Base};
- $ISCORE = 1;
-}
-
-# determine if the user needs nmake, and download it if needed
-sub check_nmake {
- my $self = shift;
- $self->load('can_run');
- $self->load('get_file');
-
- require Config;
- return unless (
- $^O eq 'MSWin32' and
- $Config::Config{make} and
- $Config::Config{make} =~ /^nmake\b/i and
- ! $self->can_run('nmake')
- );
-
- print "The required 'nmake' executable not found, fetching it...\n";
-
- require File::Basename;
- my $rv = $self->get_file(
- url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
- ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
- local_dir => File::Basename::dirname($^X),
- size => 51928,
- run => 'Nmake15.exe /o > nul',
- check_for => 'Nmake.exe',
- remove => 1,
- );
-
- die <<'END_MESSAGE' unless $rv;
-
--------------------------------------------------------------------------------
-
-Since you are using Microsoft Windows, you will need the 'nmake' utility
-before installation. It's available at:
-
- http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
- or
- ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
-
-Please download the file manually, save it to a directory in %PATH% (e.g.
-C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
-that directory, and run "Nmake15.exe" from there; that will create the
-'nmake.exe' file needed by this module.
-
-You may then resume the installation process described in README.
-
--------------------------------------------------------------------------------
-END_MESSAGE
-
-}
-
-1;
+++ /dev/null
-#line 1
-package Module::Install::WriteAll;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.77';
- @ISA = qw{Module::Install::Base};
- $ISCORE = 1;
-}
-
-sub WriteAll {
- my $self = shift;
- my %args = (
- meta => 1,
- sign => 0,
- inline => 0,
- check_nmake => 1,
- @_,
- );
-
- $self->sign(1) if $args{sign};
- $self->Meta->write if $args{meta};
- $self->admin->WriteAll(%args) if $self->is_admin;
-
- $self->check_nmake if $args{check_nmake};
- unless ( $self->makemaker_args->{PL_FILES} ) {
- $self->makemaker_args( PL_FILES => {} );
- }
-
- if ( $args{inline} ) {
- $self->Inline->write;
- } else {
- $self->Makefile->write;
- }
-}
-
-1;
package Devel::Size;
use strict;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $warn);
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $warn $dangle);
-require 5.006;
+require 5.008;
require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
-# This allows declaration use Devel::Size ':all';
+# This allows declaration use Devel::Size ':all';
%EXPORT_TAGS = ( 'all' => [ qw(
- size total_size
+ size total_size
) ] );
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
@EXPORT = qw( );
-$VERSION = '0.71';
+$VERSION = '0.72';
bootstrap Devel::Size $VERSION;
$warn = 1;
+$dangle = 0; ## Set true to enable warnings about dangling pointers
1;
__END__
my $other_size = size(\@foo);
my $foo = {a => [1, 2, 3],
- b => {a => [1, 3, 4]}
+ b => {a => [1, 3, 4]}
};
my $total_size = total_size($foo);
=head2 The C library
-It's important firtst to understand how your OS and libraries handle
+It's important first to understand how your OS and libraries handle
memory. When the perl interpreter needs some memory, it asks the C
runtime library for it, using the C<malloc()> call. C<malloc> has one
parameter, the size of the memory allocation you want, and returns a
pointer to that memory. C<malloc> also makes sure that the pointer it
returns to you is properly aligned. When you're done with the memory
you hand it back to the library with the C<free()> call. C<free> has
-one parameter, the pointer that C<malloc> returned. There are a couple of interesting ramifications to this.
+one parameter, the pointer that C<malloc> returned.
+There are a couple of interesting ramifications to this.
Because malloc has to return an aligned pointer, it will round up the
memory allocation to make sure that the memory it returns is aligned
a 32 bit system. If you're on a 64 bit system the numbers get even
larger.
-This does mean that hashes eat up a I<lot> of memory, both in memory
-Devel::Size can track (the memory actually in the structures and
-strings) and that it can't (the malloc alignment and length overhead).
-
=head1 DANGERS
-Devel::Size, because of the way it works, can consume a
-considerable amount of memory as it runs. It will use five
-pointers, two integers, and two bytes worth of storage, plus
-potential alignment and bucket overhead, per thing it looks at. This
-memory is released at the end, but it may fragment your free pool,
-and will definitely expand your process' memory footprint.
+Since version 7.2, Devel::Size uses a new pointer tracking mechanism
+that consumes far less memory than was previously the case. It does this
+by using a bit vector where 1 bit represents each 4- or 8-byte aligned pointer
+(32- or 64-bit platform dependant) that could exist. Further, it segments
+that bit vector and only allocates each chunk when an address is seen within
+that chunk. By default, the module builds a static table of 8,192 slots of
+16k chunks which is sufficient to cover the full 4GB virtual address space on
+32-bit platforms. Or the first 8GB on 64-bit platforms.
+
+Besides saving a lot of memory, this change means that Devel::Size
+runs significantly faster than previous versions.
+
+One caveat of this new mechanism is that on 64-bit platforms with more than 8GB
+of memory a new fatal error may be seen. See the next section.
=head1 Messages: texts originating from this module.
=over 4
-=item "Devel::Size: Unknown variable type"
+=item "Devel::Size: Please rebuild D::S with TRACKING_SLOTS > 8192"
+
+This fatal error may be produced when using Devel::Size on 64-bit platforms
+with more than 8GB of virtual memory. It indicates that a pointer has been
+encountered that is to high for the internal pointer tracking mechanism.
+
+The solution is to rebuild Devel::Size having edited Size.XS to increase
+the value of
+
+ #define TRACKING_SLOTS 8192
-The thing (or something contained within it) that you gave to
+On 64-bit platforms, Devel::Size requires 1 slot for each 1MB of virtual
+address space. So, for a system with 12GB of memory, this should be set to
+12GB / 1MB = 12884901888 / 1048576 = 12288 ( 12 * 1024 ).
+
+=item "Devel::Size: Unknown variable type"
+
+The thing (or something contained within it) that you gave to
total_size() was unrecognisable as a Perl entity.
=back
=head2 warnings
-These messages warn you that for some types, the sizes calculated may not include
-everything that could be associated with those types. The differences are usually
+These messages warn you that for some types, the sizes calculated may not include
+everything that could be associated with those types. The differences are usually
insignificant for most uses of this module.
These may be disabled by setting
- $Devel::Size::warn = 0
+ $Devel::Size::warn = 0
=over 4
-=item "Devel::Size: Calculated sizes for CVs are incomplete"
+=item "Devel::Size: Calculated sizes for CVs are incomplete"
+
+=item "Devel::Size: Calculated sizes for FMs are incomplete"
-=item "Devel::Size: Calculated sizes for FMs are incomplete"
+=item "Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be"
+
+=back
+
+=head2 New warnings since 7.2
+
+Devel::Size has always been vulnerable to trapping when traversing Perl's
+internal data structures, if it encounters uninitialised (dangling) pointers.
+
+Exception handling has been added to deal with this possibility, and Devel::Size
+will now attempt to ignore (or log) them and continue. These messages are mainly
+of interest to Devel::Size and core developers, and so are disabled by default.
+
+They may be enabled by setting
+
+ $Devel::Size::dangle = 0
+
+=over 4
+
+=item "Devel::Size: Can't determine class of operator OPx_XXXX, assuming BASEOP\n"
+
+=item "Devel::Size: Encountered bad magic at: 0xXXXXXXXX"
+
+=item "Devel::Size: Encountered dangling pointer in opcode at: 0xXXXXXXXX"
+
+=item "Devel::Size: Encountered invalid pointer: 0xXXXXXXXX"
=back
Small portion taken from the B module as shipped with perl 5.6.2.
+New pointer tracking & exception handling by BrowserUK
+
Maintained now by Tels <http://bloodgate.com>
=head1 COPYRIGHT
use Test::More;
use strict;
-
+
my $tests;
BEGIN
{
chdir 't' if -d 't';
- plan tests => 12;
+ plan tests => 13;
use lib '../lib';
use lib '../blib/arch';
Devel::Size->import( qw(size total_size) );
die ("Uhoh, test uses an outdated version of Devel::Size")
- unless is ($Devel::Size::VERSION, '0.71', 'VERSION MATCHES');
+ unless is ($Devel::Size::VERSION, '0.72', 'VERSION MATCHES');
#############################################################################
# some basic checks:
%foo = (a => 1, b => 2);
my $x = "A string";
-my $y = "A much much longer string"; # need to be at least 7 bytes longer for 64 bit
+my $y = "A much much longer string"; # need to be at least 7 bytes longer for 64 bit
ok (size($x) < size($y), 'size() of strings');
ok (total_size($x) < total_size($y), 'total_size() of strings');
my @ary2 = (\$a, \$b);
isnt ( total_size(\@ary2) - total_size(\@ary1), 0,
- 'total_size(\@ary1) < total_size(\@ary2)');
+ 'total_size(\@ary1) < total_size(\@ary2)');
#############################################################################
# check that circular references don't mess things up
my $code = sub { '1' };
isnt (total_size($code), 0, 'total_size($code) > 0');
+
+##########################################################
+# RT#14849 (& RT#26781 and possibly RT#29238?)
+isnt( total_size( sub{ do{ my $t=0 }; } ), 0, 'total_size( sub{ my $t=0 } ) > 0' );
use Test::More;
use strict;
-
+
my $tests;
BEGIN
Devel::Size->import( qw(size total_size) );
die ("Uhoh, test uses an outdated version of Devel::Size")
- unless is ($Devel::Size::VERSION, '0.71', 'VERSION MATCHES');
+ unless is ($Devel::Size::VERSION, '0.72', 'VERSION MATCHES');
#############################################################################
# verify that pointer sizes in array slots are sensible:
my $hash = {};
$hash->{a} = 1;
-is (total_size($hash),
- total_size( { a => undef } ) + total_size(1) - total_size(undef),
- 'assert hash and hash key size');
+is (total_size($hash),
+ total_size( { a => undef } ) + total_size(1) - total_size(undef),
+ 'assert hash and hash key size');
#############################################################################
# #24846 (Does not correctly recurse into references in a PVNV-type scalar)
projects / p5sagit/Devel-Size.git / commitdiff