libsubtitle-perl/lib/Subtitle/SSA.pm

package Subtitle::SSA;

use strict;
use warnings;
use utf8;

use Subtitle::SSA::Header;
use Subtitle::SSA::Style;
use Subtitle::SSA::Event;

use Subtitle::Utils qw(:string);

use base 'Subtitle::BASE';

sub new {
  my ($class, %args) = @_;
  my $self = {
    debug => 0,
    eol   => "\n",
    type  => undef,
    %args,
    h_order => [], # headers order
    headers => {},
    styles  => [],
    events  => [],
    log     => [],
  };

  return bless($self, $class);
}

sub new_event { ... }

sub parse {
  my ($self, $lines) = @_;
  my $linenum = 0;
  my $section;

  foreach my $line (@$lines) {
    $linenum++;
    chomp_all($line);
    trim($line);
    next unless $line;
    study $line;

    # check section switch
    if ($line =~ m/^\s*\[(.+)\]\s*/o) {
      my $name = $1;
      if ($name =~ m{script \s+ info}oix) {
        $section = 'header';
      } elsif ($name =~ m{events}oi) {
        $section = 'events';
      } elsif ($name =~ m{v4(\+)? \s+ styles}oix) {
        $section = 'styles';
        unless ($self->{type}) {
          $self->{type} = ($1) ? 'ass' : 'ssa';
          $self->log(warn => "Set type to $self->{type} because of line $linenum (fallback mode)");
        }
      } else {
        undef $section;
        $self->log(debug => "Unknown section at line $linenum: $line");
      }
      next;
    }
    #
    unless ($section) {
      $self->log(warn => "Line $linenum outside any section, skip");
      next;
    }
    # TODO: fonts section
    # skip comments
    next if $line =~ m{^ \s* ;}xo;
    if ($section eq 'header') {
      my $header = Subtitle::SSA::Header->new;
      unless ($header->parse($line)) {
        $self->log(error => "Can't parse header at line $linenum: $line");
        next;
      }
      my $key = $header->hash_key();
      if (exists $self->{headers}->{$key}) {
        $self->log(warn => "Duplicate header at line $linenum: $header->{name}, replacing");
      } else {
        push @{ $self->{h_order} }, $key;
      }
      $self->{headers}->{$key} = $header;
      if ($key eq 'scripttype') {
        my $type = index($header->{value}, "+") >= 0 ? 'ass' : 'ssa';
        $self->log(info => "File recognized as '$type' type from header at line $linenum");
        $self->{type} = $type;
      }
      next;
    }
    if ($section eq 'styles') {
      if ($line =~ m/^\s*Format:/oi) {
        $self->log(debug => "Set style format from line $linenum");
        next;
      }
      my $style = Subtitle::SSA::Style->new(type => $self->{type});
      if ($style->parse($line)) {
        push @{ $self->{styles} }, $style;
      } else {
        my $error = $style->error();
        $self->log(error => "Can't parse style at line $linenum: $error");
      }
      next;
    }
    if ($section eq 'events') {
      if ($line =~ m/^\s*Format:/oi) {
        $self->log(debug => "Set event format from line $linenum");
        next;
      }
      my $event = Subtitle::SSA::Event->new(type => $self->{type});
      if ($event->parse($line)) {
        push @{ $self->{events} }, $event;
      } else {
        my $error = $event->error();
        $self->log(error => "Can't parse event at line $linenum: $error");
      }
      next;
    }
    $self->log(warn => "unrecognized line at line $linenum: $line");
  }

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

sub build {
  my ($self) = @_;
  my (@lines, $out);

  # headers
  push @lines, "[Script Info]";
  push @lines, "; generated with Subtitle::SSA";
  foreach my $key (@{ $self->{h_order} }) {
    my $h = $self->{headers}->{$key};
    push @lines, $h->to_string();
  }
  push @lines, "";

  # styles
  if ($self->{type} eq 'ass') {
    push @lines, "[V4+ Styles]";
  } else {
    push @lines, "[V4 Styles]";
  }
  push @lines, Subtitle::SSA::Style->new(type => $self->{type})->get_format_line();
  foreach my $s (@{ $self->{styles} }) {
    push @lines, $s->to_string();
  }
  push @lines, "";

  # events
  push @lines, "[Events]";
  push @lines, Subtitle::SSA::Event->new(type => $self->{type})->get_format_line();
  foreach my $e (@{ $self->{events} }) {
    push @lines, $e->to_string();
  }
  push @lines, "";

  # TODO: fonts

  return join($self->{eol}, @lines);
}

1;