App-diff_spreadsheets
5 results

 view release on metacpan or  search on metacpan

bin/diff_spreadsheets  view on Meta::CPAN 

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 

#    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 

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 



########################################
#
#
#
########################################
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 

  }

  # 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 

  $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 

        }
        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 

# 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 

use feature qw/say state/;

require Exporter;
use parent '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 

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 

    _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 

# 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 

#
# 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 

    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 

  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 

    ($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 

    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 

        ."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 

    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 

#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 

  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 

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 

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 0.276 second using v1.01-cache-2.11-cpan-e9199f4ba4c )