[svn:parrot] r41655 - in branches/pcc_reapply: runtime/parrot/include runtime/parrot/library/Test t/pmc

tene at svn.parrot.org tene at svn.parrot.org
Sat Oct 3 23:34:50 UTC 2009


Author: tene
Date: Sat Oct  3 23:34:49 2009
New Revision: 41655
URL: https://trac.parrot.org/parrot/changeset/41655

Log:
Add 'substring' and 'throws_substring' functions to Test::More
Use substring functions instead of PGE in three tests.

Modified:
   branches/pcc_reapply/runtime/parrot/include/test_more.pir
   branches/pcc_reapply/runtime/parrot/library/Test/More.pir
   branches/pcc_reapply/t/pmc/fixedpmcarray.t
   branches/pcc_reapply/t/pmc/integer.t
   branches/pcc_reapply/t/pmc/namespace.t

Modified: branches/pcc_reapply/runtime/parrot/include/test_more.pir
==============================================================================
--- branches/pcc_reapply/runtime/parrot/include/test_more.pir	Sat Oct  3 23:30:30 2009	(r41654)
+++ branches/pcc_reapply/runtime/parrot/include/test_more.pir	Sat Oct  3 23:34:49 2009	(r41655)
@@ -20,7 +20,7 @@
     .local pmc exports, curr_namespace, test_namespace
     curr_namespace = get_namespace
     test_namespace = get_root_namespace [ 'parrot'; 'Test'; 'More' ]
-    exports = split ' ', 'plan diag ok nok is is_deeply like isa_ok skip isnt todo throws_like'
+    exports = split ' ', 'plan diag ok nok is is_deeply like substring isa_ok skip isnt todo throws_like throws_substring'
 
     test_namespace.'export_to'(curr_namespace, exports)
 

Modified: branches/pcc_reapply/runtime/parrot/library/Test/More.pir
==============================================================================
--- branches/pcc_reapply/runtime/parrot/library/Test/More.pir	Sat Oct  3 23:30:30 2009	(r41654)
+++ branches/pcc_reapply/runtime/parrot/library/Test/More.pir	Sat Oct  3 23:34:49 2009	(r41655)
@@ -886,6 +886,85 @@
   done:
 .end
 
+=item C<throws_substring( codestring, text, description )>
+
+Takes PIR code in C<codestring> and a string to match in C<text>, as
+well as an optional message in C<description>. Passes a test if the PIR throws
+an exception that matches the pattern, fails the test otherwise.
+
+=cut
+
+.sub throws_substring
+    .param string target
+    .param string text
+    .param string description :optional
+
+    .local pmc test
+    get_hll_global test, [ 'Test'; 'More' ], '_test'
+
+    .local pmc comp
+    .local pmc compfun
+    .local pmc compiler
+    compiler = compreg 'PIR'
+
+    .local pmc eh
+    eh = new 'ExceptionHandler'
+    set_addr eh, handler            # set handler label for exceptions
+    push_eh eh
+
+    compfun = compiler(target)
+    compfun()                       # eval the target code
+
+    pop_eh
+
+    # if it doesn't throw an exception, fail
+    test.'ok'( 0, description )
+    test.'diag'( 'no error thrown' )
+
+    goto done
+
+  handler:
+    .local pmc ex
+    .local string error_msg
+    .get_results (ex)
+    pop_eh
+    error_msg = ex
+    substring(error_msg, text, description)
+
+  done:
+.end
+
+=item C<substring( target, text, description )>
+
+Similar to is, but using the index opcode to compare the string passed as
+C<text> to the string passed as C<target>.  It passes if C<text> is a substring
+of C<target> and fails otherwise.  This will report the results with the
+optional test description in C<description>.
+
+=cut
+
+.sub substring
+    .param string target
+    .param string text
+    .param string description :optional
+
+    .local pmc test
+    .local string diagnostic
+    get_hll_global test, [ 'Test'; 'More' ], '_test'
+    $I0 = index target, text
+    $I0 = isne $I0, -1
+    test.'ok'( $I0, description )
+    if $I0 goto done
+    diagnostic = "substring failed: '"
+    diagnostic .= target
+    diagnostic .= "' does not contain '"
+    diagnostic .= text
+    diagnostic .= "'"
+    test.'diag'(diagnostic)
+  done:
+.end
+
+
 =item C<like( target, pattern, description )>
 
 Similar to is, but using the Parrot Grammar Engine to compare the string

