How to completely destroy class attributes with Test::Most?

[nysus]

I'm using Test::Most and have the following simple test:

{
  my $fi2 = '';
  $fi2 = FileImporter->new('t/test_data/really_good');

  my %ref_check = (
    _parseable_files => 'ARRAY',
    _nonparseable_files => 'ARRAY',
    _files => 'HASH',
    _bad_header_files => 'ARRAY',
  );
  ref_check($fi2, \%ref_check); # tests are run in the subroutine

}

The test passes fine when run by itself. However, when I throw another test in front of it which creates a similar object...

{   ### New test place in front of the earlier test
  my $fi;

  lives_ok { $fi = FileImporter->new('t/test_data/file'); }
    'creates object';

  $fi->DESTROY;
  FileImporter->DESTROY;
}

{     ### Same test as before, now fails with new test in front of it
  my $fi2 = '';
  $fi2 = FileImporter->new('t/test_data/really_good');

  my %ref_check = (
    _parseable_files => 'ARRAY',
    _nonparseable_files => 'ARRAY',
    _files => 'HASH',
    _bad_header_files => 'ARRAY',
  );
  ref_check($fi2, \%ref_check);


}

...the second test now fails even though it's the same test that ran alone. I traced the problem down to a class subroutine which iterates over file names:

{
  my $iterator;
  sub _file_iterator {
    my @files = @_;
    my $f = sub {
      shift @files;
    };
    return $f;
  }

  sub get_next_file {
    my $s = shift;

    if (!$s->{_selected_file}) {
      my @files = @_ ? @_ : $s->get_files;
      $iterator = _file_iterator(@files) if !$iterator;
    }
    my $next_file = $iterator->();
    $s->{_selected_file} = $next_file;
    $iterator = '' if !$next_file;
    return $next_file;
  }
}

Somehow, the iterator is populated with a file name left over from the first test. I'm not sure how or why this is happening. I've placed the tests in two different scopes and given them a different name. I'm assuming there is some kind of voodoo going on under the hood with Test::Most. I'm looking for a way to wipe out my FileImporter class out of memory.

[jcb]

Can you post the new method and any other code involved in constructing a FileImporter? You should not need any explicit calls to DESTROY; perl destroys the object when the last reference goes out of scope and your $fi2 is a completely separate object — unless new is doing something funny...

...and the above is not the source of your problem. Your problem is the my $iterator on line 2, which makes get_next_file a closure. If it is supposed to be per-object, it needs to be an instance variable ($s->{_iterator}) instead of a lexical ($iterator). You would probably be better off getting rid of the closures entirely and just stashing a reference to @files in an instance variable ($s->{_file_queue}) and changing that whole block to: (obviously untested)

sub get_next_file {
  my $s = shift;

  if (!$s->{_selected_file}) {
    my @files = @_ ? @_ : $s->get_files;
    $s->{_file_queue} = \@files;
  }
  my $next_file = shift @{$s->{_file_queue}};
  $s->{_selected_file} = $next_file;
  return $next_file;
}

You might even be able to globally replace $s->{_selected_file} with $s->{_file_queue}[0] if eliminating an instance variable is helpful.

As for destroying the value of $iterator... how do you reach into another scope's lexicals? Some kind of XS magic, obviously, but what does the debugger use for this?

[nysus]

Thanks for the tip on creating a simpler iterator. I had just been re-reviewing Damian Conway's old OO Perl book and I had closures and class variables on the brain and so reached for the shiny new hammer I had just learned about.

My new sub is actually spread out over several classes with FileCollector as my base class:

package FileCollector ;

sub new {
  my $class = shift;

  my $s = bless { _files => {},
                  _target_repo   => '',
                  _selected_file => '',
                  _common_dir    => ''}, $class;
  $s->add_resources(@_);
  return $s;
}

sub add_resources {
  my $s = shift;
  ... does stuff, basically like an init subroutine ...
}

package FileParser ;
use parent qw ( FileCollector );


sub new {
  my $class = shift;
  return $class->SUPER::new(shift);
}

sub add_resources {
  my $s = shift;

  $s->SUPER::add_resources(@_);
  $s->{_nonparseable_files} = $s->{_nonparseable_files} || [];
  $s->{_parseable_files}    = $s->{_parseable_files}    || [];
  $s->_test_parsability;
}

package HeaderAnalyzer ;
use parent qw ( FileParser );

sub new {
  my $class = shift;
  return $class->SUPER::new(shift);
}

sub add_resources {
  my $s = shift;

  $s->SUPER::add_resources(@_);
  $s->{_bad_header_files}          = $s->{_bad_header_files}   || [];
  $s->{_blank_header_files}        = $s->{_blank_header_files} || [];
  $s->{_no_header_files}           = $s->{_no_header_files}    || [];
  $s->{_good_header_files}         = $s->{_good_header_files}  || [];
  $s->{_unrec_header_files}        = $s->{_unrec_header_files} || [];
  $s->_analyze_headers;
}

