From e5b9b7685d51d37e17125943377cb15e2dcda6e0 Mon Sep 17 00:00:00 2001 From: Chad Granum Date: Tue, 28 Nov 2023 16:22:36 -0800 Subject: [PATCH] Util restructuring --- lib/App/Yath/Util.pm | 369 ----------------- lib/Test2/Harness/Util.pm | 564 ++++++-------------------- lib/Test2/Harness/Util/File.pm | 256 ------------ lib/Test2/Harness/Util/File/JSON.pm | 91 ----- lib/Test2/Harness/Util/File/JSONL.pm | 91 ----- lib/Test2/Harness/Util/File/Stream.pm | 207 ---------- lib/Test2/Harness/Util/File/Value.pm | 100 ----- lib/Test2/Harness/Util/HashBase.pm | 69 ++-- lib/Test2/Harness/Util/JSON.pm | 267 +----------- lib/Test2/Harness/Util/LogFile.pm | 73 ++++ lib/Test2/Harness/Util/Minimal.pm | 102 +++++ lib/Test2/Harness/Util/Queue.pm | 213 ---------- lib/Test2/Harness/Util/Term.pm | 104 ----- 13 files changed, 362 insertions(+), 2144 deletions(-) delete mode 100644 lib/App/Yath/Util.pm delete mode 100644 lib/Test2/Harness/Util/File.pm delete mode 100644 lib/Test2/Harness/Util/File/JSON.pm delete mode 100644 lib/Test2/Harness/Util/File/JSONL.pm delete mode 100644 lib/Test2/Harness/Util/File/Stream.pm delete mode 100644 lib/Test2/Harness/Util/File/Value.pm create mode 100644 lib/Test2/Harness/Util/LogFile.pm create mode 100644 lib/Test2/Harness/Util/Minimal.pm delete mode 100644 lib/Test2/Harness/Util/Queue.pm delete mode 100644 lib/Test2/Harness/Util/Term.pm diff --git a/lib/App/Yath/Util.pm b/lib/App/Yath/Util.pm deleted file mode 100644 index 9d0a96ca1..000000000 --- a/lib/App/Yath/Util.pm +++ /dev/null @@ -1,369 +0,0 @@ -package App::Yath::Util; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use File::Spec; -use Sys::Hostname qw/hostname/; - -use Test2::Harness::Util qw/clean_path/; -use Test2::Harness::Util::File::JSON; - -use Cwd qw/realpath/; -use Importer Importer => 'import'; -use Config qw/%Config/; -use Carp qw/croak/; - -our @EXPORT_OK = qw{ - find_pfile - find_in_updir - is_generated_test_pl - fit_to_width - isolate_stdout - find_yath -}; - -sub find_yath { - return $App::Yath::Script::SCRIPT if defined $App::Yath::Script::SCRIPT; - - if (-d 'scripts') { - my $script = File::Spec->catfile('scripts', 'yath'); - return $App::Yath::Script::SCRIPT = clean_path($script) if -e $script && -x $script; - } - - my @keys = qw{ - bin binexp initialinstalllocation installbin installscript - installsitebin installsitescript installusrbinperl installvendorbin - scriptdir scriptdirexp sitebin sitebinexp sitescript sitescriptexp - vendorbin vendorbinexp - }; - - my %seen; - for my $path (@Config{@keys}) { - next unless $path; - next if $seen{$path}++; - - my $script = File::Spec->catfile($path, 'yath'); - next unless -f $script && -x $script; - - $App::Yath::Script::SCRIPT = $script = clean_path($script); - return $script; - } - - die "Could not find yath in Config paths"; -} - -sub isolate_stdout { - # Make $fh point at STDOUT, it is our primary output - open(my $fh, '>&', STDOUT) or die "Could not clone STDOUT: $!"; - select $fh; - $| = 1; - - # re-open STDOUT redirected to STDERR - open(STDOUT, '>&', STDERR) or die "Could not redirect STDOUT to STDERR: $!"; - select STDOUT; - $| = 1; - - # Yes, we want to keep STDERR selected - select STDERR; - $| = 1; - - return $fh; -} - -sub is_generated_test_pl { - my ($file) = @_; - - open(my $fh, '<', $file) or die "Could not open '$file': $!"; - - my $count = 0; - while (my $line = <$fh>) { - last if $count++ > 5; - next unless $line =~ m/^# THIS IS A GENERATED YATH RUNNER TEST$/; - return 1; - } - - return 0; -} - - -sub find_in_updir { - my $path = shift; - return clean_path($path) if -f $path; - - my %seen; - while(1) { - $path = File::Spec->catdir('..', $path); - my $check = eval { realpath(File::Spec->rel2abs($path)) }; - last unless $check; - last if $seen{$check}++; - return $check if -f $check; - } - - return; -} - -sub _find_pfile { - my ($settings, %params) = @_; - - croak "Settings is a required argument" unless $settings; - - # First do the entire search without vivify - if ($params{vivify}) { - my $found = find_pfile($settings, %params, vivify => 0); - return $found if $found; - } - - my $yath = $settings->harness; - - if (my $pfile = $yath->persist_file) { - return $pfile if -f $pfile || $params{vivify}; - - return; # Specified, but not found and no vivify - } - - my $basename = "yath-persist.json"; - my $user = $ENV{USER}; - my $hostname = hostname(); - my $project = $yath->project; - - my @names = ($basename); - @names = (@names, map { "$project-$_" } @names) if $project; - @names = (@names, map { "$hostname-$_" } @names) if $hostname; - @names = (@names, map { "$user-$_" } @names) if $user; - @names = reverse map { ".$_" } @names; - - my $set_dir = $yath->persist_dir // $ENV{YATH_PERSISTENCE_DIR}; - my $dir = $set_dir // $ENV{TMPDIR} // $ENV{TEMPDIR} // File::Spec->tmpdir; - - # If a dir was specified, or if the current dir is not writable then we must use $dir/$name - if ($project || $set_dir || !-w '.') { - for my $name (@names) { - my $pfile = clean_path(File::Spec->catfile($dir, $name)); - return $pfile if -f $pfile; - } - - return clean_path(File::Spec->catfile($dir, $names[0])) if $params{vivify}; - return; # Not found - } - - # Fall back to using the current dir (which must be writable) - for my $name (@names) { - my $pfile = find_in_updir($name); - return $pfile if $pfile && -f $pfile; - } - - # Creating it here! - return clean_path(File::Spec->catfile('.', $names[0])) if $params{vivify}; - - # Nope, nothing. - return; -} - -sub fit_to_width { - my ($width, $join, $text) = @_; - - my @parts = ref($text) ? @$text : split /\s+/, $text; - - my @out; - - my $line = ""; - for my $part (@parts) { - my $new = $line ? "$line$join$part" : $part; - - if ($line && length($new) > $width) { - push @out => $line; - $line = $part; - } - else { - $line = $new; - } - } - push @out => $line if $line; - - return join "\n" => @out; -} - -my $SEEN_ERROR = 0; -sub find_pfile { - my ($settings, %params) = @_; - my $pfile = _find_pfile($settings, %params) or return; - - return $pfile unless -e $pfile; - return $pfile if $params{no_checks}; - return $pfile if $SEEN_ERROR; - - my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); - - $data->{version} //= ''; - $data->{hostname} //= ''; - $data->{user} //= ''; - $data->{pid} //= ''; - $data->{dir} //= ''; - - my $hostname = hostname(); - my $user = $ENV{USER}; - - my @bad; - - push @bad => "** Version mismatch, persistent runner is version $data->{version}, current is version $VERSION. **" - if $data->{version} ne $VERSION; - - push @bad => "** Hostname mismatch, persistent runner hostname is '$data->{hostname}', current hostname is '$hostname'. **" - if $data->{hostname} ne $hostname; - - push @bad => "** User mismatch, persistent runner user is '$data->{user}', current user is '$user'. **" - if $data->{user} ne $user; - - push @bad => "** Workdir missing, persistent runner is supposed to be at '$data->{dir}', but it does not exist. **" - unless -d $data->{dir}; - - push @bad => "** PID not running, persistent runner is supposed to be running with PID '$data->{pid}', but it is not. **" - unless kill(0, $data->{pid}); - - return $pfile unless @bad; - - my $break = ('=' x 120) . "\n"; - my $msg = join "\n" => $break, @bad, <<" EOT", $break; - -Errors like this usually indicate that the persistent runner has gone away. -Maybe the system was shut down improperly, or maybe the process was killed too -quickly to clean up after itself. - -Here is the information indicated by the persistence file: - Runner PID: $data->{pid} - Runner Vers: $data->{version} - Runner user: $data->{user} - Runner host: $data->{hostname} - Working dir: $data->{dir} - -If the persistent runner is truly gone you should delete the following file to -continue: - -$pfile - EOT - - $SEEN_ERROR = 1; - die $msg unless $params{no_fatal}; - warn $msg unless $params{no_warn}; - return $pfile; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -App::Yath::Util - General utilities for yath that do not fit anywhere else. - -=head1 DESCRIPTION - -This package exports several tools used throughout yath that did not fit into -any other package. - -=head1 SYNOPSIS - - use App::Yath::Util qw{ - find_pfile - find_in_updir - is_generated_test_pl - fit_to_width - isolate_stdout - find_yath - }; - -=head1 EXPORTS - -Note that nothing is exported by default, you must request each function to -import. - -=over 4 - -=item $path_to_pfile = find_pfile($settings, %params) - -The first argument must be an instance of L. - -Currently the only supported param is C, when set to true the pfile -will be created if one does not already exist. - -The pfile is a file that tells yath that a persistent runner is active, and how -to communicate with it. - -=item $path_to_file = find_in_updir($file_name) - -Look for C<$file_name> in the current directory or any parent directory. - -=item $bool = is_generated_test_pl($path_to_test_file) - -Check if the specified test file was generated by the C command. - -=item fit_to_width($width, $join, $text) - -This will split the C<$text> on space, and then recombine it using C<$join> -inserting newlines as necessary in an attempt to fit the text into C<$width> -horizontal characters. If any words are larger than C<$width> they will not be -split and text-wrapping may occur if used for terminal display. - -=item $stdout = isolate_stdout() - -This will close STDOUT and reopen it to point at STDERR. The result of this is -that any print statement that does not specify a fielhandle will print to -STDERR instead of STDOUT, in addition any print directly to STDOUT will instead -go to STDERR. A filehandle to the real STDOUT is returned for you to use when -you actually want to write to STDOUT. - -This is used by some yath processes that need to print structured data to -STDOUT without letting any third part modules they may load write to the real -STDOUT. - -=item $path_to_script = find_yath() - -This will attempt to find the C command line script. When possible this -will return the path that was used to launch yath. If yath was not run to start -the process it will search the paths specified in the L module. This -will throw an exception if the script cannot be found. - -Note: The result is cached so that subsequent calls will return the same path -even if something installs a new yath script in another location that would -otherwise be found first. This guarentees that a single process will not switch -scripts. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Util.pm b/lib/Test2/Harness/Util.pm index 880358607..a19f767d1 100644 --- a/lib/Test2/Harness/Util.pm +++ b/lib/Test2/Harness/Util.pm @@ -2,45 +2,40 @@ package Test2::Harness::Util; use strict; use warnings; -use Carp qw/confess/; -use Cwd qw/realpath/; +use Carp qw/confess croak/; +use Fcntl qw/:mode/; use Test2::Util qw/try_sig_mask do_rename/; -use Fcntl qw/LOCK_EX LOCK_UN SEEK_SET :mode/; -use File::Spec; -our $VERSION = '1.000152'; +our $VERSION = '2.000000'; use Importer Importer => 'import'; -our @EXPORT_OK = qw{ - find_libraries - clean_path - - parse_exit - mod2file - file2mod - fqmod - - maybe_open_file - maybe_read_file - open_file - read_file - write_file - write_file_atomic - lock_file - unlock_file - - hub_truth - - apply_encoding - - process_includes - - chmod_tmp - - looks_like_uuid - is_same_file -}; +use Importer 'Test2::Harness::Util::Minimal'; + +our @EXPORT_OK = ( + @Test2::Harness::Util::Minimal::EXPORT, + qw{ + find_libraries + mod2file + file2mod + fqmod + parse_exit + hub_truth + apply_encoding + chmod_tmp + + maybe_open_file + maybe_read_file + open_file + read_file + write_file + write_file_atomic + + hash_purge + + is_same_file + }, +); sub is_same_file { my ($file1, $file2) = @_; @@ -62,60 +57,35 @@ sub is_same_file { return 1; } -sub looks_like_uuid { - my ($in) = @_; - - return undef unless defined $in; - return undef unless length($in) == 36; - return undef unless $in =~ m/^[0-9A-F\-]+$/i; - return $in; -} - -sub chmod_tmp { - my $file = shift; - - my $mode = S_ISVTX | S_IRWXU | S_IRWXG | S_IRWXO; - - chmod($mode, $file); -} - -sub process_includes { - my %params = @_; +sub hash_purge { + my ($hash) = @_; - my @start = @{delete $params{list} // []}; + my $keep = 0; - my @list; - my %seen = ('.' => 1); + for my $key (keys %$hash) { + my $val = $hash->{$key}; - if (my $ch_dir = delete $params{ch_dir}) { - for my $path (@start) { - # '.' is special. - $seen{'.'}++ and next if $path eq '.'; + my $delete = 0; + $delete = 1 unless defined($val); + $delete ||= ref($hash->{$key}) eq 'HASH' && !hash_purge($hash->{$key}); - if (File::Spec->file_name_is_absolute($path)) { - push @list => $path; - } - else { - push @list => File::Spec->catdir($ch_dir, $path); - } + if ($delete) { + delete $hash->{$key}; + next; } - } - else { - @list = @start; - } - - push @list => @INC if delete $params{include_current}; - @list = map { $_ eq '.' ? $_ : clean_path($_) || $_ } @list if delete $params{clean}; + $keep++; + } - @list = grep { !$seen{$_}++ } @list; + return $keep; +} - # If we ask for dot, or saw it during our processing, add it to the end. - push @list => '.' if delete($params{include_dot}) || $seen{'.'} > 1; +sub chmod_tmp { + my $file = shift; - confess "Invalid parameters: " . join(', ' => sort keys %params) if keys %params; + my $mode = S_ISVTX | S_IRWXU | S_IRWXG | S_IRWXO; - return @list; + chmod($mode, $file); } sub apply_encoding { @@ -131,6 +101,7 @@ sub apply_encoding { sub parse_exit { my ($exit) = @_; + croak "an exit value is required" unless defined $exit; my $sig = $exit & 127; my $dmp = $exit & 128; @@ -143,12 +114,6 @@ sub parse_exit { }; } -sub fqmod { - my ($prefix, $input) = @_; - return $1 if $input =~ m/^\+(.*)$/; - return "$prefix\::$input"; -} - sub hub_truth { my ($f) = @_; @@ -157,134 +122,18 @@ sub hub_truth { return {}; } -sub maybe_read_file { - my ($file) = @_; - return undef unless -f $file; - return read_file($file); -} - -sub read_file { - my ($file, @args) = @_; - - my $fh = open_file($file, '<', @args); - local $/; - my $out = <$fh>; - close_file($fh, $file); - - return $out; -} - -sub write_file { - my ($file, @content) = @_; - - my $fh = open_file($file, '>'); - print $fh @content; - close_file($fh, $file); - - return @content; -}; - -my %COMPRESSION = ( - bz2 => {module => 'IO::Uncompress::Bunzip2', errors => \$IO::Uncompress::Bunzip2::Bunzip2Error}, - gz => {module => 'IO::Uncompress::Gunzip', errors => \$IO::Uncompress::Gunzip::GunzipError}, -); -sub open_file { - my ($file, $mode, %opts) = @_; - $mode ||= '<'; - - unless ($opts{no_decompress}) { - if (my $ext = $opts{ext}) { - $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; - } - - if ($file =~ m/\.(gz|bz2)$/i) { - my $ext = lc($1); - $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; - } - - if ($mode eq '<' && $opts{compression}) { - my $spec = $opts{compression}; - my $mod = $spec->{module}; - require(mod2file($mod)); - - my $fh = $mod->new($file) or die "Could not open file '$file' ($mode): ${$spec->{errors}}"; - return $fh; - } - } - - open(my $fh, $mode, $file) or confess "Could not open file '$file' ($mode): $!"; - return $fh; -} - -sub maybe_open_file { - my ($file, $mode) = @_; - return undef unless -f $file; - return open_file($file, $mode); -} - -sub close_file { - my ($fh, $name) = @_; - return if close($fh); - confess "Could not close file: $!" unless $name; - confess "Could not close file '$name': $!"; -} - -sub write_file_atomic { - my ($file, @content) = @_; - - my $pend = "$file.pend"; - - my ($ok, $err) = try_sig_mask { - write_file($pend, @content); - my ($ren_ok, $ren_err) = do_rename($pend, $file); - die "$pend -> $file: $ren_err" unless $ren_ok; - }; - - die $err unless $ok; - - return @content; -} - -sub lock_file { - my ($file, $mode) = @_; - - my $fh; - if (ref $file) { - $fh = $file; - } - else { - open($fh, $mode // '>>', $file) or die "Could not open file '$file': $!"; - } - - for (1 .. 21) { - flock($fh, LOCK_EX) and last; - die "Could not lock file (try $_): $!" if $_ >= 20; - next if $!{EINTR} || $!{ERESTART}; - die "Could not lock file: $!"; - } - - return $fh; -} - -sub unlock_file { - my ($fh) = @_; - for (1 .. 21) { - flock($fh, LOCK_UN) and last; - die "Could not unlock file (try $_): $!" if $_ >= 20; - next if $!{EINTR} || $!{ERESTART}; - die "Could not unlock file: $!"; - } - - return $fh; +sub fqmod { + my ($prefix, $input) = @_; + return $1 if $input =~ m/^\+(.*)$/; + return "$prefix\::$input"; } -sub clean_path { - my ( $path, $absolute ) = @_; - - $absolute //= 1; - $path = realpath($path) // $path if $absolute; - - return File::Spec->rel2abs($path); +sub file2mod { + my $file = shift; + my $mod = $file; + $mod =~ s{/}{::}g; + $mod =~ s/\..*$//; + return $mod; } sub mod2file { @@ -296,15 +145,6 @@ sub mod2file { return $file; } -sub file2mod { - my $file = shift; - my $mod = $file; - $mod =~ s{/}{::}g; - $mod =~ s/\..*$//; - return $mod; -} - - sub find_libraries { my ($search, @paths) = @_; my @parts = grep $_, split /::(\*)?/, $search; @@ -372,242 +212,92 @@ sub find_libraries { return \%out; } -1; - -__END__ - - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Util - General utiliy functions. - -=head1 DESCRIPTION - -=head1 METHODS - -=head2 MISC - -=over 4 - -=item apply_encoding($fh, $enc) - -Apply the specified encoding to the filehandle. - -B: -L -If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in -order to avoid the thread segfault. - -This is a reusable implementation of this: - - sub apply_encoding { - my ($fh, $enc) = @_; - return unless $enc; - return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; - binmode($fh, ":encoding($enc)"); - } - -=item $clean = clean_path($path) - -Take a file path and clean it up to a minimal absolute path if possible. Always -returns a path, but if it cannot be cleaned up it is unchanged. - -=item $hashref = find_libraries($search) - -=item $hashref = find_libraries($search, @paths) - -C<@INC> is used if no C<@paths> are provided. - -C<$search> should be a module name with C<*> wildcards replacing sections. +sub maybe_read_file { + my ($file) = @_; + return undef unless -f $file; + return read_file($file); +} - find_libraries('Foo::*::Baz') - find_libraries('*::Bar::Baz') - find_libraries('Foo::Bar::*') +sub read_file { + my ($file, @args) = @_; -These all look for modules matching the search, this is a good way to find -plugins, or similar patterns. + my $fh = open_file($file, '<', @args); + local $/; + my $out = <$fh>; + close_file($fh, $file); -The result is a hashref of C<< { $module => $path } >>. If a module exists in -more than 1 search path the first is used. + return $out; +} -=item $mod = fqmod($prefix, $mod) +sub write_file { + my ($file, @content) = @_; -This will automatically add C<$prefix> to C<$mod> with C<'::'> to join them. If -C<$mod> starts with the C<'+'> character the character will be removed and the -result returned without prepending C<$prefix>. + my $fh = open_file($file, '>'); + print $fh @content; + close_file($fh, $file); -=item hub_truth + return @content; +}; -This is an internal implementation detail, do not use it. +my %COMPRESSION = ( + bz2 => {module => 'IO::Uncompress::Bunzip2', errors => \$IO::Uncompress::Bunzip2::Bunzip2Error}, + gz => {module => 'IO::Uncompress::Gunzip', errors => \$IO::Uncompress::Gunzip::GunzipError}, +); +sub open_file { + my ($file, $mode, %opts) = @_; + $mode ||= '<'; -=item $hashref = parse_exit($?) + unless ($opts{no_decompress}) { + if (my $ext = $opts{ext}) { + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } -This parses the exit value as typically stored in C<$?>. + if ($file =~ m/\.(gz|bz2)$/i) { + my $ext = lc($1); + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } -Resulting hash: + if ($mode eq '<' && $opts{compression}) { + my $spec = $opts{compression}; + my $mod = $spec->{module}; + require(mod2file($mod)); - { - sig => ($? & 127), # Signal value if the exit was caused by a signal - err => ($? >> 8), # Actual exit code, if any. - dmp => ($? & 128), # Was there a core dump? - all => $?, # Original exit value, unchanged + my $fh = $mod->new($file) or die "Could not open file '$file' ($mode): ${$spec->{errors}}"; + return $fh; + } } + open(my $fh, $mode, $file) or confess "Could not open file '$file' ($mode): $!"; + return $fh; +} -=item @list = process_includes(%PARAMS) - -This method will build up a list of include dirs fit for C<@INC>. The returned -list should contain only unique values, in proper order. - -Params: - -=over 4 - -=item list => \@START - -Paths to start the new list. - -Optional. - -=item ch_dir => $path - -Prefix to prepend to all paths in the C param. No effect without an -initial list. - -=item include_current => $bool - -This will add all paths from C<@INC> to the output, after the initial list. -Note that '.', if in C<@INC> will be moved to the end of the final output. - -=item clean => $bool - -If included all paths except C<'.'> will be cleaned using C. - -=item include_dot => $bool - -If true C<'.'> will be appended to the end of the output. - -B even if this is set to false C<'.'> may still be included if it was in -the initial list, or if it was in C<@INC> and C<@INC> was included using the -C parameter. - -=back - -=back - -=head2 FOR DEALING WITH MODULE <-> FILE CONVERSION - -These convert between module names like C and filenames like -C. - -=over 4 - -=item $file = mod2file($mod) - -=item $mod = file2mod($file) - -=back - -=head2 FOR READING/WRITING FILES - -=over 4 - -=item $fh = open_file($path, $mode) - -=item $fh = open_file($path) - -If no mode is provided C<< '<' >> is assumed. - -This will open the file at C<$path> and return a filehandle. - -An exception will be thrown if the file cannot be opened. - -B This will automatically use L or -L to uncompress the file if it has a .bz2 or .gz -extension. - -=item $text = read_file($file) - -This will open the file at C<$path> and return all its contents. - -An exception will be thrown if the file cannot be opened. - -B This will automatically use L or -L to uncompress the file if it has a .bz2 or .gz -extension. - -=item $fh = maybe_open_file($path) - -=item $fh = maybe_open_file($path, $mode) - -If no mode is provided C<< '<' >> is assumed. - -This will open the file at C<$path> and return a filehandle. - -C is returned if the file cannot be opened. - -B This will automatically use L or -L to uncompress the file if it has a .bz2 or .gz -extension. - -=item $text = maybe_read_file($path) - -This will open the file at C<$path> and return all its contents. - -This will return C if the file cannot be opened. - -B This will automatically use L or -L to uncompress the file if it has a .bz2 or .gz -extension. - -=item @content = write_file($path, @content) - -Write content to the specified file. This will open the file with mode -C<< '>' >>, write the content, then close the file. - -An exception will be thrown if any part fails. - -=item @content = write_file_atomic($path, @content) - -This will open a temporary file, write the content, close the file, then rename -the file to the desired C<$path>. This is essentially an atomic write in that -C<$file> will not exist until all content is written, preventing other -processes from doing a partial read while C<@content> is being written. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 +sub maybe_open_file { + my ($file, $mode) = @_; + return undef unless -f $file; + return open_file($file, $mode); +} -=item Chad Granum Eexodist@cpan.orgE +sub close_file { + my ($fh, $name) = @_; + return if close($fh); + confess "Could not close file: $!" unless $name; + confess "Could not close file '$name': $!"; +} -=back +sub write_file_atomic { + my ($file, @content) = @_; -=head1 COPYRIGHT + my $pend = "$file.pend"; -Copyright 2020 Chad Granum Eexodist7@gmail.comE. + my ($ok, $err) = try_sig_mask { + write_file($pend, @content); + my ($ren_ok, $ren_err) = do_rename($pend, $file); + die "$pend -> $file: $ren_err" unless $ren_ok; + }; -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. + die $err unless $ok; -See F + return @content; +} -=cut +1; diff --git a/lib/Test2/Harness/Util/File.pm b/lib/Test2/Harness/Util/File.pm deleted file mode 100644 index 6a19341f1..000000000 --- a/lib/Test2/Harness/Util/File.pm +++ /dev/null @@ -1,256 +0,0 @@ -package Test2::Harness::Util::File; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use IO::Handle; - -use Test2::Harness::Util(); - -use Carp qw/croak confess/; -use Fcntl qw/SEEK_SET SEEK_CUR/; - -use Test2::Harness::Util::HashBase qw{ -name -_fh -_init_fh done -line_pos {+NAME} } - -sub decode { shift; $_[0] } -sub encode { shift; $_[0] } - -sub init { - my $self = shift; - - croak "'name' is a required attribute" unless $self->{+NAME}; - - $self->{+_INIT_FH} = delete $self->{fh}; -} - -sub open_file { - my $self = shift; - return Test2::Harness::Util::open_file($self->{+NAME}, @_) -} - -sub maybe_read { - my $self = shift; - return undef unless -e $self->{+NAME}; - return $self->read; -} - -sub read { - my $self = shift; - my $out = Test2::Harness::Util::read_file($self->{+NAME}); - - eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; - return $out; -} - -sub rewrite { - my $self = shift; - return Test2::Harness::Util::write_file($self->{+NAME}, $self->encode(@_)); -} - -sub write { - my $self = shift; - return Test2::Harness::Util::write_file_atomic($self->{+NAME}, $self->encode(@_)); -} - -sub reset { - my $self = shift; - delete $self->{+_FH}; - delete $self->{+DONE}; - delete $self->{+LINE_POS}; - return; -} - -sub fh { - my $self = shift; - return $self->{+_FH}->{$$} if $self->{+_FH}->{$$}; - - # Remove any other PID handles - $self->{+_FH} = {}; - - if (my $fh = $self->{+_INIT_FH}) { - $self->{+_FH}->{$$} = $fh; - } - else { - $self->{+_FH}->{$$} = Test2::Harness::Util::maybe_open_file($self->{+NAME}) or return undef; - } - - $self->{+_FH}->{$$}->blocking(0); - return $self->{+_FH}->{$$}; -} - -sub read_line { - my $self = shift; - my %params = @_; - - my $pos = $params{from}; - $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; - - my $fh = $self->{+_FH}->{$$} || $self->fh or return undef; - seek($fh,$pos,SEEK_SET) or die "Could not seek: $!" - if eof($fh) || tell($fh) != $pos; - - my $line = <$fh>; - - # No line, nothing to do - return unless defined $line && length($line); - - # Partial line, hold off unless done - return unless $self->{+DONE} || substr($line, -1, 1) eq "\n"; - - my $new_pos = tell($fh); - die "Failed to 'tell': $!" if $new_pos == -1; - - my $err = 0; - local $@; - unless (eval { $line = $self->decode($line); 1 }) { - $err = $@ // 'error'; - confess "$self->{+NAME} ($pos -> $new_pos): $err" unless $self->{+SKIP_BAD_DECODE}; - warn "Skipping line that failed to decode: $err\n" if $self->{+SKIP_BAD_DECODE} > 1; - $line = undef; - } - - $self->{+LINE_POS} = $new_pos unless defined $params{peek} || defined $params{from}; - return $line unless wantarray; - return ($pos, $new_pos, $line, $err); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Util::File - Utility class for manipulating a file. - -=head1 DESCRIPTION - -This is a utility class for file operations. This also serves as a base class -for several file helpers. - -=head1 SYNOPSIS - - use Test2::Harness::Util::File; - - my $f = Test2::Harness::Util::File->new(name => '/path/to/file'); - - $f->write($content); - - my $fh = $f->open_file('<'); - - # Read, throw exception if it cannot read - my $content = $f->read(); - - # Try to read, but do not throw an exception if it cannot be read. - my $content_or_undef = $f->maybe_read(); - - my $line1 = $f->read_line(); - my $line2 = $f->read_line(); - ... - -=head1 ATTRIBUTES - -=over 4 - -=item $filename = $f->name; - -Get the filename. Must also be provided during construction. - -=item $bool = $f->done; - -True if read_line() has read every line. - -=back - -=head1 METHODS - -=over 4 - -=item $decoded = $f->decode($encoded) - -This is a no-op, it returns the argument unchanged. This is called by C -and C. Subclasses can override this if the file contains encoded -data. - -=item $encoded = $f->encode($decoded) - -This is a no-op, it returns the argument unchanged. This is called by C. -Subclasses can override this if the file contains encoded data. - -=item $bool = $f->exists() - -Check if the file exists - -=item $content = $f->maybe_read() - -This will read the file if it can and return the content (all lines joined -together as a single string). If the file cannot be read, or does not exist -this will return undef. - -=item $fh = $f->open_file() - -=item $fh = $f->open_file($mode) - -Open a handle to the file. If no $mode is provided C<< '<' >> is used. - -=item $content = $f->read() - -This will read the file if it can and return the content (all lines joined -together as a single string). If the file cannot be read, or does not exist -this will throw an exception. - -=item $line = $f->read_line() - -Read a single line from the file, subsequent calls will read the next line and -so on until the end of the file is reached. Reset with the C method. - -=item $f->reset() - -Reset the internal line iterator used by C. - -=item $f->write($content) - -This is an atomic-write. First $content will be written to a temporary file -using C<< '>' >> mode. Then the temporary file will be renamed to the desired -file name. Under the hood this uses C from -L. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Util/File/JSON.pm b/lib/Test2/Harness/Util/File/JSON.pm deleted file mode 100644 index f3f6c5a1e..000000000 --- a/lib/Test2/Harness/Util/File/JSON.pm +++ /dev/null @@ -1,91 +0,0 @@ -package Test2::Harness::Util::File::JSON; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Carp qw/croak confess/; -use Test2::Harness::Util::JSON qw/encode_json decode_json encode_pretty_json/; - -use parent 'Test2::Harness::Util::File'; -use Test2::Harness::Util::HashBase qw/pretty/; - -sub decode { shift; decode_json(@_) } -sub encode { shift->pretty ? encode_pretty_json(@_) : encode_json(@_) } - -sub reset { croak "line reading is disabled for json files" } -sub read_line { croak "line reading is disabled for json files" } - -sub maybe_read { - my $self = shift; - - return undef unless -e $self->{+NAME}; - my $out = Test2::Harness::Util::read_file($self->{+NAME}); - - return undef unless defined($out) && length($out); - - eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; - return $out; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Util::File::JSON - Utility class for a JSON file. - -=head1 DESCRIPTION - -Subclass of L which automatically handles -encoding/decoding JSON data. - -=head1 SYNOPSIS - - require Test2::Harness::Util::File::JSON; - my $file = Test2::Harness::Util::File::JSON->new(name => '/path/to/file.json'); - - $hash = $file->read; - # or - $$file->write({...}); - -=head1 SEE ALSO - -See the base class L for methods. - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Util/File/JSONL.pm b/lib/Test2/Harness/Util/File/JSONL.pm deleted file mode 100644 index ce64c51b3..000000000 --- a/lib/Test2/Harness/Util/File/JSONL.pm +++ /dev/null @@ -1,91 +0,0 @@ -package Test2::Harness::Util::File::JSONL; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Carp qw/croak/; -use Test2::Harness::Util::JSON qw/encode_json decode_json/; - -use parent 'Test2::Harness::Util::File::Stream'; -use Test2::Harness::Util::HashBase; - -sub decode { shift; decode_json($_[0]) } -sub encode { shift; encode_json(@_) . "\n" } - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Util::File::JSONL - Utility class for a JSONL file (stream) - -=head1 DESCRIPTION - -Subclass of L and -L which automatically handles -encoding/decoding JSONL data. - -=head1 SYNOPSIS - - use Test2::Harness::Util::File::JSONL; - - my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); - - while (1) { - my @items = $jsonl->poll(max => 1000) or last; - for my $item (@items) { - ... handle $item ... - } - } - -or - - use Test2::Harness::Util::File::JSONL; - - my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); - - $jsonl->write({my => 'item', ... }); - ... - -=head1 SEE ALSO - -See the base classes L and -L for methods. - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Util/File/Stream.pm b/lib/Test2/Harness/Util/File/Stream.pm deleted file mode 100644 index d9dece480..000000000 --- a/lib/Test2/Harness/Util/File/Stream.pm +++ /dev/null @@ -1,207 +0,0 @@ -package Test2::Harness::Util::File::Stream; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Carp qw/croak/; -use Test2::Harness::Util qw/lock_file unlock_file/; -use Fcntl qw/SEEK_SET/; - -use parent 'Test2::Harness::Util::File'; -use Test2::Harness::Util::HashBase qw/use_write_lock -tail/; - -sub init { - my $self = shift; - - $self->SUPER::init(); - - my $tail = $self->{+TAIL} or return; - - return unless $self->exists; - - my @lines = $self->poll_with_index; - if (@lines < $self->{+TAIL}) { - $self->seek(0); - } - else { - $self->seek($lines[0 - $tail]->[0]); - } -} - -sub poll_with_index { - my $self = shift; - my %params = @_; - - my $max = delete $params{max} || 0; - - my $pos = $params{from}; - $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; - - my @out; - while (!$max || @out < $max) { - my ($spos, $epos, $line, $err) = $self->read_line(%params, from => $pos); - last unless defined($line) || defined($spos) || defined($epos) || $err; - - $self->{+LINE_POS} = $epos unless $params{peek} || defined $params{from}; - push @out => [$spos, $epos, $line] unless $err; - $pos = $epos; - } - - return @out; -} - -sub read { - my $self = shift; - - return $self->poll(from => 0); -} - -sub poll { - my $self = shift; - my @lines = $self->poll_with_index(@_); - return map { $_->[-1] } @lines; -} - -sub write { - my $self = shift; - - my $name = $self->{+NAME}; - - my $fh; - if ($self->{+USE_WRITE_LOCK}) { - $fh = lock_file($self->name, '>>'); - } - else { - $fh = Test2::Harness::Util::open_file($self->name, '>>'); - } - - $fh->autoflush(1); - seek($fh,2,0); - print {$fh} $self->encode($_) for @_; - - unlock_file($fh) if $self->{+USE_WRITE_LOCK}; - - close($fh) or die "Could not close file '$name': $!"; - - return @_; -} - -sub seek { - my $self = shift; - my ($pos) = @_; - - my $fh = $self->fh; - my $name = $self->{+NAME}; - - seek($fh, $pos, SEEK_SET) or die "Could not seek to position $pos in file '$name': $!"; - $self->{+LINE_POS} = $pos; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Util::File::Stream - Utility class for manipulating a file that -serves as an output stream. - -=head1 DESCRIPTION - -Subclass of L that streams the contents of a file, even -if the file is still being written. - -=head1 SYNOPSIS - - use Test2::Harness::Util::File::Stream; - - my $stream = Test2::Harness::Util::File::Stream->new(name => 'path/to/file'); - - # Read some lines - my @lines = $stream->poll; - - ... - - # Read more lines, if any. - push @lines => $stream->poll; - -=head1 ATTRIBUTES - -See L for additional attributes. - -These can be passed in as construction arguments if desired. - -=over 4 - -=item $bool = $stream->use_write_lock - -=item $stream->use_write_lock($bool) - -Lock the file for every C operation. - -=item $bool = $stream->tail - -Start near the end of the file and only poll for updates appended to it. - -=back - -=head1 METHODS - -See L for additional methods. - -=over 4 - -=item @lines = $stream->read() - -Read all lines from the beginning. Every time it is called it returns ALL lines. - -=item @lines = $stream->poll() - -=item @lines = $stream->poll(max => $int) - -Poll for lines. This is an iterator, it should not return the same line more -than once, you can call it multiple times to get any additional lines that have -been added since the last poll. - -=item $stream->write(@content) - -Append @content to the file. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Util/File/Value.pm b/lib/Test2/Harness/Util/File/Value.pm deleted file mode 100644 index bf291ba5b..000000000 --- a/lib/Test2/Harness/Util/File/Value.pm +++ /dev/null @@ -1,100 +0,0 @@ -package Test2::Harness::Util::File::Value; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use parent 'Test2::Harness::Util::File'; -use Test2::Harness::Util::HashBase; - -sub init { - my $self = shift; - $self->{+DONE} = 1; -} - -sub read { - my $self = shift; - my $out = $self->SUPER::read(@_); - chomp($out) if defined $out; - return $out; -} - -sub read_line { - my $self = shift; - my $out = $self->SUPER::read_line(@_); - chomp($out) if defined $out; - return $out; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Util::File::Value - Utility class for a file that contains -exactly 1 value. - -=head1 DESCRIPTION - -This is a subclass of L for files expected to have -exactly 1 value stored in them. - -=head1 SYNOPSIS - - use Test2::Harness::Util::File::Value; - - my $vf = Test2::Harness::Util::File::Value->new(name => 'path/to/file'); - my $val = $vf->read; - -=head1 METHODS - -=over 4 - -=item $val = $vf->read() - -Read all contents from the file, C it, and return it. - -=item $val = $vf->read_line() - -Read the first line from the file, C it, and return it. Note, this -may not return anything if the value in the file does not terminate with a -newline. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Util/HashBase.pm b/lib/Test2/Harness/Util/HashBase.pm index 0146e1c7c..f5d2a6b59 100644 --- a/lib/Test2/Harness/Util/HashBase.pm +++ b/lib/Test2/Harness/Util/HashBase.pm @@ -2,7 +2,7 @@ package Test2::Harness::Util::HashBase; use strict; use warnings; -our $VERSION = '1.000152'; +our $VERSION = '0.010'; ################################################################# # # @@ -16,7 +16,7 @@ our $VERSION = '1.000152'; { no warnings 'once'; - $Test2::Harness::Util::HashBase::HB_VERSION = '0.008'; + $Test2::Harness::Util::HashBase::HB_VERSION = '0.010'; *Test2::Harness::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; *Test2::Harness::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; *Test2::Harness::Util::HashBase::VERSION = \%Object::HashBase::VERSION; @@ -52,9 +52,17 @@ my %SPEC = ( '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, ); +sub spec { \%SPEC } + sub import { my $class = shift; my $into = caller; + $class->do_import($into, @_); +} + +sub do_import { + my $class = shift; + my $into = shift; # Make sure we list the OLDEST version used to create this class. my $ver = $Test2::Harness::Util::HashBase::HB_VERSION || $Test2::Harness::Util::HashBase::VERSION; @@ -65,34 +73,49 @@ sub import { my $attr_subs = $Test2::Harness::Util::HashBase::ATTR_SUBS{$into} ||= {}; my %subs = ( - ($into->can('new') ? () : (new => \&_new)), + ($into->can('new') ? () : (new => $class->can('_new'))), (map %{$Test2::Harness::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), - ( - map { - my $p = substr($_, 0, 1); - my $x = $_; + ($class->args_to_subs($attr_list, $attr_subs, \@_)), + ); - my $spec = $SPEC{$p} || {reader => 1, writer => 1}; + no strict 'refs'; + *{"$into\::$_"} = $subs{$_} for keys %subs; +} - substr($x, 0, 1) = '' if $spec->{strip}; - push @$attr_list => $x; - my ($sub, $attr) = (uc $x, $x); +sub args_to_subs { + my $class = shift; + my ($attr_list, $attr_subs, $args) = @_; - $attr_subs->{$sub} = sub() { $attr }; - my %out = ($sub => $attr_subs->{$sub}); + my $use_gen = $class->can('gen_accessor') ; - $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader}; - $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; - $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; - $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; + my %out; - %out; - } @_ - ), - ); + while (@$args) { + my $x = shift @$args; + my $p = substr($x, 0, 1); - no strict 'refs'; - *{"$into\::$_"} = $subs{$_} for keys %subs; + my $spec = $class->spec->{$p} || {reader => 1, writer => 1}; + substr($x, 0, 1) = '' if $spec->{strip}; + + push @$attr_list => $x; + my ($sub, $attr) = (uc $x, $x); + + $attr_subs->{$sub} = sub() { $attr }; + $out{$sub} = $attr_subs->{$sub}; + + my $copy = "$attr"; + $out{$attr} = $use_gen ? $class->gen_accessor(reader => $copy, $spec, $args) : sub { $_[0]->{$attr} } if $spec->{reader}; + $out{"set_$attr"} = $use_gen ? $class->gen_accessor(writer => $copy, $spec, $args) : sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; + $out{"set_$attr"} = $use_gen ? $class->gen_accessor(read_only => $copy, $spec, $args) : sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; + $out{"set_$attr"} = $use_gen ? $class->gen_accessor(dep_writer => $copy, $spec, $args) : sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; + + if ($spec->{custom}) { + my %add = $class->gen_accessor(custom => $copy, $spec, $args); + $out{$_} = $add{$_} for keys %add; + } + } + + return %out; } sub attr_list { diff --git a/lib/Test2/Harness/Util/JSON.pm b/lib/Test2/Harness/Util/JSON.pm index 2c73ec443..0bc504c38 100644 --- a/lib/Test2/Harness/Util/JSON.pm +++ b/lib/Test2/Harness/Util/JSON.pm @@ -2,262 +2,23 @@ package Test2::Harness::Util::JSON; use strict; use warnings; -use Carp qw/croak/; +use Carp qw/confess longmess/; +use Cpanel::JSON::XS(); +use Importer Importer => 'import'; -our $VERSION = '1.000152'; +our $VERSION = '2.000000'; -BEGIN { - local $@ = undef; - my $ok = eval { - require JSON::MaybeXS; - JSON::MaybeXS->import('JSON'); - 1; +our @EXPORT = qw{encode_json decode_json encode_ascii_json encode_pretty_json encode_canon_json}; - if (JSON() eq 'JSON::PP') { - *JSON_IS_PP = sub() { 1 }; - *JSON_IS_XS = sub() { 0 }; - *JSON_IS_CPANEL = sub() { 0 }; - *JSON_IS_CPANEL_OR_XS = sub() { 0 }; - } - elsif (JSON() eq 'JSON::XS') { - *JSON_IS_PP = sub() { 0 }; - *JSON_IS_XS = sub() { 1 }; - *JSON_IS_CPANEL = sub() { 0 }; - *JSON_IS_CPANEL_OR_XS = sub() { 1 }; - } - elsif (JSON() eq 'Cpanel::JSON::XS') { - *JSON_IS_PP = sub() { 0 }; - *JSON_IS_XS = sub() { 0 }; - *JSON_IS_CPANEL = sub() { 1 }; - *JSON_IS_CPANEL_OR_XS = sub() { 1 }; - } - }; +my $json = Cpanel::JSON::XS->new->utf8(1)->convert_blessed(1)->allow_nonref(1); +my $ascii = Cpanel::JSON::XS->new->ascii(1)->convert_blessed(1)->allow_nonref(1); +my $canon = Cpanel::JSON::XS->new->utf8(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); +my $pretty = Cpanel::JSON::XS->new->utf8(1)->pretty(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); - unless ($ok) { - require JSON::PP; - *JSON = sub() { 'JSON::PP' }; - - *JSON_IS_PP = sub() { 1 }; - *JSON_IS_XS = sub() { 0 }; - *JSON_IS_CPANEL = sub() { 0 }; - *JSON_IS_CPANEL_OR_XS = sub() { 0 }; - } - -} - -our @EXPORT = qw{JSON encode_json decode_json encode_pretty_json encode_canon_json stream_json_l stream_json_l_file stream_json_l_url}; -our @EXPORT_OK = qw{JSON_IS_PP JSON_IS_XS JSON_IS_CPANEL JSON_IS_CPANEL_OR_XS}; - -BEGIN { require Exporter; our @ISA = qw(Exporter) } - -my $json = JSON->new->utf8(1)->convert_blessed(1)->allow_nonref(1); -my $json_non_utf8 = JSON->new->utf8(0)->convert_blessed(1)->allow_nonref(1); -my $canon = JSON->new->utf8(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); -my $pretty = JSON->new->utf8(1)->pretty(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); - -sub encode_json { $json->encode(@_) } -sub encode_canon_json { $canon->encode(@_) } -sub encode_pretty_json { $pretty->encode(@_) } - -sub decode_json { - my ($input) = @_; - my $data; - - local $@; - my $error; - - # Try to decode the JSON stream as utf8. In malformed tests or tests which are intentionally - # testing bytes behavior we need to accept the bytes from the JSON file instead. - my $ok = eval { $data = $json->decode($input); 1 } || do { - $error = $@; - eval { $data = $json_non_utf8->decode($input); 1 }; - }; - $error ||= $@; - return $data if $ok; - my $mess = Carp::longmess("JSON decode error: $error"); - die "$mess\n=======\n$input\n=======\n"; -} - -sub stream_json_l { - my ($path, $handler, %params) = @_; - - croak "No path provided" unless $path; - - return stream_json_l_file($path, $handler) if -f $path; - return stream_json_l_url($path, $handler, %params) if $path =~ m{^https?://}; - - croak "'$path' is not a valid path (file does not exist, or is not an http(s) url)"; -} - -sub stream_json_l_file { - my ($path, $handler) = @_; - - croak "Invalid file '$path'" unless -f $path; - - croak "Path must have a .json or .jsonl extension with optional .gz or .bz2 postfix." - unless $path =~ m/\.(json(?:l)?)(?:.(?:bz2|gz))?$/; - - if ($1 eq 'json') { - require Test2::Harness::Util::File::JSON; - my $json = Test2::Harness::Util::File::JSON->new(name => $path); - $handler->($json->read); - } - else { - require Test2::Harness::Util::File::JSONL; - my $jsonl = Test2::Harness::Util::File::JSONL->new(name => $path); - while (my ($item) = $jsonl->poll(max => 1)) { - $handler->($item); - } - } - - return 1; -} - -sub stream_json_l_url { - my ($path, $handler, %params) = @_; - my $meth = $params{http_method} // 'get'; - my $args = $params{http_args} // []; - - require HTTP::Tiny; - my $ht = HTTP::Tiny->new(); - - my $buffer = ''; - my $iterate = sub { - my ($res) = @_; - - my @parts = split /(\n)/, $buffer; - - while (@parts > 1) { - my $line = shift @parts; - my $nl = shift @parts; - my $data; - unless (eval { $data = decode_json($line); 1 }) { - warn "Unable to decode json for chunk when parsing json/l chunk:\n----\n$line\n----\n$@\n----\n"; - next; - } - - $handler->($data, $res); - } - - $buffer = shift @parts // ''; - }; - - my $res = $ht->$meth( - $path, - { - @$args, - data_callback => sub { - my ($chunk, $res) = @_; - $buffer .= $chunk; - $iterate->($res); - }, - } - ); - - if (length($buffer)) { - $buffer .= "\n" unless $buffer =~ m/\n$/; - $iterate->($res); - } - - return $res; -} +sub decode_json { my $out; eval { $out = $json->decode(@_); 1} // confess($@); $out } +sub encode_json { my $out; eval { $out = $json->encode(@_); 1} // confess($@); $out } +sub encode_ascii_json { my $out; eval { $out = $ascii->encode(@_); 1} // confess($@); $out } +sub encode_canon_json { my $out; eval { $out = $canon->encode(@_); 1} // confess($@); $out } +sub encode_pretty_json { my $out; eval { $out = $pretty->encode(@_); 1} // confess($@); $out } 1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Util::JSON - Utility class to help Test2::Harness pick the best -JSON implementation. - -=head1 DESCRIPTION - -This package provides functions for encoding/decoding json, and uses the best -json tools available. - -=head1 SYNOPSIS - - use Test2::Harness::Util::JSON qw/encode_json decode_json/; - - my $data = { foo => 1 }; - my $json = encode_json($data); - my $copy = decode_json($json); - -=head1 EXPORTS - -=over 4 - -=item $package = JSON() - -This returns the JSON package being used by yath. - -=item $bool = JSON_IS_PP() - -True if yath is using L. - -=item $bool = JSON_IS_XS() - -True if yath is using L. - -=item $bool = JSON_IS_CPANEL() - -True if yath is using L. - -=item $bool = JSON_IS_CPANEL_OR_XS() - -True if either L or L are being used. - -=item $string = encode_json($data) - -Encode data into json. String will be 1-line. - -=item $data = decode_json($string) - -Decode json data from the string. - -=item $string = encode_pretty_json($data) - -Encode into human-friendly json. - -=item $string = encode_canon_json($data) - -Encode into canon-json. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Util/LogFile.pm b/lib/Test2/Harness/Util/LogFile.pm new file mode 100644 index 000000000..0765b822e --- /dev/null +++ b/lib/Test2/Harness/Util/LogFile.pm @@ -0,0 +1,73 @@ +package Test2::Harness::Util::LogFile; +use strict; +use warnings; + +use Carp qw/croak/; + +use Test2::Harness::Util::JSON qw/decode_json/; + +use Test2::Harness::Event; + +use Test2::Harness::Util::HashBase qw{ + {+CLIENT}) { + $self->{+NAME} //= $client->send_and_get('log_file'); + } + + my $file = $self->{+NAME} // croak "'name' is a required attribute unless 'client' is specified"; + croak "'$file' is not a valid log file" unless -f $file; + + open(my $fh, '<', $file) or croak "Could not open log file '$file' for reading: $!"; + $fh->blocking(0); + $self->{+FH} = $fh; + + $self->{+OLD_SIZE} = 0; + + $self->{+BUFFER} = ""; +} + +sub poll { + my $self = shift; + + my $log_file = $self->{+NAME}; + + my $fh = $self->{+FH}; + + my @out; + + my $new_size = -s $log_file; + + if ($new_size != $self->{+OLD_SIZE}) { + $self->{+OLD_SIZE} = $new_size; + seek($fh, 0, 1); + + while (my $line = <$fh>) { + if (chomp($line)) { + if (my $b = $self->{+BUFFER}) { + $line = $b . $line; + $self->{+BUFFER} = ''; + } + + my $event = decode_json($line); + push @out => Test2::Harness::Event->new(%$event); + } + else { + $self->{+BUFFER} .= $line; + } + } + } + + return @out; +} + +1; + diff --git a/lib/Test2/Harness/Util/Minimal.pm b/lib/Test2/Harness/Util/Minimal.pm new file mode 100644 index 000000000..906e6f580 --- /dev/null +++ b/lib/Test2/Harness/Util/Minimal.pm @@ -0,0 +1,102 @@ +package Test2::Harness::Util::Minimal; +use strict; +use warnings; + +############################################################################### +# # +# !!!!!!!! READ THIS FIRST !!!!!!!! # +# # +# This file needs to load as little as possible. This is used to process some # +# initial config files and arguments. These may add paths to @INC. Anything # +# we load here will be loaded before the @INC changes! # +# # +############################################################################### + +# Core, not likely to be overriden in a project lib directory, +# and if they are, oh well, we need them. +use File::Spec; +use Cwd qw/realpath/; +BEGIN { require Exporter; push @Test2::Harness::Util::Minimal::ISA => 'Exporter' } + +our @EXPORT = qw/clean_path find_in_updir pre_process_args scan_config/; + +sub clean_path { + my ( $path, $absolute ) = @_; + + $absolute //= 1; + $path = realpath($path) // $path if $absolute; + + return File::Spec->rel2abs($path); +} + +sub find_in_updir { + my $path = shift; + return clean_path($path) if -f $path; + + my %seen; + while(1) { + $path = File::Spec->catdir('..', $path); + my $check = eval { realpath(File::Spec->rel2abs($path)) }; + last unless $check; + last if $seen{$check}++; + return $check if -f $check; + } + + return; +} + +sub scan_config { + my ($file) = @_; + + my ($vol, $dir) = File::Spec->splitpath(clean_path($file)); + my $reldir = File::Spec->catpath($vol, $dir); + + my @out; + + open(my $fh, '<', $file) or die "Could not open config file '$file': $!"; + while (my $line = <$fh>) { + chomp($line); + + # Only scan the global top section + last if $line =~ /^\[/; + + next unless $line =~ m/^(-D|--dev-lib)(?:(=)?(.+))?$/; + my ($arg, $eq, $val) = ($1, $2, $3); + $eq //= ''; + + if ($val =~ m/^(relglob|rel|glob)\((.+)\)$/) { + my ($op, $v) = ($1, $2); + $val = File::Spec->catfile($reldir, $v) if $op =~ m/rel/; + + if ($op =~ m/glob/) { + push @out => map { "${arg}${eq}${_}" } glob($val); + last; + } + } + + push @out => "${arg}${eq}${val}"; + } + + return \@out; +} + +sub pre_process_args { + my ($args) = @_; + + my $defaults = 0; + my @add_paths; + for my $arg (@$args) { + next unless $arg =~ m/^(?:-D|--dev-lib)(?:=?(.+))?$/; + if ($1) { push @add_paths => clean_path($1) ; next}; + next if $defaults++; + push @add_paths => map { clean_path($_) } 'lib', 'blib/lib', 'blib/arch'; + } + + my %seen; + unshift @INC => grep { !$seen{$_}++ } @add_paths; + + return @add_paths +} + + +1; diff --git a/lib/Test2/Harness/Util/Queue.pm b/lib/Test2/Harness/Util/Queue.pm deleted file mode 100644 index efe7289b3..000000000 --- a/lib/Test2/Harness/Util/Queue.pm +++ /dev/null @@ -1,213 +0,0 @@ -package Test2::Harness::Util::Queue; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Carp qw/croak/; -use Time::HiRes qw/time/; -use Test2::Harness::Util qw/write_file_atomic/; - -use Test2::Harness::Util::File::JSONL(); - -use Test2::Harness::Util::HashBase qw{ - -file -qh -ended -}; - -sub init { - my $self = shift; - - croak "'file' is a required attribute" - unless $self->{+FILE}; -} - -sub start { - my $self = shift; - write_file_atomic($self->{+FILE}, ""); -} - -sub seek { - my $self = shift; - my ($pos) = @_; - - $self->{+QH} ||= Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}); - $self->{+QH}->seek($pos); - - return $pos; -} - -sub reset { - my $self = shift; - delete $self->{+QH}; -} - -sub poll { - my $self = shift; - my $max = shift; - - return $self->{+ENDED} if $self->{+ENDED}; - - $self->{+QH} ||= Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}); - my @out = $self->{+QH}->poll_with_index( $max ? (max => $max) : () ); - - $self->{+ENDED} = $out[-1] if @out && !defined($out[-1]->[-1]); - - return @out; -} - -sub end { - my $self = shift; - $self->_enqueue(undef); -} - -sub enqueue { - my $self = shift; - my ($task) = @_; - - croak "Invalid task" - unless $task && ref($task) eq 'HASH' && values %$task; - - $task->{stamp} ||= time; - - $self->_enqueue($task); -} - -sub _enqueue { - my $self = shift; - my ($task) = @_; - - my $fh = Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}, use_write_lock => 1); - $fh->write($task); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Util::Queue - Representation of a queue. - -=head1 DESCRIPTION - -This module represents a queue, stored as a jsonl file. - -=head1 SYNOPSIS - - use Test2::Harness::Util::Queue; - - my $queue = Test2::Harness::Util::Queue->new(file => '/path/to/queue.jsonl'); - - $queue->start(); # Create the queue - - $queue->enqueue({foo => 'bar', baz => 'bat'}); - $queue->enqueue({foo => 'bar2', baz => 'bat2'}); - ... - - $queue->end(); - -Then in another processs: - - use Test2::Harness::Util::Queue; - - my $queue = Test2::Harness::Util::Queue->new(file => '/path/to/queue.jsonl'); - - my @items; - while (1) { - @items = $queue->poll(); - while (@items) { - my $item = shift @items or last; - - ... process $item - } - - # Queue ends with an 'undef' entry - last if @items && !defined($items[0]); - } - -=head1 METHODS - -=over 4 - -=item $path = $queue->file - -The filename used for the queue - -=back - -=head2 READING - -=over 4 - -=item $queue->reset() - -Restart reading the queue. - -=item @items = $queue->poll() - -Get more items from the queue. May need to call it multiple times, specially if -another process is still writing to the queue. - -Returns an empty list if no items are available yet. - -Returns 'undef' to terminate the list. - -=item $bool = $queue->ended() - -Check if the queue has ended. - -=back - -=head1 WRITING - -=over 4 - -=item $queue->start() - -Open the queue file for writing. - -=item $queue->enqueue(\%HASHREF) - -Add an item to the queue. - -=item $queue->end() - -Terminate the queue. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Util/Term.pm b/lib/Test2/Harness/Util/Term.pm deleted file mode 100644 index da0b6a306..000000000 --- a/lib/Test2/Harness/Util/Term.pm +++ /dev/null @@ -1,104 +0,0 @@ -package Test2::Harness::Util::Term; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Test2::Util qw/IS_WIN32/; - -use Importer Importer => 'import'; -our @EXPORT_OK = qw/USE_ANSI_COLOR/; - -{ - my $use = 0; - local ($@, $!); - - if (eval { require Term::ANSIColor; Term::ANSIColor->VERSION('4.03') }) { - if (IS_WIN32) { - if (eval { require Win32::Console::ANSI }) { - Win32::Console::ANSI->import(); - $use = 1; - } - } - else { - $use = 1; - } - } - - if ($use) { - *USE_ANSI_COLOR = sub() { 1 }; - } - else { - *USE_ANSI_COLOR = sub() { 0 }; - } -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Util::Term - Terminal utilities for Test2::Harness - -=head1 DESCRIPTION - -This module provides information about the terminal in which the harness is -running. - -=head1 SYNOPSIS - - use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; - - if (USE_ANSI_COLOR) { - ... - } - else { - ... - } - -=head1 EXPORTS - -=over 4 - -=item $bool = USE_ANSI_COLOR() - -True if L is available and usable. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut