* Subtitle::SSA : first working version

lib/Subtitle/SSA.pm

@@ -7,14 +7,28 @@ use utf8;
 
 use base 'Subtitle::BASE';
 
+use constant SSA_STYLE_FMT => [qw(name fontname fontsize primarycolour secondarycolour
+  tertiarycolour backcolour bold italic
+  borderstyle outline shadow alignment marginl marginr marginv alphalevel encoding)];
+
+use constant ASS_STYLE_FMT => [qw(name fontname fontsize primarycolour secondarycolour
+  outlinecolour  backcolour bold italic underline strikeout scalex scaley spacing angle
+  borderstyle outline shadow alignment marginl marginr marginv encoding)];
+
+use constant SSA_EVENT_FMT => [qw(marked start end style name marginl marginr marginv effect text)];
+use constant ASS_EVENT_FMT => [qw(layer  start end style name marginl marginr marginv effect text)];
+
 sub new {
   my ($class, %args) = @_;
   my $self = {
     debug  => 0,
     eol    => "\n",
+    type   => undef,
     %args,
-    events => [],
+    headers => {},
-    log    => [],
+    styles  => [],
+    events  => [],
+    log     => [],
   };
 
   return bless($self, $class);
@@ -22,7 +36,6 @@ sub new {
 
 sub parse_timing {
   my ($self, $str) = @_;
-  ...
   my $time = 0.0;
   return unless $str =~ m/(\d+):(\d+):(\d+)([.,])(\d+)/oi;
   my ($hrs, $min, $sec, $delim, $msec) = ($1, $2, $3, $4, $5);
@@ -54,14 +67,168 @@ sub parse_timing {
   return $time;
 }
 
-sub new_event { return +{ id => undef, timing => undef, style => undef, text => undef }; }
+sub parse_header {
+  my ($self, $linenum, $line) = @_;
+
+  return if $line =~ m/^\s*;/; # comment
+
+  my ($name, $value) = ($line =~ m/^(.+):\s*(.*)$/o);
+  if ($name and not defined $value) {
+    $self->log(debug => "Header line with empty value at $linenum, skipped: $line");
+    return;
+  }
+  unless ($name) {
+    $self->log(debug => "Can't parse header line at $linenum: $line");
+    return;
+  }
+  $self->log(warn => "Duplicate header $name at line $linenum, overwriting")
+    if (exists $self->{headers}->{$name});
+
+  $self->{headers}->{$name} = $value;
+  if (lc($name) eq 'scripttype') {
+    $self->{type} = (lc($value) eq 'v4.00+') ? 'ass' : 'ssa';
+    $self->log(debug => "Set type to $self->{type} because of line $linenum: $line");
+  }
+  return;
+}
+
+sub parse_style {
+  my ($self, $linenum, $line) = @_;
+
+  my ($rest) = ($line =~ m/^\s*Style:\s*(.+)/oi);
+  unless ($rest) {
+    $self->log(warn => "Can't parse style at line $linenum: $line");
+    return;
+  }
+
+  my $fields = scalar @{ $self->{style_fmt} };
+  my @values = split /\s*,\s*/, $rest;
+  if($fields != scalar @values) {
+    $self->log(warn => "Style line fields at $linenum not equals number of style format fields");
+    return;
+  }
+
+  my $style = {};
+  for (my $i = 0; $i < $fields; $i++) {
+    $style->{$self->{style_fmt}->[$i]} = $values[$i];
+  }
+  push @{ $self->{styles} }, $style;
+
+  return;
+}
+
+sub parse_event {
+  my ($self, $linenum, $line) = @_;
+
+  my ($type, $rest) = ($line =~ m/^\s*(Dialogue):\s*(.+)/oi);
+  unless ($rest) {
+    $self->log(warn => "Can't parse style at line $linenum: $line");
+    return;
+  }
+
+  my $fields = scalar @{ $self->{event_fmt} };
+  my @values = split /\s*,\s*/, $rest, $fields;
+  if($fields > scalar @values) {
+    $self->log(warn => "Event line fields at $linenum less than number of style format fields ($fields)");
+    return;
+  }
+
+  my $event = { type => lc($type) };
+  for (my $i = 0; $i < $fields; $i++) {
+    $event->{$self->{event_fmt}->[$i]} = $values[$i];
+  }
+  foreach my $key (qw(start end)) {
+    next unless $event->{$key};
+    $event->{$key} = $self->parse_timing($event->{$key});
+  }
+  $event->{marked} =~ s/^Marked=\s*//oi
+    if ($self->{type} eq 'ssa');
+
+  push @{ $self->{events} }, $event;
+  return;
+}
+
+sub new_event { ... }
 
 sub parse {
   my ($self, $lines) = @_;
   my $linenum = 0;
-  my $event;
+  my $section;
 
   foreach my $line (@$lines) {
+    $linenum++;
+    $line = $self->chomp($line);
+    $line = $self->trim($line);
+    next unless $line;
+    study $line;
+
+    # check section switch
+    if ($line =~ m/^\s*\[(.+)\]\s*/o) {
+      my $name = $1;
+      given ($name) {
+        when (m/script\s+info/oi) { $section = "header"; }
+        when (m/events/oi)        { $section = "events"; }
+        when (m/v4(\+)?\s+styles/oi) {
+          $section = "styles";
+          unless ($self->{type}) {
+            $self->{type} = ($1) ? 'ass' : 'ssa';
+            $self->log(warn => "Set type to $self->{type} because of $linenum (fallback mode)");
+          }
+        }
+        default {
+          $self->log(debug => "Unknown section at line $linenum: $line");
+        }
+      }
+      next;
+    }
+    #
+    unless ($section) {
+      $self->log(warn => "Line $linenum outside any section: $line");
+      next;
+    }
+    if ($section eq 'header') {
+      $self->parse_header($linenum, $line);
+      next;
+    }
+    if ($section eq 'styles') {
+      if ($line =~ m/^\s*Format:\s*(.*)/oi) {
+        if ($self->{style_fmt}) {
+          $self->log(error => "Style format found at line $linenum, but already set before");
+          next;
+        }
+        my @fmt = map { lc($_) } split(/\s*,\s*/o, $1);
+        $self->{style_fmt} = \@fmt;
+        $self->log(debug => "Set style format from line $linenum");
+        next;
+      }
+      unless ($self->{style_fmt}) {
+        $self->log(warn => "Style format still not set, assuming default for $self->{type} type");
+        $self->{style_fmt} = ($self->{type} and $self->{type} eq 'ass')
+          ? ASS_STYLE_FMT : SSA_STYLE_FMT;
+      }
+      $self->parse_style($linenum, $line);
+      next;
+    }
+    if ($section eq 'events') {
+      if ($line =~ m/^\s*Format:\s*(.*)/oi) {
+        if ($self->{event_fmt}) {
+          $self->log(error => "Event format found at line $linenum, but already set before");
+          next;
+        }
+        my @fmt = map { lc($_) } split(/\s*,\s*/o, $1);
+        $self->{event_fmt} = \@fmt;
+        $self->log(debug => "Set event format from line $linenum");
+        next;
+      }
+      unless ($self->{event_fmt}) {
+        $self->log(warn => "Event format still not set, assuming default for $self->{type} type");
+        $self->{event_fmt} = ($self->{type} and $self->{type} eq 'ass')
+          ? ASS_EVENT_FMT : SSA_EVENT_FMT;
+      }
+      $self->parse_event($linenum, $line);
+      next;
+    }
+    $self->log(warn => "unrecognized line at $linenum: $line");
   }
 
   return scalar @{ $self->{events} };