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::SSA::File;

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  => [],
    fonts   => [],
    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*([a-z0-9+ ]+)\s*\]\s*$/io) {
      my $name = lc($1);
      if ($name =~ m{script \s+ info}oix) {
        $section = 'header';
      } elsif ($name eq 'events') {
        $section = 'events';
      } elsif ($name eq 'fonts') {
        $section = 'fonts';
      } 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 {
        $section = 'unknown';
        $self->log(warn => "Unknown section at line $linenum: $line");
      }
      $self->log(debug => "section changed to [$section] at line $linenum");
      next;
    }
    #
    unless ($section) {
      $self->log(warn => "Line $linenum outside any section, skip");
      next;
    }
    if ($section eq 'fonts') {
      if ($line =~ m/^fontname:\s*(.*)/i) {
        my $font = Subtitle::SSA::File->new;
        $font->type('font');
        $font->name($1);
        push @{ $self->{fonts} }, $font;
        next;
      }
      my $curr = $self->{fonts}->[-1]
        or next; # missing 'fontname' line?
      $curr->parse_uue_line($line);
      next;
    }
    # TODO: graphics 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(debug => "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, "";

  if (scalar @{ $self->{fonts} } > 0) {
    push @lines, "[Fonts]";
    foreach my $font (@{ $self->{fonts} }) {
      push @lines, $font->uue_block;
    }
  }

  # TODO: graphics

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

sub style_usage {
  my ($self) = @_;

  my $styles = {};
  foreach my $s (@{ $self->{styles} }) {
    $styles->{ $s->{name} } = 0;
  }

  my $stats = {};
  foreach my $e (@{ $self->{events} }) {
    my $sn = $e->{style} || 'Default';
    if ($sn eq '*Default') {
      # even libass author not knows what really '*' means
      $sn = 'Default';
    }
    $stats->{$sn} //= 0;
    $stats->{$sn}++;
    next if exists $styles->{$sn};
    my $msg = sprintf "Event uses style named '%s' but it's not defined", $sn;
    $self->log(warn => $msg);
  }

  my @unused = grep { $stats->{$_} == 0 } keys %{ $stats };
  foreach my $u (@unused) {
    $self->log(warn => "Style '$u' not used by any event");
  }

  return $stats;
}

sub fonts_usage {
  my ($self) = @_;
  my $stats = {};
  foreach my $s (@{ $self->{styles} }) {
    my $fn = $s->{fontname};
    $stats->{$fn} //= 0;
    $stats->{$fn}++;
  }
  foreach my $e (@{ $self->{events} }) {
    next unless index($e->{text}, '\fn') > 0;
    my ($fn) = ($e->{text} =~ m<\\fn([^\\}]+)>);
    next unless $fn;
    $stats->{$fn} //= 0;
    $stats->{$fn}++;
  }
  return $stats;
}

1;