File::SAUCE - A library to manipulate SAUCE metadata

    use File::SAUCE;

    # Read the data...
    # file, handle or string
    my $sauce = File::SAUCE->new( file => 'myansi.ans' );

    # Does the file have a SAUCE record?
    print $sauce->has_sauce ? "has SAUCE" : "does not have SAUCE";

    # Print the metadata...
    $sauce->print;

    # Get a value...
    my $title = $sauce->title;

    # Set a value...
    $sauce->title( 'ANSi is 1337' );

    # Get the SAUCE record as a string...
    my $output = $sauce->as_string;

    # Write the data...
    # file, handle or string
    $sauce->write( file => 'myansi.ans' );

    # Clear the in-memory data...
    $sauce->clear;

    # Read the data...
    # file, handle or string
    $sauce->read( file => 'myansi.ans' );

    # Remove the data...
    # file, handle or string
    $sauce->remove( file => 'myansi.ans' );

    +----------------+
    | FILE Data      |
    +----------------+
    | EOF Marker     |
    +----------------+
    | SAUCE Comments |
    +----------------+
    | SAUCE Record   |
    +----------------+

    +----------------+------+------+---------+-------------+
    | Field          | Size | Type | Default | set / get   |
    +----------------+------+------+---------+-------------+
    | ID             | 5    | Char | COMNT   | commment_id |
    +----------------+------+------+---------+-------------+
    | Comment Line 1 | 64   | Char |         | comments*   |
    +----------------+------+------+---------+-------------+
    | ...                                                  |
    +----------------+------+------+---------+-------------+
    | Comment Line X | 64   | Char |         | comments    |
    +----------------+------+------+---------+-------------+

    +----------------+------+------+---------+-------------+
    | Field          | Size | Type | Default | set / get   |
    +----------------+------+------+---------+-------------+
    | ID             | 5    | Char | SAUCE   | sauce_id    |
    +----------------+------+------+---------+-------------+
    | SAUCE Version  | 2    | Char | 00      | version     |
    +----------------+------+------+---------+-------------+
    | Title          | 35   | Char |         | title       |
    +----------------+------+------+---------+-------------+
    | Author         | 20   | Char |         | author      |
    +----------------+------+------+---------+-------------+
    | Group          | 20   | Char |         | group       |
    +----------------+------+------+---------+-------------+
    | Date           | 8    | Char |         | date        |
    +----------------+------+------+---------+-------------+
    | FileSize       | 4    | Long |         | filesize    |
    +----------------+------+------+---------+-------------+
    | DataType       | 1    | Byte |         | datatype_id |
    +----------------+------+------+---------+-------------+
    | FileType       | 1    | Byte |         | filetype_id |
    +----------------+------+------+---------+-------------+
    | TInfo1         | 2    | Word |         | tinfo1      |
    +----------------+------+------+---------+-------------+
    | TInfo2         | 2    | Word |         | tinfo2      |
    +----------------+------+------+---------+-------------+
    | TInfo3         | 2    | Word |         | tinfo3      |
    +----------------+------+------+---------+-------------+
    | TInfo4         | 2    | Word |         | tinfo4      |
    +----------------+------+------+---------+-------------+
    | Comments       | 1    | Byte |         | comments    |
    +----------------+------+------+---------+-------------+
    | Flags          | 1    | Byte |         | flags_id    |
    +----------------+------+------+---------+-------------+
    | Filler         | 22   | Byte |         | filler      |
    +----------------+------+------+---------+-------------+

    SAUCE was initially created for supporting only the ANSi
    & RIP screens. Since both ANSi and RIP are in effect
    text-based and have no other form of control but the
    End-Of-File marker, SAUCE should never interfere with the
    workings of a program using either ANSi or RIP. If it does,
    the program is not functionning the way it should. This is
    NOT true for the other types of files however. Adding SAUCE
    to some of the other filetypes supported in the SAUCE
    specifications may have serious consequences on the proper
    functionning of programs using those files, In the worst
    case, they'll simply refuse the file, stating it is invalid.

    perl Makefile.PL
    make
    make test
    make install

    my $sauce = File::SAUCE->new( file   => 'filename.ext' );
    my $sauce = File::SAUCE->new( handle => \*FILEHANDLE );
    my $sauce = File::SAUCE->new( string => $string );

    my $sauce = File::SAUCE->new(
        author => 'Me',
        title  => 'My Work',
        group  => 'My Group'
    );

    if( Filesize on disk - Filesize in SAUCE rec - Size of SAUCE rec ( w/ comments ) == 0 or 1 ) {
        truncate to Filesize in SAUCE rec
    }
    else {
        truncate to Filesize on disk - Size of SAUCE rec - 1 (EOF char)
    }

package File::SAUCE;

use strict;
use warnings;
use Carp;
use FileHandle;
use IO::String;
use Time::Piece;

use base qw( Class::Accessor );

our $VERSION = '0.25';