Modified: branches/pcc_reapply/t/pmc/fixedpmcarray.t
==============================================================================
--- branches/pcc_reapply/t/pmc/fixedpmcarray.t	Sat Oct  3 23:30:30 2009	(r41654)
+++ branches/pcc_reapply/t/pmc/fixedpmcarray.t	Sat Oct  3 23:34:49 2009	(r41655)
@@ -310,7 +310,7 @@
     concat s, aux
     aux = get_repr_fpa_n(3)
     concat s, aux
-    like(s,'\(\)\(0\)\(0\,\s*1\)\(0\,\s*1\,\s*2\)','get_repr')
+    substring(s,'()(0)(0, 1)(0, 1, 2)','get_repr')
 .end
 
 .sub get_repr_fpa_n
@@ -333,7 +333,7 @@
 .end
 
 .sub test_splice_oob
-    throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds','splice oob, offset 0')
+    throws_substring(<<'CODE','FixedPMCArray: index out of bounds','splice oob, offset 0')
     .sub main
         .local pmc fpa
         fpa = new ['FixedPMCArray']
@@ -345,7 +345,7 @@
         splice fpa, nil, 0, 6
     .end
 CODE
-    throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds','splice oob, big offset')
+    throws_substring(<<'CODE','FixedPMCArray: index out of bounds','splice oob, big offset')
     .sub main
         .local pmc fpa
         fpa = new ['FixedPMCArray']
@@ -390,7 +390,7 @@
 .end
 
 .sub test_get_uninitialized
-    throws_like(<<'CODE',':s Null PMC access in name','get uninitialized')
+    throws_substring(<<'CODE','Null PMC access in name','get uninitialized')
     .sub main
         .local pmc arr1
         arr1 = new ['FixedPMCArray']
@@ -469,14 +469,14 @@
 .end
 
 .sub test_oob_elem
-    throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds\!','set out-of-bounds index')
+    throws_substring(<<'CODE','FixedPMCArray: index out of bounds!','set out-of-bounds index')
         .sub main
             new $P0, ['FixedPMCArray']
             set $P0, 1
             set $P0[1], -7
         .end
 CODE
-    throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds\!','set out-of-bounds index')
+    throws_substring(<<'CODE','FixedPMCArray: index out of bounds!','set out-of-bounds index')
         .sub main
             new $P0, ['FixedPMCArray']
             set $P0, 1
@@ -487,14 +487,14 @@
 .end
 
 .sub test_negative_index
-    throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds\!','set negative index')
+    throws_substring(<<'CODE','FixedPMCArray: index out of bounds!','set negative index')
 .sub main
     new $P0, ['FixedPMCArray']
     set $P0, 1
     set $P0[-1], -7
 .end
 CODE
-    throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds\!','get negative index')
+    throws_substring(<<'CODE','FixedPMCArray: index out of bounds!','get negative index')
 .sub main
     new $P0, ['FixedPMCArray']
     set $P0, 1
@@ -547,7 +547,7 @@
 .end
 
 .sub test_tt991
-    throws_like(<<'CODE',':s FixedPMCArray\: Cannot set array size to a negative number','cannot create a negative length array')
+    throws_substring(<<'CODE','FixedPMCArray: Cannot set array size to a negative number','cannot create a negative length array')
         .sub main
             new $P0, ['FixedPMCArray']
             set $P0, -1
@@ -556,7 +556,7 @@
 .end
 
 .sub test_resize_exception
-    throws_like(<<'CODE',':s FixedPMCArray\: Can.t resize','cannot resize FixedPMCArray')
+    throws_substring(<<'CODE',"FixedPMCArray: Can't resize",'cannot resize FixedPMCArray')
         .sub main
             new $P0, ['FixedPMCArray']
             set $I0,$P0
@@ -565,14 +565,14 @@
         .end
 CODE
 
-    throws_like(<<'CODE',":s set_number_native.* not implemented in class .*FixedPMCArray", 'cannot use float as length to FixedPMCArray')
+    throws_substring(<<'CODE',"set_number_native() not implemented in class 'FixedPMCArray'", 'cannot use float as length to FixedPMCArray')
         .sub main
             new $P0, ['FixedPMCArray']
             set $P0, 42.0
         .end
 CODE
 
-    throws_like(<<'CODE',":s set_string_native.* not implemented in class .*FixedPMCArray", 'cannot use string as length to FixedPMCArray')
+    throws_substring(<<'CODE',"set_string_native() not implemented in class 'FixedPMCArray'", 'cannot use string as length to FixedPMCArray')
         .sub main
             new $P0, ['FixedPMCArray']
             set $P0,"GIGO"
