File Coverage

blib/lib/POE/Component/Enc/Flac.pm

Criterion	Covered	Total	%
statement	28	80	35.0
branch	3	34	8.8
condition	14	22	63.6
subroutine	6	15	40.0
pod	2	3	66.6
total	53	154	34.4

#   FLAC encoding component for POE
#   Copyright (c) 2004 Steve James. All rights reserved.
#
#   This library is free software; you can redistribute it and/or modify
#   it under the same terms as Perl itself.
#

package POE::Component::Enc::Flac;

use 5.008;
use strict;
use warnings;
use Carp;
use POE qw(Wheel::Run Filter::Line Driver::SysRW);

our $VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);

# Create a new encoder object
sub new {
    my $class = shift;
    my $opts  = shift;

    my $self = bless({}, $class);

    my %opts = !defined($opts) ? () : ref($opts) ? %$opts : ($opts, @_);
    %$self = (%$self, %opts);

    $self->{compression} ||= 5;   # Default compression level
    $self->{priority}    ||= 0;   # No priority delta by default

    $self->{parent}    ||= 'main';    # Default parent
    $self->{status}    ||= 'status';  # Default events
    $self->{error}     ||= 'error';
    $self->{done}      ||= 'done';
    $self->{warning}   ||= 'warning';

    return $self;
}


# Start an encoder.
sub enc {
    my $self = shift;
    my $opts = shift;

    my %opts = !defined($opts) ? () : ref($opts) ? %$opts : ($opts, @_);
    %$self = (%$self, %opts);

    croak "No input file specified" unless $self->{input};

    # Output filename is derived from input, unless specified
    unless ($self->{output}) {
        ($self->{output} = $self->{input}) =~ s/(.*)\.(.*)$/$1.flac/;
    }

    # For posting events to the parent session. Always passes $self as
    # the first event argument.
    sub post_parent {
        my $kernel = shift;
        my $self   = shift;
        my $event  = shift;

        $kernel->post($self->{parent}, $event, $self, @_)
            or carp "Failed to post to '$self->{parent}': $!";
    }

    POE::Session->create(
        inline_states => {
            _start => sub {
                my ($heap, $kernel, $self) = @_[HEAP, KERNEL, ARG0];

                $kernel->sig(CHLD => "child"); # We must handle SIGCHLD

                $heap->{self} = $self;

                my @args;   # List of arguments for encoder

                push @args, '--output-name="' . $self->{output} .'"';

                push @args, '-' . $self->{compression}
                    if $self->{compression};

                # The comment parameter is a list of tag-value pairs.
                # Each list element must be passed to the encoder as a
                # separate --tag argument.
                if ($self->{comment}) {
                    foreach (@{$self->{comment}}) {
                        push @args, '--tag="' . $_ .'"'
                    }
                }

                # Finally, the input file
                push @args, $self->{input};

                $heap->{wheel} = POE::Wheel::Run->new(
                    Program     => 'flac',
                    ProgramArgs => \@args,
                    Priority    => $self->{priority},
                    StdioFilter => POE::Filter::Line->new(),
                    Conduit     => 'pty',
                    StdoutEvent => 'wheel_stdout',
                    CloseEvent  => 'wheel_done',
                    ErrorEvent  => 'wheel_error',
                );
            },

            _stop => sub {
            },

            close => sub {
                delete $_[HEAP]->{wheel};
            },

            # Handle CHLD signal. Stop the wheel if the exited child is ours.
            child => sub {
                my ($kernel, $heap, $signame, $child_pid, $exit_code)
                    = @_[KERNEL, HEAP, ARG0, ARG1, ARG2];

                if ($heap->{wheel} && $heap->{wheel}->PID() == $child_pid) {
                    delete $heap->{wheel};

                    # If we got en exit code, the child died unexpectedly,
                    # so create a wheel-error event. otherwise the child exited
                    # normally, so create a wheel-done event.
                    if ($exit_code) {
                        $kernel->yield('wheel_error', $exit_code);
                    } else {
                        $kernel->yield('wheel_done');
                    }
                }
            },

            wheel_stdout => sub {
                my ($kernel, $heap) = @_[KERNEL, HEAP];
                my $self = $heap->{self};
                $_ = $_[ARG0];

                if (m{^ERROR: (.*)}i) {
                    # An error message has been emitted by the encoder.
                    # Remember the message for later
                    $self->{message} = $1;
                } elsif (m{^WARNING: (.*)}i) {
                    # A warning message has been emitted by the encoder.
                    # Post the warning message to the parent
                    post_parent($kernel, $self, $self->{warning},
                                $self->{input},
                                $self->{output},
                                $1
                                );
                    return;
                } elsif (m{
                    \S+:\s+                 # input file name
                    (\d+)%\s+complete,      # Percentage completion
                    \s+ratio=([0-9.]+)      # Current compression ratio
                    }x) {
                    # We have a progress message from the compressor
                    # Post the percentage and ratio to the parent.
                    my ($percent, $ratio) = ($1, $2);

                    post_parent($kernel, $self, $self->{status},
                                $self->{input},
                                $self->{output},
                                $percent, $ratio
                    );
                } elsif (m{
                    \S+:\s+                 # input file name
                    wrote\s+(\d+)\s+bytes,  # Percentage completion
                    \s+ratio=([0-9.]+)      # Compression ratio
                    }x) {
                    # We have a completion message from the compressor
                    # Post the percentage and ratio to the parent.
                    my ($size, $ratio) = ($1, $2);

                    post_parent($kernel, $self, $self->{status},
                                $self->{input},
                                $self->{output},
                                100, $ratio
                    );
                }
            },

            wheel_error => sub {
                my ($kernel, $heap) = @_[KERNEL, HEAP];
                my $self = $heap->{self};

                post_parent($kernel, $self, $self->{error},
                    $self->{input},
                    $self->{output},
                    $_[ARG0],
                    $self->{message} || ''
                );

                # Remove output file: might be incomplete
                $_ = $self->{output}; unlink if ($_ && -f);
            },

            wheel_done => sub {
                my ($kernel, $heap) = @_[KERNEL, HEAP];
                my $self = $heap->{self};

                # Delete the input file if instructed
                unlink $self->{input} if $self->{delete};

                post_parent($kernel, $self, $self->{done},
                    $self->{input},
                    $self->{output}
                );
            },
        },
        args => [$self]
    );
}

1;
__END__