Skip to content

Commit 8e5dcc3

Browse files
arcarc
committed
Upgrade Devel::PPPort from 3.21 to 3.22
 [DELTA] * Add support for the following API SvREFCNT_dec_NN mg_findext sv_unmagicext * Update META Move bug tracker to github Provide link to repository
1 parent 6fa4f5e commit 8e5dcc3

File tree

11 files changed

+317
-12
lines changed

11 files changed

+317
-12
lines changed

‎Porting/Maintainers.pl

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -351,7 +351,7 @@ package Maintainers;
351351
},
352352

353353
'Devel::PPPort' => {
354-
'DISTRIBUTION' => 'MHX/Devel-PPPort-3.21.tar.gz',
354+
'DISTRIBUTION' => 'WOLFSAGE/Devel-PPPort-3.22.tar.gz',
355355
# RJBS has asked MHX to have UPSTREAM be 'blead'
356356
# (i.e. move this from cpan/ to dist/)
357357
'FILES' => q[cpan/Devel-PPPort],

‎cpan/Devel-PPPort/Makefile.PL

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,21 @@ WriteMakefile(
3434
OBJECT => 'RealPPPort$(OBJ_EXT) $(O_FILES)',
3535
XSPROTOARG => '-noprototypes',
3636
CONFIGURE => \&configure,
37+
META_MERGE => {
38+
'meta-spec' => {
39+
version => 2,
40+
},
41+
resources => {
42+
bugtracker => {
43+
web => 'https://github.com/mhx/Devel-PPPort/issues/',
44+
},
45+
repository => {
46+
type => 'git',
47+
url => 'git://github.com/mhx/Devel-PPPort.git',
48+
web => 'https://github.com/mhx/Devel-PPPort/',
49+
},
50+
},
51+
},
3752
);
3853

3954
sub configure

‎cpan/Devel-PPPort/PPPort_pm.PL

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -499,6 +499,10 @@ Version 2.x was ported to the Perl core by Paul Marquess.
499499
500500
Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
501501
502+
=item *
503+
504+
Versions >= 3.22 are maintained with support from Matthew Horsfall (alh).
505+
502506
=back
503507
504508
=head1 COPYRIGHT
@@ -523,7 +527,7 @@ package Devel::PPPort;
523527
use strict;
524528
use vars qw($VERSION $data);
525529
526-
$VERSION = '3.21';
530+
$VERSION = '3.22';
527531
528532
sub _init_data
529533
{

‎cpan/Devel-PPPort/parts/apicheck.pl

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -146,6 +146,7 @@
146146
#define NEED_load_module
147147
#define NEED_my_snprintf
148148
#define NEED_my_sprintf
149+
#define NEED_mg_findext
149150
#define NEED_my_strlcat
150151
#define NEED_my_strlcpy
151152
#define NEED_newCONSTSUB

‎cpan/Devel-PPPort/parts/inc/SvREFCNT

Lines changed: 19 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ SvREFCNT_inc
1515
SvREFCNT_inc_simple
1616
SvREFCNT_inc_NN
1717
SvREFCNT_inc_void
18+
SvREFCNT_dec_NN
1819
__UNDEFINED__
1920

2021
=implementation
@@ -76,6 +77,20 @@ __UNDEFINED__
7677
# endif
7778
#endif
7879

80+
#ifndef SvREFCNT_dec_NN
81+
# ifdef PERL_USE_GCC_BRACE_GROUPS
82+
# define SvREFCNT_dec_NN(sv) \
83+
({ \
84+
SV * const _sv = (SV*)(sv); \
85+
SvREFCNT(_sv)--; \
86+
_sv; \
87+
})
88+
# else
89+
# define SvREFCNT_dec_NN(sv) \
90+
(PL_Sv=(SV*)(sv),--(SvREFCNT(PL_Sv)),PL_Sv)
91+
# endif
92+
#endif
93+
7994
__UNDEFINED__ SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END
8095
__UNDEFINED__ SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv))
8196
__UNDEFINED__ SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv)))
@@ -110,13 +125,15 @@ SvREFCNT()
110125
mXPUSHi(SvREFCNT(sv) == 8);
111126
SvREFCNT_inc_simple_void_NN(sv);
112127
mXPUSHi(SvREFCNT(sv) == 9);
128+
SvREFCNT_dec_NN(sv);
129+
mXPUSHi(SvREFCNT(sv) == 8);
113130
while (SvREFCNT(sv) > 1)
114131
SvREFCNT_dec(sv);
115132
mXPUSHi(SvREFCNT(sv) == 1);
116133
SvREFCNT_dec(sv);
117-
XSRETURN(14);
134+
XSRETURN(15);
118135

