libsubtitle-perl/lib/Subtitle/SSA.pm

package Subtitle::SSA;

use strict;
use warnings;
use feature qw(switch);
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,
    headers => {},
    styles  => [],
    events  => [],
    log     => [],
  };

  return bless($self, $class);
}

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 $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} };
}

1;