File Coverage

blib/lib/WWW/Slides/SlideShow.pm

Criterion	Covered	Total	%
statement	109	154	70.7
branch	28	50	56.0
condition	3	3	100.0
subroutine	20	25	80.0
pod	0	13	0.0
total	160	245	65.3

package WWW::Slides::SlideShow;
{
   use version; our $VERSION = qv('0.0.7');

   use warnings;
   use strict;
   use Carp;
   use English qw( -no_match_vars );

   use Object::InsideOut;

   # Other recommended modules (uncomment to use):
   #  use IO::Prompt;
   #  use Perl6::Export;
   #  use Perl6::Slurp;
   #  use Perl6::Say;
   #  use Regexp::Autoflags;
   #  use Readonly;

   # Module implementation here
   my @filename : Field    # File to read for slides
     : Get(Name => 'filename')    # Public getter
     : Std(Name => 'filename', Private => 1);

   my @preamble : Field           # HTML/whatever preamble
     : Std(Name => 'preamble');
   my @slides : Field             # slide repository
     : Std(Name => 'slides', Private => 1);
   my @postamble : Field          # HTML/whatever postamble
     : Std(Name => 'postamble');

   sub read_line_by_line : Private {
      my $self = shift;
      my ($iterator) = @_;

      my $preamble;
      while (defined $iterator->()) {
         $preamble .= $_;
         last if /
      }
      $self->set_preamble($preamble);

      my @slides;
      my $slide     = '';
      my $div_id    = '';
      my $div_depth = 0;
      my $div_mark  = 0;
      my $postamble = '';
      while (defined $iterator->()) {
         if (m{}mxsi) {
            $postamble = $_;
            last;
         }
         $slide .= $_;
         if (m{]*\sid="([^"]*)"}mxsi) {
            $div_id   = $1;
            $div_mark = $div_depth++;
         }
         elsif (m{
            ++$div_depth;
         }
         if (m{}mxsi) {
            if (--$div_depth == $div_mark) {
               push @slides, {div_id => $div_id, slide => $slide};
               $slide  = '';
               $div_id = '';
            }
         } ## end if (m{}mxsi)
      } ## end while (defined $iterator->...
      $self->set_slides(\@slides);

      $self->set_postamble($postamble . join('', $iterator->()));

      return;
   } ## end sub read_line_by_line :

   sub read_fh : Private {
      my $self = shift;
      my ($fh) = @_;

      return $self->read_line_by_line(
         sub {
            return <$fh> if wantarray;
            return $_ = <$fh>;
         }
      );
   } ## end sub read_fh :

   sub read {
      my $self = shift;
      my ($what) = @_;

      croak "undefined file to read slide show" unless defined $what;

      my ($fh, $was_mine);
      if (ref $what eq 'SCALAR') {    # Straight string, in-memory handle
         $self->set_filename('');
         eval { open $fh, '<', $what or die };    # The perl 5.8 way...

         if ($EVAL_ERROR) {    # Try to use IO::String, if available...
            eval {
               require IO::String;
               $fh = IO::String->new($$what);
            };
         } ## end if ($EVAL_ERROR)

         # I really wouldn't fall back to this, because I've to
         # split it all in advance, but this is the best I can think
         # at the moment
         if ($EVAL_ERROR) {

            # split and re-insert newlines. I don't really mind that
            # I could potentially add a newline to the final line.
            my @lines = map { "$_\n" } split /\n/, $$what;
            return $self->read_line_by_line(
               sub {
                  return splice @lines if wantarray;
                  return $_ = shift @lines;
               }
            );
         } ## end if ($EVAL_ERROR)

         $was_mine = 1;
      } ## end if (ref $what eq 'SCALAR')
      elsif (ref $what eq 'GLOB') {
         $self->set_filename('');
         $fh = $what;
      }
      elsif (ref $what eq 'ARRAY') {    # One file per slide
         $self->set_filename('');
         return $self->read_slides(@$what);
      }
      else {
         $self->set_filename($what);
         open $fh, '<', $what
           or croak "can't open('$what'): $OS_ERROR";
         $was_mine = 1;
      } ## end else [ if (ref $what eq 'SCALAR')

      my $retval = $self->read_fh($fh);
      close $fh if $was_mine;

      return $retval;
   } ## end sub read

   sub read_slides {
      my $self = shift;

      $self->set_preamble('

                      "http://www.w3.org/TR/html4/loose.dtd">


      WWW::Slides presentation


      ');

      $self->set_postamble("\n\n");

      my @slides;
      for my $filename (@_) {
         my $text   = $self->read_slide($filename);
         my $div_id = 'slide' . scalar @slides;
         push @slides,
           {
            div_id => $div_id,
            slide  => qq{\n\n"
           };
      } ## end for my $filename (@_)
      $self->set_slides(\@slides);
      return 1;
   } ## end sub read_slides

   sub read_slide {    # append a slide
      my $self = shift;
      my ($filename) = @_;
      require HTML::Parser;
      my $parser = HTML::Parser->new(api_version => 3) or die $!;

      my $text = '';
      my $start_handler = sub {
         my ($tag, $self) = @_;
         return unless lc($tag) eq 'body';
         $self->handler(default => sub { $text .= shift }, 'text');
         $self->handler(start   => sub { $text .= shift }, 'text');
         $self->handler(
            end => sub {
               my ($tagname, $self, $newtext) = @_;
               if (lc($tagname) eq 'body') {
                  $self->eof();
               }
               else {
                  $text .= $newtext if defined $newtext;
               }
            },
            'tagname,self,text'
         );
      };
      $parser->handler(start => $start_handler, 'tagname,self');

      $parser->parse_file($filename)
        or die "could not parse '$filename': $OS_ERROR";
      return $text;
   } ## end sub read_slide

   sub add_headers {    # Headers are ok for the moment
      my $self = shift;
      return;
   }

   sub get_ping {
      return "\n";
   }

   sub get_show_div {
      my $self       = shift;
      my ($slide_no) = @_;
      my $div_id     = $self->_get_slide($slide_no)->{div_id};
      return "#$div_id { display: block }\n";
   } ## end sub get_show_div

   sub get_hide_div {
      my $self       = shift;
      my ($slide_no) = @_;
      my $div_id     = $self->_get_slide($slide_no)->{div_id};
      return "#$div_id { display: none }\n";
   } ## end sub get_hide_div

   sub get_slide {
      my $self = shift;
      my ($slide_no) = @_;
      return $self->_get_slide($slide_no)->{slide};
   }

   sub _get_slide {
      my $self = shift;
      my ($n) = @_;
      return $self->get_slides()->[$n - 1];
   }

   sub id_first {
      return 1;
   }

   sub id_last {
      my $self = shift;
      return scalar @{$self->get_slides()};
   }

   sub id_next {
      my $self = shift;
      my ($id) = @_;
      return ($id + 1) if $self->validate_slide_id($id + 1);
      return $id;
   } ## end sub id_next

   sub id_previous {
      my $self = shift;
      my ($id) = @_;
      return ($id - 1) if $self->validate_slide_id($id - 1);
      return $id;
   } ## end sub id_previous

   sub validate_slide_id {
      my $self = shift;
      my ($id) = @_;
      return if $id !~ /\A\d+\z/;
      return ($id > 0) && ($id <= @{$self->get_slides()});
   } ## end sub validate_slide_id

}

1;    # Magic true value required at end of module
__END__