File Coverage

blib/lib/Win32/MCI/CD.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Win32::MCI::CD;

use warnings;
use strict;

require 5;

our $VERSION = "0.02";

use Win32::API;
use Carp;


###########################################################################
###
### Define variables for this module.
###
###########################################################################

my $mci_sendstring = new Win32::API("winmm.dll", "mciSendStringA", ['P', 'P', 'N', 'N'], 'N') || croak "Creating api call mciSendStringA failed";
my $mci_error = new Win32::API("winmm.dll", "mciGetErrorStringA", ['N', 'P', 'N'], 'N') || croak "Creating api call mciGetErrorStringA failed";
my $last_error = 0;


###########################################################################
###
### Construct our object.
###
###########################################################################

sub new {
 my $class = shift;
 my %parms = @_;
 my $self;
 if(!defined $parms{-aliasname}) { croak "Option -aliasname was ignored";}
 if(!defined $parms{-drive}) { croak "Option -drive was ignored";}
 %{$self} = %parms;
 bless $self, $class;
 return $self;
}


###########################################################################
###
### Functions below are used by the module itself.
###
###########################################################################

sub strip_spaces { return unpack('A*', shift); }

sub sendstring
{
 my $command = shift;
 my $return_string = " " x 256;
 my $return = $mci_sendstring->Call($command, $return_string, length($return_string), 0);
 return ($return, strip_spaces($return_string));
}


###########################################################################
###
### Functions below can be called by user, as methods.
###
###########################################################################

sub cd_opendevice
{
 my $self = shift;
 my $drive = $self->{-drive};
 my $namedevice = $self->{-aliasname};
 my $ret = (sendstring("open $drive type cdaudio ALIAS $namedevice wait shareable"))[0];
 if($ret != 0) { $last_error = $ret; return 0;}
 return 1;
}

sub cd_closedevice
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my $ret = (sendstring("close $namedevice"))[0];
 if($ret != 0) { $last_error = $ret; return 0;}
 return 1;
}

sub cd_getlasterror
{
 my $self = shift;
 my $return_string = " " x 128;
 my $return = $mci_error->Call($last_error, $return_string, length($return_string));
 return ($last_error, strip_spaces($return_string));
}

sub cd_mode_milliseconds
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my $ret = (sendstring("set $namedevice time format milliseconds wait"))[0];
 if($ret != 0) { $last_error = $ret; return 0; }
 return 1;
}

sub cd_mode_tmsf
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my $ret = (sendstring("set $namedevice time format tmsf wait"))[0];
 if($ret != 0) { $last_error = $ret; return 0; }
 return 1;
}

sub cd_play
{
 my ($self, $pos) = @_;
 my $namedevice = $self->{-aliasname};
 my $ret;
 if($pos)
 {
  $ret =  (sendstring("play $namedevice from $pos"))[0];
  if($ret != 0) { $last_error = $ret; return 0; }
 }
 else
 {
  $ret =  (sendstring("play $namedevice"))[0];
  if($ret != 0) { $last_error = $ret; return 0; }
 }
 return 1;
}

sub cd_stop
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my $ret = (sendstring("stop $namedevice"))[0];
 if($ret != 0) { $last_error = $ret; return 0; }
 return 1;
}

sub cd_pause
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my $ret = (sendstring("pause $namedevice"))[0];
 if($ret != 0) { $last_error = $ret; return 0; }
 return 1;
}

sub cd_status
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my ($ret, $status) = sendstring("status $namedevice mode");
 if($ret != 0) { $last_error = $ret; return 0; }
 return $status;
}

sub cd_currentpos
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my ($ret, $pos) = sendstring("status $namedevice position");
 if($ret != 0) { $last_error = $ret; return 0; }
 return $pos;
}

sub cd_tracklength
{
 my ($self, $track) = @_;
 my $namedevice = $self->{-aliasname};
 my ($ret, $length) = sendstring("status $namedevice length track $track");
 if($ret != 0) { $last_error = $ret; return 0; }
 return $length;
}

sub cd_cdlength
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my ($ret, $length) = sendstring("status $namedevice length wait");
 if($ret != 0) { $last_error = $ret; return 0; }
 return $length;
}

sub cd_tracks
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my ($ret, $tracks) = sendstring("status $namedevice number of tracks wait");
 if($ret != 0) { $last_error = $ret; return 0; }
 return $tracks;
}

sub cd_opentray
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my $ret = (sendstring("set $namedevice door open"))[0];
 if($ret != 0) { $last_error = $ret; return 0; }
 return 1;
}

sub cd_closetray
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my $ret = (sendstring("set $namedevice door closed"))[0];
 if($ret != 0) { $last_error = $ret; return 0; }
 return 1;
}

sub cd_present
{
 my $self = shift;
 my $namedevice = $self->{-aliasname};
 my ($ret, $status) = sendstring("status $namedevice media present");
 if($ret != 0) { $last_error = $ret; return 0; }
 return $status;
}

sub cd_seek
{
 my ($self, $pos) = @_;
 my $namedevice = $self->{-aliasname};
 my $ret = (sendstring("seek $namedevice to $pos"))[0];
 if($ret != 0) { $last_error = $ret; return 0; }
 return 1;
}

1;

__END__