You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

204 lines
5.8 KiB

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;