From: Vincent Pit Date: Fri, 8 Aug 2008 14:18:08 +0000 (+0200) Subject: Rewrite scale in XS X-Git-Tag: v0.03~13 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;ds=inline;h=462a647c8b471a029c5dc2527bd4b78e64d93cee;p=perl%2Fmodules%2FSub-Nary.git Rewrite scale in XS --- diff --git a/Nary.xs b/Nary.xs index 75892ce..cea5f95 100644 --- a/Nary.xs +++ b/Nary.xs @@ -112,20 +112,14 @@ CODE: res = newHV(); if (!SvROK(sv)) { val = newSVuv(1); - if (!hv_store_ent(res, sv, val, 0)) { + if (!hv_store_ent(res, sv, val, 0)) SvREFCNT_dec(val); - SvREFCNT_dec(res); - XSRETURN_UNDEF; - } } else { hv = (HV *) SvRV(sv); if (!hv_iterinit(hv)) { val = newSVuv(1); - if (!hv_store(res, "0", 1, val, 0)) { + if (!hv_store(res, "0", 1, val, 0)) SvREFCNT_dec(val); - SvREFCNT_dec(res); - XSRETURN_UNDEF; - } } else { while (key = hv_iternext(hv)) { c += SvNV(HeVAL(key)); @@ -141,6 +135,42 @@ CODE: ST(0) = sv_2mortal(newRV_noinc((SV *) res)); XSRETURN(1); +void +scale(SV *csv, SV *sv) +PROTOTYPE: $;$ +PREINIT: + HV *hv, *res; + HE *key; + SV *val; + NV c = 1; +CODE: + if (!SvOK(sv)) + XSRETURN_UNDEF; + if (SvOK(csv)) + c = SvNV(csv); + res = newHV(); + if (!SvROK(sv)) { + val = newSVnv(c); + if (!hv_store_ent(res, sv, val, 0)) + SvREFCNT_dec(val); + } else { + hv = (HV *) SvRV(sv); + if (!hv_iterinit(hv)) { + val = newSVnv(c); + if (!hv_store(res, "0", 1, val, 0)) + SvREFCNT_dec(val); + } else { + hv_iterinit(hv); + while (key = hv_iternext(hv)) { + val = newSVnv(SvNV(HeVAL(key)) * c); + if (!hv_store_ent(res, HeSVKEY_force(key), val, HeHASH(key))) + SvREFCNT_dec(val); + } + } + } + ST(0) = sv_2mortal(newRV_noinc((SV *) res)); + XSRETURN(1); + void combine(...) PROTOTYPE: @ diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm index f21c8f8..d5a9645 100644 --- a/lib/Sub/Nary.pm +++ b/lib/Sub/Nary.pm @@ -178,12 +178,6 @@ sub name ($) { $n eq 'null' ? substr(ppname($_[0]->targ), 3) : $n } -sub scale { - my ($c, $r) = @_; - return unless defined $r; - return (ref $r) ? { map { $_ => $r->{$_} * $c } keys %$r } : { $r => $c }; -} - sub power { my ($p, $n, $c) = @_; return unless defined $p;