view release on metacpan or  search on metacpan

t/TestSuite.pm  view on Meta::CPAN

=head1 FILES AND DIRECTORIES

=over

=cut

=item B<FAFTS_tempfile()>

    use t::TestSuite qw/ :temp /;
    $tempfile = FAFTS_tempfile %args;

Creates a temporal file.
This file is scheduled for deletion when test-unit completes.
The file is named:
F<skip_$caller_$nick_XXXX>
Known parameters are:

=over

=item I<$caller>

If unset, reasonable default based on B<caller> return is provided.

=item I<$content>

If set will be fed into just created file.

=item I<$dir>

Requests file to be created in specific directory.
B<cwd()> isa default.

=item I<$nick>

Arbitrary identification what has meaning in calling code.
C<void> isa deafult.

=item I<$suffix>

Obvious.

=item I<$unlink>

If TRUE then just created temporal is removed.
Only filename what's left.

=back

Returns a filename.
Due to I<$args{dir}> defaulting filename is always fully qualified;
probably canonicalized.
A filehandle is implicitly closed.

=cut

my @Tempfiles = ( $$ );
sub FAFTS_tempfile ( % ) {
    my %args = @_;
    my $fn =
      sprintf q|skip_%s_%s_XXXX|,
        $args{caller} || ( split m{/}, ( caller )[1])[-1],
        $args{nick} || q|void|;
    my $fh;
    ( $fh, $fn ) = tempfile $fn,
      DIR => $args{dir} || cwd, SUFFIX => $args{suffix} || '';
    push @Tempfiles, $fn;
    print $fh $args{content}                                if $args{content};
    unlink $fn or croak qq|[unlink] ($fn): $!|               if $args{unlink};
    return $fn            }

END { unlink @Tempfiles if $$ == shift @Tempfiles }

=item B<FAFTS_tempdir()>

    use t::TestSuite qw/ :temp /;
    $tempdir = FAFTS_tempdir %args;

Creates a temporal directory.
This directory is scheduled for deletion when test-unit completes.
The directory is named:
F<skip_$caller_$nick_XXXX>.
Known parameters are:

=over

=item I<$caller>

If unset, reasonable default based on B<caller> return is provided.

=item I<$dir>

Overrides default provided by B<File::Temp::tempdir()>.

=item I<$nick>

Arbitrary identification what has meaning in callig code.
C<void> isa default.

=item I<$suffix>

Obvious.

=back

Returns dirname.
If I<$args{dir}> is set, then dirname is expanded to be fully qualified;
no canonicalization.

=cut

sub FAFTS_tempdir ( % ) {
    my %args = @_;
    my $dn = sprintf q|skip_%s_%s_XXXX|,
      $args{caller} || ( split m{/}, ( caller )[1])[-1],
      $args{nick} || q|void|;
    $dn = tempdir $dn,
      DIR => $args{dir}, SUFFIX => $args{suffix}, CLEANUP => 1;
    $dn = sprintf q|%s/%s|, cwd, $dn                        unless $args{dir};
    return $dn           }

=item B<FAFTS_cat_fn()>

    use t::TestSuite qw/ :temp /;
    $new_file = FAFTS_cat_fn $new_dir, $old_file;

