From: Vincent Pit <vince@profvince.com>
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/?p=perl%2Fmodules%2FSub-Nary.git;a=commitdiff_plain;h=462a647c8b471a029c5dc2527bd4b78e64d93cee

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;