119-
=tests plan => 14
136+
=tests plan => 15
120137

121138
for (Devel::PPPort::SvREFCNT()) {
122139
ok(defined $_ and $_);

‎cpan/Devel-PPPort/parts/inc/call

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -124,6 +124,9 @@ vload_module(U32 flags, SV *name, SV *ver, va_list *args)
124124
#if { VERSION >= 5.004 }
125125
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
126126
veop, modname, imop);
127+
#elif { VERSION > 5.003 }
128+
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
129+
veop, modname, imop);
127130
#else
128131
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
129132
modname, imop);

‎cpan/Devel-PPPort/parts/inc/magic

Lines changed: 242 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,14 +11,34 @@
1111

1212
=provides
1313

14+
mg_findext
15+
sv_unmagicext
16+
1417
__UNDEFINED__
1518
/sv_\w+_mg/
1619
sv_magic_portable
20+
MUTABLE_PTR
21+
MUTABLE_SV
1722

1823
=implementation
1924

2025
__UNDEFINED__ SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
2126

27+
/* Some random bits for sv_unmagicext. These should probably be pulled in for
28+
real and organized at some point */
29+
30+
__UNDEFINED__ HEf_SVKEY -2
31+
32+
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
33+
# define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
34+
#else
35+
# define MUTABLE_PTR(p) ((void *) (p))
36+
#endif
37+
38+
#define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
39+
40+
/* end of random bits */
41+
2242
__UNDEFINED__ PERL_MAGIC_sv '\0'
2343
__UNDEFINED__ PERL_MAGIC_overload 'A'
2444
__UNDEFINED__ PERL_MAGIC_overload_elem 'a'
@@ -200,8 +220,205 @@ __UNDEFINED__ SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring
200220

201221
#endif
202222

223+
#if !defined(mg_findext)
224+
#if { NEED mg_findext }
225+
226+
MAGIC *
227+
mg_findext(pTHX_ SV * sv, int type, const MGVTBL *vtbl) {
228+
if (sv) {
229+
MAGIC *mg;
230+
231+
#ifdef AvPAD_NAMELIST
232+
assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
233+
#endif
234+
235+
for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
236+
if (mg->mg_type == type && mg->mg_virtual == vtbl)
237+
return mg;
238+
}
239+
}
240+
241+
return NULL;
242+
}
243+
244+
#endif
245+
#endif
246+
247+
#if !defined(sv_unmagicext)
248+
#if { NEED sv_unmagicext }
249+
250+
int
251+
sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
252+
{
253+
MAGIC* mg;
254+
MAGIC** mgp;
255+
256+
if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
257+
return 0;
258+
mgp = &(SvMAGIC(sv));
259+
for (mg = *mgp; mg; mg = *mgp) {
260+
const MGVTBL* const virt = mg->mg_virtual;
261+
if (mg->mg_type == type && virt == vtbl) {
262+
*mgp = mg->mg_moremagic;
263+
if (virt && virt->svt_free)
264+
virt->svt_free(aTHX_ sv, mg);
265+
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
266+
if (mg->mg_len > 0)
267+
Safefree(mg->mg_ptr);
268+
else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */
269+
SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
270+
else if (mg->mg_type == PERL_MAGIC_utf8)
271+
Safefree(mg->mg_ptr);
272+
}
273+
if (mg->mg_flags & MGf_REFCOUNTED)
274+
SvREFCNT_dec(mg->mg_obj);
275+
Safefree(mg);
276+
}
277+
else
278+
mgp = &mg->mg_moremagic;
279+
}
280+
if (SvMAGIC(sv)) {
281+
if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
282+
mg_magical(sv); /* else fix the flags now */
283+
}
284+
else {
285+
SvMAGICAL_off(sv);
286+
SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
287+
}
288+
return 0;
289+
}
290+
291+
#endif
292+
#endif
293+
294+
=xsinit
295+
296+
#define NEED_mg_findext
297+
#define NEED_sv_unmagicext
298+
299+
#ifndef STATIC
300+
#define STATIC static
301+
#endif
302+
303+
STATIC MGVTBL null_mg_vtbl = {
304+
NULL, /* get */
305+
NULL, /* set */
306+
NULL, /* len */
307+
NULL, /* clear */
308+
NULL, /* free */
309+
#if MGf_COPY
310+
NULL, /* copy */
311+
#endif /* MGf_COPY */
312+
#if MGf_DUP
313+
NULL, /* dup */
314+
#endif /* MGf_DUP */
315+
#if MGf_LOCAL
316+
NULL, /* local */
317+
#endif /* MGf_LOCAL */
318+
};
319+
320+
STATIC MGVTBL other_mg_vtbl = {
321+
NULL, /* get */
322+
NULL, /* set */
323+
NULL, /* len */
324+
NULL, /* clear */
325+
NULL, /* free */
326+
#if MGf_COPY
327+
NULL, /* copy */
328+
#endif /* MGf_COPY */
329+
#if MGf_DUP
330+
NULL, /* dup */
331+
#endif /* MGf_DUP */
332+
#if MGf_LOCAL
333+
NULL, /* local */
334+
#endif /* MGf_LOCAL */
335+
};
336+
203337
=xsubs
204338

