File Coverage

blib/lib/Text/Slidez.pm

Criterion	Covered	Total	%
statement	12	12	100.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	16	16	100.0

package Text::Slidez;
$VERSION = v0.0.1;

use warnings;
use strict;
use Carp;

use base 'Shebangml';
use Class::Accessor::Classy;
lw 'slides';
no  Class::Accessor::Classy;

use XML::Bits qw(T);

=head1 NAME

Text::Slidez - format slideshows into XHTML

=head1 SYNOPSIS

See L for the command-line frontend.

  use Text::Slidez;

  my $slidez = Text::Slidez->new;
  $slidez->load('my_slides.hbml');
  foreach my $slide ($slidez->slides) {
    ...
  }

=cut


=head2 load

  $slidez->load('my_slides.hbml');

=cut

sub load {
  my $self = shift;
  my $input = shift;

  local $self->{ctx};
  local $self->{started};

  $self->process($input);

  # bit of cleanup on the innards:
  foreach my $slide ($self->slides) {
    my @kids =
      grep({not ($_->tag eq '' and "$_" eq '')} $slide->children);
    shift(@kids) while($kids[0] =~ m/^\s+$/);
    pop(@kids) if($kids[-1] =~ m/^\n\s*$/);
    $slide->{children} = [@kids];
  }

  #warn join("\n---\n", @{$self->{slides}});
  return($self);
} # load ###############################################################

=head2 dump

Dump a marked-up version of the raw data.

  warn $slidez->dump;

=cut

sub dump {
  my $self = shift;
  return join("\n---\n",
    map({join("|", map({"($_)=" . $_->tag} $_->children))}
      $self->slides)
  ), "\n";
} # dump ###############################################################

=head2 format_slide

Format a single slide for output.

  my $xhtml = $slidez->format_slide($slide, %opts);

=cut