...MORE PACKAGES THAT BUILD THE CHILD-PARENT CLASS CHAIN FURTHER...

I'm not sure how orthodox this design pattern is with the chained SUPER calls like this but it works really well. I'm not sure if this complexity might be part of my problem. I'm just cutting my teeth on old school OO. Have mostly used Moose and Moo up until now.

[jcb]

The chained SUPER::add_resources calls are fine, but why are you overriding new if all you do is return $class->SUPER::new()? I suggest replacing your "empty" new methods with comments indicating that new is inherited.

Why are all of your instance variables prefixed with underscore? They are instance variables — of course they are internal — so an underscore prefix is just extra typing for no reason.

Baseline Perl 5 OO is really simple: an object is a reference that has been blessed with a vtable. A vtable is a package stash, which bless looks up from the package name. A method call is performed by looking for that method in the vtable. If found, it is called. If not found, the @ISA array is checked and any packages listed there are searched recursively for the method, which is called if found, otherwise AUTOLOAD is tried similarly. If none of this produces a code reference, a fatal exception is thrown. While calling a method, whatever was used to start the method search is unshifted onto @_.

All the rest is built on those basic mechanisms. These is nothing magic about my $self = shift; at all.

[nysus]

This is the entire FileCollector base class, btw. I got sick of dealing with the headaches and complexities of tracking individual files and paths and directories. This takes all those headaches away. Basically, the FileCollector scoops up all the files and directories you send it with new and add_resources. Then I use children classes to perform operations on and filter and categorize the files. If it's not reinventing the wheel, I may submit it to CPAN.

package Dondley::WestfieldVote::FileCollector ;
use strict; use warnings;

use Cwd;
use Carp;
use File::Basename;
use Log::Log4perl::Shortcuts qw(:all);

{
  my $iterator;
  sub _file_iterator {
    my @files = @_;
    my $f = sub {
      shift @files;
    };
    return $f;
  }

  sub get_next_file {
    my $s = shift;

    if (!$s->{_selected_file}) {
      my @files = @_ ? @_ : $s->get_files;
      $iterator = _file_iterator(@files) if !$iterator;
    }
    my $next_file = $iterator->();
    $s->{_selected_file} = $next_file;
    $iterator = '' if !$next_file;
    return $next_file;
  }
}

sub AUTOLOAD {
  our $AUTOLOAD;
  my $s = shift;
  $AUTOLOAD  =~ /.*::get(_next)*(_\w+)_files*$/ or
    croak "No such method: $AUTOLOAD";
  my ($next, $type) = ($1, $2);
  my $attr = "${type}_files";
  my @files = @{$s->{$attr}};
  return if !@files || !$next;
  return $s->get_next_file(@files);
}

sub new {
  my $class = shift;

  my $s = bless { _files => {},
                  _target_repo   => '',
                  _selected_file => '',
                  _common_dir    => ''}, $class;
  $s->add_resources(@_);
  return $s;
}

sub get_count {
  my $s = shift;
  return (scalar keys %{$s->{_files}})
}

sub get_obj_prop {
  my $s    = shift;
  my $obj  = shift;
  my $prop = shift;

  if (!$prop || !$obj) {
    $s->croak ("Missing arguments to get_obj_prop method"
      . ' at ' .  (caller(0))[1] . ', line ' . (caller(0))[2] );
  }

  my $file = $s->{_selected_file};

  my $o = $obj . '_obj';
  my $object = $s->{_files}{$file}{$o};
  my $attr = "_$prop";
  if (! exists $object->{$attr} ) {
    $s->croak ("Non-existent $obj object attribute requested: '$prop'"
      . ' at ' .  (caller(0))[1] . ', line ' . (caller(0))[2] );
  }
  my $value = $object->{$attr};
  if (ref $value eq 'ARRAY') {
    return @$value;
  } else {
    return $value;
  }
}

sub set_obj_prop {
  my $s = shift;
  my $obj  = shift;
  my $prop = shift;
  my $val  = shift;

  if (!$prop || !$obj) {
    $s->croak ("Missing arguments to get_obj_prop method"
      . ' at ' .  (caller(0))[1] . ', line ' . (caller(0))[2] );
  }

  my $file = $s->{_selected_file};

  my $o = $obj . '_obj';
  my $object = $s->{_files}{$file}{$o};
  my $attr = "_$prop";
  if (! exists $object->{$attr} ) {
    $s->croak ("Non-existent $obj object attribute requested: '$prop'"
      . ' at ' .  (caller(0))[1] . ', line ' . (caller(0))[2] );
  }

  $object->{$attr} = $val;
}

