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     => [],
    timing_fmt => "%d:%02d:%02d.%s",
  };

  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");
        my @fmt = ($self->{type} and $self->{type} eq 'ass')
          ? ASS_STYLE_FMT : SSA_STYLE_FMT;
        $self->{style_fmt} = [ map { lc($_) } @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");
        my @fmt = ($self->{type} and $self->{type} eq 'ass')
          ? ASS_EVENT_FMT : SSA_EVENT_FMT;
        $self->{event_fmt} = [ map { lc($_) } @fmt ];
      }
      $self->parse_event($linenum, $line);
      next;
    }
    $self->log(warn => "unrecognized line at $linenum: $line");
  }

  return scalar @{ $self->{events} };
}

sub build {
  my ($self) = @_;
  my $out = "[Script Info]\n";

  # headers
  foreach my $h (sort keys($self->{headers})) {
    $out .= sprintf "%s: %s\n", $h, $self->{headers}->{$h};
  }
  $out .= "\n";

  # styles
  if ($self->{type} eq 'ass') {
    $out .= "[V4+ Styles]\n";
    $out .= sprintf "Format: %s\n", join(', ' => @{ $self->ASS_STYLE_FMT });
  } else {
    $out .= "[V4 Styles]\n";
    $out .= sprintf "Format: %s\n", join(', ' => @{ $self->SSA_STYLE_FMT });
  }
  my @fields = @{ $self->{style_fmt} };
  foreach my $s (@{ $self->{styles} }) {
    $out .= sprintf "Style: %s\n", join(",", @{$s}{@fields});
  }
  $out .= "\n";

  # events
  $out .= "[Events]\n";
  if ($self->{type} eq 'ass') {
    $out .= sprintf "Format: %s\n", join(', ' => @{ $self->ASS_EVENT_FMT });
  } else {
    $out .= sprintf "Format: %s\n", join(', ' => @{ $self->SSA_EVENT_FMT });
  }
  @fields = @{ $self->{event_fmt} };
  foreach my $e (@{ $self->{events} }) {
    my %event = %{$e};
    $event{start} = $self->build_timing($event{start});
    $event{end}   = $self->build_timing($event{end});
    $event{marked} =~ s/^/Marked=/o if $self->{type} eq 'ssa';
    $out .= sprintf "%s: %s\n", ucfirst($e->{type}), join(',' => @event{@fields});
  }
  $out .= "\n";

  return $out;
}

1;