webadmin/bpfire
1
0
Fork 0
mirror of https://github.com/vincentmli/bpfire.git synced 2026-04-20 07:53:01 +02:00
Code Issues Packages Projects Releases Wiki Activity

Finalized core13 and redirector fixes

Browse Source 
Added some files to core14
First Beta of MPFire V3
This commit is contained in:
Christian Schmidt
2008-05-12 15:58:31 +02:00
parent 76f912a0c1
commit 83d20a4555
20 changed files with 4790 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

675
config/mpfire/perl/Accessor.pm Executable file
View File

@@ -0,0 +1,675 @@
package Class::Accessor;
require 5.00502;
use strict;
$Class::Accessor::VERSION = '0.31';
=head1 NAME
Class::Accessor - Automated accessor generation
=head1 SYNOPSIS
package Employee;
use base qw(Class::Accessor);
Employee->mk_accessors(qw(name role salary));
# Meanwhile, in a nearby piece of code!
# Class::Accessor provides new().
my $mp = Foo->new({ name => "Marty", role => "JAPH" });
my $job = $mp->role; # gets $mp->{role}
$mp->salary(400000); # sets $mp->{salary} = 400000 (I wish)
# like my @info = @{$mp}{qw(name role)}
my @info = $mp->get(qw(name role));
# $mp->{salary} = 400000
$mp->set('salary', 400000);
=head1 DESCRIPTION
This module automagically generates accessors/mutators for your class.
Most of the time, writing accessors is an exercise in cutting and
pasting. You usually wind up with a series of methods like this:
sub name {
my $self = shift;
if(@_) {
$self->{name} = $_[0];
}
return $self->{name};
}
sub salary {
my $self = shift;
if(@_) {
$self->{salary} = $_[0];
}
return $self->{salary};
}
# etc...
One for each piece of data in your object. While some will be unique,
doing value checks and special storage tricks, most will simply be
exercises in repetition. Not only is it Bad Style to have a bunch of
repetitious code, but its also simply not lazy, which is the real
tragedy.
If you make your module a subclass of Class::Accessor and declare your
accessor fields with mk_accessors() then you'll find yourself with a
set of automatically generated accessors which can even be
customized!
The basic set up is very simple:
package My::Class;
use base qw(Class::Accessor);
My::Class->mk_accessors( qw(foo bar car) );
Done. My::Class now has simple foo(), bar() and car() accessors
defined.
=head2 What Makes This Different?
What makes this module special compared to all the other method
generating modules (L<"SEE ALSO">)? By overriding the get() and set()
methods you can alter the behavior of the accessors class-wide. Also,
the accessors are implemented as closures which should cost a bit less
memory than most other solutions which generate a new method for each
accessor.
=head1 METHODS
=head2 new
my $obj = Class->new;
my $obj = $other_obj->new;
my $obj = Class->new(\%fields);
my $obj = $other_obj->new(\%fields);
Class::Accessor provides a basic constructor. It generates a
hash-based object and can be called as either a class method or an
object method.
It takes an optional %fields hash which is used to initialize the
object (handy if you use read-only accessors). The fields of the hash
correspond to the names of your accessors, so...
package Foo;
use base qw(Class::Accessor);
Foo->mk_accessors('foo');
my $obj = Class->new({ foo => 42 });
print $obj->foo; # 42
however %fields can contain anything, new() will shove them all into
your object. Don't like it? Override it.
=cut
sub new {
my($proto, $fields) = @_;
my($class) = ref $proto || $proto;
$fields = {} unless defined $fields;
# make a copy of $fields.
bless {%$fields}, $class;
}
=head2 mk_accessors
Class->mk_accessors(@fields);
This creates accessor/mutator methods for each named field given in
@fields. Foreach field in @fields it will generate two accessors.
One called "field()" and the other called "_field_accessor()". For
example:
# Generates foo(), _foo_accessor(), bar() and _bar_accessor().
Class->mk_accessors(qw(foo bar));
See L<CAVEATS AND TRICKS/"Overriding autogenerated accessors">
for details.
=cut
sub mk_accessors {
my($self, @fields) = @_;
$self->_mk_accessors('rw', @fields);
}
{
no strict 'refs';
sub _mk_accessors {
my($self, $access, @fields) = @_;
my $class = ref $self || $self;
my $ra = $access eq 'rw' || $access eq 'ro';
my $wa = $access eq 'rw' || $access eq 'wo';
foreach my $field (@fields) {
my $accessor_name = $self->accessor_name_for($field);
my $mutator_name = $self->mutator_name_for($field);
if( $accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY' ) {
$self->_carp("Having a data accessor named DESTROY in '$class' is unwise.");
}
if ($accessor_name eq $mutator_name) {
my $accessor;
if ($ra && $wa) {
$accessor = $self->make_accessor($field);
} elsif ($ra) {
$accessor = $self->make_ro_accessor($field);
} else {
$accessor = $self->make_wo_accessor($field);
}
unless (defined &{"${class}::$accessor_name"}) {
*{"${class}::$accessor_name"} = $accessor;
}
if ($accessor_name eq $field) {
# the old behaviour
my $alias = "_${field}_accessor";
*{"${class}::$alias"} = $accessor unless defined &{"${class}::$alias"};
}
} else {
if ($ra and not defined &{"${class}::$accessor_name"}) {
*{"${class}::$accessor_name"} = $self->make_ro_accessor($field);
}
if ($wa and not defined &{"${class}::$mutator_name"}) {
*{"${class}::$mutator_name"} = $self->make_wo_accessor($field);
}
}
}
}
sub follow_best_practice {
my($self) = @_;
my $class = ref $self || $self;
*{"${class}::accessor_name_for"} = \&best_practice_accessor_name_for;
*{"${class}::mutator_name_for"} = \&best_practice_mutator_name_for;
}
}
=head2 mk_ro_accessors
Class->mk_ro_accessors(@read_only_fields);
Same as mk_accessors() except it will generate read-only accessors
(ie. true accessors). If you attempt to set a value with these
accessors it will throw an exception. It only uses get() and not
set().
package Foo;
use base qw(Class::Accessor);
Class->mk_ro_accessors(qw(foo bar));
# Let's assume we have an object $foo of class Foo...
print $foo->foo; # ok, prints whatever the value of $foo->{foo} is
$foo->foo(42); # BOOM! Naughty you.
=cut
sub mk_ro_accessors {
my($self, @fields) = @_;
$self->_mk_accessors('ro', @fields);
}
=head2 mk_wo_accessors
Class->mk_wo_accessors(@write_only_fields);
Same as mk_accessors() except it will generate write-only accessors
(ie. mutators). If you attempt to read a value with these accessors
it will throw an exception. It only uses set() and not get().
B<NOTE> I'm not entirely sure why this is useful, but I'm sure someone
will need it. If you've found a use, let me know. Right now its here
for orthoginality and because its easy to implement.
package Foo;
use base qw(Class::Accessor);
Class->mk_wo_accessors(qw(foo bar));
# Let's assume we have an object $foo of class Foo...
$foo->foo(42); # OK. Sets $self->{foo} = 42
print $foo->foo; # BOOM! Can't read from this accessor.
=cut
sub mk_wo_accessors {
my($self, @fields) = @_;
$self->_mk_accessors('wo', @fields);
}
=head1 DETAILS
An accessor generated by Class::Accessor looks something like
this:
# Your foo may vary.
sub foo {
my($self) = shift;
if(@_) { # set
return $self->set('foo', @_);
}
else {
return $self->get('foo');
}
}
Very simple. All it does is determine if you're wanting to set a
value or get a value and calls the appropriate method.
Class::Accessor provides default get() and set() methods which
your class can override. They're detailed later.
=head2 follow_best_practice
In Damian's Perl Best Practices book he recommends separate get and set methods
with the prefix set_ and get_ to make it explicit what you intend to do. If you
want to create those accessor methods instead of the default ones, call:
__PACKAGE__->follow_best_practice
=head2 accessor_name_for / mutator_name_for
You may have your own crazy ideas for the names of the accessors, so you can
make those happen by overriding C<accessor_name_for> and C<mutator_name_for> in
your subclass. (I copied that idea from Class::DBI.)
=cut
sub best_practice_accessor_name_for {
my ($class, $field) = @_;
return "get_$field";
}
sub best_practice_mutator_name_for {
my ($class, $field) = @_;
return "set_$field";
}
sub accessor_name_for {
my ($class, $field) = @_;
return $field;
}
sub mutator_name_for {
my ($class, $field) = @_;
return $field;
}
=head2 Modifying the behavior of the accessor
Rather than actually modifying the accessor itself, it is much more
sensible to simply override the two key methods which the accessor
calls. Namely set() and get().
If you -really- want to, you can override make_accessor().
=head2 set
$obj->set($key, $value);
$obj->set($key, @values);
set() defines how generally one stores data in the object.
override this method to change how data is stored by your accessors.
=cut
sub set {
my($self, $key) = splice(@_, 0, 2);
if(@_ == 1) {
$self->{$key} = $_[0];
}
elsif(@_ > 1) {
$self->{$key} = [@_];
}
else {
$self->_croak("Wrong number of arguments received");
}
}
=head2 get
$value = $obj->get($key);
@values = $obj->get(@keys);
get() defines how data is retreived from your objects.
override this method to change how it is retreived.
=cut
sub get {
my $self = shift;
if(@_ == 1) {
return $self->{$_[0]};
}
elsif( @_ > 1 ) {
return @{$self}{@_};
}
else {
$self->_croak("Wrong number of arguments received");
}
}
=head2 make_accessor
$accessor = Class->make_accessor($field);
Generates a subroutine reference which acts as an accessor for the given
$field. It calls get() and set().
If you wish to change the behavior of your accessors, try overriding
get() and set() before you start mucking with make_accessor().
=cut
sub make_accessor {
my ($class, $field) = @_;
# Build a closure around $field.
return sub {
my $self = shift;
if(@_) {
return $self->set($field, @_);
}
else {
return $self->get($field);
}
};
}
=head2 make_ro_accessor
$read_only_accessor = Class->make_ro_accessor($field);
Generates a subroutine refrence which acts as a read-only accessor for
the given $field. It only calls get().
Override get() to change the behavior of your accessors.
=cut
sub make_ro_accessor {
my($class, $field) = @_;
return sub {
my $self = shift;
if (@_) {
my $caller = caller;
$self->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
}
else {
return $self->get($field);
}
};
}
=head2 make_wo_accessor
$read_only_accessor = Class->make_wo_accessor($field);
Generates a subroutine refrence which acts as a write-only accessor
(mutator) for the given $field. It only calls set().
Override set() to change the behavior of your accessors.
=cut
sub make_wo_accessor {
my($class, $field) = @_;
return sub {
my $self = shift;
unless (@_) {
my $caller = caller;
$self->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
}
else {
return $self->set($field, @_);
}
};
}
=head1 EXCEPTIONS
If something goes wrong Class::Accessor will warn or die by calling Carp::carp
or Carp::croak. If you don't like this you can override _carp() and _croak() in
your subclass and do whatever else you want.
=cut
use Carp ();
sub _carp {
my ($self, $msg) = @_;
Carp::carp($msg || $self);
return;
}
sub _croak {
my ($self, $msg) = @_;
Carp::croak($msg || $self);
return;
}
=head1 EFFICIENCY
Class::Accessor does not employ an autoloader, thus it is much faster
than you'd think. Its generated methods incur no special penalty over
ones you'd write yourself.
accessors:
Rate Basic Average Fast Faster Direct
Basic 189150/s -- -42% -51% -55% -89%
Average 327679/s 73% -- -16% -22% -82%
Fast 389212/s 106% 19% -- -8% -78%
Faster 421646/s 123% 29% 8% -- -76%
Direct 1771243/s 836% 441% 355% 320% --
mutators:
Rate Basic Average Fast Faster Direct
Basic 173769/s -- -34% -53% -59% -90%
Average 263046/s 51% -- -29% -38% -85%
Fast 371158/s 114% 41% -- -13% -78%
Faster 425821/s 145% 62% 15% -- -75%
Direct 1699081/s 878% 546% 358% 299% --
Class::Accessor::Fast is faster than methods written by an average programmer
(where "average" is based on Schwern's example code).
Class::Accessor is slower than average, but more flexible.
Class::Accessor::Faster is even faster than Class::Accessor::Fast. It uses an
array internally, not a hash. This could be a good or bad feature depending on
your point of view.
Direct hash access is, of course, much faster than all of these, but it
provides no encapsulation.
Of course, its not as simple as saying "Class::Accessor is slower than
average". These are benchmarks for a simple accessor. If your accessors do
any sort of complicated work (such as talking to a database or writing to a
file) the time spent doing that work will quickly swamp the time spend just
calling the accessor. In that case, Class::Accessor and the ones you write
will be roughly the same speed.
=head1 EXAMPLES
Here's an example of generating an accessor for every public field of
your class.
package Altoids;
use base qw(Class::Accessor Class::Fields);
use fields qw(curiously strong mints);
Altoids->mk_accessors( Altoids->show_fields('Public') );
sub new {
my $proto = shift;
my $class = ref $proto || $proto;
return fields::new($class);
}
my Altoids $tin = Altoids->new;
$tin->curiously('Curiouser and curiouser');
print $tin->{curiously}; # prints 'Curiouser and curiouser'
# Subclassing works, too.
package Mint::Snuff;
use base qw(Altoids);
my Mint::Snuff $pouch = Mint::Snuff->new;
$pouch->strong('Blow your head off!');
print $pouch->{strong}; # prints 'Blow your head off!'
Here's a simple example of altering the behavior of your accessors.
package Foo;
use base qw(Class::Accessor);
Foo->mk_accessor(qw(this that up down));
sub get {
my $self = shift;
# Note every time someone gets some data.
print STDERR "Getting @_\n";
$self->SUPER::get(@_);
}
sub set {
my ($self, $key) = splice(@_, 0, 2);
# Note every time someone sets some data.
print STDERR "Setting $key to @_\n";
$self->SUPER::set($key, @_);
}
=head1 CAVEATS AND TRICKS
Class::Accessor has to do some internal wackiness to get its
job done quickly and efficiently. Because of this, there's a few
tricks and traps one must know about.
Hey, nothing's perfect.
=head2 Don't make a field called DESTROY
This is bad. Since DESTROY is a magical method it would be bad for us
to define an accessor using that name. Class::Accessor will
carp if you try to use it with a field named "DESTROY".
=head2 Overriding autogenerated accessors
You may want to override the autogenerated accessor with your own, yet
have your custom accessor call the default one. For instance, maybe
you want to have an accessor which checks its input. Normally, one
would expect this to work:
package Foo;
use base qw(Class::Accessor);
Foo->mk_accessors(qw(email this that whatever));
# Only accept addresses which look valid.
sub email {
my($self) = shift;
my($email) = @_;
if( @_ ) { # Setting
require Email::Valid;
unless( Email::Valid->address($email) ) {
carp("$email doesn't look like a valid address.");
return;
}
}
return $self->SUPER::email(@_);
}
There's a subtle problem in the last example, and its in this line:
return $self->SUPER::email(@_);
If we look at how Foo was defined, it called mk_accessors() which
stuck email() right into Foo's namespace. There *is* no
SUPER::email() to delegate to! Two ways around this... first is to
make a "pure" base class for Foo. This pure class will generate the
accessors and provide the necessary super class for Foo to use:
package Pure::Organic::Foo;
use base qw(Class::Accessor);
Pure::Organic::Foo->mk_accessors(qw(email this that whatever));
package Foo;
use base qw(Pure::Organic::Foo);
And now Foo::email() can override the generated
Pure::Organic::Foo::email() and use it as SUPER::email().
This is probably the most obvious solution to everyone but me.
Instead, what first made sense to me was for mk_accessors() to define
an alias of email(), _email_accessor(). Using this solution,
Foo::email() would be written with:
return $self->_email_accessor(@_);
instead of the expected SUPER::email().
=head1 AUTHORS
Copyright 2007 Marty Pauley <marty+perl@kasei.com>
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. That means either (a) the GNU General Public
License or (b) the Artistic License.
=head2 ORIGINAL AUTHOR
Michael G Schwern <schwern@pobox.com>
=head2 THANKS
Liz and RUZ for performance tweaks.
Tels, for his big feature request/bug report.
=head1 SEE ALSO
L<Class::Accessor::Fast>
These are some modules which do similar things in different ways
L<Class::Struct>, L<Class::Methodmaker>, L<Class::Generate>,
L<Class::Class>, L<Class::Contract>
L<Class::DBI> for an example of this module in use.
=cut
1;

94
config/mpfire/perl/Accessor/Fast.pm Executable file
View File

@@ -0,0 +1,94 @@
package Class::Accessor::Fast;
use base 'Class::Accessor';
use strict;
$Class::Accessor::Fast::VERSION = '0.31';
=head1 NAME
Class::Accessor::Fast - Faster, but less expandable, accessors
=head1 SYNOPSIS
package Foo;
use base qw(Class::Accessor::Fast);
# The rest is the same as Class::Accessor but without set() and get().
=head1 DESCRIPTION
This is a faster but less expandable version of Class::Accessor.
Class::Accessor's generated accessors require two method calls to accompish
their task (one for the accessor, another for get() or set()).
Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
resulting in a somewhat faster accessor.
The downside is that you can't easily alter the behavior of your
accessors, nor can your subclasses. Of course, should you need this
later, you can always swap out Class::Accessor::Fast for
Class::Accessor.
Read the documentation for Class::Accessor for more info.
=cut
sub make_accessor {
my($class, $field) = @_;
return sub {
return $_[0]->{$field} if @_ == 1;
return $_[0]->{$field} = $_[1] if @_ == 2;
return (shift)->{$field} = \@_;
};
}
sub make_ro_accessor {
my($class, $field) = @_;
return sub {
return $_[0]->{$field} if @_ == 1;
my $caller = caller;
$_[0]->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
};
}
sub make_wo_accessor {
my($class, $field) = @_;
return sub {
if (@_ == 1) {
my $caller = caller;
$_[0]->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
}
else {
return $_[0]->{$field} = $_[1] if @_ == 2;
return (shift)->{$field} = \@_;
}
};
}
=head1 EFFICIENCY
L<Class::Accessor/EFFICIENCY> for an efficiency comparison.
=head1 AUTHORS
Copyright 2007 Marty Pauley <marty+perl@kasei.com>
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. That means either (a) the GNU General Public
License or (b) the Artistic License.
=head2 ORIGINAL AUTHOR
Michael G Schwern <schwern@pobox.com>
=head1 SEE ALSO
L<Class::Accessor>
=cut
1;

105
config/mpfire/perl/Accessor/Faster.pm Executable file
View File

@@ -0,0 +1,105 @@
package Class::Accessor::Faster;
use base 'Class::Accessor';
use strict;
$Class::Accessor::Faster::VERSION = '0.31';
=head1 NAME
Class::Accessor::Faster - Even faster, but less expandable, accessors
=head1 SYNOPSIS
package Foo;
use base qw(Class::Accessor::Faster);
=head1 DESCRIPTION
This is a faster but less expandable version of Class::Accessor::Fast.
Class::Accessor's generated accessors require two method calls to accompish
their task (one for the accessor, another for get() or set()).
Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
resulting in a somewhat faster accessor.
Class::Accessor::Faster uses an array reference underneath to be faster.
Read the documentation for Class::Accessor for more info.
=cut
my %slot;
sub _slot {
my($class, $field) = @_;
my $n = $slot{$class}->{$field};
return $n if defined $n;
$n = keys %{$slot{$class}};
$slot{$class}->{$field} = $n;
return $n;
}
sub new {
my($proto, $fields) = @_;
my($class) = ref $proto || $proto;
my $self = bless [], $class;
$fields = {} unless defined $fields;
for my $k (keys %$fields) {
my $n = $class->_slot($k);
$self->[$n] = $fields->{$k};
}
return $self;
}
sub make_accessor {
my($class, $field) = @_;
my $n = $class->_slot($field);
return sub {
return $_[0]->[$n] if @_ == 1;
return $_[0]->[$n] = $_[1] if @_ == 2;
return (shift)->[$n] = \@_;
};
}
sub make_ro_accessor {
my($class, $field) = @_;
my $n = $class->_slot($field);
return sub {
return $_[0]->[$n] if @_ == 1;
my $caller = caller;
$_[0]->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
};
}
sub make_wo_accessor {
my($class, $field) = @_;
my $n = $class->_slot($field);
return sub {
if (@_ == 1) {
my $caller = caller;
$_[0]->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
} else {
return $_[0]->[$n] = $_[1] if @_ == 2;
return (shift)->[$n] = \@_;
}
};
}
=head1 AUTHORS
Copyright 2007 Marty Pauley <marty+perl@kasei.com>
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. That means either (a) the GNU General Public
License or (b) the Artistic License.
=head1 SEE ALSO
L<Class::Accessor>
=cut
1;

897
config/mpfire/perl/Audio/MPD.pm Normal file
View File

@@ -0,0 +1,897 @@
#
# This file is part of Audio::MPD
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD;
use warnings;
use strict;
use Audio::MPD::Collection;
use Audio::MPD::Common::Item;
use Audio::MPD::Common::Stats;
use Audio::MPD::Common::Status;
use Audio::MPD::Playlist;
use Encode;
use IO::Socket;
use Readonly;
use base qw[ Class::Accessor::Fast Exporter ];
__PACKAGE__->mk_accessors(
qw[ _conntype _host _password _port _socket
collection playlist version ] );
our $VERSION = '0.19.1';
Readonly our $REUSE => 1;
Readonly our $ONCE => 0;
our @EXPORT = qw[ $REUSE $ONCE ];
#--
# Constructor
#
# my $mpd = Audio::MPD->new( [%opts] )
#
# This is the constructor for Audio::MPD. One can specify the following
# options:
# - hostname => $hostname : defaults to environment var MPD_HOST, then to 'localhost'
# - port => $port : defaults to env var MPD_PORT, then to 6600
# - password => $password : defaults to env var MPD_PASSWORD, then to ''
# - conntype => $type : how the connection to mpd server is handled. it can be
# either $REUSE: reuse the same connection
# or $ONCE: open a new connection per command (default)
#
sub new {
my ($class, %opts) = @_;
# use mpd defaults.
my ($default_password, $default_host) = split( '@', $ENV{MPD_HOST} )
if exists $ENV{MPD_HOST} && $ENV{MPD_HOST} =~ /@/;
my $host = $opts{host} || $default_host || $ENV{MPD_HOST} || 'localhost';
my $port = $opts{port} || $ENV{MPD_PORT} || '6600';
my $password = $opts{password} || $ENV{MPD_PASSWORD} || $default_password || '';
# create & bless the object.
my $self = {
_host => $host,
_port => $port,
_password => $password,
_conntype => exists $opts{conntype} ? $opts{conntype} : $ONCE,
};
bless $self, $class;
# create the connection if conntype is set to $REUSE
$self->_connect_to_mpd_server if $self->_conntype == $REUSE;
# create the helper objects and store them.
$self->collection( Audio::MPD::Collection->new($self) );
$self->playlist ( Audio::MPD::Playlist->new($self) );
# try to issue a ping to test connection - this can die.
$self->ping;
return $self;
}
#--
# Private methods
#
# $mpd->_connect_to_mpd_server;
#
# This method connects to the mpd server. It can die on several conditions:
# - if the server cannot be reached,
# - if it's not an mpd server,
# - or if the password is incorrect,
#
sub _connect_to_mpd_server {
my ($self) = @_;
# try to connect to mpd.
my $socket = IO::Socket::INET->new(
PeerAddr => $self->_host,
PeerPort => $self->_port,
)
or die "Could not create socket: $!\n";
# parse version information.
my $line = $socket->getline;
chomp $line;
die "Not a mpd server - welcome string was: [$line]\n"
if $line !~ /^OK MPD (.+)$/;
$self->version($1);
# send password.
if ( $self->_password ) {
$socket->print( 'password ' . encode('utf-8', $self->_password) . "\n" );
$line = $socket->getline;
die $line if $line =~ s/^ACK //;
}
# save socket
$self->_socket($socket);
}
#
# my @result = $mpd->_send_command( $command );
#
# This method is central to the module. It is responsible for interacting with
# mpd by sending the $command and reading output - that will be returned as an
# array of chomped lines (status line will not be returned).
#
# This method can die on several conditions:
# - if the server cannot be reached,
# - if it's not an mpd server,
# - if the password is incorrect,
# - or if the command is an invalid mpd command.
# In the latter case, the mpd error message will be returned.
#
sub _send_command {
my ($self, $command) = @_;
$self->_connect_to_mpd_server if $self->_conntype == $ONCE;
my $socket = $self->_socket;
# ok, now we're connected - let's issue the command.
$socket->print( encode('utf-8', $command) );
my @output;
while (defined ( my $line = $socket->getline ) ) {
chomp $line;
die $line if $line =~ s/^ACK //; # oops - error.
last if $line =~ /^OK/; # end of output.
push @output, decode('utf-8', $line);
}
# close the socket.
$socket->close if $self->_conntype == $ONCE;
return @output;
}
#
# my @items = $mpd->_cooked_command_as_items( $command );
#
# Lots of Audio::MPD methods are using _send_command() and then parse the
# output as a collection of AMC::Item. This method is meant to factorize
# this code, and will parse the raw output of _send_command() in a cooked
# list of items.
#
sub _cooked_command_as_items {
my ($self, $command) = @_;
my @lines = $self->_send_command($command);
my (@items, %param);
# parse lines in reverse order since "file:" or "directory:" lines
# come first. therefore, let's first store every other parameter,
# and the last line will trigger the object creation.
# of course, since we want to preserve the playlist order, this means
# that we're going to unshift the objects instead of push.
foreach my $line (reverse @lines) {
my ($k,$v) = split /:\s/, $line, 2;
$param{$k} = $v;
next unless $k eq 'file' || $k eq 'directory' || $k eq 'playlist'; # last param of item
unshift @items, Audio::MPD::Common::Item->new(%param);
%param = ();
}
return @items;
}
sub _cooked_command_as_filename {
my ($self, $command) = @_;
my @lines = $self->_send_command($command);
my (@items, %param);
# parse lines in reverse order since "file:" or "directory:" lines
# come first. therefore, let's first store every other parameter,
# and the last line will trigger the object creation.
# of course, since we want to preserve the playlist order, this means
# that we're going to unshift the objects instead of push.
foreach my $line (@lines) {
my ($k,$v) = split /:\s/, $line, 2;
if ( $k eq 'file'){$param{$k} = $v;}
unshift @items, $param{'file'};
%param = ();
}
return @items;
}
#
# my %hash = $mpd->_cooked_command_as_kv( $command );
#
# Lots of Audio::MPD methods are using _send_command() and then parse the
# output to get a list of key / value (with the colon ":" acting as separator).
# This method is meant to factorize this code, and will parse the raw output
# of _send_command() in a cooked hash.
#
sub _cooked_command_as_kv {
my ($self, $command) = @_;
my %hash =
map { split(/:\s/, $_, 2) }
$self->_send_command($command);
return %hash;
}
#
# my @list = $mpd->_cooked_command_strip_first_field( $command );
#
# Lots of Audio::MPD methods are using _send_command() and then parse the
# output to remove the first field (with the colon ":" acting as separator).
# This method is meant to factorize this code, and will parse the raw output
# of _send_command() in a cooked list of strings.
#
sub _cooked_command_strip_first_field {
my ($self, $command) = @_;
my @list =
map { ( split(/:\s+/, $_, 2) )[1] }
$self->_send_command($command);
return @list;
}
#--
# Public methods
# -- MPD interaction: general commands
#
# $mpd->ping;
#
# Sends a ping command to the mpd server.
#
sub ping {
my ($self) = @_;
$self->_send_command( "ping\n" );
}
#
# my $version = $mpd->version;
#
# Return version of MPD server's connected.
#
# sub version {} # implemented as an accessor.
#
#
# $mpd->kill;
#
# Send a message to the MPD server telling it to shut down.
#
sub kill {
my ($self) = @_;
$self->_send_command("kill\n");
}
#
# $mpd->password( [$password] )
#
# Change password used to communicate with MPD server to $password.
# Empty string is assumed if $password is not supplied.
#
sub password {
my ($self, $passwd) = @_;
$passwd ||= '';
$self->_password($passwd);
$self->ping; # ping sends a command, and thus the password is sent
}
#
# $mpd->updatedb( [$path] );
#
# Force mpd to rescan its collection. If $path (relative to MPD's music
# directory) is supplied, MPD will only scan it - otherwise, MPD will rescan
# its whole collection.
#
sub updatedb {
my ($self, $path) = @_;
$path ||= '';
$self->_send_command("update $path\n");
}
#
# my @handlers = $mpd->urlhandlers;
#
# Return an array of supported URL schemes.
#
sub urlhandlers {
my ($self) = @_;
return $self->_cooked_command_strip_first_field("urlhandlers\n");
}
# -- MPD interaction: handling volume & output
#
# $mpd->volume( [+][-]$volume );
#
# Sets the audio output volume percentage to absolute $volume.
# If $volume is prefixed by '+' or '-' then the volume is changed relatively
# by that value.
#
sub volume {
my ($self, $volume) = @_;
if ($volume =~ /^(-|\+)(\d+)/ ) {
my $current = $self->status->volume;
$volume = $1 eq '+' ? $current + $2 : $current - $2;
}
$self->_send_command("setvol $volume\n");
}
#
# $mpd->output_enable( $output );
#
# Enable the specified audio output. $output is the ID of the audio output.
#
sub output_enable {
my ($self, $output) = @_;
$self->_send_command("enableoutput $output\n");
}
#
# $mpd->output_disable( $output );
#
# Disable the specified audio output. $output is the ID of the audio output.
#
sub output_disable {
my ($self, $output) = @_;
$self->_send_command("disableoutput $output\n");
}
# -- MPD interaction: retrieving info from current state
#
# $mpd->stats;
#
# Return an AMC::Stats object with the current statistics of MPD.
#
sub stats {
my ($self) = @_;
my %kv = $self->_cooked_command_as_kv( "stats\n" );
return Audio::MPD::Common::Stats->new(\%kv);
}
#
# my $status = $mpd->status;
#
# Return an AMC::Status object with various information on current
# MPD server settings. Check the embedded pod for more information on the
# available accessors.
#
sub status {
my ($self) = @_;
my %kv = $self->_cooked_command_as_kv( "status\n" );
my $status = Audio::MPD::Common::Status->new( \%kv );
return $status;
}
#
# my $song = $mpd->current;
#
# Return an AMC::Item::Song representing the song currently playing.
#
sub current {
my ($self) = @_;
my ($item) = $self->_cooked_command_as_items("currentsong\n");
return $item;
}
#
# my $song = $mpd->song( [$song] )
#
# Return an AMC::Item::Song representing the song number $song.
# If $song is not supplied, returns the current song.
#
sub song {
my ($self, $song) = @_;
return $self->current unless defined $song;
my ($item) = $self->_cooked_command_as_items("playlistinfo $song\n");
return $item;
}
#
# my $song = $mpd->songid( [$songid] )
#
# Return an AMC::Item::Song representing the song with id $songid.
# If $songid is not supplied, returns the current song.
#
sub songid {
my ($self, $songid) = @_;
return $self->current unless defined $songid;
my ($item) = $self->_cooked_command_as_items("playlistid $songid\n");
return $item;
}
# -- MPD interaction: altering settings
#
# $mpd->repeat( [$repeat] );
#
# Set the repeat mode to $repeat (1 or 0). If $repeat is not specified then
# the repeat mode is toggled.
#
sub repeat {
my ($self, $mode) = @_;
$mode = not $self->status->repeat
unless defined $mode; # toggle if no param
$mode = $mode ? 1 : 0; # force integer
$self->_send_command("repeat $mode\n");
}
#
# $mpd->random( [$random] );
#
# Set the random mode to $random (1 or 0). If $random is not specified then
# the random mode is toggled.
#
sub random {
my ($self, $mode) = @_;
$mode = not $self->status->random
unless defined $mode; # toggle if no param
$mode = $mode ? 1 : 0; # force integer
$self->_send_command("random $mode\n");
}
#
# $mpd->fade( [$seconds] );
#
# Enable crossfading and set the duration of crossfade between songs. If
# $seconds is not specified or $seconds is 0, then crossfading is disabled.
#
sub fade {
my ($self, $value) = @_;
$value ||= 0;
$self->_send_command("crossfade $value\n");
}
# -- MPD interaction: controlling playback
#
# $mpd->play( [$song] );
#
# Begin playing playlist at song number $song. If no argument supplied,
# resume playing.
#
sub play {
my ($self, $number) = @_;
$number = '' unless defined $number;
$self->_send_command("play $number\n");
}
#
# $mpd->playid( [$songid] );
#
# Begin playing playlist at song ID $songid. If no argument supplied,
# resume playing.
#
sub playid {
my ($self, $number) = @_;
$number ||= '';
$self->_send_command("playid $number\n");
}
#
# $mpd->pause( [$sate] );
#
# Pause playback. If $state is 0 then the current track is unpaused, if
# $state is 1 then the current track is paused.
#
# Note that if $state is not given, pause state will be toggled.
#
sub pause {
my ($self, $state) = @_;
$state ||= ''; # default is to toggle
$self->_send_command("pause $state\n");
}
#
# $mpd->stop;
#
# Stop playback.
#
sub stop {
my ($self) = @_;
$self->_send_command("stop\n");
}
#
# $mpd->next;
#
# Play next song in playlist.
#
sub next {
my ($self) = @_;
$self->_send_command("next\n");
}
#
# $mpd->prev;
#
# Play previous song in playlist.
#
sub prev {
my($self) = shift;
$self->_send_command("previous\n");
}
#
# $mpd->seek( $time, [$song] );
#
# Seek to $time seconds in song number $song. If $song number is not specified
# then the perl module will try and seek to $time in the current song.
#
sub seek {
my ($self, $time, $song) = @_;
$time ||= 0; $time = int $time;
$song = $self->status->song if not defined $song; # seek in current song
$self->_send_command( "seek $song $time\n" );
}
#
# $mpd->seekid( $time, [$songid] );
#
# Seek to $time seconds in song ID $songid. If $songid number is not specified
# then the perl module will try and seek to $time in the current song.
#
sub seekid {
my ($self, $time, $song) = @_;
$time ||= 0; $time = int $time;
$song = $self->status->songid if not defined $song; # seek in current song
$self->_send_command( "seekid $song $time\n" );
}
1;
__END__
=pod
=head1 NAME
Audio::MPD - class to talk to MPD (Music Player Daemon) servers
=head1 SYNOPSIS
use Audio::MPD;
my $mpd = Audio::MPD->new();
$mpd->play();
sleep 10;
$mpd->next();
=head1 DESCRIPTION
Audio::MPD gives a clear object-oriented interface for talking to and
controlling MPD (Music Player Daemon) servers. A connection to the MPD
server is established as soon as a new Audio::MPD object is created.
Note that the module will by default connect to mpd before sending any
command, and will disconnect after the command has been issued. This scheme
is far from optimal, but allows us not to care about timeout disconnections.
B</!\> Note that Audio::MPD is using high-level, blocking sockets. This
means that if the mpd server is slow, or hangs for whatever reason, or
even crash abruptly, the program will be hung forever in this sub. The
POE::Component::Client::MPD module is way safer - you're advised to use
it instead of Audio::MPD. Or you can try to set C<conntype> to C<$REUSE>
(see Audio::MPD constructor for more details), but you would be then on
your own to deal with disconnections.
=head1 METHODS
=head2 Constructor
=over 4
=item new( [%opts] )
This is the constructor for Audio::MPD. One can specify the following
options:
=over 4
=item hostname => C<$hostname>
defaults to environment var MPD_HOST, then to 'localhost'. Note that
MPD_HOST can be of the form password@host.
=item port => C<$port>
defaults to environment var MPD_PORT, then to 6600.
=item password => $password
defaults to environment var MPD_PASSWORD, then to ''.
=item conntype => $type
change how the connection to mpd server is handled. It can be either
C<$REUSE> to reuse the same connection or C<$ONCE> to open a new
connection per command (default)
=back
=back
=head2 Controlling the server
=over 4
=item $mpd->ping()
Sends a ping command to the mpd server.
=item $mpd->version()
Return the version number for the server we are connected to.
=item $mpd->kill()
Send a message to the MPD server telling it to shut down.
=item $mpd->password( [$password] )
Change password used to communicate with MPD server to $password.
Empty string is assumed if $password is not supplied.
=item $mpd->updatedb( [$path] )
Force mpd to recan its collection. If $path (relative to MPD's music directory)
is supplied, MPD will only scan it - otherwise, MPD will rescan its whole
collection.
=item $mpd->urlhandlers()
Return an array of supported URL schemes.
=back
=head2 Handling volume & output
=over 4
=item $mpd->volume( [+][-]$volume )
Sets the audio output volume percentage to absolute $volume.
If $volume is prefixed by '+' or '-' then the volume is changed relatively
by that value.
=item $mpd->output_enable( $output )
Enable the specified audio output. $output is the ID of the audio output.
=item $mpd->output_disable( $output )
Disable the specified audio output. $output is the ID of the audio output.
=back
=head2 Retrieving info from current state
=over 4
=item $mpd->stats()
Return an C<Audio::MPD::Common::Stats> object with the current statistics
of MPD. See the associated pod for more information.
=item $mpd->status()
Return an C<Audio::MPD::Common::Status> object with various information on
current MPD server settings. Check the embedded pod for more information on
the available accessors.
=item $mpd->current()
Return an C<Audio::MPD::Common::Item::Song> representing the song currently
playing.
=item $mpd->song( [$song] )
Return an C<Audio::MPD::Common::Item::Song> representing the song number
C<$song>. If C<$song> is not supplied, returns the current song.
=item $mpd->songid( [$songid] )
Return an C<Audio::MPD::Common::Item::Song> representing the song with id
C<$songid>. If C<$songid> is not supplied, returns the current song.
=back
=head2 Altering MPD settings
=over 4
=item $mpd->repeat( [$repeat] )
Set the repeat mode to $repeat (1 or 0). If $repeat is not specified then
the repeat mode is toggled.
=item $mpd->random( [$random] )
Set the random mode to $random (1 or 0). If $random is not specified then
the random mode is toggled.
=item $mpd->fade( [$seconds] )
Enable crossfading and set the duration of crossfade between songs.
If $seconds is not specified or $seconds is 0, then crossfading is disabled.
=back
=head2 Controlling playback
=over 4
=item $mpd->play( [$song] )
Begin playing playlist at song number $song. If no argument supplied,
resume playing.
=item $mpd->playid( [$songid] )
Begin playing playlist at song ID $songid. If no argument supplied,
resume playing.
=item $mpd->pause( [$state] )
Pause playback. If C<$state> is 0 then the current track is unpaused,
if $state is 1 then the current track is paused.
Note that if C<$state> is not given, pause state will be toggled.
=item $mpd->stop()
Stop playback.
=item $mpd->next()
Play next song in playlist.
=item $mpd->prev()
Play previous song in playlist.
=item $mpd->seek( $time, [$song])
Seek to $time seconds in song number $song. If $song number is not specified
then the perl module will try and seek to $time in the current song.
=item $mpd->seekid( $time, $songid )
Seek to $time seconds in song ID $songid. If $song number is not specified
then the perl module will try and seek to $time in the current song.
=back
=head2 Searching the collection
To search the collection, use the C<collection()> accessor, returning the
associated C<Audio::MPD::Collection> object. You will then be able to call:
$mpd->collection->random_song();
See C<Audio::MPD::Collection> documentation for more details on available
methods.
=head2 Handling the playlist
To update the playlist, use the C<playlist()> accessor, returning the
associated C<Audio::MPD::Playlist> object. You will then be able to call:
$mpd->playlist->clear;
See C<Audio::MPD::Playlist> documentation for more details on available
methods.
=head1 SEE ALSO
You can find more information on the mpd project on its homepage at
L<http://www.musicpd.org>, or its wiki L<http://mpd.wikia.com>.
Regarding this Perl module, you can report bugs on CPAN via
L<http://rt.cpan.org/Public/Bug/Report.html?Queue=Audio-MPD>.
Audio::MPD development takes place on <audio-mpd@googlegroups.com>: feel free
to join us. (use L<http://groups.google.com/group/audio-mpd> to sign in). Our
subversion repository is located at L<https://svn.musicpd.org>.
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
Original code by Tue Abrahamsen C<< <tue.abrahamsen at gmail.com> >>,
documented by Nicholas J. Humfrey C<< <njh at aelius.com> >>.
=head1 COPYRIGHT & LICENSE
Copyright (c) 2005 Tue Abrahamsen, all rights reserved.
Copyright (c) 2006 Nicolas J. Humfrey, all rights reserved.
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

594
config/mpfire/perl/Audio/MPD/Collection.pm Normal file
View File

@@ -0,0 +1,594 @@
#
# This file is part of Audio::MPD
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Collection;
use strict;
use warnings;
use Scalar::Util qw[ weaken ];
use base qw[ Class::Accessor::Fast ];
__PACKAGE__->mk_accessors( qw[ _mpd ] );
#our ($VERSION) = '$Rev: 5284 $' =~ /(\d+)/;
#--
# Constructor
#
# my $collection = Audio::MPD::Collection->new( $mpd );
#
# This will create the object, holding a back-reference to the Audio::MPD
# object itself (for communication purposes). But in order to play safe and
# to free the memory in time, this reference is weakened.
#
# Note that you're not supposed to call this constructor yourself, an
# Audio::MPD::Collection is automatically created for you during the creation
# of an Audio::MPD object.
#
sub new {
my ($pkg, $mpd) = @_;
my $self = { _mpd => $mpd };
weaken( $self->{_mpd} );
bless $self, $pkg;
return $self;
}
#--
# Public methods
# -- Collection: retrieving songs & directories
#
# my @items = $collection->all_items( [$path] );
#
# Return *all* AMC::Items (both songs & directories) currently known
# by mpd.
#
# If $path is supplied (relative to mpd root), restrict the retrieval to
# songs and dirs in this directory.
#
sub all_items {
my ($self, $path) = @_;
$path ||= '';
$path =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_items( qq[listallinfo "$path"\n] );
}
#
# my @items = $collection->all_items_simple( [$path] );
#
# Return *all* AMC::Items (both songs & directories) currently known
# by mpd.
#
# If $path is supplied (relative to mpd root), restrict the retrieval to
# songs and dirs in this directory.
#
# /!\ Warning: the AMC::Item::Song objects will only have their tag
# file filled. Any other tag will be empty, so don't use this sub for any
# other thing than a quick scan!
#
sub all_items_simple {
my ($self, $path) = @_;
$path ||= '';
$path =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_items( qq[listall "$path"\n] );
}
#
# my @items = $collection->items_in_dir( [$path] );
#
# Return the items in the given $path. If no $path supplied, do it on mpd's
# root directory.
#
# Note that this sub does not work recusrively on all directories.
#
sub items_in_dir {
my ($self, $path) = @_;
$path ||= '';
$path =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_items( qq[lsinfo "$path"\n] );
}
# -- Collection: retrieving the whole collection
#
# my @songs = $collection->all_songs( [$path] );
#
# Return *all* AMC::Item::Songs currently known by mpd.
#
# If $path is supplied (relative to mpd root), restrict the retrieval to
# songs and dirs in this directory.
#
sub all_songs {
my ($self, $path) = @_;
return grep { $_->isa('Audio::MPD::Common::Item::Song') } $self->all_items($path);
}
#
# my @albums = $collection->all_albums;
#
# Return the list of all albums (strings) currently known by mpd.
#
sub all_albums {
my ($self) = @_;
return $self->_mpd->_cooked_command_strip_first_field( "list album\n" );
}
#
# my @artists = $collection->all_artists;
#
# Return the list of all artists (strings) currently known by mpd.
#
sub all_artists {
my ($self) = @_;
return $self->_mpd->_cooked_command_strip_first_field( "list artist\n" );
}
#
# my @titles = $collection->all_titles;
#
# Return the list of all titles (strings) currently known by mpd.
#
sub all_titles {
my ($self) = @_;
return $self->_mpd->_cooked_command_strip_first_field( "list title\n" );
}
#
# my @genre = $collection->all_genre;
#
# Return the list of all genres (strings) currently known by mpd.
#
sub all_genre {
my ($self) = @_;
return $self->_mpd->_cooked_command_strip_first_field( "list genre\n" );
}
#
# my @yers = $collection->all_years;
#
# Return the list of all years (strings) currently known by mpd.
#
sub all_years {
my ($self) = @_;
return $self->_mpd->_cooked_command_strip_first_field( "list date\n" );
}
#
# my @pathes = $collection->all_pathes;
#
# Return the list of all pathes (strings) currently known by mpd.
#
sub all_pathes {
my ($self) = @_;
return $self->_mpd->_cooked_command_strip_first_field( "list filename\n" );
}
#
# my @items = $collection->all_playlists;
#
# Return the list of playlists (strings) currently known by mpd.
#
sub all_playlists {
my ($self) = @_;
return
map { /^playlist: (.*)$/ ? ($1) : () }
$self->_mpd->_send_command( "lsinfo\n" );
}
# -- Collection: picking songs
#
# my $song = $collection->song( $path );
#
# Return the AMC::Item::Song which correspond to $path.
#
sub song {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
my ($item) = $self->_mpd->_cooked_command_as_items( qq[find filename "$what"\n] );
return $item;
}
#
# my $song = $collection->songs_with_filename_partial( $path );
#
# Return the AMC::Item::Songs containing $string in their path.
#
sub songs_with_filename_partial {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_items( qq[search filename "$what"\n] );
}
# -- Collection: songs, albums & artists relations
#
# my @albums = $collection->albums_by_artist($artist);
#
# Return all albums (strings) performed by $artist or where $artist
# participated.
#
sub albums_by_artist {
my ($self, $artist) = @_;
$artist =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_strip_first_field( qq[list album "$artist"\n] );
}
#
# my @songs = $collection->songs_by_artist( $genre );
#
# Return all AMC::Item::Songs performed in $genre.
#
sub songs_by_genre {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_items( qq[find genre "$what"\n] );
}
sub filenames_by_artist {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_filename( qq[find artist "$what"\n] );
}
sub filenames_by_year {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_filename( qq[find date "$what"\n] );
}
sub filenames_by_genre {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_filename( qq[find genre "$what"\n] );
}
sub filenames_by_album {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_filename( qq[find album "$what"\n] );
}
#
# my @songs = $collection->songs_by_artist_partial( $string );
#
# Return all AMC::Item::Songs performed by an artist with $string
# in her name.
#
sub songs_by_artist_partial {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_items( qq[search artist "$what"\n] );
}
#
# my @songs = $collection->songs_from_album( $album );
#
# Return all AMC::Item::Songs appearing in $album.
#
sub songs_from_album {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_items( qq[find album "$what"\n] );
}
#
# my @songs = $collection->songs_from_album_partial( $string );
#
# Return all AMC::Item::Songs appearing in album containing $string.
#
sub songs_from_album_partial {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_items( qq[search album "$what"\n] );
}
#
# my @songs = $collection->songs_with_title( $title );
#
# Return all AMC::Item::Songs which title is exactly $title.
#
sub songs_with_title {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_items( qq[find title "$what"\n] );
}
#
# my @songs = $collection->songs_with_title_partial( $string );
#
# Return all AMC::Item::Songs where $string is part of the title.
#
sub songs_with_title_partial {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_items( qq[search title "$what"\n] );
}
# my @songs = $collection->songs_with_title_partial_filename( $string );
#
# Return all AMC::Item::Songs where $string is part of the title.
#
sub songs_with_title_partial_filename {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_filename( qq[search title "$what"\n] );
}
# my @songs = $collection->songs_with_artist_partial_filename( $string );
#
# Return all AMC::Item::Songs where $string is part of the artist.
#
sub songs_with_artist_partial_filename {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_filename( qq[search artist "$what"\n] );
}
# my @songs = $collection->songs_with_album_partial_filename( $string );
#
# Return all AMC::Item::Songs where $string is part of the album.
#
sub songs_with_album_partial_filename {
my ($self, $what) = @_;
$what =~ s/"/\\"/g;
return $self->_mpd->_cooked_command_as_filename( qq[search album "$what"\n] );
}
1;
__END__
=head1 NAME
Audio::MPD::Collection - an object to query MPD's collection
=head1 SYNOPSIS
my $song = $mpd->collection->random_song;
=head1 DESCRIPTION
C<Audio::MPD::Collection> is a class meant to access & query MPD's
collection. You will be able to use those high-level methods instead
of using the low-level methods provided by mpd itself.
=head1 PUBLIC METHODS
=head2 Constructor
=over 4
=item new( $mpd )
This will create the object, holding a back-reference to the C<Audio::MPD>
object itself (for communication purposes). But in order to play safe and
to free the memory in time, this reference is weakened.
Note that you're not supposed to call this constructor yourself, an
C<Audio::MPD::Collection> is automatically created for you during the creation
of an C<Audio::MPD> object.
=back
=head2 Retrieving songs & directories
=over 4
=item $coll->all_items( [$path] )
Return B<all> C<Audio::MPD::Common::Item>s (both songs & directories)
currently known by mpd.
If C<$path> is supplied (relative to mpd root), restrict the retrieval to
songs and dirs in this directory.
=item $coll->all_items_simple( [$path] )
Return B<all> C<Audio::MPD::Common::Item>s (both songs & directories)
currently known by mpd.
If C<$path> is supplied (relative to mpd root), restrict the retrieval to
songs and dirs in this directory.
B</!\ Warning>: the C<Audio::MPD::Common::Item::Song> objects will only have
their tag file filled. Any other tag will be empty, so don't use this sub for
any other thing than a quick scan!
=item $coll->items_in_dir( [$path] )
Return the items in the given C<$path>. If no C<$path> supplied, do it on
mpd's root directory.
Note that this sub does not work recusrively on all directories.
=back
=head2 Retrieving the whole collection
=over 4
=item $coll->all_songs( [$path] )
Return B<all> C<Audio::MPD::Common::Item::Song>s currently known by mpd.
If C<$path> is supplied (relative to mpd root), restrict the retrieval to
songs and dirs in this directory.
=item $coll->all_albums()
Return the list of all albums (strings) currently known by mpd.
=item $coll->all_artists()
Return the list of all artists (strings) currently known by mpd.
=item $coll->all_titles()
Return the list of all song titles (strings) currently known by mpd.
=item $coll->all_pathes()
Return the list of all pathes (strings) currently known by mpd.
=item $coll->all_playlists()
Return the list of all playlists (strings) currently known by mpd.
=back
=head2 Picking a song
=over 4
=item $coll->song( $path )
Return the C<Audio::MPD::Common::Item::Song> which correspond to C<$path>.
=item $coll->songs_with_filename_partial( $path )
Return the C<Audio::MPD::Common::Item::Song>s containing $string in their path.
=back
=head2 Songs, albums & artists relations
=over 4
=item $coll->albums_by_artist( $artist )
Return all albums (strings) performed by C<$artist> or where C<$artist>
participated.
=item $coll->songs_by_artist( $artist )
Return all C<Audio::MPD::Common::Item::Song>s performed by C<$artist>.
=item $coll->songs_by_artist_partial( $string )
Return all C<Audio::MPD::Common::Item::Song>s performed by an artist with
C<$string> in her name.
=item $coll->songs_from_album( $album )
Return all C<Audio::MPD::Common::Item::Song>s appearing in C<$album>.
=item $coll->songs_from_album_partial( $string )
Return all C<Audio::MPD::Common::Item::Song>s appearing in album containing C<$string>.
=item $coll->songs_with_title( $title )
Return all C<Audio::MPD::Common::Item::Song>s which title is exactly C<$title>.
=item $coll->songs_with_title_partial( $string )
Return all C<Audio::MPD::Common::Item::Song>s where C<$string> is part of the title.
=back
=head1 SEE ALSO
L<Audio::MPD>
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

88
config/mpfire/perl/Audio/MPD/Common.pm Normal file
View File

@@ -0,0 +1,88 @@
#
# This file is part of Audio::MPD::Common
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Common;
use warnings;
use strict;
our $VERSION = '0.1.2';
1;
__END__
=head1 NAME
Audio::MPD::Common - a bunch of common helper classes for mpd
=head1 DESCRIPTION
Depending on whether you're using a POE-aware environment or not, people
wanting to tinker with mpd (Music Player Daemon) will use either
L<POE::Component::Client::MPD> or L<Audio::MPD>.
But even if the run-cores of those two modules differ completely, they
are using the exact same common classes to represent the various mpd
states and information.
Therefore, those common classes have been outsourced to
L<Audio::MPD::Common>.
This module does not export any methods, but the dist provides the
following classes that you can query with perldoc:
=over 4
=item o L<Audio::MPD::Common::Item>
=item o L<Audio::MPD::Common::Item::Directory>
=item o L<Audio::MPD::Common::Item::Playlist>
=item o L<Audio::MPD::Common::Item::Song>
=item o L<Audio::MPD::Common::Stats>
=item o L<Audio::MPD::Common::Status>
=item o L<Audio::MPD::Common::Time>
=back
Note that those modules should not be of any use outside the two mpd
modules afore-mentioned.
=head1 SEE ALSO
=over 4
=item L<Audio::MPD>
=item L<POE::Component::Client::MPD>
=back
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

100
config/mpfire/perl/Audio/MPD/Common/Item.pm Normal file
View File

@@ -0,0 +1,100 @@
#
# This file is part of Audio::MPD::Common
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Common::Item;
use strict;
use warnings;
use Audio::MPD::Common::Item::Directory;
use Audio::MPD::Common::Item::Playlist;
use Audio::MPD::Common::Item::Song;
#our ($VERSION) = '$Rev: 5645 $' =~ /(\d+)/;
#
# constructor.
#
sub new {
my ($pkg, %params) = @_;
# transform keys in lowercase.
my %lowcase;
@lowcase{ keys %params } = values %params;
return Audio::MPD::Common::Item::Song->new(\%lowcase) if exists $params{file};
return Audio::MPD::Common::Item::Directory->new(\%lowcase) if exists $params{directory};
return Audio::MPD::Common::Item::Playlist->new(\%lowcase) if exists $params{playlist};
}
1;
__END__
=head1 NAME
Audio::MPD::Common::Item - a generic collection item
=head1 SYNOPSIS
my $item = Audio::MPD::Common::Item->new( %params );
=head1 DESCRIPTION
C<Audio::MPD::Common::Item> is a virtual class representing a generic
item of mpd's collection. It can be either a song, a directory or a playlist.
Depending on the params given to C<new>, it will create and return an
C<Audio::MPD::Common::Item::Song>, an C<Audio::MPD::Common::Item::Directory>
or an C<Audio::MPD::Common::Playlist> object. Currently, the
discrimination is done on the existence of the C<file> key of C<%params>.
=head1 PUBLIC METHODS
Note that the only sub worth it in this class is the constructor:
=over 4
=item new( key => val [, key => val [, ...] ] )
Create and return either an C<Audio::MPD::Common::Item::Song>, an
C<Audio::MPD::Common::Item::Directory> or an C<Audio::MPD::Common::Playlist>
object, depending on the existence of a key C<file>, C<directory> or
C<playlist> (respectively).
=back
=head1 SEE ALSO
=over 4
=item L<Audio::MPD>
=item L<POE::Component::Client::MPD>
=back
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

72
config/mpfire/perl/Audio/MPD/Common/Item/Directory.pm Normal file
View File

@@ -0,0 +1,72 @@
#
# This file is part of Audio::MPD::Common
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Common::Item::Directory;
use strict;
use warnings;
use base qw[ Class::Accessor::Fast Audio::MPD::Common::Item ];
__PACKAGE__->mk_accessors( qw[ directory ] );
#our ($VERSION) = '$Rev: 5645 $' =~ /(\d+)/;
1;
__END__
=head1 NAME
Audio::MPD::Common::Item::Directory - a directory object
=head1 SYNOPSIS
print $item->directory . "\n";
=head1 DESCRIPTION
C<Audio::MPD::Common::Item::Directory> is more a placeholder for a
hash ref with one pre-defined key, namely the directory name.
=head1 PUBLIC METHODS
This module only has a C<new()> constructor, which should only be called by
C<Audio::MPD::Common::Item>'s constructor.
The only other public method is an accessor: directory().
=head1 SEE ALSO
=over 4
=item L<Audio::MPD>
=item L<POE::Component::Client::MPD>
=back
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

72
config/mpfire/perl/Audio/MPD/Common/Item/Playlist.pm Normal file
View File

@@ -0,0 +1,72 @@
#
# This file is part of Audio::MPD::Common
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Common::Item::Playlist;
use strict;
use warnings;
use base qw[ Class::Accessor::Fast Audio::MPD::Common::Item ];
__PACKAGE__->mk_accessors( qw[ playlist ] );
#our ($VERSION) = '$Rev: 5645 $' =~ /(\d+)/;
1;
__END__
=head1 NAME
Audio::MPD::Common::Item::Playlist - a playlist object
=head1 SYNOPSIS
print $item->playlist . "\n";
=head1 DESCRIPTION
C<Audio::MPD::Common::Item::Playlist> is more a placeholder for a hash ref
with one pre-defined key, namely the playlist name.
=head1 PUBLIC METHODS
This module only has a C<new()> constructor, which should only be called by
C<Audio::MPD::Common::Item>'s constructor.
The only other public method is an accessor: playlist().
=head1 SEE ALSO
=over 4
=item L<Audio::MPD>
=item L<POE::Component::Client::MPD>
=back
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

133
config/mpfire/perl/Audio/MPD/Common/Item/Song.pm Normal file
View File

@@ -0,0 +1,133 @@
#
# This file is part of Audio::MPD::Common
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Common::Item::Song;
use strict;
use warnings;
use overload '""' => \&as_string;
use Readonly;
use base qw[ Class::Accessor::Fast Audio::MPD::Common::Item ];
__PACKAGE__->mk_accessors( qw[ Album Artist file id pos Title Track time ] );
#our ($VERSION) = '$Rev: 5645 $' =~ /(\d+)/;
Readonly my $SEP => ' = ';
#
# my $str = $song->as_string;
#
# Return a string representing $song. This string will be;
# - either "Album = Track = Artist = Title"
# - or "Artist = Title"
# - or "Title"
# - or "file"
# (in this order), depending on the existing tags of the song. The last
# possibility always exist of course, since it's a path.
#
sub as_string {
my ($self) = @_;
return $self->file unless defined $self->Title;
my $str = $self->Title;
return $str unless defined $self->Artist;
$str = $self->Artist . $SEP . $str;
return $str unless defined $self->Album && defined $self->Track;
return join $SEP,
$self->Album,
$self->Track,
$str;
}
1;
__END__
=head1 NAME
Audio::MPD::Common::Item::Song - a song object with some audio tags
=head1 DESCRIPTION
C<Audio::MPD::Common::Item::Song> is more a placeholder for a
hash ref with some pre-defined keys, namely some audio tags.
=head1 PUBLIC METHODS
This module has a C<new()> constructor, which should only be called by
C<Audio::MPD::Common::Item>'s constructor.
The only other public methods are the accessors - see below.
=head2 Accessors
The following methods are the accessors to their respective named fields:
C<Album()>, C<Artist()>, C<file()>, C<id>, C<pos>, C<Title()>, CTTrack()>,
C<time()>. You can call them either with no arg to get the value, or with
an arg to replace the current value.
=head2 Methods
=over 4
=item $song->as_string()
Return a string representing $song. This string will be:
=over 4
=item either "Album = Track = Artist = Title"
=item or "Artist = Title"
=item or "Title"
=item or "file"
=back
(in this order), depending on the existing tags of the song. The last
possibility always exist of course, since it's a path.
=back
=head1 SEE ALSO
=over 4
=item L<Audio::MPD>
=item L<POE::Component::Client::MPD>
=back
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

135
config/mpfire/perl/Audio/MPD/Common/Stats.pm Normal file
View File

@@ -0,0 +1,135 @@
#
# This file is part of Audio::MPD::Common
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Common::Stats;
use warnings;
use strict;
use base qw[ Class::Accessor::Fast ];
__PACKAGE__->mk_accessors
( qw[ artists albums songs uptime playtime db_playtime db_update ] );
#our ($VERSION) = '$Rev$' =~ /(\d+)/;
1;
__END__
=head1 NAME
Audio::MPD::Common::Stats - class representing MPD stats
=head1 SYNOPSIS
print $stats->artists;
=head1 DESCRIPTION
The MPD server maintains some general information. Those information can be
queried with the mpd modules. Some of those information are served to you as
an C<Audio::MPD::Common::Status> object.
Note that an C<Audio::MPD::Common::Stats> object does B<not> update itself
regularly, and thus should be used immediately.
=head1 METHODS
=head2 Constructor
=over 4
=item new( %kv )
The C<new()> method is the constructor for the C<Audio::MPD::Common::Stats>
class.
Note: one should B<never> ever instantiate an C<Audio::MPD::Common::Stats>
object directly - use the mpd modules instead.
=back
=head2 Accessors
Once created, one can access to the following members of the object:
=over 4
=item $stats->artists()
Number of artists in the music database.
=item $stats->albums()
Number of albums in the music database.
=item $stats->songs()
Number of songs in the music database.
=item $stats->uptime()
Daemon uptime (time since last startup) in seconds.
=item $stats->playtime()
Time length of music played.
=item $stats->db_playtime()
Sum of all song times in the music database.
=item $stats->db_update()
Last database update in UNIX time.
=back
Please note that those accessors are read-only: changing a value will B<not>
change the current settings of MPD server. Use the mpd modules to alter the
settings.
=head1 SEE ALSO
=over 4
=item L<Audio::MPD>
=item L<POE::Component::Client::MPD>
=back
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

192
config/mpfire/perl/Audio/MPD/Common/Status.pm Normal file
View File

@@ -0,0 +1,192 @@
#
# This file is part of Audio::MPD::Common
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Common::Status;
use warnings;
use strict;
use Audio::MPD::Common::Time;
use base qw[ Class::Accessor::Fast ];
__PACKAGE__->mk_accessors
( qw[ audio bitrate error playlist playlistlength random
repeat song songid state time volume updating_db xfade ] );
#our ($VERSION) = '$Rev: 5865 $' =~ /(\d+)/;
#--
# Constructor
#
# my $status = Audio::MPD::Common::Status->new( \%kv )
#
# The constructor for the class Audio::MPD::Common::Status. %kv is
# a cooked output of what MPD server returns to the status command.
#
sub new {
my ($class, $kv) = @_;
my %kv = %$kv;
$kv{time} = Audio::MPD::Common::Time->new( delete $kv{time} );
bless \%kv, $class;
return \%kv;
}
1;
__END__
=head1 NAME
Audio::MPD::Common::Status - class representing MPD status
=head1 SYNOPSIS
print $status->bitrate;
=head1 DESCRIPTION
The MPD server maintains some information on its current state. Those
information can be queried with mpd modules. Some of those information
are served to you as an C<Audio::MPD::Common::Status> object.
Note that an C<Audio::MPD::Common::Status> object does B<not> update
itself regularly, and thus should be used immediately.
=head1 METHODS
=head2 Constructor
=over 4
=item new( \%kv )
The C<new()> method is the constructor for the C<Audio::MPD::Common::Status>
class.
Note: one should B<never> ever instantiate an C<Audio::MPD::Common::Status>
object directly - use the mpd modules instead.
=back
=head2 Accessors
Once created, one can access to the following members of the object:
=over 4
=item $status->audio()
A string with the sample rate of the song currently playing, number of bits
of the output and number of channels (2 for stereo) - separated by a colon.
=item $status->bitrate()
The instantaneous bitrate in kbps.
=item $status->error()
May appear in special error cases, such as when disabling output.
=item $status->playlist()
The playlist version number, that changes every time the playlist is updated.
=item $status->playlistlength()
The number of songs in the playlist.
=item $status->random()
Whether the playlist is read randomly or not.
=item $status->repeat()
Whether the song is repeated or not.
=item $status->song()
The offset of the song currently played in the playlist.
=item $status->songid()
The song id (MPD id) of the song currently played.
=item $status->state()
The state of MPD server. Either C<play>, C<stop> or C<pause>.
=item $status->time()
An C<Audio::MPD::Common::Time> object, representing the time elapsed /
remainging and total. See the associated pod for more details.
=item $status->updating_db()
An integer, representing the current update job.
=item $status->volume()
The current MPD volume - an integer between 0 and 100.
=item $status->xfade()
The crossfade in seconds.
=back
Please note that those accessors are read-only: changing a value will B<not>
change the current settings of MPD server. Use the mpd modules to alter the
settings.
=head1 SEE ALSO
=over 4
=item L<Audio::MPD>
=item L<POE::Component::Client::MPD>
=back
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

186
config/mpfire/perl/Audio/MPD/Common/Time.pm Normal file
View File

@@ -0,0 +1,186 @@
#
# This file is part of Audio::MPD::Common
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Common::Time;
use warnings;
use strict;
use base qw[ Class::Accessor::Fast ];
__PACKAGE__->mk_accessors
( qw[ percent sofar left total
sofar_secs sofar_mins seconds_sofar
total_secs total_mins seconds_total
left_secs left_mins seconds_left
] );
#our ($VERSION) = '$Rev$' =~ /(\d+)/;
#--
# Constructor
#
# my $status = Audio::MPD::Common::Time->new( $time )
#
# The constructor for the class Audio::MPD::Common::Time. $time is
# the time value (on the "time" line) of what the output MPD server
# returns to the status command.
#
sub new {
my ($class, $time) = @_;
$time ||= '0:0';
my ($seconds_sofar, $seconds_total) = split /:/, $time;
my $seconds_left = $seconds_total - $seconds_sofar;
my $percent = $seconds_total ? 100*$seconds_sofar/$seconds_total : 0;
# Parse the time so far
my $sofar_mins = int( $seconds_sofar / 60 );
my $sofar_secs = $seconds_sofar % 60;
my $sofar = sprintf "%d:%02d", $sofar_mins, $sofar_secs;
# Parse the total time
my $total_mins = int( $seconds_total / 60 );
my $total_secs = $seconds_total % 60;
my $total = sprintf "%d:%02d", $total_mins, $total_secs;
# Parse the time left
my $left_mins = int( $seconds_left / 60 );
my $left_secs = $seconds_left % 60;
my $left = sprintf "%d:%02d", $left_mins, $left_secs;
# create object
my $self = {
# time elapsed in seconds
seconds_sofar => $seconds_sofar,
seconds_left => $seconds_left,
seconds_total => $seconds_total,
# cooked values
sofar => $sofar,
left => $left,
total => $total,
percent => sprintf("%.1f", $percent), # 1 decimal
# details
sofar_secs => $sofar_secs,
sofar_mins => $sofar_mins,
total_secs => $total_secs,
total_mins => $total_mins,
left_secs => $left_secs,
left_mins => $left_mins,
};
bless $self, $class;
return $self;
}
1;
__END__
=head1 NAME
Audio::MPD::Common::Time - class representing time of current song
=head1 SYNOPSIS
my $time = $status->time;
print $time->sofar;
=head1 DESCRIPTION
C<Audio::MPD::Common::Status> returns some time information with the C<time()>
accessor. This information relates to the elapsed time of the current song,
as well as the remaining and total time. This information is encapsulated
in an C<Audio::MPD::Common::Time> object.
Note that an C<Audio::MPD::Common::Time> object does B<not> update itself
regularly, and thus should be used immediately.
=head1 METHODS
=head2 Constructor
=over 4
=item new( $time )
The C<new()> method is the constructor for the C<Audio::MPD::Common::Time>
class.
Note: one should B<never> ever instantiate an C<Audio::MPD::Common::Time>
object directly - use the mpd modules instead.
=back
=head2 Accessors
Once created, one can access the following members of the object:
=over 4
=item cooked values:
The C<sofar()>, C<left()> and C<total()> methods return the according values
under the form C<minutes:seconds>. Note the existence of a C<percent()>
method returning a percentage complete. (one decimal)
=item values in seconds:
The C<seconds_sofar()>, C<seconds_left()> and C<seconds_total()> return the
according values in seconds.
=item detailled values:
If you want to cook your own value, then the following methods can help:
C<sofar_secs()> and C<sofar_mins()> return the seconds and minutes elapsed.
Same for C<left_secs()> and C<left_mins()> (time remaining), C<total_secs()>
and C<total_mins()>. (total song length)
=back
Please note that those accessors are read-only: changing a value will B<not>
change the current settings of MPD server. Use the mpd modules to alter the
settings.
=head1 SEE ALSO
=over 4
=item L<Audio::MPD>
=item L<POE::Component::Client::MPD>
=back
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

427
config/mpfire/perl/Audio/MPD/Playlist.pm Normal file
View File

@@ -0,0 +1,427 @@
#
# This file is part of Audio::MPD
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Playlist;
use strict;
use warnings;
use Scalar::Util qw[ weaken ];
use base qw[ Class::Accessor::Fast ];
__PACKAGE__->mk_accessors( qw[ _mpd ] );
#our ($VERSION) = '$Rev$' =~ /(\d+)/;
#--
# Constructor
#
# my $collection = Audio::MPD::Playlist->new( $mpd );
#
# This will create the object, holding a back-reference to the Audio::MPD
# object itself (for communication purposes). But in order to play safe and
# to free the memory in time, this reference is weakened.
#
# Note that you're not supposed to call this constructor yourself, an
# Audio::MPD::Playlist is automatically created for you during the creation
# of an Audio::MPD object.
#
sub new {
my ($pkg, $mpd) = @_;
my $self = { _mpd => $mpd };
weaken( $self->{_mpd} );
bless $self, $pkg;
return $self;
}
#--
# Public methods
# -- Playlist: retrieving information
#
# my @items = $pl->as_items;
#
# Return an array of AMC::Item::Songs, one for each of the
# songs in the current playlist.
#
sub as_items {
my ($self) = @_;
my @list = $self->_mpd->_cooked_command_as_items("playlistinfo\n");
return @list;
}
#
# my @items = $pl->items_changed_since( $plversion );
#
# Return a list with all the songs (as API::Song objects) added to
# the playlist since playlist $plversion.
#
sub items_changed_since {
my ($self, $plid) = @_;
return $self->_mpd->_cooked_command_as_items("plchanges $plid\n");
}
# -- Playlist: adding / removing songs
#
# $pl->add( $path [, $path [...] ] );
#
# Add the songs identified by $path (relative to MPD's music directory) to
# the current playlist. No return value.
#
sub add {
my ($self, @pathes) = @_;
my $command =
"command_list_begin\n"
. join( '', map { s/"/\\"/g; qq[add "$_"\n] } @pathes )
. "command_list_end\n";
$self->_mpd->_send_command( $command );
}
#
# $pl->delete( $song [, $song [...] ] );
#
# Remove song number $song (starting from 0) from the current playlist. No
# return value.
#
sub delete {
my ($self, @songs) = @_;
my $command =
"command_list_begin\n"
. join( '', map { s/"/\\"/g; "delete $_\n" } @songs )
. "command_list_end\n";
$self->_mpd->_send_command( $command );
}
#
# $pl->deleteid( $songid [, $songid [...] ]);
#
# Remove the specified $songid (as assigned by mpd when inserted in playlist)
# from the current playlist. No return value.
#
sub deleteid {
my ($self, @songs) = @_;
my $command =
"command_list_begin\n"
. join( '', map { "deleteid $_\n" } @songs )
. "command_list_end\n";
$self->_mpd->_send_command( $command );
}
#
# $pl->clear;
#
# Remove all the songs from the current playlist. No return value.
#
sub clear {
my ($self) = @_;
$self->_mpd->_send_command("clear\n");
}
#
# $pl->crop;
#
# Remove all of the songs from the current playlist *except* the current one.
#
sub crop {
my ($self) = @_;
my $status = $self->_mpd->status;
my $cur = $status->song;
my $len = $status->playlistlength - 1;
my $command =
"command_list_begin\n"
. join( '', map { $_ != $cur ? "delete $_\n" : '' } reverse 0..$len )
. "command_list_end\n";
$self->_mpd->_send_command( $command );
}
# -- Playlist: changing playlist order
#
# $pl->shuffle();
#
# Shuffle the current playlist. No return value.
#
sub shuffle {
my ($self) = @_;
$self->_mpd->_send_command("shuffle\n");
}
#
# $pl->swap( $song1, $song2 );
#
# Swap positions of song number $song1 and $song2 in the current playlist.
# No return value.
#
sub swap {
my ($self, $from, $to) = @_;
$self->_mpd->_send_command("swap $from $to\n");
}
#
# $pl->swapid( $songid1, $songid2 );
#
# Swap the postions of song ID $songid1 with song ID $songid2 in the
# current playlist. No return value.
#
sub swapid {
my ($self, $from, $to) = @_;
$self->_mpd->_send_command("swapid $from $to\n");
}
#
# $pl->move( $song, $newpos );
#
# Move song number $song to the position $newpos. No return value.
#
sub move {
my ($self, $song, $pos) = @_;
$self->_mpd->_send_command("move $song $pos\n");
}
#
# $pl->moveid( $songid, $newpos );
#
# Move song ID $songid to the position $newpos. No return value.
#
sub moveid {
my ($self, $song, $pos) = @_;
$self->_mpd->_send_command("moveid $song $pos\n");
}
# -- Playlist: managing playlists
#
# $pl->load( $playlist );
#
# Load list of songs from specified $playlist file. No return value.
#
sub load {
my ($self, $playlist) = @_;
$self->_mpd->_send_command( qq[load "$playlist"\n] );
}
#
# $pl->save( $playlist );
#
# Save the current playlist to a file called $playlist in MPD's playlist
# directory. No return value.
#
sub save {
my ($self, $playlist) = @_;
$self->_mpd->_send_command( qq[save "$playlist"\n] );
}
#
# $pl->rm( $playlist )
#
# Delete playlist named $playlist from MPD's playlist directory. No
# return value.
#
sub rm {
my ($self, $playlist) = @_;
$self->_mpd->_send_command( qq[rm "$playlist"\n] );
}
1;
__END__
=head1 NAME
Audio::MPD::Playlist - an object to mess MPD's playlist
=head1 SYNOPSIS
my $song = $mpd->playlist->randomize;
=head1 DESCRIPTION
C<Audio::MPD::Playlist> is a class meant to access & update MPD's
playlist.
=head1 PUBLIC METHODS
=head2 Constructor
=over 4
=item new( $mpd )
This will create the object, holding a back-reference to the C<Audio::MPD>
object itself (for communication purposes). But in order to play safe and
to free the memory in time, this reference is weakened.
Note that you're not supposed to call this constructor yourself, an
C<Audio::MPD::Playlist> is automatically created for you during the creation
of an C<Audio::MPD> object.
=back
=head2 Retrieving information
=over 4
=item $pl->as_items()
Return an array of C<Audio::MPD::Common::Item::Song>s, one for each of the
songs in the current playlist.
=item $pl->items_changed_since( $plversion )
Return a list with all the songs (as AMC::Item::Song objects) added to
the playlist since playlist $plversion.
=back
=head2 Adding / removing songs
=over 4
=item $pl->add( $path [, $path [...] ] )
Add the songs identified by C<$path> (relative to MPD's music directory) to the
current playlist. No return value.
=item $pl->delete( $song [, $song [...] ] )
Remove song number C<$song>s (starting from 0) from the current playlist. No
return value.
=item $pl->deleteid( $songid [, $songid [...] ] )
Remove the specified C<$songid>s (as assigned by mpd when inserted in playlist)
from the current playlist. No return value.
=item $pl->clear()
Remove all the songs from the current playlist. No return value.
=item $pl->crop()
Remove all of the songs from the current playlist *except* the
song currently playing.
=back
=head2 Changing playlist order
=over 4
=item $pl->shuffle()
Shuffle the current playlist. No return value.
=item $pl->swap( $song1, $song2 )
Swap positions of song number C<$song1> and C<$song2> in the current
playlist. No return value.
=item $pl->swapid( $songid1, $songid2 )
Swap the postions of song ID C<$songid1> with song ID C<$songid2> in the
current playlist. No return value.
=item $pl->move( $song, $newpos )
Move song number C<$song> to the position C<$newpos>. No return value.
=item $pl->moveid( $songid, $newpos )
Move song ID C<$songid> to the position C<$newpos>. No return value.
=back
=head2 Managing playlists
=over 4
=item $pl->load( $playlist )
Load list of songs from specified C<$playlist> file. No return value.
=item $pl->save( $playlist )
Save the current playlist to a file called C<$playlist> in MPD's playlist
directory. No return value.
=item $pl->rm( $playlist )
Delete playlist named C<$playlist> from MPD's playlist directory. No
return value.
=back
=head1 SEE ALSO
L<Audio::MPD>
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

217
config/mpfire/perl/Audio/MPD/Test.pm Normal file
View File

@@ -0,0 +1,217 @@
#
# This file is part of Audio::MPD
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#
package Audio::MPD::Test;
use strict;
use warnings;
use Exporter;
use FindBin qw[ $Bin ];
use Readonly;
use base qw[ Exporter ];
our @EXPORT = qw[ customize_test_mpd_configuration start_test_mpd stop_test_mpd ];
#our ($VERSION) = '$Rev: 5284 $' =~ /(\d+)/;
Readonly my $TEMPLATE => "$Bin/mpd-test/mpd.conf.template";
Readonly my $CONFIG => "$Bin/mpd-test/mpd.conf";
{ # this will be run when Audio::MPD::Test will be use-d.
my $restart = 0;
my $stopit = 0;
customize_test_mpd_configuration();
$restart = _stop_user_mpd_if_needed();
$stopit = start_test_mpd();
END {
stop_test_mpd() if $stopit;
return unless $restart; # no need to restart
system 'mpd 2>/dev/null'; # restart user mpd
sleep 1; # wait 1 second to let mpd start.
}
}
#--
# public subs
#
# customize_test_mpd_configuration( [$port] )
#
# Create a fake mpd configuration file, based on the file mpd.conf.template
# located in t/mpd-test. The string PWD will be replaced by the real path -
# ie, where the tarball has been untarred. The string PORT will be replaced
# by $port if specified, 6600 otherwise (MPD default).
#
sub customize_test_mpd_configuration {
my ($port) = @_;
$port ||= 6600;
# open template and config.
open my $in, '<', $TEMPLATE or die "can't open [$TEMPLATE]: $!\n";
open my $out, '>', $CONFIG or die "can't open [$CONFIG]: $!\n";
# replace string and fill in config file.
while ( defined( my $line = <$in> ) ) {
$line =~ s!PWD!$Bin/mpd-test!;
$line =~ s!PORT!$port!;
print $out $line;
}
# clean up.
close $in;
close $out;
# create a fake mpd db.
system( "mpd --create-db $CONFIG >/dev/null 2>&1" ) == 0
or die "could not create fake mpd database: $?\n";
}
#
# start_test_mpd()
#
# Start the fake mpd, and die if there were any error.
#
sub start_test_mpd {
my $output = qx[mpd $CONFIG 2>&1];
die "could not start fake mpd: $output\n" if $output;
sleep 1; # wait 1 second to let mpd start.
return 1;
}
#
# stop_test_mpd()
#
# Kill the fake mpd.
#
sub stop_test_mpd {
system "mpd --kill $CONFIG 2>/dev/null";
sleep 1; # wait 1 second to free output device.
unlink "$Bin/mpd-test/state", "$Bin/mpd-test/music.db";
}
#--
# private subs
#
# my $was_running = _stop_user_mpd_if_needed()
#
# This sub will check if mpd is currently running. If it is, force it to
# a full stop (unless MPD_TEST_OVERRIDE is not set).
#
# In any case, it will return a boolean stating whether mpd was running
# before forcing stop.
#
sub _stop_user_mpd_if_needed {
# check if mpd is running.
my $is_running = grep { /mpd$/ } qx[ ps -e ];
return 0 unless $is_running; # mpd does not run - nothing to do.
# check force stop.
die "mpd is running\n" unless $ENV{MPD_TEST_OVERRIDE};
system( 'mpd --kill 2>/dev/null') == 0 or die "can't stop user mpd: $?\n";
sleep 1; # wait 1 second to free output device
return 1;
}
1;
__END__
=head1 NAME
Audio::MPD::Test - automate launching of fake mdp for testing purposes
=head1 SYNOPSIS
use Audio::MPD::Test; # die if error
[...]
stop_fake_mpd();
=head1 DESCRIPTION
=head2 General usage
This module will try to launch a new mpd server for testing purposes. This
mpd server will then be used during Audio::MPD tests.
In order to achieve this, the module will create a fake mpd.conf file with
the correct pathes (ie, where you untarred the module tarball). It will then
check if some mpd server is already running, and stop it if the
MPD_TEST_OVERRIDE environment variable is true (die otherwise). Last it will
run the test mpd with its newly created configuration file.
Everything described above is done automatically when the module is C<use>-d.
Once the tests are run, the mpd server will be shut down, and the original
one will be relaunched (if there was one).
Note that the test mpd will listen to C<localhost>, so you are on the safe
side. Note also that the test suite comes with its own ogg files - and yes,
we can redistribute them since it's only some random voice recordings :-)
=head2 Advanced usage
In case you want more control on the test mpd server, you can use the
following public methods:
=over 4
=item start_test_mpd()
Start the fake mpd, and die if there were any error.
=item stop_test_mpd()
Kill the fake mpd.
=item customize_test_mpd_configuration( [$port] )
Create a fake mpd configuration file, based on the file mpd.conf.template
located in t/mpd-test. The string PWD will be replaced by the real path -
ie, where the tarball has been untarred. The string PORT will be replaced
by $port if specified, 6600 otherwise (MPD default).
=back
This might be useful when trying to test connections with mpd server.
=head1 SEE ALSO
L<Audio::MPD>
=head1 AUTHOR
Jerome Quelin, C<< <jquelin at cpan.org> >>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2007 Jerome Quelin, all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

803
config/mpfire/perl/Readonly.pm Normal file
View File

@@ -0,0 +1,803 @@
=for gpg
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
- -----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
=head1 NAME
Readonly - Facility for creating read-only scalars, arrays, hashes.
=head1 VERSION
This documentation describes version 1.03 of Readonly.pm, April 20, 2004.
=cut
# Rest of documentation is after __END__.
use 5.005;
use strict;
#use warnings;
#no warnings 'uninitialized';
package Readonly;
$Readonly::VERSION = '1.03'; # Also change in the documentation!
# Autocroak (Thanks, MJD)
# Only load Carp.pm if module is croaking.
sub croak
{
require Carp;
goto &Carp::croak;
}
# These functions may be overridden by Readonly::XS, if installed.
sub is_sv_readonly ($) { 0 }
sub make_sv_readonly ($) { die "make_sv_readonly called but not overridden" }
use vars qw/$XSokay/; # Set to true in Readonly::XS, if available
# Common error messages, or portions thereof
use vars qw/$MODIFY $REASSIGN $ODDHASH/;
$MODIFY = 'Modification of a read-only value attempted';
$REASSIGN = 'Attempt to reassign a readonly';
$ODDHASH = 'May not store an odd number of values in a hash';
# See if we can use the XS stuff.
$Readonly::XS::MAGIC_COOKIE = "Do NOT use or require Readonly::XS unless you're me.";
eval 'use Readonly::XS';
# ----------------
# Read-only scalars
# ----------------
package Readonly::Scalar;
sub TIESCALAR
{
my $whence = (caller 2)[3]; # Check if naughty user is trying to tie directly.
Readonly::croak "Invalid tie" unless $whence && $whence =~ /^Readonly::(?:Scalar1?|Readonly)$/;
my $class = shift;
Readonly::croak "No value specified for readonly scalar" unless @_;
Readonly::croak "Too many values specified for readonly scalar" unless @_ == 1;
my $value = shift;
return bless \$value, $class;
}
sub FETCH
{
my $self = shift;
return $$self;
}
*STORE = *UNTIE =
sub {Readonly::croak $Readonly::MODIFY};
# ----------------
# Read-only arrays
# ----------------
package Readonly::Array;
sub TIEARRAY
{
my $whence = (caller 1)[3]; # Check if naughty user is trying to tie directly.
Readonly::croak "Invalid tie" unless $whence =~ /^Readonly::Array1?$/;
my $class = shift;
my @self = @_;
return bless \@self, $class;
}
sub FETCH
{
my $self = shift;
my $index = shift;
return $self->[$index];
}
sub FETCHSIZE
{
my $self = shift;
return scalar @$self;
}
BEGIN {
eval q{
sub EXISTS
{
my $self = shift;
my $index = shift;
return exists $self->[$index];
}
} if $] >= 5.006; # couldn't do "exists" on arrays before then
}
*STORE = *STORESIZE = *EXTEND = *PUSH = *POP = *UNSHIFT = *SHIFT = *SPLICE = *CLEAR = *UNTIE =
sub {Readonly::croak $Readonly::MODIFY};
# ----------------
# Read-only hashes
# ----------------
package Readonly::Hash;
sub TIEHASH
{
my $whence = (caller 1)[3]; # Check if naughty user is trying to tie directly.
Readonly::croak "Invalid tie" unless $whence =~ /^Readonly::Hash1?$/;
my $class = shift;
# must have an even number of values
Readonly::croak $Readonly::ODDHASH unless (@_ %2 == 0);
my %self = @_;
return bless \%self, $class;
}
sub FETCH
{
my $self = shift;
my $key = shift;
return $self->{$key};
}
sub EXISTS
{
my $self = shift;
my $key = shift;
return exists $self->{$key};
}
sub FIRSTKEY
{
my $self = shift;
my $dummy = keys %$self;
return scalar each %$self;
}
sub NEXTKEY
{
my $self = shift;
return scalar each %$self;
}
*STORE = *DELETE = *CLEAR = *UNTIE =
sub {Readonly::croak $Readonly::MODIFY};
# ----------------------------------------------------------------
# Main package, containing convenience functions (so callers won't
# have to explicitly tie the variables themselves).
# ----------------------------------------------------------------
package Readonly;
use Exporter;
use vars qw/@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/;
push @ISA, 'Exporter';
push @EXPORT, qw/Readonly/;
push @EXPORT_OK, qw/Scalar Array Hash Scalar1 Array1 Hash1/;
# Predeclare the following, so we can use them recursively
sub Scalar ($$);
sub Array (\@;@);
sub Hash (\%;@);
# Returns true if a string begins with "Readonly::"
# Used to prevent reassignment of Readonly variables.
sub _is_badtype
{
my $type = $_[0];
return lc $type if $type =~ s/^Readonly:://;
return;
}
# Shallow Readonly scalar
sub Scalar1 ($$)
{
croak "$REASSIGN scalar" if is_sv_readonly $_[0];
my $badtype = _is_badtype (ref tied $_[0]);
croak "$REASSIGN $badtype" if $badtype;
# xs method: flag scalar as readonly
if ($XSokay)
{
$_[0] = $_[1];
make_sv_readonly $_[0];
return;
}
# pure-perl method: tied scalar
my $tieobj = eval {tie $_[0], 'Readonly::Scalar', $_[1]};
if ($@)
{
croak "$REASSIGN scalar" if substr($@,0,43) eq $MODIFY;
die $@; # some other error?
}
return $tieobj;
}
# Shallow Readonly array
sub Array1 (\@;@)
{
my $badtype = _is_badtype (ref tied $_[0]);
croak "$REASSIGN $badtype" if $badtype;
my $aref = shift;
return tie @$aref, 'Readonly::Array', @_;
}
# Shallow Readonly hash
sub Hash1 (\%;@)
{
my $badtype = _is_badtype (ref tied $_[0]);
croak "$REASSIGN $badtype" if $badtype;
my $href = shift;
# If only one value, and it's a hashref, expand it
if (@_ == 1 && ref $_[0] eq 'HASH')
{
return tie %$href, 'Readonly::Hash', %{$_[0]};
}
# otherwise, must have an even number of values
croak $ODDHASH unless (@_%2 == 0);
return tie %$href, 'Readonly::Hash', @_;
}
# Deep Readonly scalar
sub Scalar ($$)
{
croak "$REASSIGN scalar" if is_sv_readonly $_[0];
my $badtype = _is_badtype (ref tied $_[0]);
croak "$REASSIGN $badtype" if $badtype;
my $value = $_[1];
# Recursively check passed element for references; if any, make them Readonly
foreach ($value)
{
if (ref eq 'SCALAR') {Scalar my $v => $$_; $_ = \$v}
elsif (ref eq 'ARRAY') {Array my @v => @$_; $_ = \@v}
elsif (ref eq 'HASH') {Hash my %v => $_; $_ = \%v}
}
# xs method: flag scalar as readonly
if ($XSokay)
{
$_[0] = $value;
make_sv_readonly $_[0];
return;
}
# pure-perl method: tied scalar
my $tieobj = eval {tie $_[0], 'Readonly::Scalar', $value};
if ($@)
{
croak "$REASSIGN scalar" if substr($@,0,43) eq $MODIFY;
die $@; # some other error?
}
return $tieobj;
}
# Deep Readonly array
sub Array (\@;@)
{
my $badtype = _is_badtype (ref tied @{$_[0]});
croak "$REASSIGN $badtype" if $badtype;
my $aref = shift;
my @values = @_;
# Recursively check passed elements for references; if any, make them Readonly
foreach (@values)
{
if (ref eq 'SCALAR') {Scalar my $v => $$_; $_ = \$v}
elsif (ref eq 'ARRAY') {Array my @v => @$_; $_ = \@v}
elsif (ref eq 'HASH') {Hash my %v => $_; $_ = \%v}
}
# Lastly, tie the passed reference
return tie @$aref, 'Readonly::Array', @values;
}
# Deep Readonly hash
sub Hash (\%;@)
{
my $badtype = _is_badtype (ref tied %{$_[0]});
croak "$REASSIGN $badtype" if $badtype;
my $href = shift;
my @values = @_;
# If only one value, and it's a hashref, expand it
if (@_ == 1 && ref $_[0] eq 'HASH')
{
@values = %{$_[0]};
}
# otherwise, must have an even number of values
croak $ODDHASH unless (@values %2 == 0);
# Recursively check passed elements for references; if any, make them Readonly
foreach (@values)
{
if (ref eq 'SCALAR') {Scalar my $v => $$_; $_ = \$v}
elsif (ref eq 'ARRAY') {Array my @v => @$_; $_ = \@v}
elsif (ref eq 'HASH') {Hash my %v => $_; $_ = \%v}
}
return tie %$href, 'Readonly::Hash', @values;
}
# Common entry-point for all supported data types
eval q{sub Readonly} . ( $] < 5.008 ? '' : '(\[$@%]@)' ) . <<'SUB_READONLY';
{
if (ref $_[0] eq 'SCALAR')
{
croak $MODIFY if is_sv_readonly ${$_[0]};
my $badtype = _is_badtype (ref tied ${$_[0]});
croak "$REASSIGN $badtype" if $badtype;
croak "Readonly scalar must have only one value" if @_ > 2;
my $tieobj = eval {tie ${$_[0]}, 'Readonly::Scalar', $_[1]};
# Tie may have failed because user tried to tie a constant, or we screwed up somehow.
if ($@)
{
croak $MODIFY if $@ =~ /^$MODIFY at/; # Point the finger at the user.
die "$@\n"; # Not a modify read-only message; must be our fault.
}
return $tieobj;
}
elsif (ref $_[0] eq 'ARRAY')
{
my $aref = shift;
return Array @$aref, @_;
}
elsif (ref $_[0] eq 'HASH')
{
my $href = shift;
croak $ODDHASH if @_%2 != 0 && !(@_ == 1 && ref $_[0] eq 'HASH');
return Hash %$href, @_;
}
elsif (ref $_[0])
{
croak "Readonly only supports scalar, array, and hash variables.";
}
else
{
croak "First argument to Readonly must be a reference.";
}
}
SUB_READONLY
1;
__END__
=head1 SYNOPSIS
use Readonly;
# Read-only scalar
Readonly::Scalar $sca => $initial_value;
Readonly::Scalar my $sca => $initial_value;
# Read-only array
Readonly::Array @arr => @values;
Readonly::Array my @arr => @values;
# Read-only hash
Readonly::Hash %has => (key => value, key => value, ...);
Readonly::Hash my %has => (key => value, key => value, ...);
# or:
Readonly::Hash %has => {key => value, key => value, ...};
# You can use the read-only variables like any regular variables:
print $sca;
$something = $sca + $arr[2];
next if $has{$some_key};
# But if you try to modify a value, your program will die:
$sca = 7;
push @arr, 'seven';
delete $has{key};
# The error message is "Modification of a read-only value
attempted"
# Alternate form (Perl 5.8 and later)
Readonly $sca => $initial_value;
Readonly my $sca => $initial_value;
Readonly @arr => @values;
Readonly my @arr => @values;
Readonly %has => (key => value, key => value, ...);
Readonly my %has => (key => value, key => value, ...);
# Alternate form (for Perls earlier than v5.8)
Readonly \$sca => $initial_value;
Readonly \my $sca => $initial_value;
Readonly \@arr => @values;
Readonly \my @arr => @values;
Readonly \%has => (key => value, key => value, ...);
Readonly \my %has => (key => value, key => value, ...);
=head1 DESCRIPTION
This is a facility for creating non-modifiable variables. This is
useful for configuration files, headers, etc. It can also be useful
as a development and debugging tool, for catching updates to variables
that should not be changed.
If any of the values you pass to C<Scalar>, C<Array>, or C<Hash> are
references, then those functions recurse over the data structures,
marking everything as Readonly. Usually, this is what you want: the
entire structure nonmodifiable. If you want only the top level to be
Readonly, use the alternate C<Scalar1>, C<Array1> and C<Hash1>
functions.
Please note that most users of Readonly will also want to install a
companion module Readonly::XS. See the L</CONS> section below for more
details.
=head1 COMPARISON WITH "use constant"
Perl provides a facility for creating constant values, via the "use
constant" pragma. There are several problems with this pragma.
=over 2
=item *
The constants created have no leading $ or @ character.
=item *
These constants cannot be interpolated into strings.
=item *
Syntax can get dicey sometimes. For example:
use constant CARRAY => (2, 3, 5, 7, 11, 13);
$a_prime = CARRAY[2]; # wrong!
$a_prime = (CARRAY)[2]; # right -- MUST use parentheses
=item *
You have to be very careful in places where barewords are allowed.
For example:
use constant SOME_KEY => 'key';
%hash = (key => 'value', other_key => 'other_value');
$some_value = $hash{SOME_KEY}; # wrong!
$some_value = $hash{+SOME_KEY}; # right
(who thinks to use a unary plus when using a hash?)
=item *
C<use constant> works for scalars and arrays, not hashes.
=item *
These constants are global ot the package in which they're declared;
cannot be lexically scoped.
=item *
Works only at compile time.
=item *
Can be overridden:
use constant PI => 3.14159;
...
use constant PI => 2.71828;
(this does generate a warning, however, if you have warnings enabled).
=item *
It is very difficult to make and use deep structures (complex data
structures) with C<use constant>.
=back
=head1 COMPARISON WITH TYPEGLOB CONSTANTS
Another popular way to create read-only scalars is to modify the symbol
table entry for the variable by using a typeglob:
*a = \'value';
This works fine, but it only works for global variables ("my"
variables have no symbol table entry). Also, the following similar
constructs do B<not> work:
*a = [1, 2, 3]; # Does NOT create a read-only array
*a = { a => 'A'}; # Does NOT create a read-only hash
=head1 PROS
Readonly.pm, on the other hand, will work with global variables and
with lexical ("my") variables. It will create scalars, arrays, or
hashes, all of which look and work like normal, read-write Perl
variables. You can use them in scalar context, in list context; you
can take references to them, pass them to functions, anything.
Readonly.pm also works well with complex data structures, allowing you
to tag the whole structure as nonmodifiable, or just the top level.
Also, Readonly variables may not be reassigned. The following code
will die:
Readonly::Scalar $pi => 3.14159;
...
Readonly::Scalar $pi => 2.71828;
=head1 CONS
Readonly.pm does impose a performance penalty. It's pretty slow. How
slow? Run the C<benchmark.pl> script that comes with Readonly. On my
test system, "use constant", typeglob constants, and regular
read/write Perl variables were all about the same speed, and
Readonly.pm constants were about 1/20 the speed.
However, there is relief. There is a companion module available,
Readonly::XS. If it is installed on your system, Readonly.pm uses it
to make read-only scalars much faster. With Readonly::XS, Readonly
scalars are as fast as the other types of variables. Readonly arrays
and hashes will still be relatively slow. But it's likely that most
of your Readonly variables will be scalars.
If you can't use Readonly::XS (for example, if you don't have a C
compiler, or your perl is statically linked and you don't want to
re-link it), you have to decide whether the benefits of Readonly
variables outweigh the speed issue. For most configuration variables
(and other things that Readonly is likely to be useful for), the speed
issue is probably not really a big problem. But benchmark your
program if it might be. If it turns out to be a problem, you may
still want to use Readonly.pm during development, to catch changes to
variables that should not be changed, and then remove it for
production:
# For testing:
Readonly::Scalar $Foo_Directory => '/usr/local/foo';
Readonly::Scalar $Bar_Directory => '/usr/local/bar';
# $Foo_Directory = '/usr/local/foo';
# $Bar_Directory = '/usr/local/bar';
# For production:
# Readonly::Scalar $Foo_Directory => '/usr/local/foo';
# Readonly::Scalar $Bar_Directory => '/usr/local/bar';
$Foo_Directory = '/usr/local/foo';
$Bar_Directory = '/usr/local/bar';
=head1 FUNCTIONS
=over 4
=item Readonly::Scalar $var => $value;
Creates a nonmodifiable scalar, C<$var>, and assigns a value of
C<$value> to it. Thereafter, its value may not be changed. Any
attempt to modify the value will cause your program to die.
A value I<must> be supplied. If you want the variable to have
C<undef> as its value, you must specify C<undef>.
If C<$value> is a reference to a scalar, array, or hash, then this
function will mark the scalar, array, or hash it points to as being
Readonly as well, and it will recursively traverse the structure,
marking the whole thing as Readonly. Usually, this is what you want.
However, if you want only the C<$value> marked as Readonly, use
C<Scalar1>.
If $var is already a Readonly variable, the program will die with
an error about reassigning Readonly variables.
=item Readonly::Array @arr => (value, value, ...);
Creates a nonmodifiable array, C<@arr>, and assigns the specified list
of values to it. Thereafter, none of its values may be changed; the
array may not be lengthened or shortened or spliced. Any attempt to
do so will cause your program to die.
If any of the values passed is a reference to a scalar, array, or hash,
then this function will mark the scalar, array, or hash it points to as
being Readonly as well, and it will recursively traverse the structure,
marking the whole thing as Readonly. Usually, this is what you want.
However, if you want only the hash C<%@arr> itself marked as Readonly,
use C<Array1>.
If @arr is already a Readonly variable, the program will die with
an error about reassigning Readonly variables.
=item Readonly::Hash %h => (key => value, key => value, ...);
=item Readonly::Hash %h => {key => value, key => value, ...};
Creates a nonmodifiable hash, C<%h>, and assigns the specified keys
and values to it. Thereafter, its keys or values may not be changed.
Any attempt to do so will cause your program to die.
A list of keys and values may be specified (with parentheses in the
synopsis above), or a hash reference may be specified (curly braces in
the synopsis above). If a list is specified, it must have an even
number of elements, or the function will die.
If any of the values is a reference to a scalar, array, or hash, then
this function will mark the scalar, array, or hash it points to as
being Readonly as well, and it will recursively traverse the
structure, marking the whole thing as Readonly. Usually, this is what
you want. However, if you want only the hash C<%h> itself marked as
Readonly, use C<Hash1>.
If %h is already a Readonly variable, the program will die with
an error about reassigning Readonly variables.
=item Readonly $var => $value;
=item Readonly @arr => (value, value, ...);
=item Readonly %h => (key => value, ...);
=item Readonly %h => {key => value, ...};
The C<Readonly> function is an alternate to the C<Scalar>, C<Array>,
and C<Hash> functions. It has the advantage (if you consider it an
advantage) of being one function. That may make your program look
neater, if you're initializing a whole bunch of constants at once.
You may or may not prefer this uniform style.
It has the disadvantage of having a slightly different syntax for
versions of Perl prior to 5.8. For earlier versions, you must supply
a backslash, because it requires a reference as the first parameter.
Readonly \$var => $value;
Readonly \@arr => (value, value, ...);
Readonly \%h => (key => value, ...);
Readonly \%h => {key => value, ...};
You may or may not consider this ugly.
=item Readonly::Scalar1 $var => $value;
=item Readonly::Array1 @arr => (value, value, ...);
=item Readonly::Hash1 %h => (key => value, key => value, ...);
=item Readonly::Hash1 %h => {key => value, key => value, ...};
These alternate functions create shallow Readonly variables, instead
of deep ones. For example:
Readonly::Array1 @shal => (1, 2, {perl=>'Rules', java=>'Bites'}, 4, 5);
Readonly::Array @deep => (1, 2, {perl=>'Rules', java=>'Bites'}, 4, 5);
$shal[1] = 7; # error
$shal[2]{APL}='Weird'; # Allowed! since the hash isn't Readonly
$deep[1] = 7; # error
$deep[2]{APL}='Weird'; # error, since the hash is Readonly
=back
=head1 EXAMPLES
# SCALARS:
# A plain old read-only value
Readonly::Scalar $a => "A string value";
# The value need not be a compile-time constant:
Readonly::Scalar $a => $computed_value;
# ARRAYS:
# A read-only array:
Readonly::Array @a => (1, 2, 3, 4);
# The parentheses are optional:
Readonly::Array @a => 1, 2, 3, 4;
# You can use Perl's built-in array quoting syntax:
Readonly::Array @a => qw/1 2 3 4/;
# You can initialize a read-only array from a variable one:
Readonly::Array @a => @computed_values;
# A read-only array can be empty, too:
Readonly::Array @a => ();
Readonly::Array @a; # equivalent
# HASHES
# Typical usage:
Readonly::Hash %a => (key1 => 'value1', key2 => 'value2');
# A read-only hash can be initialized from a variable one:
Readonly::Hash %a => %computed_values;
# A read-only hash can be empty:
Readonly::Hash %a => ();
Readonly::Hash %a; # equivalent
# If you pass an odd number of values, the program will die:
Readonly::Hash %a => (key1 => 'value1', "value2");
--> dies with "May not store an odd number of values in a hash"
=head1 EXPORTS
By default, this module exports the following symbol into the calling
program's namespace:
Readonly
The following symbols are available for import into your program, if
you like:
Scalar Scalar1
Array Array1
Hash Hash1
=head1 REQUIREMENTS
Perl 5.000
Carp.pm (included with Perl)
Exporter.pm (included with Perl)
Readonly::XS is recommended but not required.
=head1 ACKNOWLEDGEMENTS
Thanks to Slaven Rezic for the idea of one common function
(Readonly) for all three types of variables (13 April 2002).
Thanks to Ernest Lergon for the idea (and initial code) for
deeply-Readonly data structures (21 May 2002).
Thanks to Damian Conway for the idea (and code) for making the
Readonly function work a lot smoother under perl 5.8+.
=head1 AUTHOR / COPYRIGHT
Eric J. Roode, roode@cpan.org
Copyright (c) 2001-2004 by Eric J. Roode. All Rights Reserved. This
module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
If you have suggestions for improvement, please drop me a line. If
you make improvements to this software, I ask that you please send me
a copy of your changes. Thanks.
Readonly.pm is made from 100% recycled electrons. No animals were
harmed during the development and testing of this module. Not sold
in stores! Readonly::XS sold separately. Void where prohibited.
=cut
=begin gpg
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.2.4 (MingW32)
iD8DBQFAhaGCY96i4h5M0egRAg++AJ0ar4ncojbOp0OOc2wo+E/1cBn5cQCg9eP9
qTzAC87PuyKB+vrcRykrDbo=
=39Ny
-----END PGP SIGNATURE-----
=cut

BIN
html/html/images/media-playback-start-all.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 518 B

BIN
html/html/images/media-repeat.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 787 B

BIN
html/html/images/media-shuffle.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 707 B

BIN
html/html/images/mpfire/box.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.5 KiB