App-diff_spreadsheets
5 results

 view release on metacpan or  search on metacpan

bin/diff_spreadsheets  view on Meta::CPAN 

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
use List::MoreUtils qw/indexes/;
use Scalar::Util qw/openhandle/;
use Pod::Usage qw/pod2usage/;
use Spreadsheet::Edit 1000.020 qw(title2ident);
use Spreadsheet::Edit::IO 1000.020 qw/convert_spreadsheet
             sheetname_from_spec filepath_from_spec form_spec_with_sheetname/;
use Spreadsheet::Edit::Log ':btw=DS ${lno}:';
use Term::ReadKey ();
use Encode 3.00 qw/decode/; # for ONLY_PRAGMA_WARNINGS
require PerlIO;
sub oops(@) { unshift @_, "oops "; require Carp; goto &Carp::confess; }
#$SIG{__WARN__} = sub{ Carp::cluck @_ };
 
sub main::Differ::compile_if_regex(@); #forward
 
# Replace invalid/undesirable filename characters with underscore
sub sanitize_filename(_) { local $_ = shift; s/[^-._[:word:]]/_/g; s/_$//; $_ }
 
use utf8;
 
my ($visible_space, $RArrow);
 
# By default set output encoding to match the user's terminal/locale,
# and suppress the "...does not mapt to..." warnings if unsupported characters
# are displayed e.g. in spreadsheet data diff displays (\x{hex} escapes will
# be displayed for un-encodeable characters).
# May be overridden by the --output-encoding option!
 
# https://rt.cpan.org/Public/Bug/Display.html?id=88592
$PerlIO::encoding::fallback |= Encode::ONLY_PRAGMA_WARNINGS;
no warnings 'utf8';
use open ':std', ':locale';
 
select STDERR; $| = 1; select STDOUT; $| = 1;
 
my $stdout_encoding;
sub decode_foruser($) {
  my $octets = shift;
  $stdout_encoding
    ? decode($stdout_encoding, $octets, Encode::FB_DEFAULT|Encode::LEAVE_SRC)
    : $octets
}
sub encode_foruser($) {
  my $chars = shift;
  $stdout_encoding
    ? encode($stdout_encoding, $chars, Encode::FB_DEFAULT|Encode::LEAVE_SRC)
    : $chars
}
 
#-------- Get Arguments ---------------
sub call_pod2usage {
  confess "bug" if (scalar(@_) % 2) != 0;
  my %opts = @_;

bin/diff_spreadsheets  view on Meta::CPAN 

87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
#    if (my $podpath = pod_where({-inc => 1},"App::diff_spreadsheets")) {
#      $opts{-input} = $podpath;
#    } else {
#      warn "Could not find App::diff_spreadsheets in \@INC\n",
#           "\@INC:\n", join("\n   ",@INC), "\n";
#    }
#  }
  pod2usage(\%opts);
}
 
sub badargs_exit(@) {
  call_pod2usage(-output => \*STDERR, -exitval => 2, @_);
}
 
# We could use Term::Encoding to detect the terminal's encoding
# but that would create a possibly-undesirable dependency.
# We just assume UTF-8, which these days is probably correct.
#my $rightarrow = '->';
#my $rightarrow = "\N{RIGHTWARDS ARROW}\N{THIN SPACE}";
#my $rightarrow = "\N{RIGHTWARDS ARROW}\N{NARROW NO-BREAK SPACE}";
#my $rightarrow = "\N{RIGHTWARDS ARROW}\N{HAIR SPACE}";
 
sub _get_terminal_width() {  # returns undef if unknowable
  if (u($ENV{COLUMNS}) =~ /^[1-9]\d*$/) {
    return $ENV{COLUMNS}; # overrides actual terminal width
  } else {
    local *_; # Try to avoid clobbering special filehandle "_"
    # This does not actualy work; https://github.com/Perl/perl5/issues/19142
 
    my $fh =
      -t STDOUT ? *STDOUT :
      -t STDERR ? *STDERR :
       # under Windows the filehandle must be an *output* handle

bin/diff_spreadsheets  view on Meta::CPAN 

147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
my %opts = (
  sort_rows       => 1,
  quote_char      => '"',
  sep_char        => ',',
  encoding        => 'UTF-8',
  trunc_title_width => max(20, int($maxwidth/3)),
);
my $method = "native";
my $help;
 
sub dashopt($) {
  my $optname = shift;
  length($optname) == 1 ? "-$optname" : "--$optname";
}
sub combined_optval($@) { # value is optional
  my ($nilval, $optname, $val) = @_;
  if ($val eq $nilval) {
    return dashopt($optname);
  } else {
    # e.g. -w20 or --width=20
    return(length($optname) == 1 ? "-$optname${val}" : "--$optname=$val");
  }
}
 
my @diff_opts;

bin/diff_spreadsheets  view on Meta::CPAN 

501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
 
 
########################################
#
#
#
########################################
package main::Differ;
 
use Carp;
sub oops(@) { unshift @_, "oops "; require Carp; goto &Carp::confess; }
use Path::Tiny 0.144;
#use File::Temp qw(tempfile tempdir);
#use File::Basename qw(basename dirname fileparse);
#use File::Path qw(make_path remove_tree);
#use File::Spec::Functions qw(canonpath catfile catdir rootdir tmpdir);
use List::Util qw(first any min max any sum0);
use List::Util qw(min max any first);
use Guard qw(guard scope_guard);
use Spreadsheet::Edit 1000.006 qw(:DEFAULT logmsg cx2let let2cx);
use Data::Dumper::Interp 6.007;
use Spreadsheet::Edit::Log ':btw=DS ${lno}:';
 
sub _visualize($);
sub _title_or_origABC($$);
 
my $seen = {};
sub warnonce(@) {
  my $msg = join "",@_;
  return if $seen->{$msg}++;
  warn $msg;
}
 
sub cx2origcx($$) {
  my ($sheet, $currcx) = @_;
  #  0 1 2 3 [4] [5] 6 7 [8] 9 10  original
  #  0 1 2 3         4 5     6  7  after deletes
  my $deleted_cxs = $sheet->attributes->{DELETED_CXS} // confess("bug");
  my $nskipped = 0;
  my $oldcx = $currcx;
  for my $dcx (@$deleted_cxs) {
    return($currcx + $nskipped) if $dcx >= $oldcx;
    $oldcx = $dcx;
    ++$nskipped;
  }
  return($currcx + $nskipped);
}
sub cx2origlet($$) { cx2let(&cx2origcx) }
 
sub compile_if_regex(@) { # compile "/.../msix" strings to qr/.../msix
  my @specs = @_;
  foreach (@specs) {
    if (m#^(/.*/[a-z]*)\z|^m([/\[\{\(\<].*)\z#s) {
      my $regex = eval "qr${1}" // do{
        $@ =~ s/ at \(eval.*//mg;
        die "$@ in $_\n";
      };
      $_ = $regex
    }
  }
  wantarray ? @specs :
  @specs > 1 ? confess("multiple results") :
  $specs[0]
}
 
sub __truncate($$) {
  my ($aref, $maxwid) = @_;
  my $changed;
  foreach (@$aref) {
    if (length($_) > $maxwid) {
      $changed++;
      # cut before the first actual newline or after visualized newline
      s/\A.+?(?:\\n|(?=\n))\K.*/.../s;
      if (length($_) > $maxwid) {
        my $numdots = max(3, length($_)-$maxwid);
        substr($_, $maxwid - $numdots) = ("." x $numdots);
      }
      #warn dvis '##TT __truncated $_ (len=',length($_),")\n";
    }
  }
  $changed
}
 
sub __visualize($) {
  local $_ = shift;
  s/\n/\\n/sg;
  s/\t/\\t/g;
  s/([^[:print:]])/ sprintf "\\x{%02x}", ord($1) /eg;
  if ($opts{ign_leading_spaces}) {
    s/^( +)//;
  } else {
    # make leading spaces visible
    s/^( +)/$visible_space x length($1)/e;
  }

bin/diff_spreadsheets  view on Meta::CPAN 

791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
  }
 
  # Append empty columns if needed to make both sheets the same width
  for my $N (1,2) {
    my $sh = $hash{"sheet$N"};
    while ($sh->num_cols < $ncols) { $sh->insert_col('>$', "") }
  }
  bless \%hash, $class;
}
 
sub _getncols($$) {
  my ($sh, $rx) = @_;
  $rx >= ($sh->title_rx//0) ? $sh->attributes->{NUMCOLS_USED} : $sh->num_cols
}
 
sub _title_or_origABC($$) {
  my ($sh, $cx) = @_;
  my $titlerow = $sh->title_row;
  (defined($titlerow) && $titlerow->[$cx] ne "")
    ? $titlerow->[$cx]
    : cx2origlet($sh,$cx)
}
 
sub _native_output {
  my ($self, $cxlist1, $cxlist2, $diff, $dumbrun) = @_; oops unless @_==5;
  my $restricted_keycols = @{$self->{id_columns}} > 0;

bin/diff_spreadsheets  view on Meta::CPAN 

1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
  $self->{exit_status} = ($changed ? 1 : 0);
}
 
# Format a value for display as an indented block.
# Newlines in the input are already converted to visible "\n".
# Actual newlines are appended to these markers and indentation
# inserted before second and subsequent lines.  Quotes are not
# included in the result.
# Usage:
#   printf "%*s: '%s'\n", $twid, $title, fmt_value($valstr,$twid+3);
sub fmt_value($$) {
  my ($str, $indent_width) = @_;
  oops if $str =~ /\n/s;
  my $indent = " " x $indent_width;
  $str =~ s/\\n/\\n\n${indent}/gs;
  if ($maxwidth) { # fold
    my $first_mw = $maxwidth - $indent_width;
    if (length($str) > $first_mw) {
      oops "maxwidth $maxwidth is too narrow\nfmw=$first_mw iw=$indent_width <<$str>>"
        if $first_mw < 20;  # sanity
      $str =~ s/\A([^\n]{$first_mw})([^\n]+)/$1\n${indent}$2/m;

bin/diff_spreadsheets  view on Meta::CPAN 

1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
        }
        next if $d==0; # both lists are the same
        foreach ($diff->Items(2)) {
          print $pfx, (($d&2) ? "+ " : "  "), fmt_value($_, $twidth+3), "\n";
          $pfx = $indent_str;
        }
      }
    }
  }
} #show_cell
sub row_header($$;$) {
  my ($verb, $rx1, $rx2) = @_;
  my $s = "$verb row ".($rx1+1);
  $s .= " (row ".($rx2+1)." in 2nd file)" if defined($rx2) && $rx1 != $rx2;
  sprintf "\n-------- %s %s\n", $s, ('-' x ($maxwidth-10-length($s)));
}
sub show_row {
  #my ($self, $N, $rx, $verb, $dumbrun) = @_; oops if @_ != 5;
  my ($self, $N, $row, $curr_rx, $verb, $dumbrun) = @_; oops if @_ != 6;
  my $sh = $self->{"sheet$N"};
  my $orig_rx = $sh->attributes->{ORIGINAL_RXS}->[$curr_rx] // $curr_rx;

t/t_Common.pm  view on Meta::CPAN 

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
# Attribution is requested but is not required.
#
# PLEASE NOTE that the above applies to THIS FILE ONLY.  Other files in the
# same distribution or in other collections may have more restrictive terms.
 
# Common setup stuff, not specifically for test cases.
# This file is intended to be identical in all my module distributions.
 
package t_Common;
 
sub hash2str($) { my $h=shift; join("",map{" ${_}=>".($h->{$_}//"u")} sort keys %$h) }
my ($default_warnbits, $default_pragmas);
BEGIN {
  $default_warnbits = ${^WARNING_BITS}//"u";
  $default_pragmas = ($^H//"u").":".hash2str(\%^H);
}
 
use strict;
 
# Do not fatalize decode warnings (under category 'utf8') because various smokers
# can have restrictive stdout encodings.

t/t_Common.pm  view on Meta::CPAN 

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
use feature qw/say state/;
 
require Exporter;
use parent 'https://metacpan.org/pod/Exporter">Exporter';
our @EXPORT = qw/mytempfile mytempdir/;
our @EXPORT_OK = qw/oops btw btwN/;
 
use Import::Into;
use Carp;
 
sub oops(@) {
  my $pkg = caller;
  my $pfx = "\noops";
  $pfx .= " in pkg '$pkg'" unless $pkg eq 'main';
  $pfx .= ":\n";
  if (defined(&Spreadsheet::Edit::logmsg)) {
    # Show current apply sheet & row if any.
    @_=($pfx, &Spreadsheet::Edit::logmsg(@_));
  } else {
    @_=($pfx, @_);
  }
  push @_,"\n" unless $_[-1] =~ /\R\z/;
  goto &Carp::confess
}
 
# "By The Way" messages showing file:linenum of the call
sub btw(@) { unshift @_,0; goto &btwN }
sub btwN($@) {
  my $N=shift;
  my ($fn, $lno) = (caller($N))[1,2];
  $fn =~ s/.*[\\\/]//;
  $fn =~ s/(.)\.[a-z]+$/$1/a;
  local $_ = join("",@_);
  s/\n\z//s;
  printf STDERR "%s:%d: %s\n", $fn, $lno, $_;
}
 
sub import {

t/t_TestCommon.pm  view on Meta::CPAN 

112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
use Config;
 
BEGIN {
  unless (Cwd::abs_path(__FILE__) =~ /Data-Dumper-Interp/) {
    # unless we are testing DDI
    #$Data::Dumper::Interp::Foldwidth = undef; # use terminal width
    $Data::Dumper::Interp::Useqq = "controlpics:unicode";
  }
}
 
sub bug(@) { @_=("BUG FOUND:",@_); goto &Carp::confess }
 
# Parse manual-testing args from @ARGV
my @orig_ARGV = @ARGV;
our ($debug, $verbose, $silent, $savepath, $nobail, $nonrandom, %dvs);
use Getopt::Long qw(GetOptions);
Getopt::Long::Configure("pass_through");
GetOptions(
  "d|debug"           => sub{ $debug=$verbose=1; $silent=0 },
  "s|silent"          => \$silent,
  "savepath=s"        => \$savepath,

t/t_TestCommon.pm  view on Meta::CPAN 

206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
    _start_silent() unless $debug;
  }
 
  die "Unhandled tag ",keys(%tags) if keys(%tags);
 
  # chain to Exporter to export any other importable items
  goto &Exporter::import
}
 
# Avoid turning on Test2 if not otherwise used...
sub dprint(@)   { print(@_)                if $debug };
sub dprintf($@) { printf($_[0],@_[1..$#_]) if $debug };
 
sub arrays_eq($$) {
  my ($a,$b) = @_;
  return 0 unless @$a == @$b;
  for(my $i=0; $i <= $#$a; $i++) {
    return 0 unless $a->[$i] eq $b->[$i];
  }
  return 1;
}
 
sub hash_subset($@) {
  my ($hash, @keys) = @_;
  return undef if ! defined $hash;
  return { map { exists($hash->{$_}) ? ($_ => $hash->{$_}) : () } @keys }
}
 
# string_to_tempfile($string, args => for-mytempfile)
# string_to_tempfile($string, pseudo_template) # see mytempfile
#
sub string_to_tempfile($@) {
  my ($string, @tfargs) = @_;
  my ($fh, $path) = mytempfile(@tfargs);
  dprint "> Creating $path\n";
  print $fh $string;
  $fh->flush;
  seek($fh,0,0) or die "seek $path : $!";
  wantarray ? ($path,$fh) : $path
}
 
# Run a Perl script in a sub-process.

t/t_TestCommon.pm  view on Meta::CPAN 

254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
# formats will be predictable for testing.
#
# This is usually enclosed in Capture::Tiny::capture { ... }
#
#    ==> IMPORTANT: Be sure STDOUT/ERR has :encoding(...) set beforehand
#        because Capture::Tiny will decode captured output the same way.
#        Otherwise wide chars will be corrupted
#
#
require Carp::Always;
sub run_perlscript(@) {
  my @tfs; # keep in scope until no longer needed
  my @perlargs = ("-CIOE", @_);
  @perlargs = ((map{ "-I$_" } @INC), @perlargs);
  #unshift @perlargs, "-MCarp=verbose" if $Carp::Verbose;
  #unshift @perlargs, "-MCarp::Always=verbose" if $Carp::Always::Verbose;
 
  ##This breaks no-internals-mentioned (AUTHOR_TESTS) in Spreadsheet::Edit
  ## For unknown reason some smokers running older perls die with
  ## "...undef value as a subroutine reference at site_perl/5.20.3/TAP/Harness.pm line 612
  ## So trying to see what is happening...

t/t_TestCommon.pm  view on Meta::CPAN 

334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
#
# Therefore tests can be simply wrapped in silent{...} or the entire
# program via the ':silent' tag; however any "Silence expected..." diagnostics
# will appear at the end, perhaps long after the specific test case which
# emitted the undesired output.
my ($orig_stdOUT, $orig_stdERR, $orig_DIE_trap);
my ($inmem_stdOUT, $inmem_stdERR) = ("", "");
my $silent_mode;
use Encode qw/decode FB_WARN FB_PERLQQ FB_CROAK LEAVE_SRC/;
my $start_silent_loc = "";
sub _finish_silent() {
  confess "not in silent mode" unless $silent_mode;
  close STDERR;
  open(STDERR, ">>&", $orig_stdERR) or exit(198);
  close STDOUT;
  open(STDOUT, ">>&", $orig_stdOUT) or die "orig_stdOUT: $!";
  $SIG{__DIE__} = $orig_DIE_trap;
  $silent_mode = 0;
  # The in-memory files hold octets; decode them before printing
  # them out (when they will be re-encoded for the user's terminal).
  my $errmsg;

t/t_TestCommon.pm  view on Meta::CPAN 

357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
    print STDOUT decode("utf8", $inmem_stdOUT, FB_PERLQQ|LEAVE_SRC);
    $errmsg //= "Silence expected on STDOUT";
  }
  if ($inmem_stdERR ne "") {
    print STDERR "--- saved STDERR ---\n";
    print STDERR decode("utf8", $inmem_stdERR, FB_PERLQQ|LEAVE_SRC);
    $errmsg = $errmsg ? "$errmsg and STDERR" : "Silence expected on STDERR";
  }
  defined($errmsg) ? $errmsg." at $start_silent_loc\n" : undef;
}
sub _start_silent() {
  confess "nested silent treatments not supported" if $silent_mode;
  $silent_mode = 1;
 
  for (my $N=0; ;++$N) {
    my ($pkg, $file, $line) = caller($N);
    $start_silent_loc = "$file line $line", last if $pkg ne __PACKAGE__;
  }
 
  $orig_DIE_trap = $SIG{__DIE__};
  $SIG{__DIE__} = sub{

t/t_TestCommon.pm  view on Meta::CPAN 

386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
  close STDOUT;
  open(STDOUT, ">", \$inmem_stdOUT) or die "redir STDOUT: $!";
  binmode(STDOUT); binmode(STDOUT, ":utf8");
 
  my @ERR_layers = grep{ $_ ne "unix" } PerlIO::get_layers(*STDERR, output=>1);
  open($orig_stdERR, ">&", \*STDERR) or die "dup STDERR: $!";
  close STDERR;
  open(STDERR, ">", \$inmem_stdERR) or die "redir STDERR: $!";
  binmode(STDERR); binmode(STDERR, ":utf8");
}
sub silent(&) {
  my $wantarray = wantarray;
  my $code = shift;
  _start_silent();
  my @result = do{
    if (defined $wantarray) {
      return( $wantarray ? $code->() : scalar($code->()) );
    }
    $code->();
    my $dummy_result; # so previous call has null context
  };

t/t_TestCommon.pm  view on Meta::CPAN 

433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
    ($testee_top_module = $1) =~ s/-/::/g;
    last
  }
  if (-e (my $p = $path->child("MYMETA.json"))) {
    $testee_top_module = JSON->new->decode($p->slurp_utf8())->{name};
    $testee_top_module =~ s/-/::/g;
    last;
  }
}
 
sub verif_no_internals_mentioned($) { # croaks if references found
  my $original = shift;
  oops "This may not be used except in a CPAN distribution tree"
    unless $testee_top_module;
  return if $Carp::Verbose;
 
  local $_ = $original;
 
  # Ignore glob refs like \*{"..."}
  s/(?<!\\)\\\*\{"[^"]*"\}//g;

t/t_TestCommon.pm  view on Meta::CPAN 

474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
    my $start = $-[1]; # offset of start of item
    my $end   = $+[1]; # offset of end+1
    substr($_,$start,0) = "HERE>>>";
    substr($_,$end+7,0) = "<<<THERE";
    local $Carp::Verbose = 0;  # no full traceback
    $Carp::CarpLevel++;
    croak $msg, ":\n«$_»\n";
  }
  1 # return true result if we don't croak
}
sub show_empty_string(_) {
  $_[0] eq "" ? "<empty string>" : $_[0]
}
 
sub show_white(_) { # show whitespace which might not be noticed
  local $_ = shift;
  return "(Is undef)" unless defined;
  s/\t/<tab>/sg;
  s/( +)$/"<space>" x length($1)/seg; # only trailing spaces
  s/\R/<newline>\n/sg;
  show_empty_string $_
}
 
#our $showstr_maxlen = 300;
our $showstr_maxlen = INT_MAX;
our @quotes = ("«", "»");
#our @quotes = ("<<", ">>");
sub rawstr(_) { # just the characters in French Quotes (truncated)
  # Show spaces visibly
  my $text = $_[0];
  ##$text =~ s/ /\N{MIDDLE DOT}/gs;
  $quotes[0].(length($text)>$showstr_maxlen ? substr($text,0,$showstr_maxlen-3)."..." : $text).$quotes[1]
}
 
# Show controls as single-charcter indicators like DDI's "controlpics",
# with the whole thing in French Quotes.  Truncate if huge.
sub showcontrols(_) {
  local $_ = shift;
  s/\n/\N{U+2424}/sg; # a special NL glyph
  s/[\x{00}-\x{1F}]/ chr( ord($&)+0x2400 ) /aseg;
  rawstr
}
 
# Show controls as traditional \t \n etc. if possible
sub showstr(_) {
  if (defined &Data::Dumper::Interp::visnew) {
    return visnew->Useqq("unicode")->vis(shift);
  } else {
    # I don't want to require Data::Dumper::Interp to be
    # loaded although it will be if t_Common.pm was used also.
    return showcontrols(shift);
  }
}
 
# Show the raw string in French Quotes.
# If STDOUT is not UTF-8 encoded, also show D::D hex escapes
# so we can still see something useful in output from non-Unicode platforms.
sub displaystr($) {
  my ($input) = @_;
  return "undef" if ! defined($input);
  local $_;
  state $utf8_output = grep /utf.?8/i, PerlIO::get_layers(*STDOUT, output=>1);
  my $r = rawstr($input);
  if (! $utf8_output && $input =~ /[^[:print:]]/a) {
    # Data::Dumper will show 'wide' characters as hex escapes
    my $dd = Data::Dumper->new([$input])->Useqq(1)->Terse(1)->Indent(0)->Dump;
    if ($dd ne $input && $dd ne "\"$input\"") {
      $r .= "\nD::D->$dd";
    }
  }
  $r
}
 
sub fmt_codestring($;$) { # returns list of lines
  my ($str, $prefix) = @_;
  $prefix //= "line ";
  my $i; map{ sprintf "%s%2d: %s\n", $prefix,++$i,$_ } (split /\n/,$_[0]);
}
 
# These wrappers add the caller's line number to the test description
# so they show when successful tests log their name.
# This is only visible with using "perl -Ilib t/xxx.t"
# not with 'prove -l' and so mostly pointless!
 
sub t_ok($;$) {
  my ($isok, $test_label) = @_;
  my $lno = (caller)[2];
  $test_label = ($test_label//"") . " (line $lno)";
  @_ = ( $isok, $test_label );
  goto &Test2::V0::ok;  # show caller's line number
}
sub ok_with_lineno($;$) { goto &t_ok };
 
sub t_is($$;$) {
  my ($got, $exp, $test_label) = @_;
  my $lno = (caller)[2];
  $test_label = ($test_label//$exp//"undef") . " (line $lno)";
  @_ = ( $got, $exp, $test_label );
  goto &Test2::V0::is;  # show caller's line number
}
sub is_with_lineno($$;$) { goto &t_is }
 
sub t_like($$;$) {
  my ($got, $exp, $test_label) = @_;
  my $lno = (caller)[2];
  $test_label = ($test_label//$exp) . " (line $lno)";
  @_ = ( $got, $exp, $test_label );
  goto &Test2::V0::like;  # show caller's line number
}
sub like_with_lineno($$;$) { goto &t_like }
 
sub _mycheck_end($$$) {
  my ($errmsg, $test_label, $ok_only_if_failed) = @_;
  return
    if $ok_only_if_failed && !$errmsg;
  my $lno = (caller)[2];
  &Test2::V0::diag("**********\n${errmsg}***********\n") if $errmsg;
  @_ = ( !$errmsg, $test_label );
  goto &ok_with_lineno;
}
 
# Nicer alternative to mycheck() when 'expected' is a literal string, not regex
sub mycheckeq_literal($$$) {
  my ($desc, $exp, $act) = @_;
  #confess "'exp' is not plain string in mycheckeq_literal" if ref($exp); #not re!
  $exp = show_white($exp); # stringifies undef
  $act = show_white($act);
  return unless $exp ne $act;
  my $hposn = 0;
  my $vposn = 0;
  for (0..length($exp)) {
    my $c = substr($exp,$_,1);
    last if $c ne substr($act,$_,1);

t/t_TestCommon.pm  view on Meta::CPAN 

615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
        ."Expected:\n".displaystr($exp)."\n"
        ."Actual:\n".displaystr($act)."\n"
        # + for opening « or << in the displayed str
        .(" " x ($hposn+length($quotes[0])))."^"
                          .($vposn > 0 ? "(line ".($vposn+1).")\n" : "\n")
        ." at line ", (caller(0))[2]."\n"
       ) ;
  goto &Carp::confess;
  #Carp::confess(@_);
}
sub expect1($$) {
  @_ = ("", @_);
  goto &mycheckeq_literal;
}
 
# Convert a literal "expected" string which contains things which are
# represented differently among versions of Perl and/or Data::Dumper
# into a regex which works with all versions.
# As of 1/1/23 the input string is expected to be what Perl v5.34 produces.
our $bs = '\\';  # a single backslash
sub _expstr2restr($) {
  local $_ = shift;
  confess "bug" if ref($_);
  return $_ if $_ eq "";
  # In \Q *string* \E the *string* may not end in a backslash because
  # it would be parsed as (\\)(E) instead of (\)(\E).
  # So change them to a unique token and later replace problematic
  # instances with ${bs} variable references.
  s/\\/<BS>/g;
  $_ = '\Q' . $_ . '\E';
  s#([\$\@\%]+)# do{ local $_ = $1;

t/t_TestCommon.pm  view on Meta::CPAN 

671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
    or
      confess "Problem with filehandle in input string <<$_>>";
#say "#XX fh AFTER : $_";
  }
  s/<BS>\\/\${bs}\\/g;
  s/<BS>/\\/g;
#say "#XX    FINAL : $_";
 
  $_
}
sub expstr2re($) {
  my $input = shift;
  my $xdesc; # extra debug description of intermediates
  my $output;
  if ($input !~ m#qr/|"::#) {
    # doesn't contain variable-representation items
    $output = $input;
    $xdesc = "";
  } else {
    my $s = _expstr2restr($input);
    my $saved_dollarat = $@;
    my $re = eval "qr{$s}"; die "$@ " if $@;
    $@ = $saved_dollarat;
    $xdesc = "**Orig match str  :".displaystr($input)."\n"
            ."**Generated re str:".displaystr($s)."\n" ;
    $output = $re;
  }
  wantarray ? ($xdesc, $output) : $output
}
 
# mycheck $test_desc, string_or_regex, result
sub mycheck($$@) {
  my ($desc, $expected_arg, @actual) = @_;
  local $_;  # preserve $1 etc. for caller
  my @expected = ref($expected_arg) eq "ARRAY" ? @$expected_arg : ($expected_arg);
  if ($@) {
    local $_;
    confess "Eval error: $@\n" unless $@ =~ /fake/i;  # It's okay if $@ is "...Fake..."
  }
  confess "zero 'actual' results" if @actual==0;
  confess "ARE WE USING THIS FEATURE? (@actual)" if @actual != 1;
  confess "ARE WE USING THIS FEATURE? (@expected)" if @expected != 1;

t/t_TestCommon.pm  view on Meta::CPAN 

739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
#say "###EXP $expected";
    } else {
      unless ($expected eq $actual) {
        @_ = ("TESTc FAILED: $desc", $expected, $actual);
        goto &mycheckeq_literal
      }
    }
  }
}
 
sub verif_eval_err(;$) {  # MUST be called on same line as the 'eval'
  my ($msg_regex) = @_;
  my @caller = caller(0);
  my $ln = $caller[2];
  my $fn = $caller[1];
  my $ex = $@;
  confess "expected error did not occur at $fn line $ln\n",
    unless $ex;
 
  if ($ex !~ / at \Q$fn\E line $ln\.?(?:$|\R)/s) {
    confess "Got UN-expected err (not ' at $fn line $ln'):\n«$ex»\n",
            "\n";
  }
  if ($msg_regex && $ex !~ qr/$msg_regex/) {
    confess "Got UN-expected err (not matching $msg_regex) at $fn line $ln'):\n«$ex»\n",
            "\n";
  }
  verif_no_internals_mentioned($ex) if defined $testee_top_module;
  dprint "Got expected err: $ex\n";
}
 
sub insert_loc_in_evalstr($) {
  my $orig = shift;
  my ($fn, $lno) = (caller(0))[1,2];
#use Data::Dumper::Interp; say dvis '###insert_loc_in_evalstr $fn $lno';
  "# line $lno \"$fn\"\n".$orig
}
 
sub timed_run(&$@) {
  my ($code, $maxcpusecs, @codeargs) = @_;
 
  my $getcpu = eval {do{
    require Time::HiRes;
    () = (&Time::HiRes::clock());
    \&Time::HiRes::clock;
  }} // sub{ my @t = times; $t[0]+$t[1] };
  dprint("Note: $@") if $@;
  $@ = ""; # avoid triggering "Eval error" in mycheck();

t/t_TestCommon.pm  view on Meta::CPAN 

790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
  if (wantarray) {@result = &$code(@codeargs)} else {$result = &$code(@codeargs)};
  my $cpusecs = &$getcpu() - $startclock;
  confess "TOOK TOO LONG ($cpusecs CPU seconds vs. limit of $maxcpusecs)\n"
    if $cpusecs > $maxcpusecs;
  if (wantarray) {return @result} else {return $result};
}
 
# Copy a file if needed to prevent any possibilty of it being modified.
# Returns the original path if the file is read-only, otherwise the path
# of a temp copy.
sub tmpcopy_if_writeable($) {
  my $path = shift;
  confess "$path : $!" unless stat($path);
  if ( (stat(_))[2] & 0222 ) {
    my ($name, $suf) = (basename($path) =~ /^(.*?)((?:\.\w{1,4})?)$/);
    (undef, my $tpath) =
      File::Temp::tempfile(SUFFIX => $suf, UNLINK => 1);
    File::Copy::copy($path, $tpath) or die "File::Copy $!";
    return $tpath;
  }
  $path
}
 
sub clean_capture_output($) {
  my $str = shift;
  # For some reason I can not track down, tests on Windows in VirtualBox sometimes emit
  # this message.  I think (unproven) that this occurs because the current directory
  # is a VBox host-shared directory mounted read-only.   But nobody should be writing
  # to the cwd!
  $str =~ s/The media is write protected\S*\R//gs;
  $str
}
 
sub my_capture(&) {
  my ($out, $err, @results) = &capture($_[0]);
  return( clean_capture_output($out), clean_capture_output($err), @results );
}
sub my_capture_merged(&) {
  my ($merged, @results) = &capture_merged($_[0]);
  return( clean_capture_output($merged), @results );
}
sub my_tee_merged(&) {
  my ($merged, @results) = &tee_merged($_[0]);
  return( clean_capture_output($merged), @results );
}
 
1;

t/t_dsUtils.pm  view on Meta::CPAN 

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
use t_Common; # strict, warnings and lots of stuff
use t_TestCommon qw/:DEFAULT $debug $verbose $silent/; # imports Test2::V0
 
use Capture::Tiny ();
use FindBin qw/$Bin/;
require PerlIO;
 
our $progname = "diff_spreadsheets";
our $progpath = "$Bin/../bin/$progname";
 
sub runtest($$$$$$;@) {
  my ($in1, $in2, $exp_out, $exp_err, $exp_exit, $desc, @extraargs) = @_;
  if (state $first_time = 1) {
    # Capture::Tiny will decode octets from the results according to whatever
    # encoding was set for STDOUT or STDERR, and if not it won't decode.
    # This corrupts wide characters unless enc is pre-set on those handles.
    unless (grep /utf.*8/i, PerlIO::get_layers(*STDOUT)) {
      croak "STDOUT does not have utf8 or encoding(UTF-8) enabled";
    }
    unless (grep /utf.*8/i, PerlIO::get_layers(*STDERR)) {
      croak "STDERR does not have utf8 or encoding(UTF-8) enabled";

tlib/xmlstuff.pl  view on Meta::CPAN 

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
use Carp;
use Data::Dumper::Interp;
use Encode qw(encode decode);
use Archive::Zip qw(:ERROR_CODES :CONSTANTS);
use XML::Twig ();
 
use Test2::V0; #for 'note' and 'diag'
 
use constant DEFAULT_MEMBER_NAME => "content.xml";
 
sub encode_xml($$;$) {
  my ($chars, $encoding, $desc) = @_;
  confess "bug" unless defined($chars) && defined($encoding);
  $chars =~ s/(<\?xml[^\?]*encoding=")([^"]+)("[^\?]*\?>)/$1${encoding}$3/s
    or confess qq(Could not find <?xml ... encoding="..."?>),
               ($desc ? " in $desc" : "");
  my $octets = encode($encoding, $chars, Encode::FB_CROAK|Encode::LEAVE_SRC);
  $octets
}
 
sub decode_xml($;$) {
  my ($octets, $desc) = @_;
  my $chars;
  my $encoding;
  if (length($octets) == 0) {
    $chars = "";
  } else {
    ($encoding) = ($octets =~ /<\?xml[^\?]*encoding="([^"]+)"[^\?]*\?>/);
    confess qq(Could not find <?xml ... encoding="..."?>),
            ($desc ? " in $desc" : "")
      unless $encoding;



( run in 1.020 second using v1.01-cache-2.11-cpan-e9199f4ba4c )