Replaced 'unlink' with 'unlink_all' in t/op/magic.t

[perl5.git] / t / test.pl

diff --git a/t/test.pl b/t/test.pl
index f6ad09c..bfda110 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -77,19 +77,29 @@ END {
     }
 }
 
-# Use this instead of "print STDERR" when outputing failure diagnostic
-# messages
 sub _diag {
     return unless @_;
-    my @mess = map { /^#/ ? "$_\n" : "# $_\n" }
-               map { split /\n/ } @_;
+    my @mess = _comment(@_);
     $TODO ? _print(@mess) : _print_stderr(@mess);
 }
 
+# Use this instead of "print STDERR" when outputing failure diagnostic
+# messages
 sub diag {
     _diag(@_);
 }
 
+# Use this instead of "print" when outputing informational messages
+sub note {
+    return unless @_;
+    _print( _comment(@_) );
+}
+
+sub _comment {
+    return map { /^#/ ? "$_\n" : "# $_\n" }
+           map { split /\n/ } @_;
+}
+
 sub skip_all {
     if (@_) {
         _print "1..0 # Skip @_\n";
@@ -417,6 +427,7 @@ USE_OK
 # Arguments :
 #   switches => [ command-line switches ]
 #   nolib    => 1 # don't use -I../lib (included by default)
+#   non_portable => Don't warn if a one liner contains quotes
 #   prog     => one-liner (avoid quotes)
 #   progs    => [ multi-liner (avoid quotes) ]
 #   progfile => perl script
@@ -470,6 +481,9 @@ sub _create_runperl { # Create the string to qx in runperl().
        die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where()
            unless ref $args{progs} eq "ARRAY";
         foreach my $prog (@{$args{progs}}) {
+           if ($prog =~ tr/'"// && !$args{non_portable}) {
+               warn "quotes in prog >>$prog<< are not portable";
+           }
             if ($is_mswin || $is_netware || $is_vms) {
                 $runperl = $runperl . qq ( -e "$prog" );
             }
@@ -544,8 +558,12 @@ sub runperl {
            join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and
                ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) }
                    split quotemeta ($sep), $1;
-       $ENV{PATH} = $ENV{PATH} . "$sep/bin" if $is_cygwin;  # Must have /bin under Cygwin
-
+       if ($is_cygwin) {   # Must have /bin under Cygwin
+           if (length $ENV{PATH}) {
+               $ENV{PATH} = $ENV{PATH} . $sep;
+           }
+           $ENV{PATH} = $ENV{PATH} . '/bin';
+       }
        $runperl =~ /(.*)/s;
        $runperl = $1;
 
@@ -778,6 +796,33 @@ sub can_ok ($@) {
     _ok( !@nok, _where(), $name );
 }
 
+
+# Call $class->new( @$args ); and run the result through isa_ok.
+# See Test::More::new_ok
+sub new_ok {
+    my($class, $args, $obj_name) = @_;
+    $args ||= [];
+    $object_name = "The object" unless defined $obj_name;
+
+    local $Level = $Level + 1;
+
+    my $obj;
+    my $ok = eval { $obj = $class->new(@$args); 1 };
+    my $error = $@;
+
+    if($ok) {
+        isa_ok($obj, $class, $object_name);
+    }
+    else {
+        ok( 0, "new() died" );
+        diag("Error was:  $@");
+    }
+
+    return $obj;
+
+}
+
+
 sub isa_ok ($$;$) {
     my($object, $class, $obj_name) = @_;
 
@@ -1084,4 +1129,17 @@ sub latin1_to_native($) {
     return $string;
 }
 
+sub ord_latin1_to_native {
+    # given an input latin1 code point, return the platform's native
+    # equivalent value
+
+    return ord latin1_to_native(chr $_[0]);
+}
+
+sub ord_native_to_latin1 {
+    # given an input platform code point, return the latin1 equivalent value
+
+    return ord native_to_latin1(chr $_[0]);
+}
+
 1;