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.

251 lines
7.1 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 => [],
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;