sub format_slide {
  my $self = shift;
  my ($slide, %opts) = @_;

  my @parts = $self->_part_slide($slide);

  # see if we can deduce a title from the first time we see one
  unless($opts{title} or $self->{title}) {
    if($parts[2] and @{$parts[1]} == 0) {
      my $text = join('', @{$parts[0]});
      ($text) = split(/\n/, $text);
      $text =~ s/<[^>]+>//g;
      $self->{title} = $text;
    }
  }

  my $page = T{html =>
    T{head =>
      T{title => $opts{title}||$self->{title}||'slidez'},
      T{meta =>
        ['http-equiv' => "Content-Type",
          content => "text/html;charset=utf-8"]},
      T{meta =>
        ['http-equiv'=>"Content-Style-Type",
          content => "text/css"]},
      T{link =>
        [rel=> 'stylesheet', href => 'style.css', type => 'text/css']},
      T{script => [type => 'text/javascript'],
        $self->_mk_script(%opts);
      },
    },
    T{body =>}
  };
  $page->set_doctype('html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
  "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"');

  my $div = $page->child(-1)->create_child(div => [class => 'slide']);

  $self->_handle_parts($div, \@parts,
    calc_width => sub {
      my $n = $self->_calc_width(shift);
      $n > 20 ? '900px' : $n . 'em';
    },
  );

  return($page);

} # format_slide #######################################################

=head2 as_single_page

  $slidez->as_single_page;

=cut

sub as_single_page {
  my $self = shift;

  my @slides = $self->slides;

  my $page = T{html =>
    T{head =>
      T{title => },
      T{meta =>
        ['http-equiv' => "Content-Type",
          content => "text/html;charset=utf-8"]},
      T{meta =>
        ['http-equiv'=>"Content-Style-Type",
          content => "text/css"]},
      T{link =>
        [rel=> 'stylesheet', href => 'style-flat.css', type => 'text/css']},
    },
    T{body =>}
  };
  $page->set_doctype('html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
  "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"');

  my $title = $page->child(0)->child(0);
  my $body = $page->child(-1);
  my $outer = $body->create_child(div => [style=> "width: 600px"]);

  for my $i (0..$#slides) {
    my $div = $outer->create_child(div => [class => 'slide']);

    my @parts = $self->_part_slide($slides[$i]);
    unless($i) { # look for title on the first slide
      if($parts[2] and @{$parts[1]} == 0) {
        my $text = join('', @{$parts[0]});
        ($text) = split(/\n/, $text);
        $text =~ s/^\s+//;
        $text =~ s/<[^>]+>//g;
        $title->create_child(''=> $text);
      }
    }

    #warn "\n\nhandle $i\n\n\n";
    $self->_handle_parts($div, \@parts,
      calc_width => sub {
        my $n = $self->_calc_width(shift);
        $n > 20 ? '500px' : $n . 'em';
      },
    );

    $outer->create_child(div =>
      [class => 'wee', style => "width:100%; text-align: right"],
    )->create_child('' =>
      '' => $i+1 . ' / ' . scalar(@slides));
    $outer->create_child(hr =>);
  }

  return($page);
} # as_single_page #####################################################

my %span_map = (
  L => 'large',
  M => 'medium',
  S => 'small',
);

sub _atag {
  my $self = shift;
  my ($tag, $atts) = @_;

  my @attr = $atts ? $atts->atts : ();
  if(my $class = $span_map{$tag}) {
    $tag = 'span';
    push(@attr, class => $class);
  }

  my $el = XML::Bits->new($tag, @attr ? \@attr : ());

  if($self->{ctx}) {
    croak("no nested slides") if($tag eq 'slide');
    $self->{ctx}->add_child($el);
    $self->{ctx} = $el;
  }
  else {
    if($tag eq 'slide') {
      croak("no start element") unless($self->{started});
      my $sl = $self->{slides} ||= [];
      $self->{ctx} = $el;
      push(@$sl, $el);
    }
    elsif($tag eq 'slides') {
      $self->{started} = 1;
    }
    else {
      croak("content '$tag' outside of slide!");
    }
  }

  return($el);
}

=head2 do_code

  $slidez->do_code($tag, $atts, $string);

=cut

sub do_code {
  my $self = shift;
  my ($tag, $atts, $string) = @_;

  my %atts = $atts ? $atts->atts : ();

  my $make = sub {
    my $pre = $self->{ctx}->create_child(pre => [%atts]);
    $pre->create_child('' => $_) for(@_);
  };

  my $ft = delete($atts{type});

  require Text::VimColor;
  my $cache;
  if($string) {
    # XXX how to do the caching?
    # warn "string code is slow: $string\n";
  }
  else {
    my $src = delete $atts{src} or croak("must have src");
    my $input = File::Fu->file($src);
    my $cache_dir = File::Fu->dir('.cache');
    if($cache_dir->d) {
      $cache = $cache_dir + $input->file;
      if($cache->e and $cache->stat->mtime >= $input->stat->mtime) {
        warn "load $input from cache\n";
        return($make->(scalar $cache->read));
      }
    }
    my %ftmap = (
      html => 'html',
      hbml => 'hbml',
      pl   => 'perl',
      pm   => 'perl',
    );
    unless($ft) {
      my ($ext) = $input =~ m/\.([^\.]+)$/;
      $ft = $ftmap{$ext} if($ftmap{$ext});
    }
    $string = $input->read;
  }
  my $html = Text::VimColor->new(
    string   => $string,
    $ft ? (filetype => $ft) : (),
  )->html;

  # leading whitespace cleanup
  $html =~ s{]*>(\s+)}{$1}g;
  # pull whitespace out front
  $html =~ s{^(]+>)(\s+)}{$2$1}mg;
  $html =~ s/\n+$//;
  $make->($html);
  $cache->write($html) if($cache);

} # do_code ############################################################

=head1 Shebangml Callbacks

These are really part of the parser class and not the API.

=head2 put_tag

  $slidez->put_tag($tag, $atts, $string);

=cut

sub put_tag {
  my $self = shift;
  my ($tag, $atts, $string) = @_;

  return $self->do_code(@_) if($tag eq 'code');
  return $self->do_include($atts) if($tag eq '.include');

  my $el = $self->_atag($tag, $atts);

  $el->create_child('' => $self->escape_text($string))
    if(defined($string));

  $self->{ctx} = $el->parent;

} # put_tag ############################################################