339+
SV *
340+
new_with_other_mg(package, ...)
341+
SV *package
342+
PREINIT:
343+
HV *self;
344+
HV *stash;
345+
SV *self_ref;
346+
int i = 0;
347+
const char *data = "hello\0";
348+
MAGIC *mg;
349+
CODE:
350+
self = newHV();
351+
stash = gv_stashpv(SvPV_nolen(package), 0);
352+
353+
self_ref = newRV_noinc((SV*)self);
354+
355+
sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data));
356+
mg = mg_find((SV*)self, PERL_MAGIC_ext);
357+
mg->mg_virtual = &other_mg_vtbl;
358+
359+
RETVAL = sv_bless(self_ref, stash);
360+
OUTPUT:
361+
RETVAL
362+
363+
SV *
364+
new_with_mg(package, ...)
365+
SV *package
366+
PREINIT:
367+
HV *self;
368+
HV *stash;
369+
SV *self_ref;
370+
int i = 0;
371+
const char *data = "hello\0";
372+
MAGIC *mg;
373+
CODE:
374+
self = newHV();
375+
stash = gv_stashpv(SvPV_nolen(package), 0);
376+
377+
self_ref = newRV_noinc((SV*)self);
378+
379+
sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data));
380+
mg = mg_find((SV*)self, PERL_MAGIC_ext);
381+
mg->mg_virtual = &null_mg_vtbl;
382+
383+
RETVAL = sv_bless(self_ref, stash);
384+
OUTPUT:
385+
RETVAL
386+
387+
void
388+
remove_null_magic(self)
389+
SV *self
390+
PREINIT:
391+
HV *obj;
392+
PPCODE:
393+
obj = (HV*) SvRV(self);
394+
395+
sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl);
396+
397+
void
398+
remove_other_magic(self)
399+
SV *self
400+
PREINIT:
401+
HV *obj;
402+
PPCODE:
403+
obj = (HV*) SvRV(self);
404+
405+
sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &other_mg_vtbl);
406+
407+
void
408+
as_string(self)
409+
SV *self
410+
PREINIT:
411+
HV *obj;
412+
MAGIC *mg;
413+
PPCODE:
414+
obj = (HV*) SvRV(self);
415+
416+
if (mg = mg_findext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl)) {
417+
XPUSHs(sv_2mortal(newSVpv(mg->mg_ptr, strlen(mg->mg_ptr))));
418+
} else {
419+
XPUSHs(sv_2mortal(newSVpvs("Sorry, your princess is in another castle.")));
420+
}
421+
205422
void
206423
sv_catpv_mg(sv, string)
207424
SV *sv;
@@ -314,7 +531,31 @@ sv_magic_portable(sv)
314531
OUTPUT:
315532
RETVAL
316533

317-
=tests plan => 15
534+
=tests plan => 23
535+
536+
# Find proper magic
537+
ok(my $obj1 = Devel::PPPort->new_with_mg());
538+
ok(Devel::PPPort::as_string($obj1), 'hello');
539+
540+
# Find with no magic
541+
my $obj = bless {}, 'Fake::Class';
542+
ok(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
543+
544+
# Find with other magic (not the magic we are looking for)
545+
ok($obj = Devel::PPPort->new_with_other_mg());
546+
ok(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
547+
548+
# Okay, attempt to remove magic that isn't there
549+
Devel::PPPort::remove_other_magic($obj1);
550+
ok(Devel::PPPort::as_string($obj1), 'hello');
551+
552+
# Remove magic that IS there
553+
Devel::PPPort::remove_null_magic($obj1);
554+
ok(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
555+
556+
# Removing when no magic present
557+
Devel::PPPort::remove_null_magic($obj1);
558+
ok(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
318559

319560
use Tie::Hash;
320561
my %h;

0 commit comments

Comments
 (0)