libsubtitle-perl/lib/Subtitle/SSA/Style.pm

package Subtitle::SSA::Style;

use strict;
use warnings;
use utf8;

use overload => (
  '""' => \&to_string,
);

my @FIELDS_SSA = qw(name fontname fontsize primarycolour secondarycolour tertiarycolour backcolour bold italic borderstyle outline shadow alignment marginl marginr marginv alphalevel encoding);
my @FIELDS_ASS = qw(name fontname fontsize primarycolour secondarycolour outlinecolour backcolour bold italic underline strikeout scalex scaley spacing angle borderstyle outline shadow alignment marginl marginr marginv encoding);

# formats:
#  s - string, use as is
#  d - decimal, no-zero pad
#  b - boolean, 0 as false, -1 as true
#  f - float, 6.01 or 6 if no fractional part
#  x - hex-number, &H00AABBCC for ASS or decimal number for SSA
my %FIELDS = (
  name              => { type => 's', value => 'Default', name => 'Name' },
  fontname          => { type => 's', value => 'Arial'  , name => 'Fontname' },
  primarycolour     => { type => 'x', value => 0x00FFFFFF, name => 'PrimaryColour' },
  secondarycolour   => { type => 'x', value => 0x00000000, name => 'SecondaryColour' },
  outlinecolour     => { type => 'x', value => 0x004E3873, name => 'OutlineColour' },
  tertiarycolour    => { type => 'x', value => 0x004E3873, name => 'TertiaryColour' },
  backcolour        => { type => 'x', value => 0x96000000, name => 'BackColour' },
  fontsize          => { type => 'd', value =>  24, name => 'Fontsize' },
  bold              => { type => 'b', value =>   0, name => 'Bold' },
  italic            => { type => 'b', value =>   0, name => 'Italic' },
  underline         => { type => 'b', value =>   0, name => 'Underline' },
  strikeout         => { type => 'b', value =>   0, name => 'StrikeOut' },
  scalex            => { type => 'd', value => 100, name => 'ScaleX' },
  scaley            => { type => 'd', value => 100, name => 'ScaleY' },
  spacing           => { type => 'f', value =>   0, name => 'Spacing' },
  angle             => { type => 'f', value =>   0, name => 'Angle' },
  borderstyle       => { type => 'd', value =>   1, name => 'BorderStyle' },
  outline           => { type => 'f', value =>   2, name => 'Outline' },
  shadow            => { type => 'f', value =>   0, name => 'Shadow' },
  alignment         => { type => 'd', value =>   2, name => 'Alignment' },
  marginl           => { type => 'd', value =>  10, name => 'MarginL' },
  marginr           => { type => 'd', value =>  10, name => 'MarginR' },
  marginv           => { type => 'd', value =>  10, name => 'MarginV' },
  alphalevel        => { type => 'd', value =>   0, name => 'AlphaLevel' },
  encoding          => { type => 'd', value => 204, name => 'Encoding' },
);

# options:
#  * version - 'ssa' for v4 or 'ass' for v4+
sub new {
  my ($class, %opts) = @_;
  my $self = {
    _vers => 'ass',
  };
  bless($self, $class);

  if ($opts{version} and $opts{version} =~ m{^(ass|ssa)$}oi) {
    $self->{_vers} = lc($opts{version});
  }

  my @fields = $self->fields();
  foreach my $field (@fields) {
    $self->{$field} = ($opts{defaults})
      ? $FIELDS{$field}->{value}
      : undef;
  }

  return $self;
}

sub fields {
  my ($self) = @_;
  return ($self->{_vers} eq 'ssa')
    ? @FIELDS_SSA
    : @FIELDS_ASS;
}

sub set {
  my ($self, $opt, $value) = @_;
  return unless $opt;
  $opt = lc($opt);
  return unless exists $self->{$opt};
  $self->{$opt} = $value;
  return 1;
}

sub parse {
  my ($self, $fields, $line) = @_;

  return unless $fields and ref($fields) eq 'ARRAY';
  return unless $line and $line =~ m{^Style:}oi;

  chomp $line;
  $line =~ s{^style:\s+}{}oi;
  my @values = split /,\s*/o, $line;
  # check that values count match fields count
  return unless scalar @{ $fields } != scalar @values;

  foreach my $field (@{ $fields }) {
    my $value = shift @values;
    $self->set($field => $value);
  }

  return 1;
}

sub to_string {
  my ($self) = @_;
  my @fields = $self->fields();
  my $string = "Style: ";
  my @values = ();
  foreach my $field (@fields) {
    my $d = $FIELD{$field};
    my $v = $self->{$f} // $d->{value};
    if ($d->{type} eq 'x') {
      $fmt = ($self->{_vers} eq 'ass') ? '&H%08X' : '%d';
      $v = sprintf $fmt, $v;
    } elsif ($d->{type} eq 'f') {
      $v = sprintf "%.2f", $v;
      # hack: make decimal from float if fractional part is zero after round up
      $v =~ s{\.00$}{}oi;
    } else {
      # use as is
    }
    push @values, $v;
  }
  $string .= join(',', @values);

  return $string;
}

1;