XS topdl - #451

Basic/Core/Core.pm

@@ -656,18 +656,6 @@ below for usage).
  $y = topdl $ndarray;       # fall through
  $x = topdl (1,2,3,4);      # Convert 1D array
 
-=cut
-
-# Convert numbers to PDL if not already
-sub PDL::topdl {
-    return $_[0]->new(@_[1..$#_]) if
-      @_ > 2 # PDLify a list
-      or ref(\$_[1]) eq 'SCALAR'
-      or ref($_[1]) eq 'ARRAY';
-    return $_[1] if blessed($_[1]); # Fall through
-    barf("Can not convert a ".ref($_[1])." to a ".$_[0]);
-0;}
-
 =head2 set_datatype
 
 =for ref

Basic/Core/Core.xs

@@ -81,6 +81,29 @@ inplace(self, ...)
   OUTPUT:
     RETVAL
 
+SV *
+topdl(klass, arg1, ...)
+  SV *klass;
+  SV *arg1;
+  CODE:
+    if (items > 2 ||
+      (!SvROK(arg1) && SvTYPE(arg1) < SVt_PVAV) ||
+      (SvROK(arg1) && SvTYPE(SvRV(arg1)) == SVt_PVAV)
+    ) {
+      SP -= items; PUSHMARK(SP); SPAGAIN; /* these pass this set of args on */
+      int retvals = perl_call_method("new", G_SCALAR);
+      SPAGAIN;
+      if (retvals != 1) barf("new returned no values");
+      RETVAL = POPs;
+    } else if (SvROK(arg1) && SvOBJECT(SvRV(arg1))) {
+      RETVAL = arg1;
+    } else {
+      barf("Can not convert a %s to a %s", sv_reftype(arg1, 1), SvPV_nolen(klass));
+    }
+    SvREFCNT_inc(RETVAL);
+  OUTPUT:
+    RETVAL
+
 # Return the transformation object or an undef otherwise.
 pdl_trans *
 trans_parent(self)

t/core.t

@@ -144,6 +144,8 @@ isa_ok( PDL->topdl([1,2,3]), "PDL", "topdl([1,2,3]) returns an ndarray" );
 isa_ok( PDL->topdl(1,2,3),   "PDL", "topdl(1,2,3) returns an ndarray" );
 $x=PDL->topdl(1,2,3);
 ok (($x->nelem == 3  and  all($x == pdl(1,2,3))), "topdl(1,2,3) returns a 3-ndarray containing (1,2,3)");
+eval {PDL->topdl({})};
+isnt $@, '', 'topdl({}) no segfault';
 
 # stringification
 {