From 4875f4aecd662c0b8ebcf50f6f42fd9915df50aa Mon Sep 17 00:00:00 2001 From: Chris White Date: Sun, 26 May 2019 13:43:41 -0400 Subject: [PATCH] Code and test updates Code changes (in package order): - Data::Hopen::hnew(): provide more accurate error messages. - Data::Hopen::loadfrom(): no longer require a list of stems. - Data::Hopen::G::DAG: pass the node inputs to visit_{node,goal}; change some exception text - Data::Hopen::G::Entity: custom stringification for easier debugging - Added Data::Hopen::G::NoOp - !!! >>> Data::Hopen::Scope: when merging predecessor-node outputs into successor-node inputs, DO NOT CLONE. This way blessed references can be successfully passed between nodes. <<< !!! - Data::Hopen::Util::NameSet: Tweaked code so 100% coverage is achievable. - Added Data::Hopen::Visitor - Updated documentation Test changes: - Added t/lib/PackagesInThisFile, which is a crazy way of doing subtests, each in its own package. WIP: a way to merge hashes, cloning non-blessed references but not references. --- Changes | 3 + MANIFEST | 19 ++- MANIFEST.SKIP | 4 + Makefile.PL | 9 +- lib/Data/Hopen.pm | 59 +++++-- lib/Data/Hopen/Base.pm | 6 +- lib/Data/Hopen/G.pod | 5 + lib/Data/Hopen/G/CollectOp.pm | 4 +- lib/Data/Hopen/G/DAG.pm | 19 ++- lib/Data/Hopen/G/Entity.pm | 38 ++++- lib/Data/Hopen/G/Goal.pm | 2 +- lib/Data/Hopen/G/GraphBuilder.pm | 25 +-- lib/Data/Hopen/G/Link.pm | 2 +- lib/Data/Hopen/G/NoOp.pm | 40 +++++ lib/Data/Hopen/G/Node.pm | 5 +- lib/Data/Hopen/G/Op.pm | 12 +- lib/Data/Hopen/G/OutputOp.pm | 2 +- lib/Data/Hopen/G/Runnable.pm | 22 ++- lib/Data/Hopen/OrderedPredecessorGraph.pm | 2 +- lib/Data/Hopen/Scope.pm | 10 +- lib/Data/Hopen/Scope/Environment.pm | 5 +- lib/Data/Hopen/Scope/Hash.pm | 2 +- lib/Data/Hopen/Scope/Inputs.pm | 2 +- lib/Data/Hopen/Scope/Overrides.pm | 2 +- lib/Data/Hopen/TEMPLATE.pm | 2 +- lib/Data/Hopen/Util/Data.pm | 2 +- lib/Data/Hopen/Util/Filename.pm | 2 +- .../Hopen/Util/MergeWithoutCloneBlessed.pm | 89 ++++++++++ lib/Data/Hopen/Util/NameSet.pm | 22 ++- lib/Data/Hopen/Visitor.pm | 44 +++++ t/001-entity.t | 14 +- t/003-node.t | 6 +- t/004-goal.t | 40 ++++- t/005-merge-without-clone-blessed.NOTYET | 43 +++++ t/008-nameset.t | 52 ++++-- t/020-dag.t | 32 ---- t/{005-op.t => 100-op.t} | 0 t/{006-collect-op.t => 101-collect-op.t} | 0 t/120-dag.t | 119 +++++++++++++ ...ag-single-goal.t => 121-dag-single-goal.t} | 0 t/{022-dag-visitor.t => 122-dag-visitor.t} | 0 t/{023-dag-warnings.t => 123-dag-warnings.t} | 0 ...e-inputs.t => 124-dag-merge-node-inputs.t} | 0 t/998-sig-die.t | 41 +++++ t/999-extras-for-coverage.t | 158 ++++++++++++++++++ t/lib/PackagesInThisFile.pm | 56 +++++++ 46 files changed, 877 insertions(+), 144 deletions(-) create mode 100755 lib/Data/Hopen/G/NoOp.pm create mode 100755 lib/Data/Hopen/Util/MergeWithoutCloneBlessed.pm create mode 100755 lib/Data/Hopen/Visitor.pm create mode 100644 t/005-merge-without-clone-blessed.NOTYET delete mode 100644 t/020-dag.t rename t/{005-op.t => 100-op.t} (100%) rename t/{006-collect-op.t => 101-collect-op.t} (100%) create mode 100644 t/120-dag.t rename t/{021-dag-single-goal.t => 121-dag-single-goal.t} (100%) rename t/{022-dag-visitor.t => 122-dag-visitor.t} (100%) rename t/{023-dag-warnings.t => 123-dag-warnings.t} (100%) rename t/{024-dag-merge-node-inputs.t => 124-dag-merge-node-inputs.t} (100%) create mode 100755 t/998-sig-die.t create mode 100755 t/999-extras-for-coverage.t create mode 100644 t/lib/PackagesInThisFile.pm diff --git a/Changes b/Changes index 5fe4c2f..b4e3c2c 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ Revision history for Data-Hopen +0.000013 2019-05-26 + Functional changes throughout + 0.000012 2019-02-28 No changes - stable release of 0.000011 diff --git a/MANIFEST b/MANIFEST index f4c10a8..1ed28b0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -10,6 +10,7 @@ lib/Data/Hopen/G/Goal.pm lib/Data/Hopen/G/GraphBuilder.pm lib/Data/Hopen/G/Link.pm lib/Data/Hopen/G/Node.pm +lib/Data/Hopen/G/NoOp.pm lib/Data/Hopen/G/Op.pm lib/Data/Hopen/G/OutputOp.pm lib/Data/Hopen/G/Runnable.pm @@ -22,6 +23,7 @@ lib/Data/Hopen/Scope/Overrides.pm lib/Data/Hopen/Util/Data.pm lib/Data/Hopen/Util/Filename.pm lib/Data/Hopen/Util/NameSet.pm +lib/Data/Hopen/Visitor.pm LICENSE.md Makefile.PL MANIFEST This list of files @@ -34,24 +36,27 @@ t/001-entity.t t/002-link.t t/003-node.t t/004-goal.t -t/005-op.t -t/006-collect-op.t t/007-hnew.t t/008-nameset.t t/009-hopen-constants.t t/010-scope-hash.t t/011-scope-env.t t/012-scope-nested.t -t/020-dag.t -t/021-dag-single-goal.t -t/022-dag-visitor.t -t/023-dag-warnings.t -t/024-dag-merge-node-inputs.t t/030-ordered_pred.t +t/100-op.t +t/101-collect-op.t +t/120-dag.t +t/121-dag-single-goal.t +t/122-dag-visitor.t +t/123-dag-warnings.t +t/124-dag-merge-node-inputs.t +t/998-sig-die.t +t/999-extras-for-coverage.t t/dir200/inner.hopen.pl t/dir200/inner/.hopen.pl t/dir200/inner/z.hopen.pl t/lib/HopenTest.pm +t/lib/PackagesInThisFile.pm xt/boilerplate.t xt/manifest.t xt/pod-coverage.t diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 43813bf..32252d6 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -1,3 +1,7 @@ +# WIP files +^lib.Data.Hopen.Util.MergeWithoutCloneBlessed\.pm +^t.005-merge-without-clone-blessed\.NOTYET + # Miscellaneous ^\.editorconfig ^\.[^\\\/]*\.yml diff --git a/Makefile.PL b/Makefile.PL index 03610aa..6022246 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -173,13 +173,18 @@ my %opts = ( 'Pod::Text' => '0', # pod2text }, TEST_REQUIRES => { + 'Capture::Tiny' => '0', 'Carp' => '0', 'Exporter' => '0', 'Import::Into' => '0', + 'List::AutoNumbered' => '0.000006', + 'Quote::Code' => '1.0102', 'rlib' => '0', 'Scalar::Util' => '0', - 'Test::Deep' => '0.084', # for superhashof + 'Sub::Identify' => '0.14', + 'Test::Deep' => '0.098', # for superhashof, Test::Deep::NoTest ## 'Test::Directory' => '0.02', # for subdirs + 'Test::Fatal' => '0.014', 'Test::More' => '0', # Test::TempDir::Tiny? If so, remove Test::Directory dependency? 'Test::Warn' => '0.35', # for metadata @@ -188,6 +193,7 @@ my %opts = ( #'Algorithm::Dependency' => '1.106', # - Probably don't need this; we can use Graph::topological_sort(). + #'base' => '0', # as used by Hash::Merge 'Carp' => '0', 'Class::Method::Modifiers' => '2.10', # most recent code change @@ -200,6 +206,7 @@ my %opts = ( ## 'Class::XPath' => '1.4', + #'Clone::Choose' => '0.008', # as used by Hash::Merge 'Config' => '0', #'Cwd' => '0', diff --git a/lib/Data/Hopen.pm b/lib/Data/Hopen.pm index 7b16427..51a3fb0 100644 --- a/lib/Data/Hopen.pm +++ b/lib/Data/Hopen.pm @@ -24,7 +24,7 @@ use Data::Hopen::Util::NameSet; use Getargs::Mixed; use Storable (); -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; # Docs {{{1 @@ -97,11 +97,27 @@ is the same as Data::Hopen::G::DAG->new( name => 'foo' ); -If the provided name does not include a double-colon, it is first tried after -C. It is then tried in C and as a -complete package name. The first one that succeeds is used. +The first parameter (C<$class>) is an abbreviated package name. It is tried +as the following, in order. The first one that succeeds is used. -The first parameter must be a part of a class name, and the second parameter +=over + +=item 1. + +C. This is tried only if C<$class> +does not include a double-colon. + +=item 2. + +C + +=item 3. + +C<$class> + +=back + +The second parameter must be the name of the new instance. All other parameters are passed unchanged to the relevant constructor. @@ -112,16 +128,22 @@ sub hnew { my @stems = ('Data::Hopen::G::', 'Data::Hopen::', ''); shift @stems if $class =~ /::/; + my $found_class = false; + foreach my $stem (@stems) { - my $instance = eval { - eval "require $stem$class"; - "$stem$class"->new('name', @_) - # put 'name' in front of the name parameter. - }; + eval "require $stem$class"; + next if $@; + $found_class = "$stem$class"; + my $instance = "$found_class"->new('name', @_); + # put 'name' in front of the name parameter. return $instance if $instance; } - croak "Could not find class for $class"; + if($found_class) { + croak "Could not create instance for $found_class"; + } else { + croak "Could not find class for $class"; + } } #hnew() =head2 loadfrom @@ -131,13 +153,14 @@ sub hnew { my $fullname = loadfrom($name[, @stems]); Returns the full name of the loaded package, or falsy on failure. +If C<@stems> is omitted, no stem is used, i.e., C<$name> is tried as-is. =cut sub loadfrom { my $class = shift or croak 'Need a class'; - foreach my $stem (@_) { + foreach my $stem (@_, '') { eval "require $stem$class"; return "$stem$class" unless $@; } @@ -157,10 +180,15 @@ Each line is prefixed with C<'# '> for the benefit of test runs. The list is in C<{}> so that it won't be evaluated if logging is turned off. It is a full block, so you can run arbitrary code to decide what to log. If the block returns an empty list, hlog will not produce any output. +However, if the block returns at least one element, hlog will produce at +least a C<'# '>. The message will be output only if L is at least the given minimum verbosity level (1 by default). +If C<< $VERBOSE > 2 >>, the filename and line from which hlog was called +will also be printed. + =cut sub hlog (&;$) { @@ -172,7 +200,12 @@ sub hlog (&;$) { chomp $log[$#log] if $log[$#log]; # TODO add an option to number the lines of the output - say STDERR (join(' ', @log)) =~ s/^/# /gmr; + my $msg = (join(' ', @log)) =~ s/^/# /gmr; + if($VERBOSE>2) { + my ($package, $filename, $line) = caller; + $msg .= " (at $filename:$line)"; + } + say STDERR $msg; } #hlog() =head2 isMYH diff --git a/lib/Data/Hopen/Base.pm b/lib/Data/Hopen/Base.pm index 357e387..fc8be3e 100755 --- a/lib/Data/Hopen/Base.pm +++ b/lib/Data/Hopen/Base.pm @@ -8,7 +8,7 @@ package Data::Hopen::Base; use parent 'Exporter'; use Import::Into; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; # Pragmas use 5.014; @@ -36,7 +36,9 @@ our @EXPORT = qw(true false); #DEBUG BEGIN { - $SIG{'__DIE__'} = sub { Carp::confess(@_) } unless $SIG{'__DIE__'}; + unless($SIG{'__DIE__'}) { + $SIG{'__DIE__'} = sub { Carp::confess(@_) }; + } #$Exporter::Verbose=1; } diff --git a/lib/Data/Hopen/G.pod b/lib/Data/Hopen/G.pod index a190339..1ead5d7 100644 --- a/lib/Data/Hopen/G.pod +++ b/lib/Data/Hopen/G.pod @@ -45,4 +45,9 @@ edges is expressed in a DAG. A DAG has zero or more goals (L) that represent named activities expressed in the DAG. +=head1 VISITORS + +L can take a C parameter. The visitor +should be an instance of a concrete subclass of L. + =cut diff --git a/lib/Data/Hopen/G/CollectOp.pm b/lib/Data/Hopen/G/CollectOp.pm index 11b2b9e..469d0fc 100755 --- a/lib/Data/Hopen/G/CollectOp.pm +++ b/lib/Data/Hopen/G/CollectOp.pm @@ -2,7 +2,7 @@ package Data::Hopen::G::CollectOp; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Data::Hopen::G::Op'; use Class::Tiny { @@ -17,7 +17,7 @@ use Storable (); =head1 NAME -Data::Hopen::G::CollectOp - a no-op +Data::Hopen::G::CollectOp - a passthrough operation =head1 SYNOPSIS diff --git a/lib/Data/Hopen/G/DAG.pm b/lib/Data/Hopen/G/DAG.pm index c28f95e..f7cfa17 100755 --- a/lib/Data/Hopen/G/DAG.pm +++ b/lib/Data/Hopen/G/DAG.pm @@ -2,7 +2,7 @@ package Data::Hopen::G::DAG; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Data::Hopen::G::Op'; use Class::Tiny { @@ -34,7 +34,9 @@ use Data::Hopen::G::Node; use Data::Hopen::G::CollectOp; use Data::Hopen::Util::Data qw(forward_opts); use Data::Hopen::OrderedPredecessorGraph; +use Getargs::Mixed; # parameters, which doesn't permit undef use Hash::Merge; +use Scalar::Util qw(refaddr); use Storable (); # Class data {{{1 @@ -157,9 +159,9 @@ sub _run { # Remove _final from the order for now - I don't yet know what it means # to traverse _final. warn "Last item in order isn't _final! This might indicate a bug in hopen, or that some graph edges are missing." - unless $QUIET or $order[$#order] == $self->_final; + unless $QUIET or refaddr $order[$#order] == refaddr $self->_final; - @order = grep { $_ != $self->_final } @order; + @order = grep { refaddr $_ != refaddr $self->_final } @order; # --- Check for non-connected ops, and goals with no inputs --- @@ -228,6 +230,7 @@ sub _run { hlog { ' -- no links' }; $node_inputs->merge(%{$pred->outputs}); # TODO specify which set these are. + # Use the predecessor's identity as the set. next; } @@ -237,6 +240,7 @@ sub _run { my $link_inputs = Data::Hopen::Scope::Hash->new->put(%{$hrPredOutputs}); # All links get the same outer scope --- they are parallel, # not in series. + # TODO use the predecessor's identity as the set. $link_inputs->outer($self->scope); # The links run at the same scope level as the node. $link_inputs->local(true); @@ -265,14 +269,14 @@ sub _run { # Give the visitor a chance, and stash the results if necessary. if(eval { $node->DOES('Data::Hopen::G::Goal') }) { - $args{visitor}->visit_goal($node) if $args{visitor}; + $args{visitor}->visit_goal($node, $node_inputs) if $args{visitor}; # Save the result if there is one. Don't save {}. # use $node->outputs, not $step_output, since the visitor may # alter $node->outputs. $retval->{$node->name} = $node->outputs if keys %{$node->outputs}; } else { - $args{visitor}->visit_node($node) if $args{visitor}; + $args{visitor}->visit_node($node, $node_inputs) if $args{visitor}; } } #foreach node in topo-sort order @@ -384,10 +388,9 @@ Returns the node, for the sake of chaining. =cut sub add { - my $self = shift or croak 'Need an instance'; - my $node = shift or croak 'Need a node'; + my ($self, undef, $node) = parameters('self', ['node'], @_); return if $self->_graph->has_vertex($node); - hlog { __PACKAGE__, 'adding', Dumper($node) } 2; + hlog { __PACKAGE__, $self->name, 'adding', Dumper($node) } 2; $self->_graph->add_vertex($node); #$self->_node_by_name->{$node->name} = $node if $node->name; diff --git a/lib/Data/Hopen/G/Entity.pm b/lib/Data/Hopen/G/Entity.pm index 83995f7..9fed73f 100755 --- a/lib/Data/Hopen/G/Entity.pm +++ b/lib/Data/Hopen/G/Entity.pm @@ -3,7 +3,10 @@ package Data::Hopen::G::Entity; use Data::Hopen; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +use overload; +use Scalar::Util qw(refaddr); + +our $VERSION = '0.000013'; sub name; @@ -40,13 +43,17 @@ version of the entity. That way every entity always has a name. =cut sub name { - my $self = shift or croak 'Need an instance'; - if (@_) { # Setter - return $self->{name} = shift; - } elsif ( exists $self->{name} ) { # Getter - return $self->{name}; + croak 'Need an instance' unless ref $_[0]; + # Note: avoiding `shift` since I've had problems with that in the past + # in classes that overload stringification. + + if (@_>1) { # Setter + croak "Name `$_[1]' is disallowed" unless !!$_[1]; # no falsy names + return $_[0]->{name} = $_[1]; + } elsif ( $_[0]->{name} ) { # Getter + return $_[0]->{name}; } else { # Default - return "$self"; + return overload::StrVal($_[0]); } } #name() @@ -56,7 +63,22 @@ Returns truthy if a name has been set using L. =cut -sub has_custom_name { !!(shift)->{name} } +sub has_custom_name { !!($_[0]->{name}) } + +=head2 Stringification + +Stringifies to the name plus, if the name is custom, the refaddr. + +=cut + +sub _stringify { + $_[0]->has_custom_name ? + sprintf("%s (%x)", $_[0]->{name}, refaddr $_[0]) : + overload::StrVal($_[0]); +} #_stringify + +use overload fallback => 1, + '""' => \&_stringify; 1; __END__ diff --git a/lib/Data/Hopen/G/Goal.pm b/lib/Data/Hopen/G/Goal.pm index c7910da..a2eb9f7 100755 --- a/lib/Data/Hopen/G/Goal.pm +++ b/lib/Data/Hopen/G/Goal.pm @@ -2,7 +2,7 @@ package Data::Hopen::G::Goal; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Data::Hopen::G::Op'; use Class::Tiny { diff --git a/lib/Data/Hopen/G/GraphBuilder.pm b/lib/Data/Hopen/G/GraphBuilder.pm index 45cbd2b..cadd8dd 100755 --- a/lib/Data/Hopen/G/GraphBuilder.pm +++ b/lib/Data/Hopen/G/GraphBuilder.pm @@ -6,7 +6,7 @@ use Exporter 'import'; our @EXPORT; BEGIN { @EXPORT=qw(make_GraphBuilder); } -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use Class::Tiny { name => 'ANON', # Name is optional; it's here so the @@ -64,17 +64,20 @@ change the builder's current node (L). =cut sub add { - my $self = shift or croak 'Need an instance'; - my $node = shift or croak 'Need a node'; - $self->dag->add($node); - return $node; + my ($self, %args) = getparameters('self', ['node'], @_); + $self->dag->add($args{node}); + return $args{node}; } #add() =head2 default_goal Links the most recent node in the chain to the default goal in the DAG. If the DAG does not have a default goal, adds one called "all". -Clears the builder's record of the current node and returns undef. + +As a side effect, calling this function clears the builder's record of the +current node and returns C. The idea is that this function +will be used at the end of a chain of calls. Clearing state in this way +reduces the chance of unintentionally connecting nodes. =cut @@ -89,10 +92,10 @@ sub default_goal { $self->node(undef); # Less likely to leak state between goals. return undef; - # Return undef because, if this is the last thing in a hopen file, + # Also, if this is the last thing in an App::hopen hopen file, # whatever it returns gets recorded in MY.hopen.pl. Therefore, - # return $self causes a copy of the whole graph to be dropped into - # MY.hopen.pl, which is a Bad Thing. + # return $self would cause a copy of the whole graph to be dropped into + # MY.hopen.pl, which would be a Bad Thing. } #default_goal() =head2 goal @@ -154,9 +157,9 @@ sub _wrapper { # Create the GraphBuilder if we don't have one already. my $self = shift; $self = __PACKAGE__->new(dag=>$self) - unless ref $self and eval { $self->DOES(__PACKAGE__) }; + unless eval { $self->DOES(__PACKAGE__) }; croak "Parameter must be a DAG or Builder" - unless $self->dag and eval { $self->dag->DOES('Data::Hopen::G::DAG') }; + unless eval { $self->dag->DOES('Data::Hopen::G::DAG') }; unshift @_, $self; # Put the builder on the arg list diff --git a/lib/Data/Hopen/G/Link.pm b/lib/Data/Hopen/G/Link.pm index 472772b..22240a0 100755 --- a/lib/Data/Hopen/G/Link.pm +++ b/lib/Data/Hopen/G/Link.pm @@ -2,7 +2,7 @@ package Data::Hopen::G::Link; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Data::Hopen::G::Runnable'; use Class::Tiny { diff --git a/lib/Data/Hopen/G/NoOp.pm b/lib/Data/Hopen/G/NoOp.pm new file mode 100755 index 0000000..041c4e0 --- /dev/null +++ b/lib/Data/Hopen/G/NoOp.pm @@ -0,0 +1,40 @@ +# Data::Hopen::G::NoOp - null operation. Used for testing. +package Data::Hopen::G::NoOp; +use Data::Hopen::Base; + +our $VERSION = '0.000013'; + +use parent 'Data::Hopen::G::Op'; +use Class::Tiny; + +# Docs {{{1 + +=head1 NAME + +Data::Hopen::G::NoOp - a no-op + +=head1 SYNOPSIS + +An C is a concrete L that returns C<{}>. +It is mostly used for testing. + +=head1 FUNCTIONS + +=cut + +# }}}1 + +=head2 _run + +Return C<{}>. All arguments are ignored. +Usage: C<< my $hrOutputs = $op->run; >>. + +=cut + +sub _run { + return {}; +} #run() + +1; +__END__ +# vi: set fdm=marker: # diff --git a/lib/Data/Hopen/G/Node.pm b/lib/Data/Hopen/G/Node.pm index 7fe8292..62dc58e 100755 --- a/lib/Data/Hopen/G/Node.pm +++ b/lib/Data/Hopen/G/Node.pm @@ -3,7 +3,7 @@ package Data::Hopen::G::Node; use Data::Hopen; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; sub outputs; @@ -32,7 +32,8 @@ be hashrefs. =cut sub outputs { - my $self = shift or croak 'Need an instance'; + my $self = shift; + croak 'Need an instance' unless $self; if (@_) { # Setter croak "Cannot set `outputs` of @{[$self->name]} to non-hashref " . ($_[0] // '(undef)') diff --git a/lib/Data/Hopen/G/Op.pm b/lib/Data/Hopen/G/Op.pm index 2ac1b1d..8294dd6 100644 --- a/lib/Data/Hopen/G/Op.pm +++ b/lib/Data/Hopen/G/Op.pm @@ -3,7 +3,7 @@ package Data::Hopen::G::Op; use Data::Hopen; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Data::Hopen::G::Node'; use Class::Tiny; @@ -17,16 +17,6 @@ Data::Hopen::G::Op - a hopen operation An C represents one step in the build process. Cs exist to provide a place for edges (L) to connect to. -=head1 MEMBERS - -=head2 need - -An arrayref of inputs that must be present for L to succeed. - -=head2 want - -An arrayref of inputs that L would like to have, but does not require. - =cut 1; diff --git a/lib/Data/Hopen/G/OutputOp.pm b/lib/Data/Hopen/G/OutputOp.pm index aa1ea21..3aec15f 100755 --- a/lib/Data/Hopen/G/OutputOp.pm +++ b/lib/Data/Hopen/G/OutputOp.pm @@ -3,7 +3,7 @@ package Data::Hopen::G::OutputOp; use Data::Hopen; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Data::Hopen::G::Op'; use Class::Tiny qw(output); diff --git a/lib/Data/Hopen/G/Runnable.pm b/lib/Data/Hopen/G/Runnable.pm index b248dea..51e98b2 100755 --- a/lib/Data/Hopen/G/Runnable.pm +++ b/lib/Data/Hopen/G/Runnable.pm @@ -2,7 +2,7 @@ package Data::Hopen::G::Runnable; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use Data::Hopen; use Data::Hopen::Scope::Hash; @@ -24,10 +24,12 @@ Anything with L inherits from this. TODO should this be a role? =head2 need +(B) Inputs this Runnable requires. A L, with the restriction that C may not contain regexes. ("Sorry, I can't run unless you give me every variable in the world that starts with Q." I don't think so!) +Or maybe later an arrayref? TODO. =head2 scope @@ -37,8 +39,10 @@ mechanism in hopen. =head2 want +(B) Inputs this Runnable accepts but does not require. A L, which may include regexes. +Or maybe later an arrayref? TODO. =cut @@ -80,7 +84,13 @@ If given, the phase that is currently under way in a build-system run. If given, an instance that supports C and C calls. A L instance invokes those calls after processing each -goal or other node, respectively. +goal or other node, respectively. They are invoked I the goal or +node has run. They are, however, given access to the L +that the node used for its inputs, in the C<$node_inputs> parameter. Example: + + $visitor->visit_goal($goal, $node_inputs); + +The return value from C or C is ignored. =item -nocontext @@ -106,6 +116,9 @@ sub run { my $retval = $self->_run(forward_opts(\%args, {'-'=>1}, qw[phase visitor])); + die "$self\->_run() did not return a hashref" unless ref $retval eq 'HASH'; + # Prevent errors about `non-hashref 1` or `invalid key`. + hlog { '<-', ref $self, $self->name, 'output', Dumper($retval) } 3; return $retval; @@ -117,8 +130,9 @@ The internal method that implements L. Must be implemented by subclasses. When C<_run> is called, C<< $self->scope >> has been hooked to the context scope, if any. -Parameters are C<-phase> and C<-visitor>. C<_run> is always called in scalar -context, and must return a new hashref. +Parameters are C<-phase> and C<-visitor>, and are always passed by name +(C<< -phase=>$p, -visitor=>$v >>). C<_run> is always called in scalar context, +and B return a new hashref. =cut diff --git a/lib/Data/Hopen/OrderedPredecessorGraph.pm b/lib/Data/Hopen/OrderedPredecessorGraph.pm index 5ae8865..b133e1c 100755 --- a/lib/Data/Hopen/OrderedPredecessorGraph.pm +++ b/lib/Data/Hopen/OrderedPredecessorGraph.pm @@ -2,7 +2,7 @@ package Data::Hopen::OrderedPredecessorGraph; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Graph'; diff --git a/lib/Data/Hopen/Scope.pm b/lib/Data/Hopen/Scope.pm index 29f1267..aba6696 100755 --- a/lib/Data/Hopen/Scope.pm +++ b/lib/Data/Hopen/Scope.pm @@ -3,7 +3,7 @@ package Data::Hopen::Scope; use Data::Hopen::Base; use Exporter 'import'; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; # Class definition use Class::Tiny { @@ -242,7 +242,7 @@ and example: If no names are available in the given C<$levels>, returns an empty C. -TODO? Support a C<$set> parameter? +TODO support a C<$set> parameter =cut @@ -277,7 +277,7 @@ If C<$levels> is not provided, go all the way to the outermost Scope. If C<$deep> is provided and truthy, make a deep copy of each value (using L. Otherwise, just copy. -TODO? Support a C<$set> parameter? +TODO support a C<$set> parameter =cut @@ -361,6 +361,10 @@ sub _merger { die "Invalid merge strategy $s" unless defined $precedence; my $merger = Hash::Merge->new($precedence); + $merger->set_clone_behavior(false); + # TODO CHECKME --- I would rather clone everything except blessed + # references, but doing so appears to be nontrivial. For now, + # I am trying not cloning. $self->_merger_instance($merger); return $merger; diff --git a/lib/Data/Hopen/Scope/Environment.pm b/lib/Data/Hopen/Scope/Environment.pm index 7425211..6c9aeac 100755 --- a/lib/Data/Hopen/Scope/Environment.pm +++ b/lib/Data/Hopen/Scope/Environment.pm @@ -3,7 +3,7 @@ package Data::Hopen::Scope::Environment; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Data::Hopen::Scope'; @@ -86,7 +86,8 @@ sub _names_here { my ($self, %args) = getparameters('self', [qw(retval ; set)], @_); _set0 $args{set} or croak 'I only support set 0'; $args{retval}->insert(keys %ENV); - hlog { __PACKAGE__ . '::_names_here', Dumper $args{retval} }; + hlog { __PACKAGE__ . '::_names_here', Dumper $args{retval} } 9; + # Don't usually log, since the environment is often fairly hefty! } #_names_here() 1; diff --git a/lib/Data/Hopen/Scope/Hash.pm b/lib/Data/Hopen/Scope/Hash.pm index 30c5e3d..3062835 100755 --- a/lib/Data/Hopen/Scope/Hash.pm +++ b/lib/Data/Hopen/Scope/Hash.pm @@ -3,7 +3,7 @@ package Data::Hopen::Scope::Hash; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Data::Hopen::Scope'; use Class::Tiny { diff --git a/lib/Data/Hopen/Scope/Inputs.pm b/lib/Data/Hopen/Scope/Inputs.pm index 93fe908..421343a 100644 --- a/lib/Data/Hopen/Scope/Inputs.pm +++ b/lib/Data/Hopen/Scope/Inputs.pm @@ -3,7 +3,7 @@ package Data::Hopen::Scope::Inputs; use Data::Hopen; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; # TODO if a class use parent 'Data::Hopen::Scope'; diff --git a/lib/Data/Hopen/Scope/Overrides.pm b/lib/Data/Hopen/Scope/Overrides.pm index 8e07f9e..2c26bd1 100755 --- a/lib/Data/Hopen/Scope/Overrides.pm +++ b/lib/Data/Hopen/Scope/Overrides.pm @@ -3,7 +3,7 @@ package Data::Hopen::Scope::Overrides; use Data::Hopen; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; # TODO if using exporter use parent 'Exporter'; diff --git a/lib/Data/Hopen/TEMPLATE.pm b/lib/Data/Hopen/TEMPLATE.pm index 9c8b9e9..f5ffbc8 100755 --- a/lib/Data/Hopen/TEMPLATE.pm +++ b/lib/Data/Hopen/TEMPLATE.pm @@ -3,7 +3,7 @@ package Data::Hopen::TEMPLATE; use Data::Hopen; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; # TODO if using exporter use parent 'Exporter'; diff --git a/lib/Data/Hopen/Util/Data.pm b/lib/Data/Hopen/Util/Data.pm index 28d5a8f..b8a9331 100755 --- a/lib/Data/Hopen/Util/Data.pm +++ b/lib/Data/Hopen/Util/Data.pm @@ -3,7 +3,7 @@ package Data::Hopen::Util::Data; use Data::Hopen; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Exporter'; our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS); diff --git a/lib/Data/Hopen/Util/Filename.pm b/lib/Data/Hopen/Util/Filename.pm index fd87e37..633245f 100755 --- a/lib/Data/Hopen/Util/Filename.pm +++ b/lib/Data/Hopen/Util/Filename.pm @@ -2,7 +2,7 @@ package Data::Hopen::Util::Filename; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; use parent 'Exporter'; our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS); diff --git a/lib/Data/Hopen/Util/MergeWithoutCloneBlessed.pm b/lib/Data/Hopen/Util/MergeWithoutCloneBlessed.pm new file mode 100755 index 0000000..2196486 --- /dev/null +++ b/lib/Data/Hopen/Util/MergeWithoutCloneBlessed.pm @@ -0,0 +1,89 @@ +# Data::Hopen::Util::MergeWithoutCloneBlessed - Hash::Merge, but without +# cloning blessed references. +package Data::Hopen::Util::MergeWithoutCloneBlessed; +use strict; +use warnings; +use 5.014; +use Carp qw(croak); + +our $VERSION = '0.000013'; + +use base 'Hash::Merge'; # since `base` is what Hash::Merge uses +use Clone::Choose 0.008; # also from Hash::Merge + +use Scalar::Util qw(blessed); + +# Docs {{{1 + +=head1 NAME + +Data::Hopen::Util::MergeWithoutCloneBlessed - Hash::Merge without cloning blessed references + +=head1 SYNOPSIS + +This is L, but modified so that, under the default behaviour, +blessed references will not be cloned. Non-blessed references, e.g., +hashrefs or arrayrefs, will be cloned. + +=head1 FUNCTIONS + +=cut + +# }}}1 + +=head2 merge + +Do the merge. Copied and modified from L. + +=cut + +sub merge { + my $self = shift or croak 'Need an instance'; + + my ($left, $right) = @_; + print "Merging:\n<<<\n$left\n>>>\n$right\n---\n" =~ s/^/# /gmr; + + # For the general use of this module, we want to create duplicates + # of all data that is merged. This behavior can be shut off, but + # can create havoc if references are used heavily. + + my $lefttype = ref($left); + $lefttype = "SCALAR" unless defined $lefttype and defined $self->{'matrix'}->{$lefttype}; + + my $righttype = ref($right); + $righttype = "SCALAR" unless defined $righttype and defined $self->{'matrix'}->{$righttype}; + + if ($self->{'clone'}) + { + # TODO this clone() call will clone blessed references inside + # $left or $right, so this module doesn't work yet. + $left = (ref($left) && !blessed($left)) ? clone($left) : $left; + $right = (ref($right) && !blessed($right)) ? clone($right) : $right; + } + + local $Hash::Merge::CONTEXT = $self; + return $self->{'matrix'}->{$lefttype}{$righttype}->($left, $right); +} #merge() + +1; +# Rest of the docs {{{1 +__END__ + +=head1 AUTHOR + +Modifications made by Christopher White C<< >>. + +=head1 LICENSE + +Modifications copyright (c) 2019 Christopher White. + +This library is free software. You can redistribute it and/or modify it +under the same terms as Perl itself. + +This code is modified from the original version of L by +adding checks to not clone blessed references. + +=cut + +# }}}1 +# vi: set fdm=marker: # diff --git a/lib/Data/Hopen/Util/NameSet.pm b/lib/Data/Hopen/Util/NameSet.pm index 6cd90b7..7796793 100755 --- a/lib/Data/Hopen/Util/NameSet.pm +++ b/lib/Data/Hopen/Util/NameSet.pm @@ -2,7 +2,7 @@ package Data::Hopen::Util::NameSet; use Data::Hopen::Base; -our $VERSION = '0.000013'; # TRIAL +our $VERSION = '0.000013'; # Docs {{{1 @@ -141,17 +141,21 @@ Regexps are matched with whatever flags they were compiled with. sub _build { my $self = shift or croak 'Need an instance'; - my $strs = join '|', map { quotemeta } @{$self->{_strings}}; - # TODO should I be using qr/\Q$_\E/ instead, since quotemeta - # isn't quite right on 5.14? Or should I be using 5.16+? - # See how the cpantesters results for t/008 turn out on 5.14. - my $str = join '|', @{$self->{_regexps}}, ($strs || ()); + my @quoted_strs; + if(@{$self->{_strings}}) { + push @quoted_strs, + join '|', map { quotemeta } @{$self->{_strings}}; + # TODO should I be using qr/\Q$_\E/ instead, since quotemeta + # isn't quite right on 5.14? Or should I be using 5.16+? + } + + my $pattern = join '|', @{$self->{_regexps}}, @quoted_strs; # Each regexp stringifies with surrounding parens, so we # don't need to add any. - return $str ? qr/\A(?:$str)\z/ : qr/(*FAIL)/; - # If $str is empty, the nameset is empty (`(*FAIL)`). Without the ?: , - # qr// would match anything, when we want to match nothing. + return $pattern ? qr/\A(?:$pattern)\z/ : qr/(*FAIL)/; + # If $pattern is empty, the nameset is empty (`(*FAIL)`). Without the + # ?:, qr// would match anything, when we want to match nothing. } #_build() 1; diff --git a/lib/Data/Hopen/Visitor.pm b/lib/Data/Hopen/Visitor.pm new file mode 100755 index 0000000..488cd8d --- /dev/null +++ b/lib/Data/Hopen/Visitor.pm @@ -0,0 +1,44 @@ +# Data::Hopen::Visitor - abstract interface for a visitor. +package Data::Hopen::Visitor; +use Data::Hopen::Base; + +our $VERSION = '0.000013'; + +use Class::Tiny; + +# Docs {{{1 + +=head1 NAME + +Data::Hopen::Visitor - Abstract base class for DAG visitors + +=head1 SYNOPSIS + +This is an abstract base class for visitors provided to +L. + +=cut + +# }}}1 + +=head1 FUNCTIONS + +=head2 visit_goal + +Process a L. + +=cut + +sub visit_goal { ... } + +=head2 visit_node + +Process a graph node that is not a C. + +=cut + +sub visit_node { ... } + +1; +__END__ +# vi: set fdm=marker: # diff --git a/t/001-entity.t b/t/001-entity.t index a9d1585..8cfb727 100644 --- a/t/001-entity.t +++ b/t/001-entity.t @@ -2,15 +2,23 @@ # 001-entity.t: test Entity use rlib 'lib'; use HopenTest; +use Test::Fatal; -BEGIN { - use_ok 'Data::Hopen::G::Entity'; -} +use Data::Hopen::G::Entity; # abort if we can't +# Basics my $e = Data::Hopen::G::Entity->new(name=>'foo'); isa_ok($e, 'Data::Hopen::G::Entity'); is($e->name, 'foo', 'Name was set by constructor'); $e->name('bar'); is($e->name, 'bar', 'Name was set by accessor'); +# Error conditions +like exception { Data::Hopen::G::Entity::name(); }, + qr/Need an instance/, 'name() throws absent instance'; + +# Misc., for coverage +$e = Data::Hopen::G::Entity->new(); +like $e->name, qr/Entity.*HASH/, 'Anonymous entity stringifies as ref'; + done_testing(); diff --git a/t/003-node.t b/t/003-node.t index b2a2c41..43ea4ac 100644 --- a/t/003-node.t +++ b/t/003-node.t @@ -3,9 +3,9 @@ use rlib 'lib'; use HopenTest; -BEGIN { - use_ok 'Data::Hopen::G::Node'; -} +use Test::Fatal; + +use Data::Hopen::G::Node; my $e = Data::Hopen::G::Node->new(name=>'foo'); isa_ok($e, 'Data::Hopen::G::Node'); diff --git a/t/004-goal.t b/t/004-goal.t index 52a3d53..035078a 100644 --- a/t/004-goal.t +++ b/t/004-goal.t @@ -2,15 +2,49 @@ # 004-goal.t: test Data::Hopen::G::Goal use rlib 'lib'; use HopenTest; +use Data::Hopen ':all'; -BEGIN { - use_ok 'Data::Hopen::G::Goal'; -} +use Capture::Tiny qw(capture_stderr); +use Test::Fatal; +use Data::Hopen::G::Goal; +use Data::Hopen::Scope::Hash; + +# Creation my $e = Data::Hopen::G::Goal->new(name=>'foo'); isa_ok($e, 'Data::Hopen::G::Goal'); is($e->name, 'foo', 'Name was set by constructor'); $e->name('bar'); is($e->name, 'bar', 'Name was set by accessor'); +# Logging +my ($result, $logtext); +$VERBOSE=1; + +$e->should_output(false); +$logtext = capture_stderr { $result = $e->run }; +like $logtext, qr/without outputs/, '_run !should_output log text'; +is_deeply $result, {}, '!should_output -> no outputs'; + +$e->should_output(true); +$logtext = capture_stderr { $result = $e->run }; +like $logtext, qr/with outputs/, '_run should_output log text'; + +$VERBOSE=0; + +# Running +my $scope = Data::Hopen::Scope::Hash->new->put(foo=>42); + +$e->should_output(false); +$result = $e->run($scope); +is_deeply $result, {}, '!should_output with inputs -> no outputs'; + +$e->should_output(true); +$result = $e->run($scope); +is_deeply $result, {foo=>42}, 'should_output with inputs -> passthrough'; + +# Error conditions +like exception { Data::Hopen::G::Goal->new; }, + qr/Goals must have names/, 'anonymous goal throws'; + done_testing(); diff --git a/t/005-merge-without-clone-blessed.NOTYET b/t/005-merge-without-clone-blessed.NOTYET new file mode 100644 index 0000000..2acdf42 --- /dev/null +++ b/t/005-merge-without-clone-blessed.NOTYET @@ -0,0 +1,43 @@ +#!perl +# 001-entity.t: test Entity +use rlib 'lib'; +use HopenTest; +use Test::Fatal; +use Scalar::Util qw(refaddr); + +use Data::Hopen::Util::MergeWithoutCloneBlessed; # abort if we can't + +package BlessedReference { + use Class::Tiny qw(name); +} + +# Construct +my $merger = Data::Hopen::Util::MergeWithoutCloneBlessed->new('RETAINMENT_PRECEDENT'); +isa_ok($merger, 'Data::Hopen::Util::MergeWithoutCloneBlessed'); + +# Setup a structure to test +my $obj = BlessedReference->new; +isa_ok($obj, 'BlessedReference'); +diag 'Obj is ' . $obj; + +my $arr = [1,2,$obj]; +my $hash = {3 => $obj, 4 => $obj}; + +# Do the merge +my $input = { foo => $arr, bar => $hash }; +my $output = $merger->merge({}, $input); +diag Dumper $output; + +# Check the structure +is(ref $output, 'HASH', 'hashrefs in -> hashref out'); +is(ref($output->{foo}), 'ARRAY', 'arrayref foo'); +cmp_ok(refaddr($output->{foo}), '!=', refaddr($arr), 'Created a new arrayref foo'); +is(ref($output->{bar}), 'HASH', 'hashref foo'); +cmp_ok(refaddr($output->{bar}), '!=', refaddr($hash), 'Created a new hashref bar'); + +foreach($output->{foo}->[2], $output->{bar}->{3}, $output->{bar}->{4}) { + isa_ok($_, 'BlessedReference'); + cmp_ok(refaddr($_), '==', refaddr($obj)); +} + +done_testing(); diff --git a/t/008-nameset.t b/t/008-nameset.t index 6252018..35042ee 100755 --- a/t/008-nameset.t +++ b/t/008-nameset.t @@ -3,9 +3,9 @@ use rlib 'lib'; use HopenTest; -BEGIN { - use_ok 'Data::Hopen::Util::NameSet'; -} +use Test::Fatal; + +use Data::Hopen::Util::NameSet; # NOTE: Even though `$s ~~ 'x'` (object first) is supported for now, we don't # use it. This is to retain compatibility with the 5.27.7-style smartmatch @@ -16,11 +16,11 @@ my $s; # Run the tests twice: once without add() and once with add(). for(my $iter=0; $iter<2; ++$iter) { - # Set up this iter's test object - if($iter == 0) { - $s = Data::Hopen::Util::NameSet->new(); - isa_ok($s, 'Data::Hopen::Util::NameSet'); - ok(!$s->contains('x'), "Empty nameset rejects 'x'"); +# Set up this iter's test object +if($iter == 0) { + $s = Data::Hopen::Util::NameSet->new(); + isa_ok($s, 'Data::Hopen::Util::NameSet'); + ok(!$s->contains('x'), "Empty nameset rejects 'x'"); ok(!('x' ~~ $s), "Empty nameset rejects 'x'"); $s->add('foo', 'bar', qr/bat/, [qr/qu+x/i, 'array', ['inner array']], {key=>'value'}, 'русский', 'язык'); @@ -58,13 +58,13 @@ for(my $iter=0; $iter<2; ++$iter) { } #foreach test -# Complex +# Complex, new() $s = Data::Hopen::Util::NameSet->new(qw(foo bar), qr/./); ok($s->complex, 'set with regexps is complex'); $s = Data::Hopen::Util::NameSet->new(qw(foo bar)); ok(!$s->complex, 'set without regexps is not complex'); -# Complex +# Complex, add() $s = Data::Hopen::Util::NameSet->new; $s->add(qw(foo bar), qr/./); ok($s->complex, 'set with regexps is complex'); @@ -72,5 +72,37 @@ $s = Data::Hopen::Util::NameSet->new; $s->add(qw(foo bar)); ok(!$s->complex, 'set without regexps is not complex'); +# More add() +ok(!defined exception { $s->add() }, 'add() without parms succeeds'); +ok(!defined exception { $s->add({key1 => 42, key2 => undef}) }, + 'add(hashref) succeeds'); +ok($s->contains($_), "add(hashref) added $_") foreach qw(key1 key2); + +# More _build() +$s = Data::Hopen::Util::NameSet->new(qr/foo/); +ok($s->contains('foo'), 'nameset without strings accepts foo from regex'); +ok(!$s->contains('bar'), 'nameset without strings rejects bar'); + +# Error cases +like(exception { Data::Hopen::Util::NameSet::new() }, + qr/Call as/, + 'new() throws when called directly'); + +like(exception { Data::Hopen::Util::NameSet::add() }, + qr/Need an instance/, + 'add() throws when called directly'); + +like(exception { Data::Hopen::Util::NameSet::contains() }, + qr/Need an instance/, + 'contains() throws when called directly'); + +like(exception { Data::Hopen::Util::NameSet::_build() }, + qr/Need an instance/, + '_build() throws when called directly'); + +like(exception { Data::Hopen::Util::NameSet->new(sub {}) }, + qr/I don't know how to handle this/, + 'new(CODEREF) throws'); + done_testing(); # vi: set fenc=utf8: diff --git a/t/020-dag.t b/t/020-dag.t deleted file mode 100644 index 85dc33d..0000000 --- a/t/020-dag.t +++ /dev/null @@ -1,32 +0,0 @@ -#!perl -# 020-dag.t: basic tests of Data::Hopen::G::DAG -use rlib 'lib'; -use HopenTest; - -BEGIN { - use_ok 'Data::Hopen::G::DAG'; - diag "Testing Data::Hopen::G::DAG from $INC{'Data/Hopen/G/DAG.pm'}"; -} - -my $dag = Data::Hopen::G::DAG->new(name=>'foo'); -isa_ok($dag, 'Data::Hopen::G::DAG'); -is($dag->name, 'foo', 'Name was set by constructor'); -$dag->name('bar'); -is($dag->name, 'bar', 'Name was set by accessor'); - -ok($dag->_graph, 'DAG has a _graph'); -ok($dag->_final, 'DAG has a _final'); - -my @goals; -foreach my $goalname (qw(all clean)) { - my $g1 = $dag->goal($goalname); - push @goals, $g1; - isa_ok($g1, 'Data::Hopen::G::Goal', 'DAG::goal()'); - is($g1->name, $goalname, 'DAG::goal() sets goal name'); - ok($dag->_graph->has_edge($g1, $dag->_final), 'DAG::goal() adds goal->final edge'); -} - -ok($dag->default_goal, 'DAG::goal() sets default_goal'); -is($dag->default_goal->name, 'all', 'First call to DAG::goal() sets default goal name'); - -done_testing(); diff --git a/t/005-op.t b/t/100-op.t similarity index 100% rename from t/005-op.t rename to t/100-op.t diff --git a/t/006-collect-op.t b/t/101-collect-op.t similarity index 100% rename from t/006-collect-op.t rename to t/101-collect-op.t diff --git a/t/120-dag.t b/t/120-dag.t new file mode 100644 index 0000000..2952055 --- /dev/null +++ b/t/120-dag.t @@ -0,0 +1,119 @@ +#!perl +# 120-dag.t: basic tests of Data::Hopen::G::DAG +use rlib 'lib'; +use HopenTest; +use Test::Deep::NoTest; # NoTest since I am using eq_deeply directly +use Test::Fatal; + +use Data::Hopen::G::Op; +use Data::Hopen::G::NoOp; + +BEGIN { + use_ok 'Data::Hopen::G::DAG'; + diag "Testing Data::Hopen::G::DAG from $INC{'Data/Hopen/G/DAG.pm'}"; +} + +my $dag = Data::Hopen::G::DAG->new(name=>'foo'); +isa_ok($dag, 'Data::Hopen::G::DAG'); +is($dag->name, 'foo', 'Name was set by constructor'); +$dag->name('bar'); +is($dag->name, 'bar', 'Name was set by accessor'); + +ok($dag->_graph, 'DAG has a _graph'); +ok($dag->_final, 'DAG has a _final'); +ok($dag->empty, 'DAG is initially empty'); +cmp_ok($dag->_graph->vertices, '==', 1, 'DAG initially has 1 vertex'); + +my @goals; +foreach my $goalname (qw(all clean)) { + my $g1 = $dag->goal($goalname); + push @goals, $g1; + isa_ok($g1, 'Data::Hopen::G::Goal', 'DAG::goal()'); + is($g1->name, $goalname, 'DAG::goal() sets goal name'); + ok($dag->_graph->has_edge($g1, $dag->_final), 'DAG::goal() adds goal->final edge'); +} + +ok(!$dag->empty, 'DAG is not empty after adding goals'); +cmp_ok($dag->_graph->vertices, '>', 1, 'DAG has >1 vertex after adding goals'); +ok($dag->default_goal, 'DAG::goal() sets default_goal'); +is($dag->default_goal->name, 'all', 'First call to DAG::goal() sets default goal name'); + +# add() +my $op = Data::Hopen::G::NoOp->new(name => 'some operation'); +$dag->add($op); +ok($dag->_graph->has_vertex($op), 'add() adds node'); +cmp_ok($dag->_graph->get_vertex_count($op), '==', 1, 'add() initial count 1'); +$dag->add($op); +cmp_ok($dag->_graph->get_vertex_count($op), '==', 1, 'add() count still 1'); + +# init() + +our @results; # lexical visible in the following package +package MY::AppendOp { + use parent 'Data::Hopen::G::Op'; + use Class::Tiny; + sub _run { + push @results, (shift)->name; + return {}; # Must return a hashref + } +} #MY::AppendOp + +# Make a dummy DAG so it will run - what we care about is the init graph +$dag = Data::Hopen::G::DAG->new(name=>'dag_with_init'); +my $goal = $dag->goal('some goal'); +$dag->connect(Data::Hopen::G::NoOp->new, $goal); + +$op = MY::AppendOp->new(name => '1'); +cmp_ok($dag->_init_graph->vertices, '==', 1, 'Init graph initially has 1 vertex'); +$dag->init($op); +cmp_ok($dag->_init_graph->vertices, '==', 2, 'init() adds a vertex to the init graph'); +ok($dag->_init_graph->has_vertex($op), 'init() adds node'); +cmp_ok($dag->_init_graph->get_vertex_count($op), '==', 1, 'init() initial count 1'); +$dag->init($op); +cmp_ok($dag->_init_graph->get_vertex_count($op), '==', 1, 'init() count still 1'); + +$op = MY::AppendOp->new(name => '2'); +$dag->init($op); +$op = MY::AppendOp->new(name => '3'); +$dag->init($op, true); +cmp_ok($dag->_init_graph->vertices, '==', 4, + 'right number of vertices in the init graph before running'); + +@results=(); +$dag->run; # Fills in @results + +# Check the results. Ops 1 and 2 are added as peers after the initial +# first node, so they can run in any order. Op 3 is added as the first node +# ($dag->init(..., true)), so will always come before the other two. +ok( eq_deeply(\@results, [3,1,2]) || + eq_deeply(\@results, [3,2,1]), + 'Init operations ran in the expected order' ); + +# Extra tests for coverage + +# Anon dag +$dag = Data::Hopen::G::DAG->new(); +isa_ok($dag, 'Data::Hopen::G::DAG'); +like($dag->name, qr/DAG.*\d/, 'Anon dag gets an autogenerated name'); + +# Invalid invocations +like exception { Data::Hopen::G::DAG::goal(); }, qr/Need an instance/, + 'goal called directly throws'; +like exception { Data::Hopen::G::DAG->goal(); }, qr/Need a goal name/, + 'goal called without name throws'; +like exception { Data::Hopen::G::DAG::connect(); }, qr/Need an instance/, + 'connect called directly throws'; +like exception { Data::Hopen::G::DAG::add(); }, qr/Missing/, + 'add called directly throws'; +like exception { Data::Hopen::G::DAG->add(); }, qr/Missing/, + 'add called without node throws'; +like exception { Data::Hopen::G::DAG::init(); }, qr/Need an instance/, + 'init called directly throws'; +like exception { Data::Hopen::G::DAG->init(); }, qr/Need an op/, + 'init called without op throws'; +like exception { Data::Hopen::G::DAG::empty(); }, qr/Need an instance/, + 'empty called directly throws'; +like exception { Data::Hopen::G::DAG::BUILD(); }, qr/Need an instance/, + 'BUILD called directly throws'; + +done_testing(); diff --git a/t/021-dag-single-goal.t b/t/121-dag-single-goal.t similarity index 100% rename from t/021-dag-single-goal.t rename to t/121-dag-single-goal.t diff --git a/t/022-dag-visitor.t b/t/122-dag-visitor.t similarity index 100% rename from t/022-dag-visitor.t rename to t/122-dag-visitor.t diff --git a/t/023-dag-warnings.t b/t/123-dag-warnings.t similarity index 100% rename from t/023-dag-warnings.t rename to t/123-dag-warnings.t diff --git a/t/024-dag-merge-node-inputs.t b/t/124-dag-merge-node-inputs.t similarity index 100% rename from t/024-dag-merge-node-inputs.t rename to t/124-dag-merge-node-inputs.t diff --git a/t/998-sig-die.t b/t/998-sig-die.t new file mode 100755 index 0000000..7adda1b --- /dev/null +++ b/t/998-sig-die.t @@ -0,0 +1,41 @@ +#!perl +# 998-sig-die.t: test for coverage in Data::Hopen: what happens when a +# $SIG{'__DIE__'} handler +# elsewhere. +BEGIN { + $SIG{'__DIE__'} = sub { die "oops" } +} + +use rlib 'lib'; +use HopenTest; + +use Data::Hopen; +use Data::Hopen::G::DAG; +use Data::Hopen::Scope::Hash; + +sub run { + # Modified from t/021-dag-single-goal.t + my $outermost_scope = Data::Hopen::Scope::Hash->new()->put(foo => 42); + + my $dag = hnew DAG => 'dag'; + + my $goal = $dag->goal('all'); + ok($dag->_graph->has_edge($goal, $dag->_final), 'DAG::goal() adds goal->final edge'); + + # Add an op + my $op = hnew CollectOp => 'op1', levels => 3; + $dag->connect($op, $goal); + ok($dag->_graph->has_edge($op, $goal), 'DAG::connect() adds edge'); + + # Oops - create cycle + $dag->connect($goal, $op); + ok($dag->_graph->has_edge($goal, $op), 'DAG::connect() adds other edge'); + + # Run it + eval { $dag->run($outermost_scope); }; + like $@, qr/oops/, "Didn't override SIG{'__DIE__'} handler"; +} #run() + +run(); + +done_testing(); diff --git a/t/999-extras-for-coverage.t b/t/999-extras-for-coverage.t new file mode 100755 index 0000000..fb4be5a --- /dev/null +++ b/t/999-extras-for-coverage.t @@ -0,0 +1,158 @@ +#!perl +# 999-extras-for-coverage.t: random tests for things that aren't covered +# elsewhere. +use rlib 'lib'; +use HopenTest; + +# Fake package, used for testing hnew +package MY::ReturnsFalsyInstance { + sub new { + return undef + } +} +BEGIN { $INC{'MY/ReturnsFalsyInstance.pm'} = 1; } + +package TestDataHopen { + use Data::Hopen ':all'; + use HopenTest; + use Capture::Tiny qw(capture_stderr); + use Test::Fatal; + + use List::AutoNumbered; + use Quote::Code; + + sub test_hnew { + like exception { hnew(); }, qr/Need a class/, 'hnew() throws'; + like exception { hnew('Data::Hopen::DOES_NOT_EXIST_TEST_ONLY'); }, + qr/Could not find class/, 'hnew() throws'; + like exception { hnew('MY::ReturnsFalsyInstance') }, + qr/Could not create instance/, 'hnew() throws'; + + ok hnew(DAG => 'foo'), 'hnew DAG works'; + } + + sub test_loadfrom { + my $pkgname; + + $pkgname = loadfrom('Data::Hopen::Scope'); + is $pkgname, 'Data::Hopen::Scope', 'loadfrom finds literal name'; + + $pkgname = loadfrom('Entity','Data::Hopen::G::'); + is $pkgname, 'Data::Hopen::G::Entity', 'loadfrom finds name with stem'; + + # Nonexistent + $pkgname = loadfrom('Data::Hopen::DOES_NOT_EXIST_TEST_ONLY'); + ok(!defined $pkgname, 'loadfrom(nonexistent) returns undef'); + + # Invalid invocations + like exception { loadfrom(); }, qr/Need a class/, + 'loadfrom dies without a class name'; + } + + sub test_hlog { + # (line,) name, VERBOSE, QUIET, expected, [hlog level] + my $tests = List::AutoNumbered->new(__LINE__); + $tests->load('quiet', 0, true, qr/^$/)-> + ('quiet beats verbose 1', 1, true, qr/^$/) + ('quiet beats verbose 2', 2, true, qr/^$/) + ('normal', 1, false, qr/\b42\b/) + ('normal level 2 verbose 1', 1, false, qr/^$/, 2) + ('normal level 2 verbose 2', 2, false, qr/\b42\b/, 2) + ; + + for my $lrTest (@{ $tests->arr }) { + my $msg = capture_stderr { + $QUIET = ($lrTest->[3] // false); + $VERBOSE = ($lrTest->[2] // 0); + + if($lrTest->[5]) { + hlog { 42 } $lrTest->[5]; + } else { + hlog { 42 }; + } + + $QUIET = false; + $VERBOSE = 0; + }; + like $msg, $lrTest->[4], + qc"hlog {$lrTest->[1]} (line {$lrTest->[0]})"; + } + + $VERBOSE = 1; # So hlog will actually get to running the sub + is capture_stderr { hlog(sub {}) }, '', 'No hlog output'; + like capture_stderr { hlog(sub { "" }) }, qr/^# $/m, + 'Empty-string hlog output'; + # coverage for the "chomp if" + $VERBOSE = 0; + } #test_hlog() + + sub test_isMYH { + ok isMYH('MY.hopen.pl'), 'MY.hopen.pl is MYH'; + ok !isMYH('foo'), 'foo is not MYH'; + + ok(isMYH, 'MY.hopen.pl is MYH ($_)') for 'MY.hopen.pl'; + ok(!isMYH, 'foo is not MYH ($_)') for 'foo'; + } + + sub run { + test_hnew; + test_loadfrom; + test_hlog; + test_isMYH; + } +} #package DH + +package TestDataHopenGOutputOp { + use HopenTest; + use Capture::Tiny; + use Test::Fatal; + + use Data::Hopen 'hnew'; + use Data::Hopen::G::OutputOp; + + sub run { + like exception { Data::Hopen::G::OutputOp::_run() }, + qr/Need an instance/, '_run() croaks absent instance'; + + my $e = hnew OutputOp => 'a name', output => []; + isa_ok($e, 'Data::Hopen::G::OutputOp'); + like exception { $e->run }, + qr/output is not a hashref/, + 'D::H::G::OutputOp requires a hashref'; + } +} #package DHGOO + +package TestDataHopenGNode { + use HopenTest; + use Capture::Tiny; + use Test::Fatal; + + use Data::Hopen 'hnew'; + use Data::Hopen::G::Node; + + sub run { + # Invalid invocations + like(exception { Data::Hopen::G::Node::outputs() }, + qr/Need an instance/, + 'outputs() dies without $self'); + + # outputs() + my $n = hnew 'Node' => 'some name'; + isa_ok($n, 'Data::Hopen::G::Node'); + + like exception { $n->outputs([]) }, + qr/set\b.*non-hashref/, + 'Node outputs(non-hashref) throws'; + like exception { $n->outputs(undef) }, + qr/set\b.*non-hashref.*undef/, + 'Node outputs(undef) throws'; + + delete $n->{outputs} if exists $n->{outputs}; + is_deeply $n->outputs, {}, 'Node->outputs defaults to {}'; + } +} #package DHGN + +use PackagesInThisFile 'run'; # every package above that has a sub run() +(diag($_), $_->run) foreach @PIF; + +done_testing(); diff --git a/t/lib/PackagesInThisFile.pm b/t/lib/PackagesInThisFile.pm new file mode 100644 index 0000000..f07584b --- /dev/null +++ b/t/lib/PackagesInThisFile.pm @@ -0,0 +1,56 @@ +package PackagesInThisFile; +use v5.014; +use strict; +use warnings; + +=head1 NAME + +PackagesInThisFile - list the top-level packages defined in a file + +=head1 SYNOPSIS + + use PackagesInThisFile qw(foo); + # populates @PIF + # +When you C this package from a file, the package populates package +variable C<@PIF> with the names of the top-level packages that are defined in +that file and that have a subroutine of the given name. C<@PIF> is sorted by +line number in the file. + +=cut + +use Sub::Identify 'get_code_location'; + +sub import { + my (undef, $sub_name) = @_; + my (undef, $caller_filename) = caller; + + # Find all the top-level packages + my @packages = map { s/::$//r } grep { /^\w+::$/ } keys %::; + + # Find the subroutines in those packages + my @subs = map + { + no strict 'refs'; + no warnings 'once'; + [$_, *{ $_ . '::' . $sub_name }{CODE}] + } + @packages; + + # Filter out non-CODE refs --- I was getting some of those early on + # and I'm not sure why. + @subs = grep { ref $_->[1] eq 'CODE' } @subs; + + # Get the filenames + my @locns = sort { $a->[2] <=> $b->[2] } # line number + map { [$_->[0], get_code_location($_->[1])] } + @subs; + my @pif = map { ($_->[1] eq $caller_filename) ? $_->[0] : () } @locns; + + { + no strict 'refs'; + *{caller . '::PIF'} = \@pif; + } +} + +1;