| ################################################################################ |
| ## |
| ## $Revision: 11 $ |
| ## $Author: mhx $ |
| ## $Date: 2010/03/07 13:15:46 +0100 $ |
| ## |
| ################################################################################ |
| ## |
| ## Version 3.x, Copyright (C) 2004-2010, Marcus Holland-Moritz. |
| ## Version 2.x, Copyright (C) 2001, Paul Marquess. |
| ## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. |
| ## |
| ## This program is free software; you can redistribute it and/or |
| ## modify it under the same terms as Perl itself. |
| ## |
| ################################################################################ |
| |
| =provides |
| |
| vnewSVpvf |
| sv_vcatpvf |
| sv_vsetpvf |
| |
| sv_catpvf_mg |
| sv_catpvf_mg_nocontext |
| sv_vcatpvf_mg |
| |
| sv_setpvf_mg |
| sv_setpvf_mg_nocontext |
| sv_vsetpvf_mg |
| |
| =implementation |
| |
| #if { VERSION >= 5.004 } && !defined(vnewSVpvf) |
| #if { NEED vnewSVpvf } |
| |
| SV * |
| vnewSVpvf(pTHX_ const char *pat, va_list *args) |
| { |
| register SV *sv = newSV(0); |
| sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); |
| return sv; |
| } |
| |
| #endif |
| #endif |
| |
| #if { VERSION >= 5.004 } && !defined(sv_vcatpvf) |
| # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) |
| #endif |
| |
| #if { VERSION >= 5.004 } && !defined(sv_vsetpvf) |
| # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) |
| #endif |
| |
| #if { VERSION >= 5.004 } && !defined(sv_catpvf_mg) |
| #if { NEED sv_catpvf_mg } |
| |
| void |
| sv_catpvf_mg(pTHX_ SV *sv, const char *pat, ...) |
| { |
| va_list args; |
| va_start(args, pat); |
| sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); |
| SvSETMAGIC(sv); |
| va_end(args); |
| } |
| |
| #endif |
| #endif |
| |
| #ifdef PERL_IMPLICIT_CONTEXT |
| #if { VERSION >= 5.004 } && !defined(sv_catpvf_mg_nocontext) |
| #if { NEED sv_catpvf_mg_nocontext } |
| |
| void |
| sv_catpvf_mg_nocontext(SV *sv, const char *pat, ...) |
| { |
| dTHX; |
| va_list args; |
| va_start(args, pat); |
| sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); |
| SvSETMAGIC(sv); |
| va_end(args); |
| } |
| |
| #endif |
| #endif |
| #endif |
| |
| /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ |
| #ifndef sv_catpvf_mg |
| # ifdef PERL_IMPLICIT_CONTEXT |
| # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext |
| # else |
| # define sv_catpvf_mg Perl_sv_catpvf_mg |
| # endif |
| #endif |
| |
| #if { VERSION >= 5.004 } && !defined(sv_vcatpvf_mg) |
| # define sv_vcatpvf_mg(sv, pat, args) \ |
| STMT_START { \ |
| sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ |
| SvSETMAGIC(sv); \ |
| } STMT_END |
| #endif |
| |
| #if { VERSION >= 5.004 } && !defined(sv_setpvf_mg) |
| #if { NEED sv_setpvf_mg } |
| |
| void |
| sv_setpvf_mg(pTHX_ SV *sv, const char *pat, ...) |
| { |
| va_list args; |
| va_start(args, pat); |
| sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); |
| SvSETMAGIC(sv); |
| va_end(args); |
| } |
| |
| #endif |
| #endif |
| |
| #ifdef PERL_IMPLICIT_CONTEXT |
| #if { VERSION >= 5.004 } && !defined(sv_setpvf_mg_nocontext) |
| #if { NEED sv_setpvf_mg_nocontext } |
| |
| void |
| sv_setpvf_mg_nocontext(SV *sv, const char *pat, ...) |
| { |
| dTHX; |
| va_list args; |
| va_start(args, pat); |
| sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); |
| SvSETMAGIC(sv); |
| va_end(args); |
| } |
| |
| #endif |
| #endif |
| #endif |
| |
| /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ |
| #ifndef sv_setpvf_mg |
| # ifdef PERL_IMPLICIT_CONTEXT |
| # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext |
| # else |
| # define sv_setpvf_mg Perl_sv_setpvf_mg |
| # endif |
| #endif |
| |
| #if { VERSION >= 5.004 } && !defined(sv_vsetpvf_mg) |
| # define sv_vsetpvf_mg(sv, pat, args) \ |
| STMT_START { \ |
| sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ |
| SvSETMAGIC(sv); \ |
| } STMT_END |
| #endif |
| |
| =xsinit |
| |
| #define NEED_vnewSVpvf |
| #define NEED_sv_catpvf_mg |
| #define NEED_sv_catpvf_mg_nocontext |
| #define NEED_sv_setpvf_mg |
| #define NEED_sv_setpvf_mg_nocontext |
| |
| =xsmisc |
| |
| static SV * test_vnewSVpvf(pTHX_ const char *pat, ...) |
| { |
| SV *sv; |
| va_list args; |
| va_start(args, pat); |
| #if { VERSION >= 5.004 } |
| sv = vnewSVpvf(pat, &args); |
| #else |
| sv = newSVpv((char *) pat, 0); |
| #endif |
| va_end(args); |
| return sv; |
| } |
| |
| static void test_sv_vcatpvf(pTHX_ SV *sv, const char *pat, ...) |
| { |
| va_list args; |
| va_start(args, pat); |
| #if { VERSION >= 5.004 } |
| sv_vcatpvf(sv, pat, &args); |
| #else |
| sv_catpv(sv, (char *) pat); |
| #endif |
| va_end(args); |
| } |
| |
| static void test_sv_vsetpvf(pTHX_ SV *sv, const char *pat, ...) |
| { |
| va_list args; |
| va_start(args, pat); |
| #if { VERSION >= 5.004 } |
| sv_vsetpvf(sv, pat, &args); |
| #else |
| sv_setpv(sv, (char *) pat); |
| #endif |
| va_end(args); |
| } |
| |
| =xsubs |
| |
| SV * |
| vnewSVpvf() |
| CODE: |
| RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42); |
| OUTPUT: |
| RETVAL |
| |
| SV * |
| sv_vcatpvf(sv) |
| SV *sv |
| CODE: |
| RETVAL = newSVsv(sv); |
| test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); |
| OUTPUT: |
| RETVAL |
| |
| SV * |
| sv_vsetpvf(sv) |
| SV *sv |
| CODE: |
| RETVAL = newSVsv(sv); |
| test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); |
| OUTPUT: |
| RETVAL |
| |
| void |
| sv_catpvf_mg(sv) |
| SV *sv |
| CODE: |
| #if { VERSION >= 5.004 } |
| sv_catpvf_mg(sv, "%s-%d", "Perl", 42); |
| #endif |
| |
| void |
| Perl_sv_catpvf_mg(sv) |
| SV *sv |
| CODE: |
| #if { VERSION >= 5.004 } |
| Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43); |
| #endif |
| |
| void |
| sv_catpvf_mg_nocontext(sv) |
| SV *sv |
| CODE: |
| #if { VERSION >= 5.004 } |
| #ifdef PERL_IMPLICIT_CONTEXT |
| sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44); |
| #else |
| sv_catpvf_mg(sv, "%s-%d", "-Perl", 44); |
| #endif |
| #endif |
| |
| void |
| sv_setpvf_mg(sv) |
| SV *sv |
| CODE: |
| #if { VERSION >= 5.004 } |
| sv_setpvf_mg(sv, "%s-%d", "mhx", 42); |
| #endif |
| |
| void |
| Perl_sv_setpvf_mg(sv) |
| SV *sv |
| CODE: |
| #if { VERSION >= 5.004 } |
| Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43); |
| #endif |
| |
| void |
| sv_setpvf_mg_nocontext(sv) |
| SV *sv |
| CODE: |
| #if { VERSION >= 5.004 } |
| #ifdef PERL_IMPLICIT_CONTEXT |
| sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44); |
| #else |
| sv_setpvf_mg(sv, "%s-%d", "bar", 44); |
| #endif |
| #endif |
| |
| =tests plan => 9 |
| |
| use Tie::Hash; |
| my %h; |
| tie %h, 'Tie::StdHash'; |
| $h{foo} = 'foo-'; |
| $h{bar} = ''; |
| |
| ok(&Devel::PPPort::vnewSVpvf(), $] >= 5.004 ? 'Perl-42' : '%s-%d'); |
| ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), $] >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); |
| ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), $] >= 5.004 ? 'Perl-42' : '%s-%d'); |
| |
| &Devel::PPPort::sv_catpvf_mg($h{foo}); |
| ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42' : 'foo-'); |
| |
| &Devel::PPPort::Perl_sv_catpvf_mg($h{foo}); |
| ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); |
| |
| &Devel::PPPort::sv_catpvf_mg_nocontext($h{foo}); |
| ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); |
| |
| &Devel::PPPort::sv_setpvf_mg($h{bar}); |
| ok($h{bar}, $] >= 5.004 ? 'mhx-42' : ''); |
| |
| &Devel::PPPort::Perl_sv_setpvf_mg($h{bar}); |
| ok($h{bar}, $] >= 5.004 ? 'foo-43' : ''); |
| |
| &Devel::PPPort::sv_setpvf_mg_nocontext($h{bar}); |
| ok($h{bar}, $] >= 5.004 ? 'bar-44' : ''); |
| |
| |