Rewrite scale in XS

diff --git a/Nary.xs b/Nary.xs
index 75892ce3338d7bcd61ca2996b5d4a865e1c7dc94..cea5f955b8448707c89e97e1162d8785eb0cec34 100644 (file)
--- 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 f21c8f81446aa64aff112b2f49f22bfb7fa47939..d5a96452a1418f7a0e3382d3e9c32d7ae33151f9 100644 (file)
--- 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;