@@ -581,7 +581,7 @@
 .end
 
 .sub test_assign_non_array
-    throws_like(<<'CODE', ':s Can.t set self from this type','assign from non-array')
+    throws_substring(<<'CODE', "Can't set self from this type",'assign from non-array')
     .sub main
         .local pmc arr, other
         .local int n

Modified: branches/pcc_reapply/t/pmc/integer.t
==============================================================================
--- branches/pcc_reapply/t/pmc/integer.t	Sat Oct  3 23:30:30 2009	(r41654)
+++ branches/pcc_reapply/t/pmc/integer.t	Sat Oct  3 23:34:49 2009	(r41655)
@@ -51,7 +51,7 @@
 .end
 
 .sub test_get_as_base_bounds_check
-    throws_like(<<'CODE', ':s get_as_base\: base out of bounds', 'get_as_base lower bound check')
+    throws_substring(<<'CODE', 'get_as_base: base out of bounds', 'get_as_base lower bound check')
     .sub main
         $P0 = new ['Integer']
         $P0 = 42
@@ -59,7 +59,7 @@
         say $S0
     .end
 CODE
-    throws_like(<<'CODE', ':s get_as_base\: base out of bounds', 'get_as_base upper bound check')
+    throws_substring(<<'CODE', 'get_as_base: base out of bounds', 'get_as_base upper bound check')
     .sub main
         $P0 = new ['Integer']
         $P0 = 42

Modified: branches/pcc_reapply/t/pmc/namespace.t
==============================================================================
--- branches/pcc_reapply/t/pmc/namespace.t	Sat Oct  3 23:30:30 2009	(r41654)
+++ branches/pcc_reapply/t/pmc/namespace.t	Sat Oct  3 23:34:49 2009	(r41655)
@@ -203,7 +203,7 @@
     pop_eh
 
   test4:
-    throws_like( <<'CODE', 'Null\ PMC\ access\ in\ invoke', 'Invoking a non-existent sub')
+    throws_substring( <<'CODE', 'Null PMC access in invoke', 'Invoking a non-existent sub')
         .sub main
             $P0 = get_global ["Foo"], "SUB_THAT_DOES_NOT_EXIST"
             $P0()
@@ -212,7 +212,7 @@
 
   test5:
     # this used to behave differently from the previous case.
-    throws_like( <<'CODE', 'Null\ PMC\ access\ in\ invoke', 'Invoking a non-existent sub')
+    throws_substring( <<'CODE', 'Null PMC access in invoke', 'Invoking a non-existent sub')
         .sub main
             $P0 = get_global ["Foo";"Bar"], "SUB_THAT_DOES_NOT_EXIST"
             $P0()
@@ -552,9 +552,9 @@
 .sub 'export_to_method'
     .local string errormsg, description
 
-    errormsg = ":s destination namespace not specified"
+    errormsg = "destination namespace not specified"
     description = "export_to() Null NameSpace"
-    throws_like(<<"CODE", errormsg, description)
+    throws_substring(<<"CODE", errormsg, description)
         .sub 'test' :main
             .local pmc nsa, nsb, ar
 
@@ -566,9 +566,9 @@
         .end
 CODE
 
-    errormsg = ":s exporting default object set not yet implemented"
+    errormsg = "exporting default object set not yet implemented"
     description = 'export_to() with null exports default object set !!!UNSPECIFIED!!!'
-    throws_like(<<'CODE', errormsg, description)
+    throws_substring(<<'CODE', errormsg, description)
         .sub 'test' :main
             .local pmc nsa, nsb, ar
 
@@ -580,9 +580,9 @@
 CODE
 
 
-    errormsg = ":s exporting default object set not yet implemented"
+    errormsg = "exporting default object set not yet implemented"
     description = 'export_to() with empty array exports default object set !!!UNSPECIFIED!!!'
-    throws_like(<<'CODE', errormsg, description)
+    throws_substring(<<'CODE', errormsg, description)
         .sub 'test' :main
             .local pmc nsa, nsb, ar
 
@@ -593,9 +593,9 @@
         .end
 CODE
 
-    errormsg = ":s exporting default object set not yet implemented"
+    errormsg = "exporting default object set not yet implemented"
     description = 'export_to() with empty hash exports default object set !!!UNSPECIFIED!!!'
-    throws_like(<<'CODE', errormsg, description)
+    throws_substring(<<'CODE', errormsg, description)
         .sub 'test' :main
             .local pmc nsa, nsb, ar
 


More information about the parrot-commits mailing list