--- /dev/null
+package Class::Accessor;
+require 5.00502;
+use strict;
+$Class::Accessor::VERSION = '0.31';
+
+=head1 NAME
+
+ Class::Accessor - Automated accessor generation
+
+=head1 SYNOPSIS
+
+ package Employee;
+ use base qw(Class::Accessor);
+ Employee->mk_accessors(qw(name role salary));
+
+ # Meanwhile, in a nearby piece of code!
+ # Class::Accessor provides new().
+ my $mp = Foo->new({ name => "Marty", role => "JAPH" });
+
+ my $job = $mp->role; # gets $mp->{role}
+ $mp->salary(400000); # sets $mp->{salary} = 400000 (I wish)
+
+ # like my @info = @{$mp}{qw(name role)}
+ my @info = $mp->get(qw(name role));
+
+ # $mp->{salary} = 400000
+ $mp->set('salary', 400000);
+
+
+=head1 DESCRIPTION
+
+This module automagically generates accessors/mutators for your class.
+
+Most of the time, writing accessors is an exercise in cutting and
+pasting. You usually wind up with a series of methods like this:
+
+ sub name {
+ my $self = shift;
+ if(@_) {
+ $self->{name} = $_[0];
+ }
+ return $self->{name};
+ }
+
+ sub salary {
+ my $self = shift;
+ if(@_) {
+ $self->{salary} = $_[0];
+ }
+ return $self->{salary};
+ }
+
+ # etc...
+
+One for each piece of data in your object. While some will be unique,
+doing value checks and special storage tricks, most will simply be
+exercises in repetition. Not only is it Bad Style to have a bunch of
+repetitious code, but its also simply not lazy, which is the real
+tragedy.
+
+If you make your module a subclass of Class::Accessor and declare your
+accessor fields with mk_accessors() then you'll find yourself with a
+set of automatically generated accessors which can even be
+customized!
+
+The basic set up is very simple:
+
+ package My::Class;
+ use base qw(Class::Accessor);
+ My::Class->mk_accessors( qw(foo bar car) );
+
+Done. My::Class now has simple foo(), bar() and car() accessors
+defined.
+
+=head2 What Makes This Different?
+
+What makes this module special compared to all the other method
+generating modules (L<"SEE ALSO">)? By overriding the get() and set()
+methods you can alter the behavior of the accessors class-wide. Also,
+the accessors are implemented as closures which should cost a bit less
+memory than most other solutions which generate a new method for each
+accessor.
+
+
+=head1 METHODS
+
+=head2 new
+
+ my $obj = Class->new;
+ my $obj = $other_obj->new;
+
+ my $obj = Class->new(\%fields);
+ my $obj = $other_obj->new(\%fields);
+
+Class::Accessor provides a basic constructor. It generates a
+hash-based object and can be called as either a class method or an
+object method.
+
+It takes an optional %fields hash which is used to initialize the
+object (handy if you use read-only accessors). The fields of the hash
+correspond to the names of your accessors, so...
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->mk_accessors('foo');
+
+ my $obj = Class->new({ foo => 42 });
+ print $obj->foo; # 42
+
+however %fields can contain anything, new() will shove them all into
+your object. Don't like it? Override it.
+
+=cut
+
+sub new {
+ my($proto, $fields) = @_;
+ my($class) = ref $proto || $proto;
+
+ $fields = {} unless defined $fields;
+
+ # make a copy of $fields.
+ bless {%$fields}, $class;
+}
+
+=head2 mk_accessors
+
+ Class->mk_accessors(@fields);
+
+This creates accessor/mutator methods for each named field given in
+@fields. Foreach field in @fields it will generate two accessors.
+One called "field()" and the other called "_field_accessor()". For
+example:
+
+ # Generates foo(), _foo_accessor(), bar() and _bar_accessor().
+ Class->mk_accessors(qw(foo bar));
+
+See L<CAVEATS AND TRICKS/"Overriding autogenerated accessors">
+for details.
+
+=cut
+
+sub mk_accessors {
+ my($self, @fields) = @_;
+
+ $self->_mk_accessors('rw', @fields);
+}
+
+
+{
+ no strict 'refs';
+
+ sub _mk_accessors {
+ my($self, $access, @fields) = @_;
+ my $class = ref $self || $self;
+ my $ra = $access eq 'rw' || $access eq 'ro';
+ my $wa = $access eq 'rw' || $access eq 'wo';
+
+ foreach my $field (@fields) {
+ my $accessor_name = $self->accessor_name_for($field);
+ my $mutator_name = $self->mutator_name_for($field);
+ if( $accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY' ) {
+ $self->_carp("Having a data accessor named DESTROY in '$class' is unwise.");
+ }
+ if ($accessor_name eq $mutator_name) {
+ my $accessor;
+ if ($ra && $wa) {
+ $accessor = $self->make_accessor($field);
+ } elsif ($ra) {
+ $accessor = $self->make_ro_accessor($field);
+ } else {
+ $accessor = $self->make_wo_accessor($field);
+ }
+ unless (defined &{"${class}::$accessor_name"}) {
+ *{"${class}::$accessor_name"} = $accessor;
+ }
+ if ($accessor_name eq $field) {
+ # the old behaviour
+ my $alias = "_${field}_accessor";
+ *{"${class}::$alias"} = $accessor unless defined &{"${class}::$alias"};
+ }
+ } else {
+ if ($ra and not defined &{"${class}::$accessor_name"}) {
+ *{"${class}::$accessor_name"} = $self->make_ro_accessor($field);
+ }
+ if ($wa and not defined &{"${class}::$mutator_name"}) {
+ *{"${class}::$mutator_name"} = $self->make_wo_accessor($field);
+ }
+ }
+ }
+ }
+
+ sub follow_best_practice {
+ my($self) = @_;
+ my $class = ref $self || $self;
+ *{"${class}::accessor_name_for"} = \&best_practice_accessor_name_for;
+ *{"${class}::mutator_name_for"} = \&best_practice_mutator_name_for;
+ }
+
+}
+
+=head2 mk_ro_accessors
+
+ Class->mk_ro_accessors(@read_only_fields);
+
+Same as mk_accessors() except it will generate read-only accessors
+(ie. true accessors). If you attempt to set a value with these
+accessors it will throw an exception. It only uses get() and not
+set().
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Class->mk_ro_accessors(qw(foo bar));
+
+ # Let's assume we have an object $foo of class Foo...
+ print $foo->foo; # ok, prints whatever the value of $foo->{foo} is
+ $foo->foo(42); # BOOM! Naughty you.
+
+
+=cut
+
+sub mk_ro_accessors {
+ my($self, @fields) = @_;
+
+ $self->_mk_accessors('ro', @fields);
+}
+
+=head2 mk_wo_accessors
+
+ Class->mk_wo_accessors(@write_only_fields);
+
+Same as mk_accessors() except it will generate write-only accessors
+(ie. mutators). If you attempt to read a value with these accessors
+it will throw an exception. It only uses set() and not get().
+
+B<NOTE> I'm not entirely sure why this is useful, but I'm sure someone
+will need it. If you've found a use, let me know. Right now its here
+for orthoginality and because its easy to implement.
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Class->mk_wo_accessors(qw(foo bar));
+
+ # Let's assume we have an object $foo of class Foo...
+ $foo->foo(42); # OK. Sets $self->{foo} = 42
+ print $foo->foo; # BOOM! Can't read from this accessor.
+
+=cut
+
+sub mk_wo_accessors {
+ my($self, @fields) = @_;
+
+ $self->_mk_accessors('wo', @fields);
+}
+
+=head1 DETAILS
+
+An accessor generated by Class::Accessor looks something like
+this:
+
+ # Your foo may vary.
+ sub foo {
+ my($self) = shift;
+ if(@_) { # set
+ return $self->set('foo', @_);
+ }
+ else {
+ return $self->get('foo');
+ }
+ }
+
+Very simple. All it does is determine if you're wanting to set a
+value or get a value and calls the appropriate method.
+Class::Accessor provides default get() and set() methods which
+your class can override. They're detailed later.
+
+=head2 follow_best_practice
+
+In Damian's Perl Best Practices book he recommends separate get and set methods
+with the prefix set_ and get_ to make it explicit what you intend to do. If you
+want to create those accessor methods instead of the default ones, call:
+
+ __PACKAGE__->follow_best_practice
+
+=head2 accessor_name_for / mutator_name_for
+
+You may have your own crazy ideas for the names of the accessors, so you can
+make those happen by overriding C<accessor_name_for> and C<mutator_name_for> in
+your subclass. (I copied that idea from Class::DBI.)
+
+=cut
+
+sub best_practice_accessor_name_for {
+ my ($class, $field) = @_;
+ return "get_$field";
+}
+
+sub best_practice_mutator_name_for {
+ my ($class, $field) = @_;
+ return "set_$field";
+}
+
+sub accessor_name_for {
+ my ($class, $field) = @_;
+ return $field;
+}
+
+sub mutator_name_for {
+ my ($class, $field) = @_;
+ return $field;
+}
+
+=head2 Modifying the behavior of the accessor
+
+Rather than actually modifying the accessor itself, it is much more
+sensible to simply override the two key methods which the accessor
+calls. Namely set() and get().
+
+If you -really- want to, you can override make_accessor().
+
+=head2 set
+
+ $obj->set($key, $value);
+ $obj->set($key, @values);
+
+set() defines how generally one stores data in the object.
+
+override this method to change how data is stored by your accessors.
+
+=cut
+
+sub set {
+ my($self, $key) = splice(@_, 0, 2);
+
+ if(@_ == 1) {
+ $self->{$key} = $_[0];
+ }
+ elsif(@_ > 1) {
+ $self->{$key} = [@_];
+ }
+ else {
+ $self->_croak("Wrong number of arguments received");
+ }
+}
+
+=head2 get
+
+ $value = $obj->get($key);
+ @values = $obj->get(@keys);
+
+get() defines how data is retreived from your objects.
+
+override this method to change how it is retreived.
+
+=cut
+
+sub get {
+ my $self = shift;
+
+ if(@_ == 1) {
+ return $self->{$_[0]};
+ }
+ elsif( @_ > 1 ) {
+ return @{$self}{@_};
+ }
+ else {
+ $self->_croak("Wrong number of arguments received");
+ }
+}
+
+=head2 make_accessor
+
+ $accessor = Class->make_accessor($field);
+
+Generates a subroutine reference which acts as an accessor for the given
+$field. It calls get() and set().
+
+If you wish to change the behavior of your accessors, try overriding
+get() and set() before you start mucking with make_accessor().
+
+=cut
+
+sub make_accessor {
+ my ($class, $field) = @_;
+
+ # Build a closure around $field.
+ return sub {
+ my $self = shift;
+
+ if(@_) {
+ return $self->set($field, @_);
+ }
+ else {
+ return $self->get($field);
+ }
+ };
+}
+
+=head2 make_ro_accessor
+
+ $read_only_accessor = Class->make_ro_accessor($field);
+
+Generates a subroutine refrence which acts as a read-only accessor for
+the given $field. It only calls get().
+
+Override get() to change the behavior of your accessors.
+
+=cut
+
+sub make_ro_accessor {
+ my($class, $field) = @_;
+
+ return sub {
+ my $self = shift;
+
+ if (@_) {
+ my $caller = caller;
+ $self->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
+ }
+ else {
+ return $self->get($field);
+ }
+ };
+}
+
+=head2 make_wo_accessor
+
+ $read_only_accessor = Class->make_wo_accessor($field);
+
+Generates a subroutine refrence which acts as a write-only accessor
+(mutator) for the given $field. It only calls set().
+
+Override set() to change the behavior of your accessors.
+
+=cut
+
+sub make_wo_accessor {
+ my($class, $field) = @_;
+
+ return sub {
+ my $self = shift;
+
+ unless (@_) {
+ my $caller = caller;
+ $self->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
+ }
+ else {
+ return $self->set($field, @_);
+ }
+ };
+}
+
+=head1 EXCEPTIONS
+
+If something goes wrong Class::Accessor will warn or die by calling Carp::carp
+or Carp::croak. If you don't like this you can override _carp() and _croak() in
+your subclass and do whatever else you want.
+
+=cut
+
+use Carp ();
+
+sub _carp {
+ my ($self, $msg) = @_;
+ Carp::carp($msg || $self);
+ return;
+}
+
+sub _croak {
+ my ($self, $msg) = @_;
+ Carp::croak($msg || $self);
+ return;
+}
+
+=head1 EFFICIENCY
+
+Class::Accessor does not employ an autoloader, thus it is much faster
+than you'd think. Its generated methods incur no special penalty over
+ones you'd write yourself.
+
+ accessors:
+ Rate Basic Average Fast Faster Direct
+ Basic 189150/s -- -42% -51% -55% -89%
+ Average 327679/s 73% -- -16% -22% -82%
+ Fast 389212/s 106% 19% -- -8% -78%
+ Faster 421646/s 123% 29% 8% -- -76%
+ Direct 1771243/s 836% 441% 355% 320% --
+
+ mutators:
+ Rate Basic Average Fast Faster Direct
+ Basic 173769/s -- -34% -53% -59% -90%
+ Average 263046/s 51% -- -29% -38% -85%
+ Fast 371158/s 114% 41% -- -13% -78%
+ Faster 425821/s 145% 62% 15% -- -75%
+ Direct 1699081/s 878% 546% 358% 299% --
+
+Class::Accessor::Fast is faster than methods written by an average programmer
+(where "average" is based on Schwern's example code).
+
+Class::Accessor is slower than average, but more flexible.
+
+Class::Accessor::Faster is even faster than Class::Accessor::Fast. It uses an
+array internally, not a hash. This could be a good or bad feature depending on
+your point of view.
+
+Direct hash access is, of course, much faster than all of these, but it
+provides no encapsulation.
+
+Of course, its not as simple as saying "Class::Accessor is slower than
+average". These are benchmarks for a simple accessor. If your accessors do
+any sort of complicated work (such as talking to a database or writing to a
+file) the time spent doing that work will quickly swamp the time spend just
+calling the accessor. In that case, Class::Accessor and the ones you write
+will be roughly the same speed.
+
+
+=head1 EXAMPLES
+
+Here's an example of generating an accessor for every public field of
+your class.
+
+ package Altoids;
+
+ use base qw(Class::Accessor Class::Fields);
+ use fields qw(curiously strong mints);
+ Altoids->mk_accessors( Altoids->show_fields('Public') );
+
+ sub new {
+ my $proto = shift;
+ my $class = ref $proto || $proto;
+ return fields::new($class);
+ }
+
+ my Altoids $tin = Altoids->new;
+
+ $tin->curiously('Curiouser and curiouser');
+ print $tin->{curiously}; # prints 'Curiouser and curiouser'
+
+
+ # Subclassing works, too.
+ package Mint::Snuff;
+ use base qw(Altoids);
+
+ my Mint::Snuff $pouch = Mint::Snuff->new;
+ $pouch->strong('Blow your head off!');
+ print $pouch->{strong}; # prints 'Blow your head off!'
+
+
+Here's a simple example of altering the behavior of your accessors.
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->mk_accessor(qw(this that up down));
+
+ sub get {
+ my $self = shift;
+
+ # Note every time someone gets some data.
+ print STDERR "Getting @_\n";
+
+ $self->SUPER::get(@_);
+ }
+
+ sub set {
+ my ($self, $key) = splice(@_, 0, 2);
+
+ # Note every time someone sets some data.
+ print STDERR "Setting $key to @_\n";
+
+ $self->SUPER::set($key, @_);
+ }
+
+
+=head1 CAVEATS AND TRICKS
+
+Class::Accessor has to do some internal wackiness to get its
+job done quickly and efficiently. Because of this, there's a few
+tricks and traps one must know about.
+
+Hey, nothing's perfect.
+
+=head2 Don't make a field called DESTROY
+
+This is bad. Since DESTROY is a magical method it would be bad for us
+to define an accessor using that name. Class::Accessor will
+carp if you try to use it with a field named "DESTROY".
+
+=head2 Overriding autogenerated accessors
+
+You may want to override the autogenerated accessor with your own, yet
+have your custom accessor call the default one. For instance, maybe
+you want to have an accessor which checks its input. Normally, one
+would expect this to work:
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->mk_accessors(qw(email this that whatever));
+
+ # Only accept addresses which look valid.
+ sub email {
+ my($self) = shift;
+ my($email) = @_;
+
+ if( @_ ) { # Setting
+ require Email::Valid;
+ unless( Email::Valid->address($email) ) {
+ carp("$email doesn't look like a valid address.");
+ return;
+ }
+ }
+
+ return $self->SUPER::email(@_);
+ }
+
+There's a subtle problem in the last example, and its in this line:
+
+ return $self->SUPER::email(@_);
+
+If we look at how Foo was defined, it called mk_accessors() which
+stuck email() right into Foo's namespace. There *is* no
+SUPER::email() to delegate to! Two ways around this... first is to
+make a "pure" base class for Foo. This pure class will generate the
+accessors and provide the necessary super class for Foo to use:
+
+ package Pure::Organic::Foo;
+ use base qw(Class::Accessor);
+ Pure::Organic::Foo->mk_accessors(qw(email this that whatever));
+
+ package Foo;
+ use base qw(Pure::Organic::Foo);
+
+And now Foo::email() can override the generated
+Pure::Organic::Foo::email() and use it as SUPER::email().
+
+This is probably the most obvious solution to everyone but me.
+Instead, what first made sense to me was for mk_accessors() to define
+an alias of email(), _email_accessor(). Using this solution,
+Foo::email() would be written with:
+
+ return $self->_email_accessor(@_);
+
+instead of the expected SUPER::email().
+
+
+=head1 AUTHORS
+
+Copyright 2007 Marty Pauley <marty+perl@kasei.com>
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself. That means either (a) the GNU General Public
+License or (b) the Artistic License.
+
+=head2 ORIGINAL AUTHOR
+
+Michael G Schwern <schwern@pobox.com>
+
+=head2 THANKS
+
+Liz and RUZ for performance tweaks.
+
+Tels, for his big feature request/bug report.
+
+
+=head1 SEE ALSO
+
+L<Class::Accessor::Fast>
+
+These are some modules which do similar things in different ways
+L<Class::Struct>, L<Class::Methodmaker>, L<Class::Generate>,
+L<Class::Class>, L<Class::Contract>
+
+L<Class::DBI> for an example of this module in use.
+
+=cut
+
+1;
--- /dev/null
+package Class::Accessor::Fast;
+use base 'Class::Accessor';
+use strict;
+$Class::Accessor::Fast::VERSION = '0.31';
+
+=head1 NAME
+
+Class::Accessor::Fast - Faster, but less expandable, accessors
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use base qw(Class::Accessor::Fast);
+
+ # The rest is the same as Class::Accessor but without set() and get().
+
+=head1 DESCRIPTION
+
+This is a faster but less expandable version of Class::Accessor.
+Class::Accessor's generated accessors require two method calls to accompish
+their task (one for the accessor, another for get() or set()).
+Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
+resulting in a somewhat faster accessor.
+
+The downside is that you can't easily alter the behavior of your
+accessors, nor can your subclasses. Of course, should you need this
+later, you can always swap out Class::Accessor::Fast for
+Class::Accessor.
+
+Read the documentation for Class::Accessor for more info.
+
+=cut
+
+sub make_accessor {
+ my($class, $field) = @_;
+
+ return sub {
+ return $_[0]->{$field} if @_ == 1;
+ return $_[0]->{$field} = $_[1] if @_ == 2;
+ return (shift)->{$field} = \@_;
+ };
+}
+
+
+sub make_ro_accessor {
+ my($class, $field) = @_;
+
+ return sub {
+ return $_[0]->{$field} if @_ == 1;
+ my $caller = caller;
+ $_[0]->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
+ };
+}
+
+
+sub make_wo_accessor {
+ my($class, $field) = @_;
+
+ return sub {
+ if (@_ == 1) {
+ my $caller = caller;
+ $_[0]->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
+ }
+ else {
+ return $_[0]->{$field} = $_[1] if @_ == 2;
+ return (shift)->{$field} = \@_;
+ }
+ };
+}
+
+
+=head1 EFFICIENCY
+
+L<Class::Accessor/EFFICIENCY> for an efficiency comparison.
+
+=head1 AUTHORS
+
+Copyright 2007 Marty Pauley <marty+perl@kasei.com>
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself. That means either (a) the GNU General Public
+License or (b) the Artistic License.
+
+=head2 ORIGINAL AUTHOR
+
+Michael G Schwern <schwern@pobox.com>
+
+=head1 SEE ALSO
+
+L<Class::Accessor>
+
+=cut
+
+1;
--- /dev/null
+package Class::Accessor::Faster;
+use base 'Class::Accessor';
+use strict;
+$Class::Accessor::Faster::VERSION = '0.31';
+
+=head1 NAME
+
+Class::Accessor::Faster - Even faster, but less expandable, accessors
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use base qw(Class::Accessor::Faster);
+
+=head1 DESCRIPTION
+
+This is a faster but less expandable version of Class::Accessor::Fast.
+
+Class::Accessor's generated accessors require two method calls to accompish
+their task (one for the accessor, another for get() or set()).
+
+Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
+resulting in a somewhat faster accessor.
+
+Class::Accessor::Faster uses an array reference underneath to be faster.
+
+Read the documentation for Class::Accessor for more info.
+
+=cut
+
+my %slot;
+sub _slot {
+ my($class, $field) = @_;
+ my $n = $slot{$class}->{$field};
+ return $n if defined $n;
+ $n = keys %{$slot{$class}};
+ $slot{$class}->{$field} = $n;
+ return $n;
+}
+
+sub new {
+ my($proto, $fields) = @_;
+ my($class) = ref $proto || $proto;
+ my $self = bless [], $class;
+
+ $fields = {} unless defined $fields;
+ for my $k (keys %$fields) {
+ my $n = $class->_slot($k);
+ $self->[$n] = $fields->{$k};
+ }
+ return $self;
+}
+
+sub make_accessor {
+ my($class, $field) = @_;
+ my $n = $class->_slot($field);
+ return sub {
+ return $_[0]->[$n] if @_ == 1;
+ return $_[0]->[$n] = $_[1] if @_ == 2;
+ return (shift)->[$n] = \@_;
+ };
+}
+
+
+sub make_ro_accessor {
+ my($class, $field) = @_;
+ my $n = $class->_slot($field);
+ return sub {
+ return $_[0]->[$n] if @_ == 1;
+ my $caller = caller;
+ $_[0]->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
+ };
+}
+
+
+sub make_wo_accessor {
+ my($class, $field) = @_;
+ my $n = $class->_slot($field);
+ return sub {
+ if (@_ == 1) {
+ my $caller = caller;
+ $_[0]->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
+ } else {
+ return $_[0]->[$n] = $_[1] if @_ == 2;
+ return (shift)->[$n] = \@_;
+ }
+ };
+}
+
+
+=head1 AUTHORS
+
+Copyright 2007 Marty Pauley <marty+perl@kasei.com>
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself. That means either (a) the GNU General Public
+License or (b) the Artistic License.
+
+=head1 SEE ALSO
+
+L<Class::Accessor>
+
+=cut
+
+1;
--- /dev/null
+#
+# This file is part of Audio::MPD
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD;
+
+use warnings;
+use strict;
+
+use Audio::MPD::Collection;
+use Audio::MPD::Common::Item;
+use Audio::MPD::Common::Stats;
+use Audio::MPD::Common::Status;
+use Audio::MPD::Playlist;
+use Encode;
+use IO::Socket;
+use Readonly;
+
+
+use base qw[ Class::Accessor::Fast Exporter ];
+__PACKAGE__->mk_accessors(
+ qw[ _conntype _host _password _port _socket
+ collection playlist version ] );
+
+
+our $VERSION = '0.19.1';
+
+Readonly our $REUSE => 1;
+Readonly our $ONCE => 0;
+
+our @EXPORT = qw[ $REUSE $ONCE ];
+
+
+#--
+# Constructor
+
+#
+# my $mpd = Audio::MPD->new( [%opts] )
+#
+# This is the constructor for Audio::MPD. One can specify the following
+# options:
+# - hostname => $hostname : defaults to environment var MPD_HOST, then to 'localhost'
+# - port => $port : defaults to env var MPD_PORT, then to 6600
+# - password => $password : defaults to env var MPD_PASSWORD, then to ''
+# - conntype => $type : how the connection to mpd server is handled. it can be
+# either $REUSE: reuse the same connection
+# or $ONCE: open a new connection per command (default)
+#
+sub new {
+ my ($class, %opts) = @_;
+
+ # use mpd defaults.
+ my ($default_password, $default_host) = split( '@', $ENV{MPD_HOST} )
+ if exists $ENV{MPD_HOST} && $ENV{MPD_HOST} =~ /@/;
+ my $host = $opts{host} || $default_host || $ENV{MPD_HOST} || 'localhost';
+ my $port = $opts{port} || $ENV{MPD_PORT} || '6600';
+ my $password = $opts{password} || $ENV{MPD_PASSWORD} || $default_password || '';
+
+ # create & bless the object.
+ my $self = {
+ _host => $host,
+ _port => $port,
+ _password => $password,
+ _conntype => exists $opts{conntype} ? $opts{conntype} : $ONCE,
+ };
+ bless $self, $class;
+
+ # create the connection if conntype is set to $REUSE
+ $self->_connect_to_mpd_server if $self->_conntype == $REUSE;
+
+
+ # create the helper objects and store them.
+ $self->collection( Audio::MPD::Collection->new($self) );
+ $self->playlist ( Audio::MPD::Playlist->new($self) );
+
+ # try to issue a ping to test connection - this can die.
+ $self->ping;
+
+ return $self;
+}
+
+
+#--
+# Private methods
+
+
+#
+# $mpd->_connect_to_mpd_server;
+#
+# This method connects to the mpd server. It can die on several conditions:
+# - if the server cannot be reached,
+# - if it's not an mpd server,
+# - or if the password is incorrect,
+#
+sub _connect_to_mpd_server {
+ my ($self) = @_;
+
+ # try to connect to mpd.
+ my $socket = IO::Socket::INET->new(
+ PeerAddr => $self->_host,
+ PeerPort => $self->_port,
+ )
+ or die "Could not create socket: $!\n";
+
+ # parse version information.
+ my $line = $socket->getline;
+ chomp $line;
+ die "Not a mpd server - welcome string was: [$line]\n"
+ if $line !~ /^OK MPD (.+)$/;
+ $self->version($1);
+
+ # send password.
+ if ( $self->_password ) {
+ $socket->print( 'password ' . encode('utf-8', $self->_password) . "\n" );
+ $line = $socket->getline;
+ die $line if $line =~ s/^ACK //;
+ }
+
+ # save socket
+ $self->_socket($socket);
+}
+
+
+#
+# my @result = $mpd->_send_command( $command );
+#
+# This method is central to the module. It is responsible for interacting with
+# mpd by sending the $command and reading output - that will be returned as an
+# array of chomped lines (status line will not be returned).
+#
+# This method can die on several conditions:
+# - if the server cannot be reached,
+# - if it's not an mpd server,
+# - if the password is incorrect,
+# - or if the command is an invalid mpd command.
+# In the latter case, the mpd error message will be returned.
+#
+sub _send_command {
+ my ($self, $command) = @_;
+
+ $self->_connect_to_mpd_server if $self->_conntype == $ONCE;
+ my $socket = $self->_socket;
+
+ # ok, now we're connected - let's issue the command.
+ $socket->print( encode('utf-8', $command) );
+ my @output;
+ while (defined ( my $line = $socket->getline ) ) {
+ chomp $line;
+ die $line if $line =~ s/^ACK //; # oops - error.
+ last if $line =~ /^OK/; # end of output.
+ push @output, decode('utf-8', $line);
+ }
+
+ # close the socket.
+ $socket->close if $self->_conntype == $ONCE;
+
+ return @output;
+}
+
+
+#
+# my @items = $mpd->_cooked_command_as_items( $command );
+#
+# Lots of Audio::MPD methods are using _send_command() and then parse the
+# output as a collection of AMC::Item. This method is meant to factorize
+# this code, and will parse the raw output of _send_command() in a cooked
+# list of items.
+#
+sub _cooked_command_as_items {
+ my ($self, $command) = @_;
+
+ my @lines = $self->_send_command($command);
+ my (@items, %param);
+
+ # parse lines in reverse order since "file:" or "directory:" lines
+ # come first. therefore, let's first store every other parameter,
+ # and the last line will trigger the object creation.
+ # of course, since we want to preserve the playlist order, this means
+ # that we're going to unshift the objects instead of push.
+ foreach my $line (reverse @lines) {
+ my ($k,$v) = split /:\s/, $line, 2;
+ $param{$k} = $v;
+ next unless $k eq 'file' || $k eq 'directory' || $k eq 'playlist'; # last param of item
+ unshift @items, Audio::MPD::Common::Item->new(%param);
+ %param = ();
+ }
+
+ return @items;
+}
+
+
+sub _cooked_command_as_filename {
+ my ($self, $command) = @_;
+
+ my @lines = $self->_send_command($command);
+ my (@items, %param);
+
+ # parse lines in reverse order since "file:" or "directory:" lines
+ # come first. therefore, let's first store every other parameter,
+ # and the last line will trigger the object creation.
+ # of course, since we want to preserve the playlist order, this means
+ # that we're going to unshift the objects instead of push.
+ foreach my $line (@lines) {
+ my ($k,$v) = split /:\s/, $line, 2;
+ if ( $k eq 'file'){$param{$k} = $v;}
+ unshift @items, $param{'file'};
+ %param = ();
+ }
+
+ return @items;
+}
+
+#
+# my %hash = $mpd->_cooked_command_as_kv( $command );
+#
+# Lots of Audio::MPD methods are using _send_command() and then parse the
+# output to get a list of key / value (with the colon ":" acting as separator).
+# This method is meant to factorize this code, and will parse the raw output
+# of _send_command() in a cooked hash.
+#
+sub _cooked_command_as_kv {
+ my ($self, $command) = @_;
+ my %hash =
+ map { split(/:\s/, $_, 2) }
+ $self->_send_command($command);
+ return %hash;
+}
+
+#
+# my @list = $mpd->_cooked_command_strip_first_field( $command );
+#
+# Lots of Audio::MPD methods are using _send_command() and then parse the
+# output to remove the first field (with the colon ":" acting as separator).
+# This method is meant to factorize this code, and will parse the raw output
+# of _send_command() in a cooked list of strings.
+#
+sub _cooked_command_strip_first_field {
+ my ($self, $command) = @_;
+
+ my @list =
+ map { ( split(/:\s+/, $_, 2) )[1] }
+ $self->_send_command($command);
+ return @list;
+}
+
+
+#--
+# Public methods
+
+# -- MPD interaction: general commands
+
+#
+# $mpd->ping;
+#
+# Sends a ping command to the mpd server.
+#
+sub ping {
+ my ($self) = @_;
+ $self->_send_command( "ping\n" );
+}
+
+
+#
+# my $version = $mpd->version;
+#
+# Return version of MPD server's connected.
+#
+# sub version {} # implemented as an accessor.
+#
+
+
+#
+# $mpd->kill;
+#
+# Send a message to the MPD server telling it to shut down.
+#
+sub kill {
+ my ($self) = @_;
+ $self->_send_command("kill\n");
+}
+
+
+#
+# $mpd->password( [$password] )
+#
+# Change password used to communicate with MPD server to $password.
+# Empty string is assumed if $password is not supplied.
+#
+sub password {
+ my ($self, $passwd) = @_;
+ $passwd ||= '';
+ $self->_password($passwd);
+ $self->ping; # ping sends a command, and thus the password is sent
+}
+
+
+#
+# $mpd->updatedb( [$path] );
+#
+# Force mpd to rescan its collection. If $path (relative to MPD's music
+# directory) is supplied, MPD will only scan it - otherwise, MPD will rescan
+# its whole collection.
+#
+sub updatedb {
+ my ($self, $path) = @_;
+ $path ||= '';
+ $self->_send_command("update $path\n");
+}
+
+
+#
+# my @handlers = $mpd->urlhandlers;
+#
+# Return an array of supported URL schemes.
+#
+sub urlhandlers {
+ my ($self) = @_;
+ return $self->_cooked_command_strip_first_field("urlhandlers\n");
+}
+
+
+# -- MPD interaction: handling volume & output
+
+#
+# $mpd->volume( [+][-]$volume );
+#
+# Sets the audio output volume percentage to absolute $volume.
+# If $volume is prefixed by '+' or '-' then the volume is changed relatively
+# by that value.
+#
+sub volume {
+ my ($self, $volume) = @_;
+
+ if ($volume =~ /^(-|\+)(\d+)/ ) {
+ my $current = $self->status->volume;
+ $volume = $1 eq '+' ? $current + $2 : $current - $2;
+ }
+ $self->_send_command("setvol $volume\n");
+}
+
+
+#
+# $mpd->output_enable( $output );
+#
+# Enable the specified audio output. $output is the ID of the audio output.
+#
+sub output_enable {
+ my ($self, $output) = @_;
+ $self->_send_command("enableoutput $output\n");
+}
+
+
+#
+# $mpd->output_disable( $output );
+#
+# Disable the specified audio output. $output is the ID of the audio output.
+#
+sub output_disable {
+ my ($self, $output) = @_;
+ $self->_send_command("disableoutput $output\n");
+}
+
+
+
+# -- MPD interaction: retrieving info from current state
+
+#
+# $mpd->stats;
+#
+# Return an AMC::Stats object with the current statistics of MPD.
+#
+sub stats {
+ my ($self) = @_;
+ my %kv = $self->_cooked_command_as_kv( "stats\n" );
+ return Audio::MPD::Common::Stats->new(\%kv);
+}
+
+
+#
+# my $status = $mpd->status;
+#
+# Return an AMC::Status object with various information on current
+# MPD server settings. Check the embedded pod for more information on the
+# available accessors.
+#
+sub status {
+ my ($self) = @_;
+ my %kv = $self->_cooked_command_as_kv( "status\n" );
+ my $status = Audio::MPD::Common::Status->new( \%kv );
+ return $status;
+}
+
+
+#
+# my $song = $mpd->current;
+#
+# Return an AMC::Item::Song representing the song currently playing.
+#
+sub current {
+ my ($self) = @_;
+ my ($item) = $self->_cooked_command_as_items("currentsong\n");
+ return $item;
+}
+
+
+#
+# my $song = $mpd->song( [$song] )
+#
+# Return an AMC::Item::Song representing the song number $song.
+# If $song is not supplied, returns the current song.
+#
+sub song {
+ my ($self, $song) = @_;
+ return $self->current unless defined $song;
+ my ($item) = $self->_cooked_command_as_items("playlistinfo $song\n");
+ return $item;
+}
+
+
+#
+# my $song = $mpd->songid( [$songid] )
+#
+# Return an AMC::Item::Song representing the song with id $songid.
+# If $songid is not supplied, returns the current song.
+#
+sub songid {
+ my ($self, $songid) = @_;
+ return $self->current unless defined $songid;
+ my ($item) = $self->_cooked_command_as_items("playlistid $songid\n");
+ return $item;
+}
+
+
+# -- MPD interaction: altering settings
+
+#
+# $mpd->repeat( [$repeat] );
+#
+# Set the repeat mode to $repeat (1 or 0). If $repeat is not specified then
+# the repeat mode is toggled.
+#
+sub repeat {
+ my ($self, $mode) = @_;
+
+ $mode = not $self->status->repeat
+ unless defined $mode; # toggle if no param
+ $mode = $mode ? 1 : 0; # force integer
+ $self->_send_command("repeat $mode\n");
+}
+
+
+#
+# $mpd->random( [$random] );
+#
+# Set the random mode to $random (1 or 0). If $random is not specified then
+# the random mode is toggled.
+#
+sub random {
+ my ($self, $mode) = @_;
+
+ $mode = not $self->status->random
+ unless defined $mode; # toggle if no param
+ $mode = $mode ? 1 : 0; # force integer
+ $self->_send_command("random $mode\n");
+}
+
+
+#
+# $mpd->fade( [$seconds] );
+#
+# Enable crossfading and set the duration of crossfade between songs. If
+# $seconds is not specified or $seconds is 0, then crossfading is disabled.
+#
+sub fade {
+ my ($self, $value) = @_;
+ $value ||= 0;
+ $self->_send_command("crossfade $value\n");
+}
+
+
+# -- MPD interaction: controlling playback
+
+#
+# $mpd->play( [$song] );
+#
+# Begin playing playlist at song number $song. If no argument supplied,
+# resume playing.
+#
+sub play {
+ my ($self, $number) = @_;
+ $number = '' unless defined $number;
+ $self->_send_command("play $number\n");
+}
+
+#
+# $mpd->playid( [$songid] );
+#
+# Begin playing playlist at song ID $songid. If no argument supplied,
+# resume playing.
+#
+sub playid {
+ my ($self, $number) = @_;
+ $number ||= '';
+ $self->_send_command("playid $number\n");
+}
+
+
+#
+# $mpd->pause( [$sate] );
+#
+# Pause playback. If $state is 0 then the current track is unpaused, if
+# $state is 1 then the current track is paused.
+#
+# Note that if $state is not given, pause state will be toggled.
+#
+sub pause {
+ my ($self, $state) = @_;
+ $state ||= ''; # default is to toggle
+ $self->_send_command("pause $state\n");
+}
+
+
+#
+# $mpd->stop;
+#
+# Stop playback.
+#
+sub stop {
+ my ($self) = @_;
+ $self->_send_command("stop\n");
+}
+
+
+#
+# $mpd->next;
+#
+# Play next song in playlist.
+#
+sub next {
+ my ($self) = @_;
+ $self->_send_command("next\n");
+}
+
+#
+# $mpd->prev;
+#
+# Play previous song in playlist.
+#
+sub prev {
+ my($self) = shift;
+ $self->_send_command("previous\n");
+}
+
+
+#
+# $mpd->seek( $time, [$song] );
+#
+# Seek to $time seconds in song number $song. If $song number is not specified
+# then the perl module will try and seek to $time in the current song.
+#
+sub seek {
+ my ($self, $time, $song) = @_;
+ $time ||= 0; $time = int $time;
+ $song = $self->status->song if not defined $song; # seek in current song
+ $self->_send_command( "seek $song $time\n" );
+}
+
+
+#
+# $mpd->seekid( $time, [$songid] );
+#
+# Seek to $time seconds in song ID $songid. If $songid number is not specified
+# then the perl module will try and seek to $time in the current song.
+#
+sub seekid {
+ my ($self, $time, $song) = @_;
+ $time ||= 0; $time = int $time;
+ $song = $self->status->songid if not defined $song; # seek in current song
+ $self->_send_command( "seekid $song $time\n" );
+}
+
+
+1;
+
+
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Audio::MPD - class to talk to MPD (Music Player Daemon) servers
+
+
+=head1 SYNOPSIS
+
+ use Audio::MPD;
+
+ my $mpd = Audio::MPD->new();
+ $mpd->play();
+ sleep 10;
+ $mpd->next();
+
+
+=head1 DESCRIPTION
+
+Audio::MPD gives a clear object-oriented interface for talking to and
+controlling MPD (Music Player Daemon) servers. A connection to the MPD
+server is established as soon as a new Audio::MPD object is created.
+
+Note that the module will by default connect to mpd before sending any
+command, and will disconnect after the command has been issued. This scheme
+is far from optimal, but allows us not to care about timeout disconnections.
+
+B</!\> Note that Audio::MPD is using high-level, blocking sockets. This
+means that if the mpd server is slow, or hangs for whatever reason, or
+even crash abruptly, the program will be hung forever in this sub. The
+POE::Component::Client::MPD module is way safer - you're advised to use
+it instead of Audio::MPD. Or you can try to set C<conntype> to C<$REUSE>
+(see Audio::MPD constructor for more details), but you would be then on
+your own to deal with disconnections.
+
+
+=head1 METHODS
+
+=head2 Constructor
+
+=over 4
+
+=item new( [%opts] )
+
+This is the constructor for Audio::MPD. One can specify the following
+options:
+
+=over 4
+
+=item hostname => C<$hostname>
+
+defaults to environment var MPD_HOST, then to 'localhost'. Note that
+MPD_HOST can be of the form password@host.
+
+=item port => C<$port>
+
+defaults to environment var MPD_PORT, then to 6600.
+
+=item password => $password
+
+defaults to environment var MPD_PASSWORD, then to ''.
+
+=item conntype => $type
+
+change how the connection to mpd server is handled. It can be either
+C<$REUSE> to reuse the same connection or C<$ONCE> to open a new
+connection per command (default)
+
+=back
+
+
+=back
+
+
+=head2 Controlling the server
+
+=over 4
+
+=item $mpd->ping()
+
+Sends a ping command to the mpd server.
+
+
+=item $mpd->version()
+
+Return the version number for the server we are connected to.
+
+
+=item $mpd->kill()
+
+Send a message to the MPD server telling it to shut down.
+
+
+=item $mpd->password( [$password] )
+
+Change password used to communicate with MPD server to $password.
+Empty string is assumed if $password is not supplied.
+
+
+=item $mpd->updatedb( [$path] )
+
+Force mpd to recan its collection. If $path (relative to MPD's music directory)
+is supplied, MPD will only scan it - otherwise, MPD will rescan its whole
+collection.
+
+
+=item $mpd->urlhandlers()
+
+Return an array of supported URL schemes.
+
+
+=back
+
+
+=head2 Handling volume & output
+
+=over 4
+
+=item $mpd->volume( [+][-]$volume )
+
+Sets the audio output volume percentage to absolute $volume.
+If $volume is prefixed by '+' or '-' then the volume is changed relatively
+by that value.
+
+
+=item $mpd->output_enable( $output )
+
+Enable the specified audio output. $output is the ID of the audio output.
+
+
+=item $mpd->output_disable( $output )
+
+Disable the specified audio output. $output is the ID of the audio output.
+
+=back
+
+
+=head2 Retrieving info from current state
+
+=over 4
+
+=item $mpd->stats()
+
+Return an C<Audio::MPD::Common::Stats> object with the current statistics
+of MPD. See the associated pod for more information.
+
+
+=item $mpd->status()
+
+Return an C<Audio::MPD::Common::Status> object with various information on
+current MPD server settings. Check the embedded pod for more information on
+the available accessors.
+
+
+=item $mpd->current()
+
+Return an C<Audio::MPD::Common::Item::Song> representing the song currently
+playing.
+
+
+=item $mpd->song( [$song] )
+
+Return an C<Audio::MPD::Common::Item::Song> representing the song number
+C<$song>. If C<$song> is not supplied, returns the current song.
+
+
+=item $mpd->songid( [$songid] )
+
+Return an C<Audio::MPD::Common::Item::Song> representing the song with id
+C<$songid>. If C<$songid> is not supplied, returns the current song.
+
+=back
+
+
+=head2 Altering MPD settings
+
+=over 4
+
+=item $mpd->repeat( [$repeat] )
+
+Set the repeat mode to $repeat (1 or 0). If $repeat is not specified then
+the repeat mode is toggled.
+
+
+=item $mpd->random( [$random] )
+
+Set the random mode to $random (1 or 0). If $random is not specified then
+the random mode is toggled.
+
+
+=item $mpd->fade( [$seconds] )
+
+Enable crossfading and set the duration of crossfade between songs.
+If $seconds is not specified or $seconds is 0, then crossfading is disabled.
+
+=back
+
+
+=head2 Controlling playback
+
+=over 4
+
+=item $mpd->play( [$song] )
+
+Begin playing playlist at song number $song. If no argument supplied,
+resume playing.
+
+
+=item $mpd->playid( [$songid] )
+
+Begin playing playlist at song ID $songid. If no argument supplied,
+resume playing.
+
+
+=item $mpd->pause( [$state] )
+
+Pause playback. If C<$state> is 0 then the current track is unpaused,
+if $state is 1 then the current track is paused.
+
+Note that if C<$state> is not given, pause state will be toggled.
+
+
+=item $mpd->stop()
+
+Stop playback.
+
+
+=item $mpd->next()
+
+Play next song in playlist.
+
+
+=item $mpd->prev()
+
+Play previous song in playlist.
+
+
+=item $mpd->seek( $time, [$song])
+
+Seek to $time seconds in song number $song. If $song number is not specified
+then the perl module will try and seek to $time in the current song.
+
+
+=item $mpd->seekid( $time, $songid )
+
+Seek to $time seconds in song ID $songid. If $song number is not specified
+then the perl module will try and seek to $time in the current song.
+
+=back
+
+
+=head2 Searching the collection
+
+To search the collection, use the C<collection()> accessor, returning the
+associated C<Audio::MPD::Collection> object. You will then be able to call:
+
+ $mpd->collection->random_song();
+
+See C<Audio::MPD::Collection> documentation for more details on available
+methods.
+
+
+=head2 Handling the playlist
+
+To update the playlist, use the C<playlist()> accessor, returning the
+associated C<Audio::MPD::Playlist> object. You will then be able to call:
+
+ $mpd->playlist->clear;
+
+See C<Audio::MPD::Playlist> documentation for more details on available
+methods.
+
+
+=head1 SEE ALSO
+
+You can find more information on the mpd project on its homepage at
+L<http://www.musicpd.org>, or its wiki L<http://mpd.wikia.com>.
+
+Regarding this Perl module, you can report bugs on CPAN via
+L<http://rt.cpan.org/Public/Bug/Report.html?Queue=Audio-MPD>.
+
+Audio::MPD development takes place on <audio-mpd@googlegroups.com>: feel free
+to join us. (use L<http://groups.google.com/group/audio-mpd> to sign in). Our
+subversion repository is located at L<https://svn.musicpd.org>.
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+Original code by Tue Abrahamsen C<< <tue.abrahamsen at gmail.com> >>,
+documented by Nicholas J. Humfrey C<< <njh at aelius.com> >>.
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2005 Tue Abrahamsen, all rights reserved.
+Copyright (c) 2006 Nicolas J. Humfrey, all rights reserved.
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Collection;
+
+use strict;
+use warnings;
+use Scalar::Util qw[ weaken ];
+
+use base qw[ Class::Accessor::Fast ];
+__PACKAGE__->mk_accessors( qw[ _mpd ] );
+
+
+#our ($VERSION) = '$Rev: 5284 $' =~ /(\d+)/;
+
+
+#--
+# Constructor
+
+#
+# my $collection = Audio::MPD::Collection->new( $mpd );
+#
+# This will create the object, holding a back-reference to the Audio::MPD
+# object itself (for communication purposes). But in order to play safe and
+# to free the memory in time, this reference is weakened.
+#
+# Note that you're not supposed to call this constructor yourself, an
+# Audio::MPD::Collection is automatically created for you during the creation
+# of an Audio::MPD object.
+#
+sub new {
+ my ($pkg, $mpd) = @_;
+
+ my $self = { _mpd => $mpd };
+ weaken( $self->{_mpd} );
+ bless $self, $pkg;
+ return $self;
+}
+
+
+#--
+# Public methods
+
+# -- Collection: retrieving songs & directories
+
+#
+# my @items = $collection->all_items( [$path] );
+#
+# Return *all* AMC::Items (both songs & directories) currently known
+# by mpd.
+#
+# If $path is supplied (relative to mpd root), restrict the retrieval to
+# songs and dirs in this directory.
+#
+sub all_items {
+ my ($self, $path) = @_;
+ $path ||= '';
+ $path =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_items( qq[listallinfo "$path"\n] );
+}
+
+
+#
+# my @items = $collection->all_items_simple( [$path] );
+#
+# Return *all* AMC::Items (both songs & directories) currently known
+# by mpd.
+#
+# If $path is supplied (relative to mpd root), restrict the retrieval to
+# songs and dirs in this directory.
+#
+# /!\ Warning: the AMC::Item::Song objects will only have their tag
+# file filled. Any other tag will be empty, so don't use this sub for any
+# other thing than a quick scan!
+#
+sub all_items_simple {
+ my ($self, $path) = @_;
+ $path ||= '';
+ $path =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_items( qq[listall "$path"\n] );
+}
+
+
+#
+# my @items = $collection->items_in_dir( [$path] );
+#
+# Return the items in the given $path. If no $path supplied, do it on mpd's
+# root directory.
+#
+# Note that this sub does not work recusrively on all directories.
+#
+sub items_in_dir {
+ my ($self, $path) = @_;
+ $path ||= '';
+ $path =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_items( qq[lsinfo "$path"\n] );
+}
+
+
+
+# -- Collection: retrieving the whole collection
+
+#
+# my @songs = $collection->all_songs( [$path] );
+#
+# Return *all* AMC::Item::Songs currently known by mpd.
+#
+# If $path is supplied (relative to mpd root), restrict the retrieval to
+# songs and dirs in this directory.
+#
+sub all_songs {
+ my ($self, $path) = @_;
+ return grep { $_->isa('Audio::MPD::Common::Item::Song') } $self->all_items($path);
+}
+
+
+#
+# my @albums = $collection->all_albums;
+#
+# Return the list of all albums (strings) currently known by mpd.
+#
+sub all_albums {
+ my ($self) = @_;
+ return $self->_mpd->_cooked_command_strip_first_field( "list album\n" );
+}
+
+
+#
+# my @artists = $collection->all_artists;
+#
+# Return the list of all artists (strings) currently known by mpd.
+#
+sub all_artists {
+ my ($self) = @_;
+ return $self->_mpd->_cooked_command_strip_first_field( "list artist\n" );
+}
+
+
+#
+# my @titles = $collection->all_titles;
+#
+# Return the list of all titles (strings) currently known by mpd.
+#
+sub all_titles {
+ my ($self) = @_;
+ return $self->_mpd->_cooked_command_strip_first_field( "list title\n" );
+}
+
+
+#
+# my @genre = $collection->all_genre;
+#
+# Return the list of all genres (strings) currently known by mpd.
+#
+sub all_genre {
+ my ($self) = @_;
+ return $self->_mpd->_cooked_command_strip_first_field( "list genre\n" );
+}
+
+
+#
+# my @yers = $collection->all_years;
+#
+# Return the list of all years (strings) currently known by mpd.
+#
+sub all_years {
+ my ($self) = @_;
+ return $self->_mpd->_cooked_command_strip_first_field( "list date\n" );
+}
+
+
+#
+# my @pathes = $collection->all_pathes;
+#
+# Return the list of all pathes (strings) currently known by mpd.
+#
+sub all_pathes {
+ my ($self) = @_;
+ return $self->_mpd->_cooked_command_strip_first_field( "list filename\n" );
+}
+
+
+#
+# my @items = $collection->all_playlists;
+#
+# Return the list of playlists (strings) currently known by mpd.
+#
+sub all_playlists {
+ my ($self) = @_;
+
+ return
+ map { /^playlist: (.*)$/ ? ($1) : () }
+ $self->_mpd->_send_command( "lsinfo\n" );
+}
+
+
+
+# -- Collection: picking songs
+
+#
+# my $song = $collection->song( $path );
+#
+# Return the AMC::Item::Song which correspond to $path.
+#
+sub song {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ my ($item) = $self->_mpd->_cooked_command_as_items( qq[find filename "$what"\n] );
+ return $item;
+}
+
+
+#
+# my $song = $collection->songs_with_filename_partial( $path );
+#
+# Return the AMC::Item::Songs containing $string in their path.
+#
+sub songs_with_filename_partial {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_items( qq[search filename "$what"\n] );
+}
+
+
+# -- Collection: songs, albums & artists relations
+
+#
+# my @albums = $collection->albums_by_artist($artist);
+#
+# Return all albums (strings) performed by $artist or where $artist
+# participated.
+#
+sub albums_by_artist {
+ my ($self, $artist) = @_;
+ $artist =~ s/"/\\"/g;
+ return $self->_mpd->_cooked_command_strip_first_field( qq[list album "$artist"\n] );
+}
+
+
+#
+# my @songs = $collection->songs_by_artist( $genre );
+#
+# Return all AMC::Item::Songs performed in $genre.
+#
+
+sub songs_by_genre {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_items( qq[find genre "$what"\n] );
+}
+
+
+sub filenames_by_artist {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_filename( qq[find artist "$what"\n] );
+}
+
+
+sub filenames_by_year {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_filename( qq[find date "$what"\n] );
+}
+
+sub filenames_by_genre {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_filename( qq[find genre "$what"\n] );
+}
+
+
+sub filenames_by_album {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_filename( qq[find album "$what"\n] );
+}
+
+
+#
+# my @songs = $collection->songs_by_artist_partial( $string );
+#
+# Return all AMC::Item::Songs performed by an artist with $string
+# in her name.
+#
+sub songs_by_artist_partial {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_items( qq[search artist "$what"\n] );
+}
+
+
+#
+# my @songs = $collection->songs_from_album( $album );
+#
+# Return all AMC::Item::Songs appearing in $album.
+#
+sub songs_from_album {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_items( qq[find album "$what"\n] );
+}
+
+
+#
+# my @songs = $collection->songs_from_album_partial( $string );
+#
+# Return all AMC::Item::Songs appearing in album containing $string.
+#
+sub songs_from_album_partial {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_items( qq[search album "$what"\n] );
+}
+
+
+#
+# my @songs = $collection->songs_with_title( $title );
+#
+# Return all AMC::Item::Songs which title is exactly $title.
+#
+sub songs_with_title {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_items( qq[find title "$what"\n] );
+}
+
+
+#
+# my @songs = $collection->songs_with_title_partial( $string );
+#
+# Return all AMC::Item::Songs where $string is part of the title.
+#
+sub songs_with_title_partial {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_items( qq[search title "$what"\n] );
+}
+
+
+# my @songs = $collection->songs_with_title_partial_filename( $string );
+#
+# Return all AMC::Item::Songs where $string is part of the title.
+#
+sub songs_with_title_partial_filename {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+
+ return $self->_mpd->_cooked_command_as_filename( qq[search title "$what"\n] );
+}
+
+# my @songs = $collection->songs_with_artist_partial_filename( $string );
+#
+# Return all AMC::Item::Songs where $string is part of the artist.
+#
+sub songs_with_artist_partial_filename {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_filename( qq[search artist "$what"\n] );
+}
+
+
+# my @songs = $collection->songs_with_album_partial_filename( $string );
+#
+# Return all AMC::Item::Songs where $string is part of the album.
+#
+sub songs_with_album_partial_filename {
+ my ($self, $what) = @_;
+ $what =~ s/"/\\"/g;
+
+ return $self->_mpd->_cooked_command_as_filename( qq[search album "$what"\n] );
+}
+
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Audio::MPD::Collection - an object to query MPD's collection
+
+
+=head1 SYNOPSIS
+
+ my $song = $mpd->collection->random_song;
+
+
+=head1 DESCRIPTION
+
+C<Audio::MPD::Collection> is a class meant to access & query MPD's
+collection. You will be able to use those high-level methods instead
+of using the low-level methods provided by mpd itself.
+
+
+=head1 PUBLIC METHODS
+
+=head2 Constructor
+
+=over 4
+
+=item new( $mpd )
+
+This will create the object, holding a back-reference to the C<Audio::MPD>
+object itself (for communication purposes). But in order to play safe and
+to free the memory in time, this reference is weakened.
+
+Note that you're not supposed to call this constructor yourself, an
+C<Audio::MPD::Collection> is automatically created for you during the creation
+of an C<Audio::MPD> object.
+
+=back
+
+
+=head2 Retrieving songs & directories
+
+=over 4
+
+=item $coll->all_items( [$path] )
+
+Return B<all> C<Audio::MPD::Common::Item>s (both songs & directories)
+currently known by mpd.
+
+If C<$path> is supplied (relative to mpd root), restrict the retrieval to
+songs and dirs in this directory.
+
+
+=item $coll->all_items_simple( [$path] )
+
+Return B<all> C<Audio::MPD::Common::Item>s (both songs & directories)
+currently known by mpd.
+
+If C<$path> is supplied (relative to mpd root), restrict the retrieval to
+songs and dirs in this directory.
+
+B</!\ Warning>: the C<Audio::MPD::Common::Item::Song> objects will only have
+their tag file filled. Any other tag will be empty, so don't use this sub for
+any other thing than a quick scan!
+
+
+=item $coll->items_in_dir( [$path] )
+
+Return the items in the given C<$path>. If no C<$path> supplied, do it on
+mpd's root directory.
+
+Note that this sub does not work recusrively on all directories.
+
+
+=back
+
+
+=head2 Retrieving the whole collection
+
+=over 4
+
+=item $coll->all_songs( [$path] )
+
+Return B<all> C<Audio::MPD::Common::Item::Song>s currently known by mpd.
+
+If C<$path> is supplied (relative to mpd root), restrict the retrieval to
+songs and dirs in this directory.
+
+
+=item $coll->all_albums()
+
+Return the list of all albums (strings) currently known by mpd.
+
+
+=item $coll->all_artists()
+
+Return the list of all artists (strings) currently known by mpd.
+
+
+=item $coll->all_titles()
+
+Return the list of all song titles (strings) currently known by mpd.
+
+
+=item $coll->all_pathes()
+
+Return the list of all pathes (strings) currently known by mpd.
+
+
+=item $coll->all_playlists()
+
+Return the list of all playlists (strings) currently known by mpd.
+
+
+=back
+
+
+=head2 Picking a song
+
+=over 4
+
+=item $coll->song( $path )
+
+Return the C<Audio::MPD::Common::Item::Song> which correspond to C<$path>.
+
+
+=item $coll->songs_with_filename_partial( $path )
+
+Return the C<Audio::MPD::Common::Item::Song>s containing $string in their path.
+
+
+=back
+
+
+=head2 Songs, albums & artists relations
+
+=over 4
+
+=item $coll->albums_by_artist( $artist )
+
+Return all albums (strings) performed by C<$artist> or where C<$artist>
+participated.
+
+
+=item $coll->songs_by_artist( $artist )
+
+Return all C<Audio::MPD::Common::Item::Song>s performed by C<$artist>.
+
+
+=item $coll->songs_by_artist_partial( $string )
+
+Return all C<Audio::MPD::Common::Item::Song>s performed by an artist with
+C<$string> in her name.
+
+
+=item $coll->songs_from_album( $album )
+
+Return all C<Audio::MPD::Common::Item::Song>s appearing in C<$album>.
+
+
+=item $coll->songs_from_album_partial( $string )
+
+Return all C<Audio::MPD::Common::Item::Song>s appearing in album containing C<$string>.
+
+
+=item $coll->songs_with_title( $title )
+
+Return all C<Audio::MPD::Common::Item::Song>s which title is exactly C<$title>.
+
+
+=item $coll->songs_with_title_partial( $string )
+
+Return all C<Audio::MPD::Common::Item::Song>s where C<$string> is part of the title.
+
+
+=back
+
+
+=head1 SEE ALSO
+
+L<Audio::MPD>
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD::Common
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Common;
+
+use warnings;
+use strict;
+our $VERSION = '0.1.2';
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Audio::MPD::Common - a bunch of common helper classes for mpd
+
+
+=head1 DESCRIPTION
+
+Depending on whether you're using a POE-aware environment or not, people
+wanting to tinker with mpd (Music Player Daemon) will use either
+L<POE::Component::Client::MPD> or L<Audio::MPD>.
+
+But even if the run-cores of those two modules differ completely, they
+are using the exact same common classes to represent the various mpd
+states and information.
+
+Therefore, those common classes have been outsourced to
+L<Audio::MPD::Common>.
+
+This module does not export any methods, but the dist provides the
+following classes that you can query with perldoc:
+
+=over 4
+
+=item o L<Audio::MPD::Common::Item>
+
+=item o L<Audio::MPD::Common::Item::Directory>
+
+=item o L<Audio::MPD::Common::Item::Playlist>
+
+=item o L<Audio::MPD::Common::Item::Song>
+
+=item o L<Audio::MPD::Common::Stats>
+
+=item o L<Audio::MPD::Common::Status>
+
+=item o L<Audio::MPD::Common::Time>
+
+=back
+
+
+Note that those modules should not be of any use outside the two mpd
+modules afore-mentioned.
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Audio::MPD>
+
+=item L<POE::Component::Client::MPD>
+
+=back
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD::Common
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Common::Item;
+
+use strict;
+use warnings;
+use Audio::MPD::Common::Item::Directory;
+use Audio::MPD::Common::Item::Playlist;
+use Audio::MPD::Common::Item::Song;
+
+#our ($VERSION) = '$Rev: 5645 $' =~ /(\d+)/;
+
+#
+# constructor.
+#
+sub new {
+ my ($pkg, %params) = @_;
+
+ # transform keys in lowercase.
+ my %lowcase;
+ @lowcase{ keys %params } = values %params;
+
+ return Audio::MPD::Common::Item::Song->new(\%lowcase) if exists $params{file};
+ return Audio::MPD::Common::Item::Directory->new(\%lowcase) if exists $params{directory};
+ return Audio::MPD::Common::Item::Playlist->new(\%lowcase) if exists $params{playlist};
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Audio::MPD::Common::Item - a generic collection item
+
+
+=head1 SYNOPSIS
+
+ my $item = Audio::MPD::Common::Item->new( %params );
+
+
+=head1 DESCRIPTION
+
+C<Audio::MPD::Common::Item> is a virtual class representing a generic
+item of mpd's collection. It can be either a song, a directory or a playlist.
+
+Depending on the params given to C<new>, it will create and return an
+C<Audio::MPD::Common::Item::Song>, an C<Audio::MPD::Common::Item::Directory>
+or an C<Audio::MPD::Common::Playlist> object. Currently, the
+discrimination is done on the existence of the C<file> key of C<%params>.
+
+
+=head1 PUBLIC METHODS
+
+Note that the only sub worth it in this class is the constructor:
+
+=over 4
+
+=item new( key => val [, key => val [, ...] ] )
+
+Create and return either an C<Audio::MPD::Common::Item::Song>, an
+C<Audio::MPD::Common::Item::Directory> or an C<Audio::MPD::Common::Playlist>
+object, depending on the existence of a key C<file>, C<directory> or
+C<playlist> (respectively).
+
+=back
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Audio::MPD>
+
+=item L<POE::Component::Client::MPD>
+
+=back
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD::Common
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Common::Item::Directory;
+
+use strict;
+use warnings;
+
+use base qw[ Class::Accessor::Fast Audio::MPD::Common::Item ];
+__PACKAGE__->mk_accessors( qw[ directory ] );
+
+#our ($VERSION) = '$Rev: 5645 $' =~ /(\d+)/;
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Audio::MPD::Common::Item::Directory - a directory object
+
+
+=head1 SYNOPSIS
+
+ print $item->directory . "\n";
+
+
+=head1 DESCRIPTION
+
+C<Audio::MPD::Common::Item::Directory> is more a placeholder for a
+hash ref with one pre-defined key, namely the directory name.
+
+
+=head1 PUBLIC METHODS
+
+This module only has a C<new()> constructor, which should only be called by
+C<Audio::MPD::Common::Item>'s constructor.
+
+The only other public method is an accessor: directory().
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Audio::MPD>
+
+=item L<POE::Component::Client::MPD>
+
+=back
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD::Common
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Common::Item::Playlist;
+
+use strict;
+use warnings;
+
+use base qw[ Class::Accessor::Fast Audio::MPD::Common::Item ];
+__PACKAGE__->mk_accessors( qw[ playlist ] );
+
+#our ($VERSION) = '$Rev: 5645 $' =~ /(\d+)/;
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Audio::MPD::Common::Item::Playlist - a playlist object
+
+
+=head1 SYNOPSIS
+
+ print $item->playlist . "\n";
+
+
+=head1 DESCRIPTION
+
+C<Audio::MPD::Common::Item::Playlist> is more a placeholder for a hash ref
+with one pre-defined key, namely the playlist name.
+
+
+=head1 PUBLIC METHODS
+
+This module only has a C<new()> constructor, which should only be called by
+C<Audio::MPD::Common::Item>'s constructor.
+
+The only other public method is an accessor: playlist().
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Audio::MPD>
+
+=item L<POE::Component::Client::MPD>
+
+=back
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD::Common
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Common::Item::Song;
+
+use strict;
+use warnings;
+
+use overload '""' => \&as_string;
+use Readonly;
+
+use base qw[ Class::Accessor::Fast Audio::MPD::Common::Item ];
+__PACKAGE__->mk_accessors( qw[ Album Artist file id pos Title Track time ] );
+
+#our ($VERSION) = '$Rev: 5645 $' =~ /(\d+)/;
+
+Readonly my $SEP => ' = ';
+
+
+#
+# my $str = $song->as_string;
+#
+# Return a string representing $song. This string will be;
+# - either "Album = Track = Artist = Title"
+# - or "Artist = Title"
+# - or "Title"
+# - or "file"
+# (in this order), depending on the existing tags of the song. The last
+# possibility always exist of course, since it's a path.
+#
+sub as_string {
+ my ($self) = @_;
+
+ return $self->file unless defined $self->Title;
+ my $str = $self->Title;
+ return $str unless defined $self->Artist;
+ $str = $self->Artist . $SEP . $str;
+ return $str unless defined $self->Album && defined $self->Track;
+ return join $SEP,
+ $self->Album,
+ $self->Track,
+ $str;
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Audio::MPD::Common::Item::Song - a song object with some audio tags
+
+
+=head1 DESCRIPTION
+
+C<Audio::MPD::Common::Item::Song> is more a placeholder for a
+hash ref with some pre-defined keys, namely some audio tags.
+
+
+=head1 PUBLIC METHODS
+
+This module has a C<new()> constructor, which should only be called by
+C<Audio::MPD::Common::Item>'s constructor.
+
+The only other public methods are the accessors - see below.
+
+
+=head2 Accessors
+
+The following methods are the accessors to their respective named fields:
+C<Album()>, C<Artist()>, C<file()>, C<id>, C<pos>, C<Title()>, CTTrack()>,
+C<time()>. You can call them either with no arg to get the value, or with
+an arg to replace the current value.
+
+
+=head2 Methods
+
+
+=over 4
+
+=item $song->as_string()
+
+Return a string representing $song. This string will be:
+
+=over 4
+
+=item either "Album = Track = Artist = Title"
+
+=item or "Artist = Title"
+
+=item or "Title"
+
+=item or "file"
+
+=back
+
+(in this order), depending on the existing tags of the song. The last
+possibility always exist of course, since it's a path.
+
+=back
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Audio::MPD>
+
+=item L<POE::Component::Client::MPD>
+
+=back
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD::Common
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Common::Stats;
+
+use warnings;
+use strict;
+
+use base qw[ Class::Accessor::Fast ];
+__PACKAGE__->mk_accessors
+ ( qw[ artists albums songs uptime playtime db_playtime db_update ] );
+
+#our ($VERSION) = '$Rev$' =~ /(\d+)/;
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Audio::MPD::Common::Stats - class representing MPD stats
+
+
+=head1 SYNOPSIS
+
+ print $stats->artists;
+
+
+=head1 DESCRIPTION
+
+The MPD server maintains some general information. Those information can be
+queried with the mpd modules. Some of those information are served to you as
+an C<Audio::MPD::Common::Status> object.
+
+Note that an C<Audio::MPD::Common::Stats> object does B<not> update itself
+regularly, and thus should be used immediately.
+
+
+=head1 METHODS
+
+=head2 Constructor
+
+=over 4
+
+=item new( %kv )
+
+The C<new()> method is the constructor for the C<Audio::MPD::Common::Stats>
+class.
+
+Note: one should B<never> ever instantiate an C<Audio::MPD::Common::Stats>
+object directly - use the mpd modules instead.
+
+=back
+
+
+=head2 Accessors
+
+Once created, one can access to the following members of the object:
+
+=over 4
+
+=item $stats->artists()
+
+Number of artists in the music database.
+
+
+=item $stats->albums()
+
+Number of albums in the music database.
+
+
+=item $stats->songs()
+
+Number of songs in the music database.
+
+
+=item $stats->uptime()
+
+Daemon uptime (time since last startup) in seconds.
+
+
+=item $stats->playtime()
+
+Time length of music played.
+
+
+=item $stats->db_playtime()
+
+Sum of all song times in the music database.
+
+
+=item $stats->db_update()
+
+Last database update in UNIX time.
+
+
+=back
+
+
+Please note that those accessors are read-only: changing a value will B<not>
+change the current settings of MPD server. Use the mpd modules to alter the
+settings.
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Audio::MPD>
+
+=item L<POE::Component::Client::MPD>
+
+=back
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD::Common
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Common::Status;
+
+use warnings;
+use strict;
+
+use Audio::MPD::Common::Time;
+
+use base qw[ Class::Accessor::Fast ];
+__PACKAGE__->mk_accessors
+ ( qw[ audio bitrate error playlist playlistlength random
+ repeat song songid state time volume updating_db xfade ] );
+
+#our ($VERSION) = '$Rev: 5865 $' =~ /(\d+)/;
+
+
+#--
+# Constructor
+
+#
+# my $status = Audio::MPD::Common::Status->new( \%kv )
+#
+# The constructor for the class Audio::MPD::Common::Status. %kv is
+# a cooked output of what MPD server returns to the status command.
+#
+sub new {
+ my ($class, $kv) = @_;
+ my %kv = %$kv;
+ $kv{time} = Audio::MPD::Common::Time->new( delete $kv{time} );
+ bless \%kv, $class;
+ return \%kv;
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Audio::MPD::Common::Status - class representing MPD status
+
+
+=head1 SYNOPSIS
+
+ print $status->bitrate;
+
+
+=head1 DESCRIPTION
+
+The MPD server maintains some information on its current state. Those
+information can be queried with mpd modules. Some of those information
+are served to you as an C<Audio::MPD::Common::Status> object.
+
+Note that an C<Audio::MPD::Common::Status> object does B<not> update
+itself regularly, and thus should be used immediately.
+
+
+=head1 METHODS
+
+=head2 Constructor
+
+=over 4
+
+=item new( \%kv )
+
+The C<new()> method is the constructor for the C<Audio::MPD::Common::Status>
+class.
+
+Note: one should B<never> ever instantiate an C<Audio::MPD::Common::Status>
+object directly - use the mpd modules instead.
+
+=back
+
+
+=head2 Accessors
+
+Once created, one can access to the following members of the object:
+
+=over 4
+
+=item $status->audio()
+
+A string with the sample rate of the song currently playing, number of bits
+of the output and number of channels (2 for stereo) - separated by a colon.
+
+
+=item $status->bitrate()
+
+The instantaneous bitrate in kbps.
+
+
+=item $status->error()
+
+May appear in special error cases, such as when disabling output.
+
+
+=item $status->playlist()
+
+The playlist version number, that changes every time the playlist is updated.
+
+
+=item $status->playlistlength()
+
+The number of songs in the playlist.
+
+
+=item $status->random()
+
+Whether the playlist is read randomly or not.
+
+
+=item $status->repeat()
+
+Whether the song is repeated or not.
+
+
+=item $status->song()
+
+The offset of the song currently played in the playlist.
+
+
+=item $status->songid()
+
+The song id (MPD id) of the song currently played.
+
+
+=item $status->state()
+
+The state of MPD server. Either C<play>, C<stop> or C<pause>.
+
+
+=item $status->time()
+
+An C<Audio::MPD::Common::Time> object, representing the time elapsed /
+remainging and total. See the associated pod for more details.
+
+
+=item $status->updating_db()
+
+An integer, representing the current update job.
+
+
+=item $status->volume()
+
+The current MPD volume - an integer between 0 and 100.
+
+
+=item $status->xfade()
+
+The crossfade in seconds.
+
+
+=back
+
+Please note that those accessors are read-only: changing a value will B<not>
+change the current settings of MPD server. Use the mpd modules to alter the
+settings.
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Audio::MPD>
+
+=item L<POE::Component::Client::MPD>
+
+=back
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD::Common
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Common::Time;
+
+use warnings;
+use strict;
+
+use base qw[ Class::Accessor::Fast ];
+__PACKAGE__->mk_accessors
+ ( qw[ percent sofar left total
+ sofar_secs sofar_mins seconds_sofar
+ total_secs total_mins seconds_total
+ left_secs left_mins seconds_left
+ ] );
+
+#our ($VERSION) = '$Rev$' =~ /(\d+)/;
+
+
+#--
+# Constructor
+
+#
+# my $status = Audio::MPD::Common::Time->new( $time )
+#
+# The constructor for the class Audio::MPD::Common::Time. $time is
+# the time value (on the "time" line) of what the output MPD server
+# returns to the status command.
+#
+sub new {
+ my ($class, $time) = @_;
+ $time ||= '0:0';
+ my ($seconds_sofar, $seconds_total) = split /:/, $time;
+ my $seconds_left = $seconds_total - $seconds_sofar;
+ my $percent = $seconds_total ? 100*$seconds_sofar/$seconds_total : 0;
+
+ # Parse the time so far
+ my $sofar_mins = int( $seconds_sofar / 60 );
+ my $sofar_secs = $seconds_sofar % 60;
+ my $sofar = sprintf "%d:%02d", $sofar_mins, $sofar_secs;
+
+ # Parse the total time
+ my $total_mins = int( $seconds_total / 60 );
+ my $total_secs = $seconds_total % 60;
+ my $total = sprintf "%d:%02d", $total_mins, $total_secs;
+
+ # Parse the time left
+ my $left_mins = int( $seconds_left / 60 );
+ my $left_secs = $seconds_left % 60;
+ my $left = sprintf "%d:%02d", $left_mins, $left_secs;
+
+
+ # create object
+ my $self = {
+ # time elapsed in seconds
+ seconds_sofar => $seconds_sofar,
+ seconds_left => $seconds_left,
+ seconds_total => $seconds_total,
+
+ # cooked values
+ sofar => $sofar,
+ left => $left,
+ total => $total,
+ percent => sprintf("%.1f", $percent), # 1 decimal
+
+ # details
+ sofar_secs => $sofar_secs,
+ sofar_mins => $sofar_mins,
+ total_secs => $total_secs,
+ total_mins => $total_mins,
+ left_secs => $left_secs,
+ left_mins => $left_mins,
+ };
+ bless $self, $class;
+ return $self;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Audio::MPD::Common::Time - class representing time of current song
+
+
+=head1 SYNOPSIS
+
+ my $time = $status->time;
+ print $time->sofar;
+
+
+=head1 DESCRIPTION
+
+C<Audio::MPD::Common::Status> returns some time information with the C<time()>
+accessor. This information relates to the elapsed time of the current song,
+as well as the remaining and total time. This information is encapsulated
+in an C<Audio::MPD::Common::Time> object.
+
+Note that an C<Audio::MPD::Common::Time> object does B<not> update itself
+regularly, and thus should be used immediately.
+
+
+=head1 METHODS
+
+=head2 Constructor
+
+=over 4
+
+=item new( $time )
+
+The C<new()> method is the constructor for the C<Audio::MPD::Common::Time>
+class.
+
+Note: one should B<never> ever instantiate an C<Audio::MPD::Common::Time>
+object directly - use the mpd modules instead.
+
+=back
+
+
+=head2 Accessors
+
+Once created, one can access the following members of the object:
+
+=over 4
+
+=item cooked values:
+
+The C<sofar()>, C<left()> and C<total()> methods return the according values
+under the form C<minutes:seconds>. Note the existence of a C<percent()>
+method returning a percentage complete. (one decimal)
+
+
+=item values in seconds:
+
+The C<seconds_sofar()>, C<seconds_left()> and C<seconds_total()> return the
+according values in seconds.
+
+
+=item detailled values:
+
+If you want to cook your own value, then the following methods can help:
+C<sofar_secs()> and C<sofar_mins()> return the seconds and minutes elapsed.
+Same for C<left_secs()> and C<left_mins()> (time remaining), C<total_secs()>
+and C<total_mins()>. (total song length)
+
+
+=back
+
+
+Please note that those accessors are read-only: changing a value will B<not>
+change the current settings of MPD server. Use the mpd modules to alter the
+settings.
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Audio::MPD>
+
+=item L<POE::Component::Client::MPD>
+
+=back
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Playlist;
+
+use strict;
+use warnings;
+use Scalar::Util qw[ weaken ];
+
+use base qw[ Class::Accessor::Fast ];
+__PACKAGE__->mk_accessors( qw[ _mpd ] );
+
+
+#our ($VERSION) = '$Rev$' =~ /(\d+)/;
+
+
+#--
+# Constructor
+
+#
+# my $collection = Audio::MPD::Playlist->new( $mpd );
+#
+# This will create the object, holding a back-reference to the Audio::MPD
+# object itself (for communication purposes). But in order to play safe and
+# to free the memory in time, this reference is weakened.
+#
+# Note that you're not supposed to call this constructor yourself, an
+# Audio::MPD::Playlist is automatically created for you during the creation
+# of an Audio::MPD object.
+#
+sub new {
+ my ($pkg, $mpd) = @_;
+
+ my $self = { _mpd => $mpd };
+ weaken( $self->{_mpd} );
+ bless $self, $pkg;
+ return $self;
+}
+
+
+#--
+# Public methods
+
+# -- Playlist: retrieving information
+
+#
+# my @items = $pl->as_items;
+#
+# Return an array of AMC::Item::Songs, one for each of the
+# songs in the current playlist.
+#
+sub as_items {
+ my ($self) = @_;
+
+ my @list = $self->_mpd->_cooked_command_as_items("playlistinfo\n");
+ return @list;
+}
+
+
+#
+# my @items = $pl->items_changed_since( $plversion );
+#
+# Return a list with all the songs (as API::Song objects) added to
+# the playlist since playlist $plversion.
+#
+sub items_changed_since {
+ my ($self, $plid) = @_;
+ return $self->_mpd->_cooked_command_as_items("plchanges $plid\n");
+}
+
+
+
+# -- Playlist: adding / removing songs
+
+#
+# $pl->add( $path [, $path [...] ] );
+#
+# Add the songs identified by $path (relative to MPD's music directory) to
+# the current playlist. No return value.
+#
+sub add {
+ my ($self, @pathes) = @_;
+ my $command =
+ "command_list_begin\n"
+ . join( '', map { s/"/\\"/g; qq[add "$_"\n] } @pathes )
+ . "command_list_end\n";
+ $self->_mpd->_send_command( $command );
+}
+
+
+#
+# $pl->delete( $song [, $song [...] ] );
+#
+# Remove song number $song (starting from 0) from the current playlist. No
+# return value.
+#
+sub delete {
+ my ($self, @songs) = @_;
+ my $command =
+ "command_list_begin\n"
+ . join( '', map { s/"/\\"/g; "delete $_\n" } @songs )
+ . "command_list_end\n";
+ $self->_mpd->_send_command( $command );
+}
+
+
+#
+# $pl->deleteid( $songid [, $songid [...] ]);
+#
+# Remove the specified $songid (as assigned by mpd when inserted in playlist)
+# from the current playlist. No return value.
+#
+sub deleteid {
+ my ($self, @songs) = @_;
+ my $command =
+ "command_list_begin\n"
+ . join( '', map { "deleteid $_\n" } @songs )
+ . "command_list_end\n";
+ $self->_mpd->_send_command( $command );
+}
+
+
+#
+# $pl->clear;
+#
+# Remove all the songs from the current playlist. No return value.
+#
+sub clear {
+ my ($self) = @_;
+ $self->_mpd->_send_command("clear\n");
+}
+
+
+#
+# $pl->crop;
+#
+# Remove all of the songs from the current playlist *except* the current one.
+#
+sub crop {
+ my ($self) = @_;
+
+ my $status = $self->_mpd->status;
+ my $cur = $status->song;
+ my $len = $status->playlistlength - 1;
+
+ my $command =
+ "command_list_begin\n"
+ . join( '', map { $_ != $cur ? "delete $_\n" : '' } reverse 0..$len )
+ . "command_list_end\n";
+ $self->_mpd->_send_command( $command );
+}
+
+
+# -- Playlist: changing playlist order
+
+#
+# $pl->shuffle();
+#
+# Shuffle the current playlist. No return value.
+#
+sub shuffle {
+ my ($self) = @_;
+ $self->_mpd->_send_command("shuffle\n");
+}
+
+
+#
+# $pl->swap( $song1, $song2 );
+#
+# Swap positions of song number $song1 and $song2 in the current playlist.
+# No return value.
+#
+sub swap {
+ my ($self, $from, $to) = @_;
+ $self->_mpd->_send_command("swap $from $to\n");
+}
+
+
+#
+# $pl->swapid( $songid1, $songid2 );
+#
+# Swap the postions of song ID $songid1 with song ID $songid2 in the
+# current playlist. No return value.
+#
+sub swapid {
+ my ($self, $from, $to) = @_;
+ $self->_mpd->_send_command("swapid $from $to\n");
+}
+
+
+#
+# $pl->move( $song, $newpos );
+#
+# Move song number $song to the position $newpos. No return value.
+#
+sub move {
+ my ($self, $song, $pos) = @_;
+ $self->_mpd->_send_command("move $song $pos\n");
+}
+
+
+#
+# $pl->moveid( $songid, $newpos );
+#
+# Move song ID $songid to the position $newpos. No return value.
+#
+sub moveid {
+ my ($self, $song, $pos) = @_;
+ $self->_mpd->_send_command("moveid $song $pos\n");
+}
+
+
+# -- Playlist: managing playlists
+
+#
+# $pl->load( $playlist );
+#
+# Load list of songs from specified $playlist file. No return value.
+#
+sub load {
+ my ($self, $playlist) = @_;
+ $self->_mpd->_send_command( qq[load "$playlist"\n] );
+}
+
+
+#
+# $pl->save( $playlist );
+#
+# Save the current playlist to a file called $playlist in MPD's playlist
+# directory. No return value.
+#
+sub save {
+ my ($self, $playlist) = @_;
+ $self->_mpd->_send_command( qq[save "$playlist"\n] );
+}
+
+
+#
+# $pl->rm( $playlist )
+#
+# Delete playlist named $playlist from MPD's playlist directory. No
+# return value.
+#
+sub rm {
+ my ($self, $playlist) = @_;
+ $self->_mpd->_send_command( qq[rm "$playlist"\n] );
+}
+
+
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Audio::MPD::Playlist - an object to mess MPD's playlist
+
+
+=head1 SYNOPSIS
+
+ my $song = $mpd->playlist->randomize;
+
+
+=head1 DESCRIPTION
+
+C<Audio::MPD::Playlist> is a class meant to access & update MPD's
+playlist.
+
+
+=head1 PUBLIC METHODS
+
+=head2 Constructor
+
+=over 4
+
+=item new( $mpd )
+
+This will create the object, holding a back-reference to the C<Audio::MPD>
+object itself (for communication purposes). But in order to play safe and
+to free the memory in time, this reference is weakened.
+
+Note that you're not supposed to call this constructor yourself, an
+C<Audio::MPD::Playlist> is automatically created for you during the creation
+of an C<Audio::MPD> object.
+
+=back
+
+
+=head2 Retrieving information
+
+=over 4
+
+=item $pl->as_items()
+
+Return an array of C<Audio::MPD::Common::Item::Song>s, one for each of the
+songs in the current playlist.
+
+
+=item $pl->items_changed_since( $plversion )
+
+Return a list with all the songs (as AMC::Item::Song objects) added to
+the playlist since playlist $plversion.
+
+
+=back
+
+
+=head2 Adding / removing songs
+
+=over 4
+
+=item $pl->add( $path [, $path [...] ] )
+
+Add the songs identified by C<$path> (relative to MPD's music directory) to the
+current playlist. No return value.
+
+
+=item $pl->delete( $song [, $song [...] ] )
+
+Remove song number C<$song>s (starting from 0) from the current playlist. No
+return value.
+
+
+=item $pl->deleteid( $songid [, $songid [...] ] )
+
+Remove the specified C<$songid>s (as assigned by mpd when inserted in playlist)
+from the current playlist. No return value.
+
+
+=item $pl->clear()
+
+Remove all the songs from the current playlist. No return value.
+
+
+=item $pl->crop()
+
+Remove all of the songs from the current playlist *except* the
+song currently playing.
+
+
+=back
+
+
+=head2 Changing playlist order
+
+=over 4
+
+=item $pl->shuffle()
+
+Shuffle the current playlist. No return value.
+
+
+=item $pl->swap( $song1, $song2 )
+
+Swap positions of song number C<$song1> and C<$song2> in the current
+playlist. No return value.
+
+
+=item $pl->swapid( $songid1, $songid2 )
+
+Swap the postions of song ID C<$songid1> with song ID C<$songid2> in the
+current playlist. No return value.
+
+
+=item $pl->move( $song, $newpos )
+
+Move song number C<$song> to the position C<$newpos>. No return value.
+
+
+=item $pl->moveid( $songid, $newpos )
+
+Move song ID C<$songid> to the position C<$newpos>. No return value.
+
+
+=back
+
+
+=head2 Managing playlists
+
+=over 4
+
+=item $pl->load( $playlist )
+
+Load list of songs from specified C<$playlist> file. No return value.
+
+
+=item $pl->save( $playlist )
+
+Save the current playlist to a file called C<$playlist> in MPD's playlist
+directory. No return value.
+
+
+=item $pl->rm( $playlist )
+
+Delete playlist named C<$playlist> from MPD's playlist directory. No
+return value.
+
+
+=back
+
+
+=head1 SEE ALSO
+
+L<Audio::MPD>
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+#
+# This file is part of Audio::MPD
+# Copyright (c) 2007 Jerome Quelin, all rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+#
+
+package Audio::MPD::Test;
+
+use strict;
+use warnings;
+
+use Exporter;
+use FindBin qw[ $Bin ];
+use Readonly;
+
+
+use base qw[ Exporter ];
+our @EXPORT = qw[ customize_test_mpd_configuration start_test_mpd stop_test_mpd ];
+#our ($VERSION) = '$Rev: 5284 $' =~ /(\d+)/;
+
+
+Readonly my $TEMPLATE => "$Bin/mpd-test/mpd.conf.template";
+Readonly my $CONFIG => "$Bin/mpd-test/mpd.conf";
+
+{ # this will be run when Audio::MPD::Test will be use-d.
+ my $restart = 0;
+ my $stopit = 0;
+
+ customize_test_mpd_configuration();
+ $restart = _stop_user_mpd_if_needed();
+ $stopit = start_test_mpd();
+
+ END {
+ stop_test_mpd() if $stopit;
+ return unless $restart; # no need to restart
+ system 'mpd 2>/dev/null'; # restart user mpd
+ sleep 1; # wait 1 second to let mpd start.
+ }
+}
+
+
+#--
+# public subs
+
+#
+# customize_test_mpd_configuration( [$port] )
+#
+# Create a fake mpd configuration file, based on the file mpd.conf.template
+# located in t/mpd-test. The string PWD will be replaced by the real path -
+# ie, where the tarball has been untarred. The string PORT will be replaced
+# by $port if specified, 6600 otherwise (MPD default).
+#
+sub customize_test_mpd_configuration {
+ my ($port) = @_;
+ $port ||= 6600;
+
+ # open template and config.
+ open my $in, '<', $TEMPLATE or die "can't open [$TEMPLATE]: $!\n";
+ open my $out, '>', $CONFIG or die "can't open [$CONFIG]: $!\n";
+
+ # replace string and fill in config file.
+ while ( defined( my $line = <$in> ) ) {
+ $line =~ s!PWD!$Bin/mpd-test!;
+ $line =~ s!PORT!$port!;
+ print $out $line;
+ }
+
+ # clean up.
+ close $in;
+ close $out;
+
+ # create a fake mpd db.
+ system( "mpd --create-db $CONFIG >/dev/null 2>&1" ) == 0
+ or die "could not create fake mpd database: $?\n";
+}
+
+
+#
+# start_test_mpd()
+#
+# Start the fake mpd, and die if there were any error.
+#
+sub start_test_mpd {
+ my $output = qx[mpd $CONFIG 2>&1];
+ die "could not start fake mpd: $output\n" if $output;
+ sleep 1; # wait 1 second to let mpd start.
+ return 1;
+}
+
+
+#
+# stop_test_mpd()
+#
+# Kill the fake mpd.
+#
+sub stop_test_mpd {
+ system "mpd --kill $CONFIG 2>/dev/null";
+ sleep 1; # wait 1 second to free output device.
+ unlink "$Bin/mpd-test/state", "$Bin/mpd-test/music.db";
+}
+
+
+#--
+# private subs
+
+
+#
+# my $was_running = _stop_user_mpd_if_needed()
+#
+# This sub will check if mpd is currently running. If it is, force it to
+# a full stop (unless MPD_TEST_OVERRIDE is not set).
+#
+# In any case, it will return a boolean stating whether mpd was running
+# before forcing stop.
+#
+sub _stop_user_mpd_if_needed {
+ # check if mpd is running.
+ my $is_running = grep { /mpd$/ } qx[ ps -e ];
+
+ return 0 unless $is_running; # mpd does not run - nothing to do.
+
+ # check force stop.
+ die "mpd is running\n" unless $ENV{MPD_TEST_OVERRIDE};
+ system( 'mpd --kill 2>/dev/null') == 0 or die "can't stop user mpd: $?\n";
+ sleep 1; # wait 1 second to free output device
+ return 1;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Audio::MPD::Test - automate launching of fake mdp for testing purposes
+
+
+=head1 SYNOPSIS
+
+ use Audio::MPD::Test; # die if error
+ [...]
+ stop_fake_mpd();
+
+
+=head1 DESCRIPTION
+
+=head2 General usage
+
+This module will try to launch a new mpd server for testing purposes. This
+mpd server will then be used during Audio::MPD tests.
+
+In order to achieve this, the module will create a fake mpd.conf file with
+the correct pathes (ie, where you untarred the module tarball). It will then
+check if some mpd server is already running, and stop it if the
+MPD_TEST_OVERRIDE environment variable is true (die otherwise). Last it will
+run the test mpd with its newly created configuration file.
+
+Everything described above is done automatically when the module is C<use>-d.
+
+
+Once the tests are run, the mpd server will be shut down, and the original
+one will be relaunched (if there was one).
+
+Note that the test mpd will listen to C<localhost>, so you are on the safe
+side. Note also that the test suite comes with its own ogg files - and yes,
+we can redistribute them since it's only some random voice recordings :-)
+
+
+=head2 Advanced usage
+
+In case you want more control on the test mpd server, you can use the
+following public methods:
+
+=over 4
+
+=item start_test_mpd()
+
+Start the fake mpd, and die if there were any error.
+
+=item stop_test_mpd()
+
+Kill the fake mpd.
+
+=item customize_test_mpd_configuration( [$port] )
+
+Create a fake mpd configuration file, based on the file mpd.conf.template
+located in t/mpd-test. The string PWD will be replaced by the real path -
+ie, where the tarball has been untarred. The string PORT will be replaced
+by $port if specified, 6600 otherwise (MPD default).
+
+=back
+
+This might be useful when trying to test connections with mpd server.
+
+
+=head1 SEE ALSO
+
+L<Audio::MPD>
+
+
+=head1 AUTHOR
+
+Jerome Quelin, C<< <jquelin at cpan.org> >>
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2007 Jerome Quelin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+=for gpg
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+- -----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+=head1 NAME
+
+Readonly - Facility for creating read-only scalars, arrays, hashes.
+
+=head1 VERSION
+
+This documentation describes version 1.03 of Readonly.pm, April 20, 2004.
+
+=cut
+
+# Rest of documentation is after __END__.
+
+use 5.005;
+use strict;
+#use warnings;
+#no warnings 'uninitialized';
+
+package Readonly;
+$Readonly::VERSION = '1.03'; # Also change in the documentation!
+
+# Autocroak (Thanks, MJD)
+# Only load Carp.pm if module is croaking.
+sub croak
+{
+ require Carp;
+ goto &Carp::croak;
+}
+
+# These functions may be overridden by Readonly::XS, if installed.
+sub is_sv_readonly ($) { 0 }
+sub make_sv_readonly ($) { die "make_sv_readonly called but not overridden" }
+use vars qw/$XSokay/; # Set to true in Readonly::XS, if available
+
+# Common error messages, or portions thereof
+use vars qw/$MODIFY $REASSIGN $ODDHASH/;
+$MODIFY = 'Modification of a read-only value attempted';
+$REASSIGN = 'Attempt to reassign a readonly';
+$ODDHASH = 'May not store an odd number of values in a hash';
+
+# See if we can use the XS stuff.
+$Readonly::XS::MAGIC_COOKIE = "Do NOT use or require Readonly::XS unless you're me.";
+eval 'use Readonly::XS';
+
+
+# ----------------
+# Read-only scalars
+# ----------------
+package Readonly::Scalar;
+
+sub TIESCALAR
+{
+ my $whence = (caller 2)[3]; # Check if naughty user is trying to tie directly.
+ Readonly::croak "Invalid tie" unless $whence && $whence =~ /^Readonly::(?:Scalar1?|Readonly)$/;
+ my $class = shift;
+ Readonly::croak "No value specified for readonly scalar" unless @_;
+ Readonly::croak "Too many values specified for readonly scalar" unless @_ == 1;
+
+ my $value = shift;
+ return bless \$value, $class;
+}
+
+sub FETCH
+{
+ my $self = shift;
+ return $$self;
+}
+
+*STORE = *UNTIE =
+ sub {Readonly::croak $Readonly::MODIFY};
+
+
+# ----------------
+# Read-only arrays
+# ----------------
+package Readonly::Array;
+
+sub TIEARRAY
+{
+ my $whence = (caller 1)[3]; # Check if naughty user is trying to tie directly.
+ Readonly::croak "Invalid tie" unless $whence =~ /^Readonly::Array1?$/;
+ my $class = shift;
+ my @self = @_;
+
+ return bless \@self, $class;
+}
+
+sub FETCH
+{
+ my $self = shift;
+ my $index = shift;
+ return $self->[$index];
+}
+
+sub FETCHSIZE
+{
+ my $self = shift;
+ return scalar @$self;
+}
+
+BEGIN {
+ eval q{
+ sub EXISTS
+ {
+ my $self = shift;
+ my $index = shift;
+ return exists $self->[$index];
+ }
+ } if $] >= 5.006; # couldn't do "exists" on arrays before then
+}
+
+*STORE = *STORESIZE = *EXTEND = *PUSH = *POP = *UNSHIFT = *SHIFT = *SPLICE = *CLEAR = *UNTIE =
+ sub {Readonly::croak $Readonly::MODIFY};
+
+
+# ----------------
+# Read-only hashes
+# ----------------
+package Readonly::Hash;
+
+sub TIEHASH
+{
+ my $whence = (caller 1)[3]; # Check if naughty user is trying to tie directly.
+ Readonly::croak "Invalid tie" unless $whence =~ /^Readonly::Hash1?$/;
+
+ my $class = shift;
+ # must have an even number of values
+ Readonly::croak $Readonly::ODDHASH unless (@_ %2 == 0);
+
+ my %self = @_;
+ return bless \%self, $class;
+}
+
+sub FETCH
+{
+ my $self = shift;
+ my $key = shift;
+
+ return $self->{$key};
+}
+
+sub EXISTS
+{
+ my $self = shift;
+ my $key = shift;
+ return exists $self->{$key};
+}
+
+sub FIRSTKEY
+{
+ my $self = shift;
+ my $dummy = keys %$self;
+ return scalar each %$self;
+}
+
+sub NEXTKEY
+{
+ my $self = shift;
+ return scalar each %$self;
+}
+
+*STORE = *DELETE = *CLEAR = *UNTIE =
+ sub {Readonly::croak $Readonly::MODIFY};
+
+
+# ----------------------------------------------------------------
+# Main package, containing convenience functions (so callers won't
+# have to explicitly tie the variables themselves).
+# ----------------------------------------------------------------
+package Readonly;
+use Exporter;
+use vars qw/@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/;
+push @ISA, 'Exporter';
+push @EXPORT, qw/Readonly/;
+push @EXPORT_OK, qw/Scalar Array Hash Scalar1 Array1 Hash1/;
+
+# Predeclare the following, so we can use them recursively
+sub Scalar ($$);
+sub Array (\@;@);
+sub Hash (\%;@);
+
+# Returns true if a string begins with "Readonly::"
+# Used to prevent reassignment of Readonly variables.
+sub _is_badtype
+{
+ my $type = $_[0];
+ return lc $type if $type =~ s/^Readonly:://;
+ return;
+}
+
+# Shallow Readonly scalar
+sub Scalar1 ($$)
+{
+ croak "$REASSIGN scalar" if is_sv_readonly $_[0];
+ my $badtype = _is_badtype (ref tied $_[0]);
+ croak "$REASSIGN $badtype" if $badtype;
+
+ # xs method: flag scalar as readonly
+ if ($XSokay)
+ {
+ $_[0] = $_[1];
+ make_sv_readonly $_[0];
+ return;
+ }
+
+ # pure-perl method: tied scalar
+ my $tieobj = eval {tie $_[0], 'Readonly::Scalar', $_[1]};
+ if ($@)
+ {
+ croak "$REASSIGN scalar" if substr($@,0,43) eq $MODIFY;
+ die $@; # some other error?
+ }
+ return $tieobj;
+}
+
+# Shallow Readonly array
+sub Array1 (\@;@)
+{
+ my $badtype = _is_badtype (ref tied $_[0]);
+ croak "$REASSIGN $badtype" if $badtype;
+
+ my $aref = shift;
+ return tie @$aref, 'Readonly::Array', @_;
+}
+
+# Shallow Readonly hash
+sub Hash1 (\%;@)
+{
+ my $badtype = _is_badtype (ref tied $_[0]);
+ croak "$REASSIGN $badtype" if $badtype;
+
+ my $href = shift;
+
+ # If only one value, and it's a hashref, expand it
+ if (@_ == 1 && ref $_[0] eq 'HASH')
+ {
+ return tie %$href, 'Readonly::Hash', %{$_[0]};
+ }
+
+ # otherwise, must have an even number of values
+ croak $ODDHASH unless (@_%2 == 0);
+
+ return tie %$href, 'Readonly::Hash', @_;
+}
+
+# Deep Readonly scalar
+sub Scalar ($$)
+{
+ croak "$REASSIGN scalar" if is_sv_readonly $_[0];
+ my $badtype = _is_badtype (ref tied $_[0]);
+ croak "$REASSIGN $badtype" if $badtype;
+
+ my $value = $_[1];
+
+ # Recursively check passed element for references; if any, make them Readonly
+ foreach ($value)
+ {
+ if (ref eq 'SCALAR') {Scalar my $v => $$_; $_ = \$v}
+ elsif (ref eq 'ARRAY') {Array my @v => @$_; $_ = \@v}
+ elsif (ref eq 'HASH') {Hash my %v => $_; $_ = \%v}
+ }
+
+ # xs method: flag scalar as readonly
+ if ($XSokay)
+ {
+ $_[0] = $value;
+ make_sv_readonly $_[0];
+ return;
+ }
+
+ # pure-perl method: tied scalar
+ my $tieobj = eval {tie $_[0], 'Readonly::Scalar', $value};
+ if ($@)
+ {
+ croak "$REASSIGN scalar" if substr($@,0,43) eq $MODIFY;
+ die $@; # some other error?
+ }
+ return $tieobj;
+}
+
+# Deep Readonly array
+sub Array (\@;@)
+{
+ my $badtype = _is_badtype (ref tied @{$_[0]});
+ croak "$REASSIGN $badtype" if $badtype;
+
+ my $aref = shift;
+ my @values = @_;
+
+ # Recursively check passed elements for references; if any, make them Readonly
+ foreach (@values)
+ {
+ if (ref eq 'SCALAR') {Scalar my $v => $$_; $_ = \$v}
+ elsif (ref eq 'ARRAY') {Array my @v => @$_; $_ = \@v}
+ elsif (ref eq 'HASH') {Hash my %v => $_; $_ = \%v}
+ }
+ # Lastly, tie the passed reference
+ return tie @$aref, 'Readonly::Array', @values;
+}
+
+# Deep Readonly hash
+sub Hash (\%;@)
+{
+ my $badtype = _is_badtype (ref tied %{$_[0]});
+ croak "$REASSIGN $badtype" if $badtype;
+
+ my $href = shift;
+ my @values = @_;
+
+ # If only one value, and it's a hashref, expand it
+ if (@_ == 1 && ref $_[0] eq 'HASH')
+ {
+ @values = %{$_[0]};
+ }
+
+ # otherwise, must have an even number of values
+ croak $ODDHASH unless (@values %2 == 0);
+
+ # Recursively check passed elements for references; if any, make them Readonly
+ foreach (@values)
+ {
+ if (ref eq 'SCALAR') {Scalar my $v => $$_; $_ = \$v}
+ elsif (ref eq 'ARRAY') {Array my @v => @$_; $_ = \@v}
+ elsif (ref eq 'HASH') {Hash my %v => $_; $_ = \%v}
+ }
+
+ return tie %$href, 'Readonly::Hash', @values;
+}
+
+
+# Common entry-point for all supported data types
+eval q{sub Readonly} . ( $] < 5.008 ? '' : '(\[$@%]@)' ) . <<'SUB_READONLY';
+{
+ if (ref $_[0] eq 'SCALAR')
+ {
+ croak $MODIFY if is_sv_readonly ${$_[0]};
+ my $badtype = _is_badtype (ref tied ${$_[0]});
+ croak "$REASSIGN $badtype" if $badtype;
+ croak "Readonly scalar must have only one value" if @_ > 2;
+
+ my $tieobj = eval {tie ${$_[0]}, 'Readonly::Scalar', $_[1]};
+ # Tie may have failed because user tried to tie a constant, or we screwed up somehow.
+ if ($@)
+ {
+ croak $MODIFY if $@ =~ /^$MODIFY at/; # Point the finger at the user.
+ die "$@\n"; # Not a modify read-only message; must be our fault.
+ }
+ return $tieobj;
+ }
+ elsif (ref $_[0] eq 'ARRAY')
+ {
+ my $aref = shift;
+ return Array @$aref, @_;
+ }
+ elsif (ref $_[0] eq 'HASH')
+ {
+ my $href = shift;
+ croak $ODDHASH if @_%2 != 0 && !(@_ == 1 && ref $_[0] eq 'HASH');
+ return Hash %$href, @_;
+ }
+ elsif (ref $_[0])
+ {
+ croak "Readonly only supports scalar, array, and hash variables.";
+ }
+ else
+ {
+ croak "First argument to Readonly must be a reference.";
+ }
+}
+SUB_READONLY
+
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use Readonly;
+
+ # Read-only scalar
+ Readonly::Scalar $sca => $initial_value;
+ Readonly::Scalar my $sca => $initial_value;
+
+ # Read-only array
+ Readonly::Array @arr => @values;
+ Readonly::Array my @arr => @values;
+
+ # Read-only hash
+ Readonly::Hash %has => (key => value, key => value, ...);
+ Readonly::Hash my %has => (key => value, key => value, ...);
+ # or:
+ Readonly::Hash %has => {key => value, key => value, ...};
+
+ # You can use the read-only variables like any regular variables:
+ print $sca;
+ $something = $sca + $arr[2];
+ next if $has{$some_key};
+
+ # But if you try to modify a value, your program will die:
+ $sca = 7;
+ push @arr, 'seven';
+ delete $has{key};
+ # The error message is "Modification of a read-only value
+attempted"
+
+ # Alternate form (Perl 5.8 and later)
+ Readonly $sca => $initial_value;
+ Readonly my $sca => $initial_value;
+ Readonly @arr => @values;
+ Readonly my @arr => @values;
+ Readonly %has => (key => value, key => value, ...);
+ Readonly my %has => (key => value, key => value, ...);
+ # Alternate form (for Perls earlier than v5.8)
+ Readonly \$sca => $initial_value;
+ Readonly \my $sca => $initial_value;
+ Readonly \@arr => @values;
+ Readonly \my @arr => @values;
+ Readonly \%has => (key => value, key => value, ...);
+ Readonly \my %has => (key => value, key => value, ...);
+
+
+=head1 DESCRIPTION
+
+This is a facility for creating non-modifiable variables. This is
+useful for configuration files, headers, etc. It can also be useful
+as a development and debugging tool, for catching updates to variables
+that should not be changed.
+
+If any of the values you pass to C<Scalar>, C<Array>, or C<Hash> are
+references, then those functions recurse over the data structures,
+marking everything as Readonly. Usually, this is what you want: the
+entire structure nonmodifiable. If you want only the top level to be
+Readonly, use the alternate C<Scalar1>, C<Array1> and C<Hash1>
+functions.
+
+Please note that most users of Readonly will also want to install a
+companion module Readonly::XS. See the L</CONS> section below for more
+details.
+
+=head1 COMPARISON WITH "use constant"
+
+Perl provides a facility for creating constant values, via the "use
+constant" pragma. There are several problems with this pragma.
+
+=over 2
+
+=item *
+
+The constants created have no leading $ or @ character.
+
+=item *
+
+These constants cannot be interpolated into strings.
+
+=item *
+
+Syntax can get dicey sometimes. For example:
+
+ use constant CARRAY => (2, 3, 5, 7, 11, 13);
+ $a_prime = CARRAY[2]; # wrong!
+ $a_prime = (CARRAY)[2]; # right -- MUST use parentheses
+
+=item *
+
+You have to be very careful in places where barewords are allowed.
+For example:
+
+ use constant SOME_KEY => 'key';
+ %hash = (key => 'value', other_key => 'other_value');
+ $some_value = $hash{SOME_KEY}; # wrong!
+ $some_value = $hash{+SOME_KEY}; # right
+
+(who thinks to use a unary plus when using a hash?)
+
+=item *
+
+C<use constant> works for scalars and arrays, not hashes.
+
+=item *
+
+These constants are global ot the package in which they're declared;
+cannot be lexically scoped.
+
+=item *
+
+Works only at compile time.
+
+=item *
+
+Can be overridden:
+
+ use constant PI => 3.14159;
+ ...
+ use constant PI => 2.71828;
+
+(this does generate a warning, however, if you have warnings enabled).
+
+=item *
+
+It is very difficult to make and use deep structures (complex data
+structures) with C<use constant>.
+
+=back
+
+=head1 COMPARISON WITH TYPEGLOB CONSTANTS
+
+Another popular way to create read-only scalars is to modify the symbol
+table entry for the variable by using a typeglob:
+
+ *a = \'value';
+
+This works fine, but it only works for global variables ("my"
+variables have no symbol table entry). Also, the following similar
+constructs do B<not> work:
+
+ *a = [1, 2, 3]; # Does NOT create a read-only array
+ *a = { a => 'A'}; # Does NOT create a read-only hash
+
+=head1 PROS
+
+Readonly.pm, on the other hand, will work with global variables and
+with lexical ("my") variables. It will create scalars, arrays, or
+hashes, all of which look and work like normal, read-write Perl
+variables. You can use them in scalar context, in list context; you
+can take references to them, pass them to functions, anything.
+
+Readonly.pm also works well with complex data structures, allowing you
+to tag the whole structure as nonmodifiable, or just the top level.
+
+Also, Readonly variables may not be reassigned. The following code
+will die:
+
+ Readonly::Scalar $pi => 3.14159;
+ ...
+ Readonly::Scalar $pi => 2.71828;
+
+=head1 CONS
+
+Readonly.pm does impose a performance penalty. It's pretty slow. How
+slow? Run the C<benchmark.pl> script that comes with Readonly. On my
+test system, "use constant", typeglob constants, and regular
+read/write Perl variables were all about the same speed, and
+Readonly.pm constants were about 1/20 the speed.
+
+However, there is relief. There is a companion module available,
+Readonly::XS. If it is installed on your system, Readonly.pm uses it
+to make read-only scalars much faster. With Readonly::XS, Readonly
+scalars are as fast as the other types of variables. Readonly arrays
+and hashes will still be relatively slow. But it's likely that most
+of your Readonly variables will be scalars.
+
+If you can't use Readonly::XS (for example, if you don't have a C
+compiler, or your perl is statically linked and you don't want to
+re-link it), you have to decide whether the benefits of Readonly
+variables outweigh the speed issue. For most configuration variables
+(and other things that Readonly is likely to be useful for), the speed
+issue is probably not really a big problem. But benchmark your
+program if it might be. If it turns out to be a problem, you may
+still want to use Readonly.pm during development, to catch changes to
+variables that should not be changed, and then remove it for
+production:
+
+ # For testing:
+ Readonly::Scalar $Foo_Directory => '/usr/local/foo';
+ Readonly::Scalar $Bar_Directory => '/usr/local/bar';
+ # $Foo_Directory = '/usr/local/foo';
+ # $Bar_Directory = '/usr/local/bar';
+
+ # For production:
+ # Readonly::Scalar $Foo_Directory => '/usr/local/foo';
+ # Readonly::Scalar $Bar_Directory => '/usr/local/bar';
+ $Foo_Directory = '/usr/local/foo';
+ $Bar_Directory = '/usr/local/bar';
+
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item Readonly::Scalar $var => $value;
+
+Creates a nonmodifiable scalar, C<$var>, and assigns a value of
+C<$value> to it. Thereafter, its value may not be changed. Any
+attempt to modify the value will cause your program to die.
+
+A value I<must> be supplied. If you want the variable to have
+C<undef> as its value, you must specify C<undef>.
+
+If C<$value> is a reference to a scalar, array, or hash, then this
+function will mark the scalar, array, or hash it points to as being
+Readonly as well, and it will recursively traverse the structure,
+marking the whole thing as Readonly. Usually, this is what you want.
+However, if you want only the C<$value> marked as Readonly, use
+C<Scalar1>.
+
+If $var is already a Readonly variable, the program will die with
+an error about reassigning Readonly variables.
+
+=item Readonly::Array @arr => (value, value, ...);
+
+Creates a nonmodifiable array, C<@arr>, and assigns the specified list
+of values to it. Thereafter, none of its values may be changed; the
+array may not be lengthened or shortened or spliced. Any attempt to
+do so will cause your program to die.
+
+If any of the values passed is a reference to a scalar, array, or hash,
+then this function will mark the scalar, array, or hash it points to as
+being Readonly as well, and it will recursively traverse the structure,
+marking the whole thing as Readonly. Usually, this is what you want.
+However, if you want only the hash C<%@arr> itself marked as Readonly,
+use C<Array1>.
+
+If @arr is already a Readonly variable, the program will die with
+an error about reassigning Readonly variables.
+
+=item Readonly::Hash %h => (key => value, key => value, ...);
+
+=item Readonly::Hash %h => {key => value, key => value, ...};
+
+Creates a nonmodifiable hash, C<%h>, and assigns the specified keys
+and values to it. Thereafter, its keys or values may not be changed.
+Any attempt to do so will cause your program to die.
+
+A list of keys and values may be specified (with parentheses in the
+synopsis above), or a hash reference may be specified (curly braces in
+the synopsis above). If a list is specified, it must have an even
+number of elements, or the function will die.
+
+If any of the values is a reference to a scalar, array, or hash, then
+this function will mark the scalar, array, or hash it points to as
+being Readonly as well, and it will recursively traverse the
+structure, marking the whole thing as Readonly. Usually, this is what
+you want. However, if you want only the hash C<%h> itself marked as
+Readonly, use C<Hash1>.
+
+If %h is already a Readonly variable, the program will die with
+an error about reassigning Readonly variables.
+
+=item Readonly $var => $value;
+
+=item Readonly @arr => (value, value, ...);
+
+=item Readonly %h => (key => value, ...);
+
+=item Readonly %h => {key => value, ...};
+
+The C<Readonly> function is an alternate to the C<Scalar>, C<Array>,
+and C<Hash> functions. It has the advantage (if you consider it an
+advantage) of being one function. That may make your program look
+neater, if you're initializing a whole bunch of constants at once.
+You may or may not prefer this uniform style.
+
+It has the disadvantage of having a slightly different syntax for
+versions of Perl prior to 5.8. For earlier versions, you must supply
+a backslash, because it requires a reference as the first parameter.
+
+ Readonly \$var => $value;
+ Readonly \@arr => (value, value, ...);
+ Readonly \%h => (key => value, ...);
+ Readonly \%h => {key => value, ...};
+
+You may or may not consider this ugly.
+
+=item Readonly::Scalar1 $var => $value;
+
+=item Readonly::Array1 @arr => (value, value, ...);
+
+=item Readonly::Hash1 %h => (key => value, key => value, ...);
+
+=item Readonly::Hash1 %h => {key => value, key => value, ...};
+
+These alternate functions create shallow Readonly variables, instead
+of deep ones. For example:
+
+ Readonly::Array1 @shal => (1, 2, {perl=>'Rules', java=>'Bites'}, 4, 5);
+ Readonly::Array @deep => (1, 2, {perl=>'Rules', java=>'Bites'}, 4, 5);
+
+ $shal[1] = 7; # error
+ $shal[2]{APL}='Weird'; # Allowed! since the hash isn't Readonly
+ $deep[1] = 7; # error
+ $deep[2]{APL}='Weird'; # error, since the hash is Readonly
+
+
+=back
+
+
+=head1 EXAMPLES
+
+ # SCALARS:
+
+ # A plain old read-only value
+ Readonly::Scalar $a => "A string value";
+
+ # The value need not be a compile-time constant:
+ Readonly::Scalar $a => $computed_value;
+
+
+ # ARRAYS:
+
+ # A read-only array:
+ Readonly::Array @a => (1, 2, 3, 4);
+
+ # The parentheses are optional:
+ Readonly::Array @a => 1, 2, 3, 4;
+
+ # You can use Perl's built-in array quoting syntax:
+ Readonly::Array @a => qw/1 2 3 4/;
+
+ # You can initialize a read-only array from a variable one:
+ Readonly::Array @a => @computed_values;
+
+ # A read-only array can be empty, too:
+ Readonly::Array @a => ();
+ Readonly::Array @a; # equivalent
+
+
+ # HASHES
+
+ # Typical usage:
+ Readonly::Hash %a => (key1 => 'value1', key2 => 'value2');
+
+ # A read-only hash can be initialized from a variable one:
+ Readonly::Hash %a => %computed_values;
+
+ # A read-only hash can be empty:
+ Readonly::Hash %a => ();
+ Readonly::Hash %a; # equivalent
+
+ # If you pass an odd number of values, the program will die:
+ Readonly::Hash %a => (key1 => 'value1', "value2");
+ --> dies with "May not store an odd number of values in a hash"
+
+
+=head1 EXPORTS
+
+By default, this module exports the following symbol into the calling
+program's namespace:
+
+ Readonly
+
+The following symbols are available for import into your program, if
+you like:
+
+ Scalar Scalar1
+ Array Array1
+ Hash Hash1
+
+
+=head1 REQUIREMENTS
+
+ Perl 5.000
+ Carp.pm (included with Perl)
+ Exporter.pm (included with Perl)
+
+ Readonly::XS is recommended but not required.
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to Slaven Rezic for the idea of one common function
+(Readonly) for all three types of variables (13 April 2002).
+
+Thanks to Ernest Lergon for the idea (and initial code) for
+deeply-Readonly data structures (21 May 2002).
+
+Thanks to Damian Conway for the idea (and code) for making the
+Readonly function work a lot smoother under perl 5.8+.
+
+
+=head1 AUTHOR / COPYRIGHT
+
+Eric J. Roode, roode@cpan.org
+
+Copyright (c) 2001-2004 by Eric J. Roode. All Rights Reserved. This
+module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+If you have suggestions for improvement, please drop me a line. If
+you make improvements to this software, I ask that you please send me
+a copy of your changes. Thanks.
+
+Readonly.pm is made from 100% recycled electrons. No animals were
+harmed during the development and testing of this module. Not sold
+in stores! Readonly::XS sold separately. Void where prohibited.
+
+=cut
+
+=begin gpg
+
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.2.4 (MingW32)
+
+iD8DBQFAhaGCY96i4h5M0egRAg++AJ0ar4ncojbOp0OOc2wo+E/1cBn5cQCg9eP9
+qTzAC87PuyKB+vrcRykrDbo=
+=39Ny
+-----END PGP SIGNATURE-----
+
+=cut
\ No newline at end of file
projects / ipfire-2.x.git / commitdiff
