Browse Source

* Subtitle::SSA : first working version

master
Alex 'AdUser' Z 10 years ago
parent
commit
8f1e59f67b
  1. 173
      lib/Subtitle/SSA.pm

173
lib/Subtitle/SSA.pm

@ -7,12 +7,26 @@ use utf8;
use base 'Subtitle::BASE'; 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 { sub new {
my ($class, %args) = @_; my ($class, %args) = @_;
my $self = { my $self = {
debug => 0, debug => 0,
eol => "\n", eol => "\n",
type => undef,
%args, %args,
headers => {},
styles => [],
events => [], events => [],
log => [], log => [],
}; };
@ -22,7 +36,6 @@ sub new {
sub parse_timing { sub parse_timing {
my ($self, $str) = @_; my ($self, $str) = @_;
...
my $time = 0.0; my $time = 0.0;
return unless $str =~ m/(\d+):(\d+):(\d+)([.,])(\d+)/oi; return unless $str =~ m/(\d+):(\d+):(\d+)([.,])(\d+)/oi;
my ($hrs, $min, $sec, $delim, $msec) = ($1, $2, $3, $4, $5); my ($hrs, $min, $sec, $delim, $msec) = ($1, $2, $3, $4, $5);
@ -54,14 +67,168 @@ sub parse_timing {
return $time; return $time;
} }
sub new_event { return +{ id => undef, timing => undef, style => undef, text => undef }; } 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 { sub parse {
my ($self, $lines) = @_; my ($self, $lines) = @_;
my $linenum = 0; my $linenum = 0;
my $event; my $section;
foreach my $line (@$lines) { 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} }; return scalar @{ $self->{events} };

Loading…
Cancel
Save