File Coverage

blib/lib/Test/Smart/Interface/File.pm

Criterion	Covered	Total	%
statement	66	67	98.5
branch	16	20	80.0
condition	4	9	44.4
subroutine	15	15	100.0
pod	4	4	100.0
total	105	115	91.3

package Test::Smart::Interface::File;

use strict;
use warnings;
use base qw(Test::Smart::Interface);

use File::Spec::Functions;
use File::Path;

use Test::Smart::Question;

=head1 NAME

Test::Smart::Interface::File - File based human interface layer for Test::Smart

=head1 SYNOPSIS

  use Test::Smart;

  initialize('Test::Smart::Interface::File',directory => '/home/tester');

  # Test::Smart normally from here

=head1 DESCRIPTION

=cut

sub load {
  my $class = shift;
  my %args  = @_;
  my $self  = {};
  $self->{_nextid}     = 0;
  $self->{_dir}       = $args{dir} ||= $args{directory} ||= '.';
  $self->{_questions} = [];

  unless( -e $self->{_dir}) {
    $self->{_dircreat} = 1;
    mkpath($self->{_dir}) or return undef;
  }

  bless $self,$class;
}

sub submit {
  my ($self,$question,$name) = @_;

  my $Qobj = Test::Smart::Question->new(
               question =>$question,
               name     =>$name,
               id       =>$self->{_nextid});

  push @{$self->{_questions}},$self->{_nextid};

  $self->{_nextid}++;

  open my $qfile, '>', $self->_get_filename($Qobj->id ,"q") or
    $self->err("Could not open question file: $!") and return undef;

  print $qfile <
$name
---------
$question
QUESTION

  close $qfile;

  return $Qobj;
}

sub has_answer {
  my ($self,$Qobj) = @_;

  my @names = map { $self->_get_filename($Qobj->id,$_) } qw(y n s);

  foreach (@names) {
    return 1 if -e $_;
  }

  return 0;
}

sub answer {
  my ($self,$Qobj) = @_;

  $self->err('Question does not have an answer yet') and return undef unless $self->has_answer($Qobj);
  my $id = $Qobj->id;

  $Qobj->answer('yes',scalar $self->_getcomments($id,'y')), return 1 if $self->_is_y($id);
  $Qobj->answer('no',scalar $self->_getcomments($id,'n')), return 1 if $self->_is_n($id);
  $Qobj->skip(scalar $self->_getcomments($id,'s')),  return 1 if $self->_is_s($id);

  return undef;
}

sub _get_filename {
  my ($self,$id,$suffix) = @_;

  return catfile($self->{_dir},"question-$id.$suffix");
}

sub _getcomments {
  my ($self,$id,$suffix) = @_;

  open my $commentfile,'<',$self->_get_filename($id,$suffix);
  my @commentlines = <$commentfile>;
  close $commentfile;

  return wantarray ? @commentlines : join '',@commentlines;
}

foreach my $suffix (qw(y n s)){
  no strict 'refs';
  *{__PACKAGE__."::_is_$suffix"} = sub {
    my ($self,$id) = @_;
    return -e $self->_get_filename($id,$suffix);
  };
}

sub DESTROY {
  my $self = shift;

  foreach my $qid (@{$self->{_questions}}) {
    unlink glob catfile $self->_get_filename($qid,"*");
  }

  rmdir $self->{_dir} if $self->{_dircreat};
}

=head1 AUTHOR

Edgar A. Bering, [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007 by Edgar A. Bering

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.

=cut

1;