From: Christian Schmidt Date: Mon, 12 May 2008 13:58:31 +0000 (+0200) Subject: Finalized core13 and redirector fixes X-Git-Tag: v2.3-beta1~75 X-Git-Url: http://git.ipfire.org/?p=people%2Fpmueller%2Fipfire-2.x.git;a=commitdiff_plain;h=83d20a455578805e79568f1500dec805f88ba834 Finalized core13 and redirector fixes Added some files to core14 First Beta of MPFire V3 --- diff --git a/config/mpfire/perl/Accessor.pm b/config/mpfire/perl/Accessor.pm new file mode 100755 index 0000000000..7dcd00ea84 --- /dev/null +++ b/config/mpfire/perl/Accessor.pm @@ -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 +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 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 and C 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 + +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 + +=head2 THANKS + +Liz and RUZ for performance tweaks. + +Tels, for his big feature request/bug report. + + +=head1 SEE ALSO + +L + +These are some modules which do similar things in different ways +L, L, L, +L, L + +L for an example of this module in use. + +=cut + +1; diff --git a/config/mpfire/perl/Accessor/Fast.pm b/config/mpfire/perl/Accessor/Fast.pm new file mode 100755 index 0000000000..6522923f59 --- /dev/null +++ b/config/mpfire/perl/Accessor/Fast.pm @@ -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 for an efficiency comparison. + +=head1 AUTHORS + +Copyright 2007 Marty Pauley + +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 + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/config/mpfire/perl/Accessor/Faster.pm b/config/mpfire/perl/Accessor/Faster.pm new file mode 100755 index 0000000000..8f81ff9d06 --- /dev/null +++ b/config/mpfire/perl/Accessor/Faster.pm @@ -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 + +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 + +=cut + +1; diff --git a/config/mpfire/perl/Audio/MPD.pm b/config/mpfire/perl/Audio/MPD.pm new file mode 100644 index 0000000000..e1c00db448 --- /dev/null +++ b/config/mpfire/perl/Audio/MPD.pm @@ -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 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 object with the current statistics +of MPD. See the associated pod for more information. + + +=item $mpd->status() + +Return an C 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 representing the song currently +playing. + + +=item $mpd->song( [$song] ) + +Return an C representing the song number +C<$song>. If C<$song> is not supplied, returns the current song. + + +=item $mpd->songid( [$songid] ) + +Return an C 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 accessor, returning the +associated C object. You will then be able to call: + + $mpd->collection->random_song(); + +See C documentation for more details on available +methods. + + +=head2 Handling the playlist + +To update the playlist, use the C accessor, returning the +associated C object. You will then be able to call: + + $mpd->playlist->clear; + +See C documentation for more details on available +methods. + + +=head1 SEE ALSO + +You can find more information on the mpd project on its homepage at +L, or its wiki L. + +Regarding this Perl module, you can report bugs on CPAN via +L. + +Audio::MPD development takes place on : feel free +to join us. (use L to sign in). Our +subversion repository is located at L. + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + +Original code by Tue Abrahamsen C<< >>, +documented by Nicholas J. Humfrey C<< >>. + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Collection.pm b/config/mpfire/perl/Audio/MPD/Collection.pm new file mode 100644 index 0000000000..7275128080 --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Collection.pm @@ -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 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 +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 is automatically created for you during the creation +of an C object. + +=back + + +=head2 Retrieving songs & directories + +=over 4 + +=item $coll->all_items( [$path] ) + +Return B Cs (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 Cs (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: the C 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 Cs 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 which correspond to C<$path>. + + +=item $coll->songs_with_filename_partial( $path ) + +Return the Cs 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 Cs performed by C<$artist>. + + +=item $coll->songs_by_artist_partial( $string ) + +Return all Cs performed by an artist with +C<$string> in her name. + + +=item $coll->songs_from_album( $album ) + +Return all Cs appearing in C<$album>. + + +=item $coll->songs_from_album_partial( $string ) + +Return all Cs appearing in album containing C<$string>. + + +=item $coll->songs_with_title( $title ) + +Return all Cs which title is exactly C<$title>. + + +=item $coll->songs_with_title_partial( $string ) + +Return all Cs where C<$string> is part of the title. + + +=back + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Common.pm b/config/mpfire/perl/Audio/MPD/Common.pm new file mode 100644 index 0000000000..07de83c201 --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Common.pm @@ -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 or L. + +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. + +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 + +=item o L + +=item o L + +=item o L + +=item o L + +=item o L + +=item o L + +=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 + +=item L + +=back + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Common/Item.pm b/config/mpfire/perl/Audio/MPD/Common/Item.pm new file mode 100644 index 0000000000..e1d4fa84da --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Common/Item.pm @@ -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 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, it will create and return an +C, an C +or an C object. Currently, the +discrimination is done on the existence of the C 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, an +C or an C +object, depending on the existence of a key C, C or +C (respectively). + +=back + + +=head1 SEE ALSO + +=over 4 + +=item L + +=item L + +=back + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Common/Item/Directory.pm b/config/mpfire/perl/Audio/MPD/Common/Item/Directory.pm new file mode 100644 index 0000000000..cd9076dc1f --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Common/Item/Directory.pm @@ -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 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 constructor, which should only be called by +C's constructor. + +The only other public method is an accessor: directory(). + + +=head1 SEE ALSO + +=over 4 + +=item L + +=item L + +=back + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Common/Item/Playlist.pm b/config/mpfire/perl/Audio/MPD/Common/Item/Playlist.pm new file mode 100644 index 0000000000..bfeda98530 --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Common/Item/Playlist.pm @@ -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 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 constructor, which should only be called by +C's constructor. + +The only other public method is an accessor: playlist(). + + +=head1 SEE ALSO + +=over 4 + +=item L + +=item L + +=back + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Common/Item/Song.pm b/config/mpfire/perl/Audio/MPD/Common/Item/Song.pm new file mode 100644 index 0000000000..4ce8d6da30 --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Common/Item/Song.pm @@ -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 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 constructor, which should only be called by +C'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, C, C, C, C, C, CTTrack()>, +C. 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 + +=item L + +=back + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Common/Stats.pm b/config/mpfire/perl/Audio/MPD/Common/Stats.pm new file mode 100644 index 0000000000..06749072e3 --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Common/Stats.pm @@ -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 object. + +Note that an C object does B update itself +regularly, and thus should be used immediately. + + +=head1 METHODS + +=head2 Constructor + +=over 4 + +=item new( %kv ) + +The C method is the constructor for the C +class. + +Note: one should B ever instantiate an C +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 +change the current settings of MPD server. Use the mpd modules to alter the +settings. + + +=head1 SEE ALSO + +=over 4 + +=item L + +=item L + +=back + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Common/Status.pm b/config/mpfire/perl/Audio/MPD/Common/Status.pm new file mode 100644 index 0000000000..f9c98e2f60 --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Common/Status.pm @@ -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 object. + +Note that an C object does B update +itself regularly, and thus should be used immediately. + + +=head1 METHODS + +=head2 Constructor + +=over 4 + +=item new( \%kv ) + +The C method is the constructor for the C +class. + +Note: one should B ever instantiate an C +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, C or C. + + +=item $status->time() + +An C 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 +change the current settings of MPD server. Use the mpd modules to alter the +settings. + + +=head1 SEE ALSO + +=over 4 + +=item L + +=item L + +=back + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Common/Time.pm b/config/mpfire/perl/Audio/MPD/Common/Time.pm new file mode 100644 index 0000000000..77b6c7dd36 --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Common/Time.pm @@ -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 returns some time information with the C +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 object. + +Note that an C object does B update itself +regularly, and thus should be used immediately. + + +=head1 METHODS + +=head2 Constructor + +=over 4 + +=item new( $time ) + +The C method is the constructor for the C +class. + +Note: one should B ever instantiate an C +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, C and C methods return the according values +under the form C. Note the existence of a C +method returning a percentage complete. (one decimal) + + +=item values in seconds: + +The C, C and C return the +according values in seconds. + + +=item detailled values: + +If you want to cook your own value, then the following methods can help: +C and C return the seconds and minutes elapsed. +Same for C and C (time remaining), C +and C. (total song length) + + +=back + + +Please note that those accessors are read-only: changing a value will B +change the current settings of MPD server. Use the mpd modules to alter the +settings. + + +=head1 SEE ALSO + +=over 4 + +=item L + +=item L + +=back + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Playlist.pm b/config/mpfire/perl/Audio/MPD/Playlist.pm new file mode 100644 index 0000000000..b59499d02d --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Playlist.pm @@ -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 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 +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 is automatically created for you during the creation +of an C object. + +=back + + +=head2 Retrieving information + +=over 4 + +=item $pl->as_items() + +Return an array of Cs, 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 + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Audio/MPD/Test.pm b/config/mpfire/perl/Audio/MPD/Test.pm new file mode 100644 index 0000000000..74359afd10 --- /dev/null +++ b/config/mpfire/perl/Audio/MPD/Test.pm @@ -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-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, 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 + + +=head1 AUTHOR + +Jerome Quelin, C<< >> + + +=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 diff --git a/config/mpfire/perl/Readonly.pm b/config/mpfire/perl/Readonly.pm new file mode 100644 index 0000000000..294c759c56 --- /dev/null +++ b/config/mpfire/perl/Readonly.pm @@ -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, C, or C 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, C and C +functions. + +Please note that most users of Readonly will also want to install a +companion module Readonly::XS. See the L 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 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. + +=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 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 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 be supplied. If you want the variable to have +C as its value, you must specify C. + +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. + +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. + +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. + +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 function is an alternate to the C, C, +and C 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 \ No newline at end of file diff --git a/html/html/images/media-playback-start-all.png b/html/html/images/media-playback-start-all.png new file mode 100644 index 0000000000..05cc4c6631 Binary files /dev/null and b/html/html/images/media-playback-start-all.png differ diff --git a/html/html/images/media-repeat.png b/html/html/images/media-repeat.png new file mode 100644 index 0000000000..32a38e058c Binary files /dev/null and b/html/html/images/media-repeat.png differ diff --git a/html/html/images/media-shuffle.png b/html/html/images/media-shuffle.png new file mode 100644 index 0000000000..ef4d922038 Binary files /dev/null and b/html/html/images/media-shuffle.png differ diff --git a/html/html/images/mpfire/box.png b/html/html/images/mpfire/box.png new file mode 100644 index 0000000000..fdf97b343a Binary files /dev/null and b/html/html/images/mpfire/box.png differ