A helper routine.
Assists with a target filename preparation.
Returns a basename of I<$old_file> concatenated with I<$new_dir>.
B<(note)> Stolen from DFS (should've been done years ago).

=cut

sub FAFTS_cat_fn ( $$ ) { sprintf q|%s/%s|, shift, ( split m{/}, shift )[-1] }

=item B<FAFTS_get_file()>

    use t::TestSuite qw/ :file /;
    $content = FAFTS_get_file $filename;

Simple file content retriever.
Whatever has been retrieved is passed to L</B<FAFTS_diag()>>.

=cut

sub FAFTS_get_file ( $ ) {
    my $fn = shift @_;
    open my $fho, q|<|, $fn                  or croak qq|[open]{r} ($fn): $!|;
    read $fho, my $buf, -s $fho;
    FAFTS_diag $buf;
    open $fho, q|>|, $fn                     or croak qq|[open]{w} ($fn): $!|;
                     $buf }

=item B<FAFTS_set_file()>

    use t::TestSuite qw/ :file /;
    FAFTS_set_file $filename, $content;

Simple file content setter.
I<filename> is set to I<$content>.
Returns a size I<filename> gets
(pretty useles, for simmetry reasons).
If B<open> fails then B<croaks>.

=cut

sub FAFTS_set_file ( $$ ) {
    my( $fn, $content ) = @_;
    open my $fh, q|>|, $fn                      or croak qq|[open] ($fn): $!|;
    print $fh $content;
                    -s $fh }

=item B<FAFTS_append_file()>

    use t::TestSuite qw/ :file /;
    FAFTS_append_file $filename, $content;

Simple file content appender.
I<content> is appended to I<filename>.
Returns a size I<filename> gets
(pretty useles, but whatever).
If B<open> fails then B<croaks>.

=cut

sub FAFTS_append_file ( $$ ) {
    my( $fn, $content ) = @_;
    open my $fh, q|>>|, $fn                     or croak qq|[open] ($fn): $!|;
    print $fh $content;
                       -s $fh }

=back

=cut

=head1 METHODS AND WRAPPERS

=over

=cut

=item B<FAFTS_prepare_method()>

    use t::TestSuite qw/ :mthd /;
    $method = FAFTS_prepare_method
      $method_path, $method_name, $stderr_name, @cmds;

Simple method preparation wrapper.
I<method_path> is path where to store prepared wanabe method;
I<method_name> is basename of method template, it's supposed to be in F<./t/>
directory of distribution.
I<stderr_name> is path where I<STDERR> of wanabe method will be redirected
(it'll be stuck at the end of wanabe method)
(defaults to F</dev/null>).
I<@cmds> are commands that will be stuck at the end of wanabe method, just
after I<stderr_name>
(they might be ignored by method itself unless supported).
Returns basename of I<method_path> (courtesy);
that basename can be passed to B<F::AF::init()>
(proper configuration through I<$F::AF::CD{lib_method}> provided).

=cut

sub FAFTS_prepare_method ( $$$@ ) {
    my( $fh, $method, $stderr, @cmds ) = ( @_ );
    $stderr ||= q|/dev/null|;
# XXX:201403151708:whynot: Can't use B<FAFTS_get_file()> because it will B<diag()> retrieved.  And it's not going to change.
    open my $fhi, q|<|, qq|t/$method|;
    read $fhi, my $buf, -s $fhi;
    FAFTS_set_file $fh, <<END_OF_METHOD . join '', map qq|$_\n|, @cmds;
$buf;

__DATA__
$stderr
END_OF_METHOD
    chmod 0755, $fh                            or croak qq|[chmod] ($fh): $!|;
           ( split m{/}, $fh )[-1] }

=item B<FAFTS_wrap()>

    use t::TestSuite qw/ :mthd /;
    ( $rv, $stderr, $stdout ) = FAFTS_wrap { die q|gotch ya| };

Safety wrapper around code that could B<die> or B<fork>-and-B<die>.
Returns whatever I<code>.
If I<code> fails, then I<$@> is returned.
In list context also returns whatever has been printed
on I<STDERR> and I<STDOUT>.
In either case I<STDERR> and I<STDOUT> are passed to L</B<FAFTS_diag()>>.

=cut

my $root_pid = $$;
sub FAFTS_wrap ( & )                           {
    require POSIX                              or die q|<POSIX> is missing\n|;
    my $code = shift;
    my $stderr = FAFTS_tempfile nick => q|stderr|;
    open my $bckerr, q|>&|, \*STDERR     or croak qq|push [dup] (STDERR): $!|;
    my $stdout = FAFTS_tempfile nick => q|stdout|;
    open my $bckout, q|>&|, \*STDOUT     or croak qq|push [dup] (STDOUT): $!|;

    open STDERR, q|>|, $stderr;
    open STDOUT, q|>|, $stdout;
    my( $rv, $ee );
    eval { $rv = $code->(); 1 }                                   or $ee = $@;
    $$ != $root_pid                                 and POSIX::_exit( !!$ee );
    open STDERR, q|>&|, $bckerr           or croak qq|pop [dup] (STDERR): $!|;
    open STDOUT, q|>&|, $bckout           or croak qq|pop [dup] (STDOUT): $!|;

    $rv = $ee                                              unless defined $rv;
    FAFTS_diag !defined $rv                    ?           q|RV: (undef)| :
      ref $rv && $rv->isa( q|File::AptFetch| ) ? qq|method: ($rv->{pid})| :
                                                            qq|RV: ($rv)|;
    $stderr = FAFTS_get_file $stderr;
    $stdout = FAFTS_get_file $stdout;
    wantarray ? ( $rv, $stderr, $stdout ) : $rv }

=item B<FAFTS_wait_and_gain()>

    use t::TestSuite qw/ :mthd /;
    ( $rv, $stderr ) = FAFTS_wait_and_gain;

Very special wrapper for B<File::AptFetch::gain()>.
Waits ~10sec until any activity happens on a method side.
Then returns whatever B<F::AF::gain()> has returned
(RV is also passed to B<FAFTS_diag()>).
In list context collected I<STDERR> is returned too.

=cut

sub FAFTS_wait_and_gain ( $;$ )       {
    my $eng = shift @_;
# XXX:201402232036:whynot: Probably fixes this: http://www.cpantesters.org/cpan/report/b9de484c-9594-11e3-ae04-8631d666d1b8
    my $timeout = shift @_ || 20;
    my( $rc, $stderr );
    my $mark = $eng->{message};
    while( 0 < $timeout-- ) {