Image::TextMode::SAUCE - Create, manipulate and save SAUCE metadata

package Image::TextMode::SAUCE;

use Moose;

# some SAUCE constants
my $SAUCE_ID      = 'SAUCE';
my $SAUCE_VERSION = '00';
my $SAUCE_FILLER  = ' ' x 22;
my $COMNT_ID      = 'COMNT';

has 'sauce_id' => ( is => 'rw', isa => 'Str', default => sub { $SAUCE_ID } );

has 'version' =>
    ( is => 'rw', isa => 'Str', default => sub { $SAUCE_VERSION } );

has 'title' => ( is => 'rw', isa => 'Str', default => sub { '' } );

has 'author' => ( is => 'rw', isa => 'Str', default => sub { '' } );

has 'group' => ( is => 'rw', isa => 'Str', default => sub { '' } );

has 'date' => (
    is      => 'rw',
    isa     => 'Str',
    default => sub {
        my @t = ( localtime )[ 5, 4, 3 ];
        return sprintf '%4d%02d%02d', 1900 + $t[ 0 ], $t[ 1 ] + 1, $t[ 2 ];
    }
);

has 'filesize' => ( is => 'rw', isa => 'Int', default => sub { 0 } );

has 'filetype_id' => ( is => 'rw', isa => 'Int', default => sub { 0 } );

has 'datatype_id' => ( is => 'rw', isa => 'Int', default => sub { 0 } );

has 'tinfo1' => ( is => 'rw', isa => 'Int', default => sub { 0 } );

has 'tinfo2' => ( is => 'rw', isa => 'Int', default => sub { 0 } );

has 'tinfo3' => ( is => 'rw', isa => 'Int', default => sub { 0 } );

has 'tinfo4' => ( is => 'rw', isa => 'Int', default => sub { 0 } );

has 'comment_count' => ( is => 'rw', isa => 'Int', default => sub { 0 } );

has 'flags_id' => ( is => 'rw', isa => 'Int', default => sub { 0 } );

has 'filler' =>
    ( is => 'rw', isa => 'Str', default => sub { $SAUCE_FILLER } );

has 'comment_id' =>
    ( is => 'rw', isa => 'Str', default => sub { $COMNT_ID } );

has 'comments' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );

has 'has_sauce' => ( is => 'rw', isa => 'Bool' );

# define datatypes and filetypes as per SAUCE specs
my @datatypes
    = qw(None Character Graphics Vector Sound BinaryText XBin Archive Executable);
my $filetypes = {
    None => {
        filetypes => [ 'Undefined' ],
        flags     => [ 'None' ]
    },
    Character => {
        filetypes =>
            [ qw( ASCII ANSi ANSiMation RIP PCBoard Avatar HTML Source ) ],
        flags => [ 'None', 'iCE Color' ],
        tinfo => [
            ( { tinfo1 => 'Width', tinfo2 => 'Height' } ) x 3,
            { tinfo1 => 'Width', tinfo2 => 'Height', tinfo3 => 'Colors' },
            ( { tinfo1 => 'Width', tinfo2 => 'Height' } ) x 2
        ]
    },
    Graphics => {
        filetypes => [
            qw( GIF PCX LBM/IFF TGA FLI FLC BMP GL DL WPG PNG JPG MPG AVI )
        ],
        flags => [ 'None' ],
        tinfo => [
            (   {   tinfo1 => 'Width',
                    tinfo2 => 'Height',
                    tinfo3 => 'Bits Per Pixel'
                }
            ) x 14
        ]
    },
    Vector => {
        filetypes => [ qw( DXF DWG WPG 3DS ) ],
        flags     => [ 'None' ],
    },
    Sound => {
        filetypes => [
            qw( MOD 669 STM S3M MTM FAR ULT AMF DMF OKT ROL CMF MIDI SADT VOC WAV SMP8 SMP8S SMP16 SMP16S PATCH8 PATCH16 XM HSC IT )
        ],
        flags => [ 'None' ],
        tinfo => [ ( {} ) x 16, ( { tinfo1 => 'Sampling Rate' } ) x 4 ]
    },
    BinaryText => {
        filetypes => [ qw( Undefined ) ],
        flags     => [ 'None', 'iCE Color' ],
    },
    XBin => {
        filetypes => [ qw( Undefined ) ],
        flags     => [ 'None' ],
        tinfo     => [ { tinfo1 => 'Width', tinfo2 => 'Height' }, ]
    },
    Archive => {
        filetypes => [ qw( ZIP ARJ LZH ARC TAR ZOO RAR UC2 PAK SQZ ) ],
        flags     => [ 'None' ],
    },
    Executable => {
        filetypes => [ qw( Undefined ) ],
        flags     => [ 'None' ],
    }
};