=head2 put_tag_start

  $slidez->put_tag_start($tag, $atts);

=cut

sub put_tag_start {
  my $self = shift;
  my ($tag, $atts) = @_;

  my $el = $self->_atag($tag, $atts);

} # put_tag_start ######################################################

=head2 put_tag_end

  $slidez->put_tag_end($tag);

=cut

sub put_tag_end {
  my $self = shift;
  my ($tag) = @_;

  $tag = 'span' if($span_map{$tag});

  my $ctx = delete($self->{ctx});
  return() if($tag eq 'slides');
  ($ctx->tag eq $tag) or croak($ctx->tag, " is not a $tag!");
  croak("context fail $tag")
    unless($self->{ctx} = $ctx->parent or $tag eq 'slide');

} # put_tag_end ########################################################

=head2 put_text

  $slidez->put_text($text);

=cut

sub put_text {
  my $self = shift;
  my ($text) = @_;

  my $ctx = $self->{ctx} or return;
  $ctx->create_child('',
    length($text) ? $self->escape_text($text) : '');
  # TODO escaped text might actually contain some certain tags :-/

} # put_text ###########################################################

=head2 _part_slide

  my @parts = $self->_part_slide($slide);

=cut

sub _part_slide {
  my $self = shift;
  my ($slide) = @_;

  my @children = $slide->children;
  pop(@children) if($children[-1] =~ m/^\s*$/);
  my @parts = ([]);
  my $sp;
  # warn join(",", map({$_->type} @children));
  # if($children[0]->is_text) { # undenting :-/
  #   $children[0]->{content} =~ s/^(\s+)//;
  #   $sp = $1;
  # }
  # warn "sp is >$sp<\n";
  while(@children) {
    my $bit = shift(@children);
    if($bit->is_text and $bit->{content} =~ s/\n$//) {
      #$bit->{content} =~ s/^$sp// if(defined($sp));
      push(@{$parts[-1]}, $bit) if(length($bit));
      push(@parts, []); # start a new group
    }
    else {
      #if($bit->is_text) { $bit->{content} =~ s/^$sp// if(defined($sp)); }
      push(@{$parts[-1]}, $bit);
    }
  }

  foreach my $part (@parts) {
    next unless(@$part);
    shift(@$part)
      while($part->[0]->is_text and $part->[0] =~ m/^\s+$/);
  }

  # drop the trailing chunk
  pop(@parts) if(@{$parts[-1]} == 0);

  if(0) {
    warn "slide:\n";
    warn join("\n---\n", map({join('|', @$_)} @parts)), "\n";
    warn "\n\n\n";
  }

  return(@parts);
} # _part_slide ########################################################

=head2 _calc_width

  my $n = $self->_calc_width($text);

=cut