# some SAUCE constants
use constant SAUCE_ID      => 'SAUCE';
use constant SAUCE_VERSION => '00';
use constant SAUCE_FILLER  => ' ' x 22;
use constant COMNT_ID      => 'COMNT';

# 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 comments flags_id filler );
my $comnt_template = 'A5 A64';
my @comnt_fields   = qw( comment_id comments );
my $date_format    = '%Y%m%d';

__PACKAGE__->mk_accessors( @sauce_fields, $comnt_fields[ 0 ], 'has_sauce' );

# define datatypes and filetypes as per SAUCE specs
my @datatypes
    = qw(None Character Graphics Vector Sound BinaryText XBin Archive Executable);
my $filetypes = {
    None => {
        filetypes => [ qw( Undefined ) ],
        flags     => { 0 => 'None' }
    },
    Character => {
        filetypes =>
            [ qw( ASCII ANSi ANSiMation RIP PCBoard Avatar HTML Source ) ],
        flags => { 0 => 'None', 1 => '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 => { 0 => 'None' },
        tinfo => [
            (   {   tinfo1 => 'Width',
                    tinfo2 => 'Height',
                    tinfo3 => 'Bits Per Pixel'
                }
            ) x 14
        ]
    },
    Vector => {
        filetypes => [ qw( DXF DWG WPG 3DS ) ],
        flags     => { 0 => '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 => { 0 => 'None' },
        tinfo => [ ( {} ) x 16, ( { tinfo1 => 'Sampling Rate' } ) x 4 ]
    },
    BinaryText => {
        filetypes => [ qw( Undefined ) ],
        flags     => { 0 => 'None', 1 => 'iCE Color' }
    },
    XBin => {
        filetypes => [ qw( Undefined ) ],
        flags     => { 0 => 'None' },
        tinfo     => [ { tinfo1 => 'Width', tinfo2 => 'Height' }, ]
    },
    Archive => {
        filetypes => [ qw( ZIP ARJ LZH ARC TAR ZOO RAR UC2 PAK SQZ ) ],
        flags     => { 0 => 'None' }
    },
    Executable => {
        filetypes => [ qw( Undefined ) ],
        flags     => { 0 => 'None' }
    }
};

sub new {
    my $class   = shift;
    my $self    = {};
    my %options = @_;

    bless $self, $class;

    $self->clear;

    if (   exists $options{ file }
        or exists $options{ string }
        or exists $options{ handle } )
    {
        $self->read( @_ );
    }
    else {
        $self->set( $_ => $options{ $_ } ) for keys %options;
        $self->date( $options{ date } ) if exists $options{ date };
    }

    return $self;
}

sub clear {
    my $self = shift;
    my $date = localtime;

    # Set empty/default SAUCE and COMMENT values
    $self->set( $_ => '' ) for @sauce_fields[ 2 .. 4 ];
    $self->set( $_ => 0 ) for @sauce_fields[ 6 .. 13, 14 ];
    $self->sauce_id( SAUCE_ID );
    $self->version( SAUCE_VERSION );
    $self->filler( SAUCE_FILLER );
    $self->comment_id( COMNT_ID );
    $self->date( $date );
    $self->comments( [] );
    $self->has_sauce( undef );
}

sub read {
    my $self    = shift;
    my %options = @_;
    my $file    = $self->_create_io_object( \%options, '<' );

    $self->clear;

    my $buffer;
    my %info;

    if ( ( $file->stat )[ 7 ] < 128 ) {
        $self->has_sauce( 0 );
        return;
    }

    $file->seek( -128, 2 );
    $file->read( $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 $comments = $info{ comments };
    delete $info{ comments };

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

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

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

sub write {
    my $self = shift;

    $self->remove( @_ );

    my %options = @_;
    my $file = $self->_create_io_object( \%options, '>>' );

    $file->seek( 0, 2 );
    $file->print( $self->as_string );

    return ${ $file->string_ref } if ref $file eq 'IO::String';
}

sub remove {
    my $self      = shift;
    my $sauce     = File::SAUCE->new( @_ );
    my $has_sauce = $sauce->has_sauce;
    my %options   = @_;

    unless ( $has_sauce ) {
        return $options{ string } if exists $options{ string };
        return;
    }

    my $file = $self->_create_io_object( \%options, '>>' );

    # remove SAUCE
    my $sizeondisk = ( $file->stat )[ 7 ];
    my $sizeinrec  = $sauce->filesize;
    my $comments   = scalar @{ $sauce->comments };
    my $saucesize  = 128 + ( $comments ? 5 + $comments * 64 : 0 );
    my $size       = $sizeondisk - $sizeinrec - $saucesize;

# for spoon compatibility
# Size on disk - size in record - SAUCE size (w/ comments) == 0 or 1 --> use size in record
    if ( $size =~ /^0|1$/ ) {
        $file->truncate( $sizeinrec ) or carp "$!";
    }

    # figure it out on our own -- spoon just balks
    else {
        $file->truncate( $sizeondisk - $saucesize - 1 ) or carp "$!";
    }

    return ${ $file->string_ref } if ref $file eq 'IO::String';
}

sub as_string {
    my $self = shift;

    # Fix values incase they've been changed
    $self->sauce_id( SAUCE_ID );
    $self->version( SAUCE_VERSION );
    $self->filler( SAUCE_FILLER );
    $self->comment_id( COMNT_ID );

    # EOF marker...
    my $output = chr( 26 );

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

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

    return $output;
}

sub print {
    my $self      = shift;
    my $width     = 10;
    my $label     = '%' . $width . 's:';
    my $has_sauce = $self->has_sauce;
    my $output;

    if ( $has_sauce == 0 ) {
        print "The file last read did not contain a SAUCE record\n";
        return;
    }

    for ( @sauce_fields ) {
        if ( /^(datatype|filetype|flags)_id$/ ) {
            $output = sprintf( "$label %s", ucfirst( $1 ), $self->get( $_ ) );
            my $value = $self->$1;
            print $output;
            print ' (' . $value . ')' if $value;
            print "\n";
        }
        elsif ( /^tinfo\d$/ ) {
            $output = sprintf( "$label %s", ucfirst( $_ ), $self->get( $_ ) );
            my $name  = $_ . '_name';
            my $value = $self->$name;
            print $output;
            print ' (' . $value . ')' if $value;
            print "\n";
        }
        elsif ( $_ eq 'date' ) {
            $output
                = sprintf( "$label %s\n", 'Date', $self->date->mdy( '/' ) );
            print $output;
        }
        elsif ( $_ eq 'comments' ) {
            $output = sprintf( "$label %s\n",
                'Comments', scalar @{ $self->comments } );
            print $output;
        }
        else {
            $output
                = sprintf( "$label %s\n", ucfirst( $_ ), $self->get( $_ ) );
            print $output;
        }
    }

    my @comments = @{ $self->comments };

    return unless @comments;

    $output = sprintf( "$label %s\n", 'Comment_id', $self->comment_id );
    $output .= sprintf( $label, 'Comments' );

    print $output;

    for ( 0 .. $#comments ) {
        $output = sprintf(
            $_ == 0 ? " %s\n" : ( ' ' x ( $width + 1 ) ) . " %s\n",
            $comments[ $_ ]
        );
        print $output;
    }
}

sub datatype {

    # Return the datatype name
    return $datatypes[ $_[ 0 ]->datatype_id ];
}

sub filetype {

    # Return the filetype name
    return $filetypes->{ $_[ 0 ]->datatype }->{ filetypes }
        ->[ $_[ 0 ]->filetype_id ];
}

sub flags {

    # Return an english description of the flags
    return $filetypes->{ $_[ 0 ]->datatype }->{ flags }
        ->{ $_[ 0 ]->flags_id };
}

sub tinfo1_name {

    # Return an english description of info flag (1) or blank if there is none
    return $filetypes->{ $_[ 0 ]->datatype }->{ tinfo }
        ->[ $_[ 0 ]->filetype_id ]->{ tinfo1 };
}

sub tinfo2_name {

    # Return an english description of info flag (2) or blank if there is none
    return $filetypes->{ $_[ 0 ]->datatype }->{ tinfo }
        ->[ $_[ 0 ]->filetype_id ]->{ tinfo2 };
}

sub tinfo3_name {

    # Return an english description of info flag (3) or blank if there is none
    return $filetypes->{ $_[ 0 ]->datatype }->{ tinfo }
        ->[ $_[ 0 ]->filetype_id ]->{ tinfo3 };
}

sub tinfo4_name {

    # Return an english description of info flag (4) or blank if there is none
    return $filetypes->{ $_[ 0 ]->datatype }->{ tinfo }
        ->[ $_[ 0 ]->filetype_id ]->{ tinfo4 };
}

sub date {
    my $self = shift;
    my $date = shift;

    if ( $date ) {
        $self->set( 'date', $date->strftime( $date_format ) )
            if ref( $date ) eq 'Time::Piece';
        $self->set( 'date', $date ) if $date =~ /^\d{8}$/;
    }

    return Time::Piece->strptime( $self->get( 'date' ), $date_format );
}

sub _create_io_object {
    my $self    = shift;
    my %options = %{ $_[ 0 ] };
    my $perms   = $_[ 1 ];

    my $file;

    # use appropriate IO object for what we get in
    if ( exists $options{ file } ) {
        $file = FileHandle->new( $options{ file }, $perms ) or croak "$!";
    }
    elsif ( exists $options{ string } ) {
        $file = IO::String->new( $options{ string } );
    }
    elsif ( exists $options{ handle } ) {
        $file = $options{ handle };
    }
    else {
        croak(
            "No valid read type. Must be one of 'file', 'string' or 'handle'."
        );
    }

    binmode $file;
    return $file;
}

1;