# vars for use with pack() and unpack()
my $sauce_template = 'A5 A2 A35 A20 A20 A8 V C C v v v v C C A22';
my @sauce_fields
    = qw( sauce_id version title author group date filesize datatype_id filetype_id tinfo1 tinfo2 tinfo3 tinfo4 comment_count flags_id filler );
my $comnt_template = 'A5 A64';
my @comnt_fields   = qw( comment_id comments );

sub read {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    my ( $self, $fh ) = @_;

    my $buffer;
    my %info;

    seek( $fh, 0, 2 );
    return if tell $fh < 128;

    seek( $fh, -128, 2 );
    my $size = read( $fh, $buffer, 128 );

    if ( substr( $buffer, 0, 5 ) ne $SAUCE_ID ) {
        $self->has_sauce( 0 );
        return;
    }

    @info{ @sauce_fields } = unpack( $sauce_template, $buffer );

    # because trailing spaces are stripped....
    $info{ filler } = $SAUCE_FILLER;

    # Do we have any comments?
    my $comment_count = $info{ comment_count };

    $self->$_( $info{ $_ } ) for keys %info;
    $self->has_sauce( 1 );

    if ( $comment_count > 0 ) {
        seek( $fh, -128 - 5 - $comment_count * 64, 2 );
        read( $fh, $buffer, 5 + $comment_count * 64 );

        if ( substr( $buffer, 0, 5 ) eq $COMNT_ID ) {
            my $template
                = $comnt_template
                . ( split( / /s, $comnt_template ) )[ 1 ]
                x ( $comment_count - 1 );
            my ( $id, @comments ) = unpack( $template, $buffer );
            $self->comment_id( $id );
            $self->comments( \@comments );
        }
    }
}

sub write {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    my ( $self, $fh ) = @_;

    seek( $fh, 0, 2 );
    print $fh chr( 26 );

    # comments...
    my $comments = scalar @{ $self->comments };
    if ( $comments ) {
        print $fh pack(
            $comnt_template
                . (
                ( split( / /s, $comnt_template ) )[ 1 ] x ( $comments - 1 )
                ),
            $self->comment_id,
            @{ $self->comments }
        );
    }

    # SAUCE...
    my @template = split( / /s, $sauce_template );
    for ( 0 .. $#sauce_fields ) {
        my $field = $sauce_fields[ $_ ];
        my $value = ( $field ne 'comments' ) ? $self->$field : $comments;
        print $fh pack( $template[ $_ ], $value );
    }

}

sub datatype {
    return $datatypes[ $_[ 0 ]->datatype_id || 0 ];
}

sub filetype {
    return $filetypes->{ $_[ 0 ]->datatype }->{ filetypes }
        ->[ $_[ 0 ]->filetype_id || 0 ];
}

sub flags {
    return $filetypes->{ $_[ 0 ]->datatype }->{ flags }
        ->[ $_[ 0 ]->flags_id ];
}

sub tinfo1_name {
    return $filetypes->{ $_[ 0 ]->datatype }->{ tinfo }
        ->[ $_[ 0 ]->filetype_id ]->{ tinfo1 };
}

sub tinfo2_name {
    return $filetypes->{ $_[ 0 ]->datatype }->{ tinfo }
        ->[ $_[ 0 ]->filetype_id ]->{ tinfo2 };
}

sub tinfo3_name {
    return $filetypes->{ $_[ 0 ]->datatype }->{ tinfo }
        ->[ $_[ 0 ]->filetype_id ]->{ tinfo3 };
}

sub tinfo4_name {
    return $filetypes->{ $_[ 0 ]->datatype }->{ tinfo }
        ->[ $_[ 0 ]->filetype_id ]->{ tinfo4 };
}

no Moose;

__PACKAGE__->meta->make_immutable;

1;