]> lifelog.hopto.org Git - PerlCNF.git/commitdiff
Made vscode line number mouse click from logs easier to browse ro source.
authorWill Budic <redacted>
Wed, 15 Jan 2025 06:47:27 +0000 (17:47 +1100)
committerWill Budic <redacted>
Wed, 15 Jan 2025 06:47:27 +0000 (17:47 +1100)
tests/TestManager.pm

index 6ded117065cc8b5ecb48d632d399300499f794a6..2e4ab236086fdb1f62b2ee7bcf3da74aca252109 100644 (file)
@@ -13,8 +13,11 @@ my $timer = Timer::Simple->new(start => 0, string => 'human');
 my $stab  = "";
 my $current_test_file;
 
-use Cwd qw(getcwd);
-my $CWD = getcwd;
+our $CWD;
+
+BEGIN{
+use Cwd qw(getcwd); $CWD = getcwd;
+}
 
 ###
 #  Notice All test are to be run from the project directory.
@@ -26,7 +29,11 @@ sub new {
      $self = bless {test_file=> $CWD.'/'.$test_file,test_cnt=>1,sub_cnt=>0,sub_err=>0}, $class;
      print  BLUE."Running -> ".WHITE."$test_file\n".RESET;
      $self->{open}=0;
-     $current_test_file = $test_file;
+     if($test_file =~ m/^$CWD/){
+        $current_test_file = $test_file;
+     }else{
+        $current_test_file = "$CWD/$test_file"
+     }
      return $self;
 }
 
@@ -37,7 +44,7 @@ sub failed {
     ++$self->{sub_err};
     my ($package, $filename, $line) = caller; $filename =~ s/^(\/(.+)\/)//gs;
     print BLINK. BRIGHT_RED. "\t$stab   Fail ".$self->{test_cnt}.".".$sub_cnt.": $err",
-                         BLUE, "\n\t$stab\t at -> ",RESET,"$CWD/$filename line $line.\n", RESET;
+                         BLUE, "\n\t$stab\t at -> ",RESET,"$CWD/$filename:$line\n", RESET;
     return $self
 }
 
@@ -47,7 +54,7 @@ sub passed {
     my $sub_cnt = ++$self->{sub_cnt};
     my ($package, $filename, $line) = caller; $filename =~ s/^(\/(.+)\/)//gs;
     print BRIGHT_GREEN, "\t$stab   Pass ".$self->{test_cnt}.".".$sub_cnt.": $msg",
-                  BLUE, "at -> ",RESET,"$CWD/$filename line $line.\n";
+                  BLUE, "at -> ",RESET,"$CWD/$filename:$line\n";
     return $self
 }
 
@@ -56,8 +63,8 @@ sub case {
     my ($package, $filename, $line) = caller; $filename =~ s/^(\/(.+)\/)//gs;
     $stab="";
     nextCase($self) if $self->{open};
-    print BRIGHT_CYAN,"\tCase ".$self->{test_cnt}.": $out",
-          BLUE, "\t\tat -> ",RESET,"$CWD/$filename line $line.\n", RESET;
+    print BRIGHT_CYAN,"\tCase ".$self->{test_cnt}.": $out",  BLUE, "\n\tat -> ",
+          "$CWD/$filename:$line\n", RESET;
     $self->{open}=1;
     return $self
 }
@@ -203,9 +210,9 @@ sub doneFailed {
 }
 
 ###
-# Following routine is custom made by Will Budic.
+# Following routine is custom made by Will Budić.
 # The pattern it seeks is like this comment in source file.
-# To display code where error occured.
+# To display code where error occurred.
 ###
 sub dumpTermination {
     my ($failed, $comment, $past, $message, $ErrAt, $cterminated) = @_;
@@ -225,8 +232,8 @@ sub dumpTermination {
             }
         }
         $comment = $message = $comment->{'message'}.$trace;
-        $comment =~ s/eval \{.+\} at/cought at/gs;
-        #Old die methods could be present, caught by an Exception, manually having Error@{lno.} set.
+        $comment =~ s/eval \{.+\} at/caught at/gs;
+        # Old die methods could be present, caught by an Exception, manually having Error@{lno.} set.
         if($message =~ /^Error\@(\d+)/){
            $ErrAt = "\\\@$1";
         }
@@ -244,17 +251,18 @@ sub dumpTermination {
             }
         }
         $comment = $message = $comment->{'message'}.$trace;
-        $comment =~ s/eval \{.+\} at/cought at/gs;
+        $comment =~ s/eval \{.+\} at/caught at/gs;
         #Old die methods could be present, caught by an Exception, manually having Error@{lno.} set.
         if($message =~ /^Error\@(\d+)/){
            $ErrAt = "\\\@$1";
         }else{
             my $error;
             ($error,$file,$lnErr) = ($message =~ m/(.*)\sat\s*(.*)\sline\s(\d*)\./)
-        }
+        }        
     }else{
         ($trace,$file,$lnErr) = ($comment =~ m/(.*)\sat\s*(.*)\sline\s(\d*)\.$/);
     }
+    $comment =~ s/(\s+line\s)(\d+)\.*\s+/:$2\n/gm;
     print BOLD BRIGHT_RED "Test file failed -> $comment";
     if($file){
     open (my $flh, '<:perlio', $file) or die("Error $! opening file: '$file'\n$comment");
@@ -266,8 +274,10 @@ sub dumpTermination {
         local $. = $i + 1;
         my $line = $slurp[$i];
         if($. >= $lnErr+1){
-           print $comment, RESET.frmln($.).$line; $message =~ m/\s*(.*)\n/ if $message; my $cap = $1?$1:"";
-           print "[".$file."] Case  $failed->{test_cnt}\n\t$cap\n\t".BRIGHT_RED."Failed\@Line".WHITE." $i -> ", $slurp[$i-1].RESET."\nFailed test file: $current_test_file";
+           print $comment, RESET.frmln($.).$line;   
+           $file = "$CWD/$file" if $file !~ m/^$CWD/;
+           print "[".$file.":$i] Case  $failed->{test_cnt}\n\t".BRIGHT_RED."Failed\@Line".WHITE." $i -> ", 
+                 $slurp[$i-1].RESET."Failed test file: $current_test_file";
            last
         }elsif($line=~m/^\s*(\#.*)/){
             if( $1 eq '#'){
@@ -314,14 +324,14 @@ sub frmln { my($at)=@_;
 1;
 
 =begin copyright
-Programed by  : Will Budic
-EContactHash  : 990MWWLWM8C2MI8K (https://github.com/wbudic/EContactHash.md)
-Source        : https://github.com/wbudic/PerlCNF.git
+Programed by  : Will Budić
+EContactHash  : 990MWWLWM8C2MI8K (https://github.com/wBudić/EContactHash.md)
+Source        : https://github.com/wBudić/PerlCNF.git
 Documentation : Specifications_For_CNF_ReadMe.md
     This source file is copied and usually placed in a local directory, outside of its repository project.
-    So it could not be the actual or current version, can vary or has been modiefied for what ever purpose in another project.
+    So it could not be the actual or current version, can vary or has been modified for what ever purpose in another project.
     Please leave source of origin in this file for future references.
-Open Source Code License -> https://github.com/wbudic/PerlCNF/blob/master/ISC_License.md
+Open Source Code License -> https://github.com/wBudić/PerlCNF/blob/master/ISC_License.md
 =cut copyright
 
 ###