sub _calc_width {
  my $self = shift;
  my $text = shift;

  my @lines = split(/\n|/, $text);
  my ($width) = sort({$b <=> $a}
    map({s/<[^>]+>//g; s/&[^;]+;/./g; length($_)} @lines));
  $width *= 0.625; # emperical em-width adjustment
} # _calc_width ########################################################

=head2 _handle_parts

  $self->_handle_parts($ctx, \@parts, %opts);

=cut

sub _handle_parts {
  my $self = shift;
  my ($ctx, $parts, %opts) = @_;

  my @parts = @$parts;
  my $calc_width = $opts{calc_width};

  if($parts[2] and @{$parts[1]} == 0) {
    my $title_chunk = shift(@parts);
    shift(@parts); # scrap
    $ctx->create_child(div => [class => 'title'], @$title_chunk);
    $ctx->create_child('br');
  }
  else {
    # center the whole thing vertically
    $ctx = $ctx->create_child(div => [class => 'cell']);
  }

  while(@parts) {
    my $part = shift(@parts);
    next unless(@$part);
    if(@$part == 1 and $part->[0] =~ m/^[^<]*[^<]*$/) {
      $ctx->add_child($part->[0]);
      next;
    }
    # pre fixup
    if(@$part == 1 and $part->[0]->tag eq 'pre') {
      my ($pre) = @$part;
      my $text = join('', $pre->children);
      $text =~ s/^\n//;
      if($text =~ s/^(\s+)//) {
        my $sp = $1;
        $text =~ s/^$sp//mg;
      }
      my %atts = $pre->atts;
      my $class = $atts{class} || '';
      $pre->{children} = [];
      $pre->create_child('' => $text);
      my $width = $calc_width->($text);
      my $inner = $ctx->create_child(
        div => [class => "auto left $class",
          style => "width: $width"]);
      $inner->add_child($pre);
      next;
    }
    # bullet points
    if($part->[0] =~ m/^(\s*)\* /) {
      my $sp = $1;
      my @points = $part;
      # then go back to the well:
      while(@parts and $parts[0][0] =~ m/^\s*\* /) {
        push(@points, shift(@parts));
      }
      foreach my $point (@points) {
        $point->[0]->is_text or die;
        $point->[0]->{content} =~ s/^$sp//;
      }

      my $width = $calc_width->(join("\n", map({@$_} @points)));
      my $inner = $ctx->create_child(
        div => [class => "auto left", style => "width: $width"]);
      my $top = $inner->create_child(ul =>);
      my @d = ($top);
      foreach my $point (@points) {
        $point->[0]->{content} =~ s/(\s*)\*\s+//;
        my $ws = length($1)/2;
        # warn "ws: $ws ($point->[0]->{content})\n";
        if($ws) {
          $d[$ws] ||= $d[$ws-1]->child(-1)->create_child(ul =>);
        }
        else {
          @d = ($top);
        }
        $d[$ws]->create_child(li => @$point);
      }
      # warn "yay: $top\n";
      next;
    }
    my $inner = $ctx->create_child(div =>);
    $inner->add_child($_) for(@$part);
  }

} # _handle_parts ######################################################

=head2 _mk_script

  $self->_mk_script(%opts);

=cut

sub _mk_script {
  my $self = shift;
  my (%opts) = @_;

  my $script =
  ($opts{next} ? qq(var next="$opts{next}"\n) .
    "var down=0; document.onmousedown=function(e) { down=1 }\n".
    "           document.onmousemove=function(e) { down=0; }\n".
    "document.onmouseup=function(e) {\n" .
    "if(down == 1) {window.location = next;}; }\n" : ''
  ) .
  ($opts{prev}  ? qq(var prev="$opts{prev}"\n) : '') .
  ($opts{first} ? qq(var first="$opts{first}"\n) : '') .
  ($opts{last}  ? qq(var last="$opts{last}"\n) : '');
  my $func = <<'  ---';
  document.onkeypress=function(e) {
    var e=window.event || e
    var n=e.keyCode || e.which
    switch (n) {
      -SWITCH-
    }
  }
  ---
  my $switch = join("\n", map({$_ . ' break;'}
    ($opts{next}  ? 'case 32 : window.location = next;' : ()),
    ($opts{prev}  ? 'case 8  : window.location = prev;' : ()),
    ($opts{first} ? 'case 36 : window.location = first;' : ()),
    ($opts{last}  ? 'case 35 : window.location = last;'  : ()),
  ));
  $func =~ s/-SWITCH-/$switch/;

  return($script . $func);
} # _mk_script #########################################################

=head1 AUTHOR

Eric Wilhelm @

http://scratchcomputing.com/

=head1 BUGS

If you found this module on CPAN, please report any bugs or feature
requests through the web interface at L.  I will be
notified, and then you'll automatically be notified of progress on your
bug as I make changes.

If you pulled this development version from my /svn/, please contact me
directly.

=head1 COPYRIGHT

Copyright (C) 2009 Eric L. Wilhelm, All Rights Reserved.

=head1 NO WARRANTY

Absolutely, positively NO WARRANTY, neither express or implied, is
offered with this software.  You use this software at your own risk.  In
case of loss, no person or entity owes you anything whatsoever.  You
have been warned.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# vi:ts=2:sw=2:et:sta
1;