sub add_obj {
  my ($s, $type, $obj)     = @_;
  my $file                 = $s->{_selected_file};
  my $ot                   = "${type}_obj";
  $s->{_files}{$file}{$ot} = $obj;
}

sub selected_file {
  my $s = shift;
  return $s->{_selected_file};
}

sub has_obj {
  my $s = shift;
  my $type = shift;

  if (!$type) {
    $s->croak ("Missing argument to has method"
      . ' at ' .  (caller(0))[1] . ', line ' . (caller(0))[2] );
  }
  my $file = shift || $s->{_selected_file};
  my $to = "${type}_obj";
  return defined $s->{_files}{$file}{$to};
}

sub get_files {
  my $s = shift;

  my @files = sort keys %{$s->{_files}};
  return @files;
}

sub add_resources {
  my ($s, @resources) = @_;

  foreach my $resource (@resources) {
    _exists($resource);
    $s->_add_file($resource)          if -f $resource;
    $s->_get_file_manifest($resource) if -d $resource;
  }

  $s->_generate_short_names;
}

sub list_files_long {
  my $s = shift;

  my @files = $s->get_files;
  print $_ . "\n" for @files;
}

sub list_files {
  my $s = shift;

  my @files = map { $s->{_files}{$_}{short_path} } keys %{$s->{_files}
+};
  print "\nFiles found in '".$s->{_common_dir}."':\n\n";
  print $_ . "\n" for @files;
}

sub print_short_name {
  my $s = shift;
  print $s->short_name . "\n";
}

sub short_name {
  my $s = shift;
  my $file = $s->{_selected_file};
  $s->{_files}{$file}{short_path};
}

sub _generate_short_names {
  my $s = shift;

  my @files                         = $s->get_files;
  my $file                          = pop @files;
  my @comps                         = split /\//, $file;
  my ($new_string, $longest_string) = '';
  foreach my $cfile (@files) {
    my @ccomps = split /\//, $cfile;
    my $lc     = 0;

    foreach my $comp (@ccomps) {
      if (defined $comps[$lc] && $ccomps[$lc] eq $comps[$lc]) {
        $new_string   .= $ccomps[$lc++] . '/';
        next;
      }
      $longest_string = $new_string;
      @comps          = split /\//, $new_string;
      $new_string     = '';
      last;
    }
  }

  $s->{_common_dir} = $longest_string || (fileparse($file))[1];

  if (@files) {
    foreach my $file ( @files, $file ) {
      $s->{_files}{$file}{short_path} = $file =~ s/$longest_string//r;
    }
  } else {
    $s->{_files}{$file}{short_path} = $file;
  }
}

sub get_filename {
  my $s = shift;
  my $file = $s->{_selected_file} || shift;

  return $s->{_files}{$file}{filename};
}

sub _add_file {
  my ($s, $file) = @_;

  $file = $s->_make_absolute($file);
  $s->{_files}{$file}{full_path} = $file;
  my $filename = (fileparse($file))[0];
  $s->{_files}{$file}{filename} = $filename;
}

sub _make_absolute {
  my ($s, $file) = @_;

  return $file =~ /^\// ? $file : cwd() . "/$file";
}

sub _get_file_manifest {
  my ($s, $dir) = @_;

  opendir (my $dh, $dir) or die "Can't opendir $dir: $!";
  my @dirs_and_files = grep { /^[^\.]/ } readdir($dh);

  my @files = grep { -f "$dir/$_" } @dirs_and_files;
  $s->_add_file("$dir/$_") for @files;

  my @dirs  = grep { -d "$dir/$_" } @dirs_and_files;
  foreach my $tdir (@dirs) {
    opendir (my $tdh, "$dir/$tdir") || die "Can't opendir $tdir: $!";
    $s->_get_file_manifest("$dir/$tdir");
  }

}

sub _exists {
  croak "'$_[0]' does not exist. Aborting." if ! -e $_[0];
}

sub _croak {
  my $msg = shift;
  croak $msg . ' at ' . (caller(1))[1] . ', line ' . (caller(1))[2];
}

sub DESTROY {
}

1; # Magic true value

[1nickt]

Hi, don't have time to look into your issue but for "I'm looking for a way to wipe out my FileImporter class out of memory":

See Class::Unload:

use strict;
use warnings;
use feature 'say';
use Time::Piece;
use Class::Unload;

eval { say gmtime->datetime; 1 } or say $@;

Class::Unload->unload('Time::Piece');

eval { say gmtime->datetime; 1 } or say $@;

require Time::Piece;

eval { say gmtime->datetime; 1 } or say $@;

__END__

$ perl monks/11105002.pl

2019-08-25T22:43:52
Can't locate object method "gmtime" via package "Time::Piece" at /User
+s/1nickt/perl5/perlbrew/perls/perl-5.30.0/lib/5.30.0/darwin-2level/Ti
+me/Piece.pm line 143.

2019-08-25T22:43:52

Hope this helps!