File Coverage

blib/lib/MP3/Icecast.pm

Criterion	Covered	Total	%
statement	56	200	28.0
branch	12	78	15.3
condition	3	46	6.5
subroutine	13	27	48.1
pod	15	15	100.0
total	99	366	27.0

package MP3::Icecast;

=head1 NAME

MP3::Icecast - Generate Icecast streams, as well as M3U and PLSv2 playlists.

=head1 SYNOPSIS

  use MP3::Icecast;
  use MP3::Info;
  use IO::Socket;


  my $listen_socket = IO::Socket::INET->new(
    LocalPort => 8000, #standard Icecast port
    Listen    => 20,
    Proto     => 'tcp',
    Reuse     => 1,
    Timeout   => 3600);

  #create an instance to find all files below /usr/local/mp3
  my $finder = MP3::Icecast->new();
  $finder->recursive(1);
  $finder->add_directory('/usr/local/mp3');
  my @files = $finder->files;

  #accept TCP 8000 connections
  while(1){
    next unless my $connection = $listen_socket->accept;

    defined(my $child = fork()) or die "Can't fork: $!";
    if($child == 0){
      $listen_socket->close;

      my $icy = MP3::Icecast->new;

      #stream files that have an ID3 genre tag of "jazz"
      while(@files){
        my $file = shift @files;
        my $info = new MP3::Info $file;
        next unless $info;
        next unless $info->genre =~ /jazz/i;
        $icy->stream($file,0,$connection);
      }
      exit 0;
    }

    #a contrived example to demonstrate that MP3::Icecast
    #can generate M3U and PLSv2 media playlists.
    print STDERR $icy->m3u, "\n";
    print STDERR $icy->pls, "\n";

    $connection->close;
  }


=head1 ABSTRACT

MP3::Icecast supports streaming Icecast protocol over socket
or other filehandle (including STDIN).  This is useful for writing
a streaming media server.

MP3::Icecast also includes support for generating M3U and PLSv2
playlist files.  These are common formats supported by most modern
media players, including XMMS, Windows Media Player 9, and Winamp.

=head1 SEE ALSO

  The Icecast project
  http://www.icecast.org

  Namp! (Apache::MP3)
  http://namp.sourceforge.net

  Unofficial M3U and PLS specifications
  http://forums.winamp.com/showthread.php?threadid=65772

=head1 AUTHOR

 Allen Day, [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright 2003, Allen Day

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

use strict;
use File::Spec;
use File::Basename 'dirname','basename','fileparse';
use URI::Escape;
use IO::File;
use MP3::Info;

use constant DEBUG => 0;

our $VERSION = '0.02';

our %AUDIO = (
               '.mp3' => 'audio/x-mp3',
             );
our %FORMAT_FIELDS = (
                      a => 'artist',
                      c => 'comment',
                      d => 'duration',
                      f => 'filename',
                      g => 'genre',
                      l => 'album',
                      m => 'min',
		              n => 'track',
                      q => 'samplerate',
		              r => 'bitrate',
		              s => 'sec',
		              S => 'seconds',
		              t => 'title',
		              y => 'year',
		                );


our $CRLF = "\015\012";

=head2 new

 Title   : new
 Usage   : $icy = MP3::Icecast->new(%arg);
 Function: create a new MP3::Icecast instance
 Returns : an MP3::Icecast object
 Args    : none


=cut

sub new{
  my($class,%arg) = @_;

  my $self = bless {}, $class;

  return $self;
}

=head2 add_directory

 Title   : add_directory
 Usage   : $icy->add_directory('/usr/local/mp3');
 Function: add a directory of files to be added to the playlist
 Returns : true on success, false on failure
 Args    : a system path


=cut

sub add_directory{
   my ($self,$dir) = @_;
   warn "adding directory $dir" if DEBUG;
   if(!-d $dir or !-r $dir){
     return undef;
   } else {
     $self->_process_directory($dir);
     return 1;
   }
}

=head2 _process_directory

 Title   : _process_directory
 Usage   : $icy->_process_directory('/usr/local/mp3');
 Function: searches a directory for files to add to the playlist
 Returns : true on success
 Args    : a system path to search for files


=cut

sub _process_directory{
   my ($self,$dir) = @_;

   if(!-r $dir){
     return undef;
   } else {
     warn "processing directory: $dir" if DEBUG;

     opendir(my $d, $dir) or die "couldn't opendir($dir): $!";
     my @dirents = grep {$_ ne '.' and $_ ne '..'} readdir($d);
     closedir($d) or die "couldn't closedir($dir): $!";

     foreach my $dirent (@dirents){
       warn "found dirent: $dirent" if DEBUG;

       next if !-r File::Spec->catfile($dir,$dirent);
       if(-d File::Spec->catfile($dir,$dirent)){
         next unless $self->recursive;
         $self->_process_directory(File::Spec->catdir($dir,$dirent));
       } else {
         $self->add_file(File::Spec->catfile($dir,$dirent));
       }
     }
   }

   return 1;
}


=head2 add_file

 Title   : add_file
 Usage   : $icy->add_file('/usr/local/mp3/meow.mp3')
 Function: add a file to be added to the playlist
 Returns : true on success, false on failure
 Args    : a system path


=cut

sub add_file{
   my ($self,$file) = @_;

   my(undef,undef,$extension) = fileparse($file,keys(%AUDIO));
   warn "adding file $file" if DEBUG;
   warn $extension if DEBUG;

   if(!-f $file or !-r $file){
     warn "not a readable file: $file" if DEBUG;
     return undef;
   } elsif($AUDIO{lc($extension)}) {
     warn "adding $file" if DEBUG;
     push @{$self->{files}}, $file;
   } else {
     warn "not a usable mimetype: $file" if DEBUG;
     return undef;
   }

   return 1;
}

=head2 files

 Title   : files
 Usage   : @files = $icy->files
 Function: returns a list of all files that have been added
           from calls to add_file() and add_directory()
 Returns : a list of files
 Args    : none


=cut

sub files{
  my $self = shift;

  if(defined($self->{files})){
    if($self->shuffle){
      for (my $i=0; $i<@{$self->{files}}; $i++) {
        my $rand = rand(scalar @{$self->{files}});

        #swap;
        ($self->{files}->[$i],$self->{files}->[$rand])
          =
        ($self->{files}->[$rand],$self->{files}->[$i]);
      }
    }

    return @{$self->{files}};

  } else {
    return ();
  }

}

=head2 clear_files

 Title   : clear_files
 Usage   :
 Function:
 Example :
 Returns :
 Args    :


=cut

sub clear_files{
   my ($self) = @_;
   $self->{files} = undef;
   return 1;
}

=head2 m3u

 Title   : m3u
 Usage   : $m3u_text = $icy->m3u
 Function: generates an Extended M3U string from the
           contents of the list returned by files().
           files not recognized by MP3::Info are
           silently ignored
 Returns : a Extended M3U string
 Args    : none


=cut

sub m3u{
   my $self = shift;

   my $output = undef;


   # The extended format is:
   #	#EXTM3U
   #	#EXTINF:seconds,title - artist (album)
   #	URL
   # but apparently you can override with this
   #	#EXTART:Britney Spears
   #	#EXTALB:Oops!.. I Did It Again
   #	#EXTTIT:Something or other
   # and there doesn't seem to be a way to escape the -, so that's safer
   # in theory, but if you send both it seems to ignore all but the EXTINF
   # and there's no way to send seconds without it anyway, so we'll just do
   # that.
   #
   # .... except that the second format breaks older versions of winamp
   # so we'll use EXTINF only!

   $output .= "#EXTM3U$CRLF" if $self->files;
   foreach my $file ($self->files){
     my $info = $self->_get_info($file);

     next unless defined($info);
     $file = $self->_mangle_path($file);

     my $time   = $info->secs   || -1;
     my $artist = $info->artist || 'Unknown Artist';
     my $album  = $info->album  || 'Unknown Album';
     my $title  = $info->title  || 'Unknown Title';

     $output .= sprintf("#EXTINF:%d,%s - %s (%s)",$time,$title,$artist,$album) . $CRLF;
     $output .= $file . $CRLF;
   }

   return $output;
}

=head2 pls

 Title   : pls
 Usage   : $pls_text = $icy->pls
 Function: generates a PLSv2 string from the
           contents of the list returned by files().
           files not recognized by MP3::Info are
           silently ignored.
 Returns : a PLSv2 string
 Args    : none


=cut

sub pls{
   my $self = shift;

   my $output = undef;

   $output .= "[playlist]$CRLF" if $self->files;
   my $c = 0;
   foreach my $file ($self->files){
     my $info = $self->_get_info($file);

     next unless defined($info);

     $c++;

     $file = $self->_mangle_path($file);

     my $time   = $info->secs   || -1;
     my $artist = $info->artist || 'Unknown Artist';
     my $album  = $info->album  || 'Unknown Album';
     my $title  = $info->title  || 'Unknown Title';

     $output .= uri_escape(sprintf("File%d=%s${CRLF}Title%d=%s - %s (%s)${CRLF}Length%d=%d$CRLF",$c,$file,$c,$title,$artist,$album,$c,$time));
   }

   $output .= "NumberOfEntries=$c$CRLF" if $self->files;
   $output .= "Version=2$CRLF"          if $self->files;

   return $output;
}

=head2 stream

 Title   : streamll: 1 at /raid5a/allenday/projects/MP3/Icecast.pm line 459.

 Usage   : $icy->stream('/usr/local/mp3/meow.mp3',0);
           $icy->stream('/usr/local/mp3/meow.mp3',0,$io_handle);
 Function: stream an audio file.  prints to STDOUT unless a
           third argument is given, in which case ->print() is
           called on the second argument.  An IO::Handle or
           Apache instance will work here.
 Returns : true on success, false on failure
 Args    : 1) system path to the file to stream
           2) offset in file to start streaming
           3) (optional) object to call ->print() on, rather
              than printing to STDOUT


=cut

sub stream{
   my ($self,$file,$offset,$handle) = @_;

   return undef unless -f $file;
   my $info = $self->_get_info($file);
   return undef unless defined($info);

   my $genre = $info->genre                    || 'unknown genre';
   my $description = $self->description($file) || 'unknown';
   my $bitrate = $info->bitrate                || 0;
   my $size = -s $file                         || 0;
   my $mime = $AUDIO{ lc((fileparse($file,keys(%AUDIO)))[2]) };
   my $path = $self->_mangle_path($file);

   my $fh = $self->_open_file($file) || die "couldn't open file $file: $!";
   binmode($fh);
   seek($fh,$offset,0);

   my $output = '';
   $output .= "ICY ". ($offset ? 206 : 200) ." OK$CRLF";
   $output .= "icy-notice1:This stream requires a shoutcast/icecast compatible player.$CRLF";
   $output .= "icy-notice2:MP3::Icecast$CRLF";
   $output .= "icy-name:$description$CRLF";
   $output .= "icy-genre:$genre$CRLF";
   $output .= "icy-url: $path$CRLF";
   $output .= "icy-pub:1$CRLF";
   $output .= "icy-br:$bitrate$CRLF";
   $output .= "Accept-Ranges: bytes$CRLF";
   if($offset){ $output .= "Content-Range: bytes $offset-" . ($size-1) . "/$size$CRLF" }
   $output .= "Content-Length: $size$CRLF";
   $output .= "Content-Type: $mime$CRLF";
   $output .= "$CRLF";

   if(!ref($handle)){
     print $output;
   } elsif($handle->can('print')) {
     $handle->print($output);
   } else {
     return undef;
   }

   my $bytes = $size;
   while($bytes > 0){
     my $data;
     my $b = read($fh,$data,2048) || last;
     $bytes -= $b;

     if(!ref($handle)){
       print $data;
     } else {
       $handle->print($data);
     }
   }

   return 1;
}

=head2 _open_file

 Title   : _open_file
 Usage   : $fh = $icy->open_file('/usr/local/mp3/meow.mp3');
 Function:
 Example :
 Returns :
 Args    :


=cut

sub _open_file{
  my ($self,$file) = @_;

  return undef unless $file;
  return IO::File->new($file,O_RDONLY);
}

=head2 _mangle_path

 Title   : _mangle_path
 Usage   : $path = $icy->_mangle_path('/usr/local/mp3/meow.mp3');
 Function: applies alias substitutions and prefixes to a system path.
           this is intended to be used to create resolvable URLs.
 Returns : a string
 Args    : a system path


=cut

sub _mangle_path{
   my ($self,$path) = @_;

   my $qpath = quotemeta($path);

   foreach my $alias ($self->alias){
     warn "replacing $alias..." if DEBUG;
     my $search = $alias;

     my $qalias = quotemeta($alias);

     next unless $path =~ /^$qalias/;

     my $replace = $self->alias($alias);
     $path =~ s/^$qalias/$replace/;
     last;
   }
   $self->_uri_path_escape(\$path);
   $path = join '', ($self->prefix ||'', $path ||'', $self->postfix ||'');
   return $path;
}

=head2 _path_escape

 Title   : _path_escape
 Usage   :
 Function:
 Example :
 Returns :
 Args    :


=cut

sub _uri_path_escape{
   my ($self,$uri) = @_;

   $$uri =~ s!([^a-zA-Z0-9_/.-])!uc sprintf("%%%02x",ord($1))!eg;
}


=head2 _get_info

 Title   : _get_info
 Usage   : $mp3_info = $icy->_get_info($file)
 Function: constucts and returns an MP3::Info object.  the intended
           use here is to access MP3 metadata (from ID3 tags,
           filesize, etc).
 Returns : a new MP3::Info object on success, false on failure
 Args    : a system path to a file


=cut

sub _get_info{
   my ($self,$file) = @_;

   return undef unless $file;
   return new MP3::Info $file;
}


=head2 alias

 Title   : alias
 Usage   : #returns 1
           $icy->alias('/home/allenday/mp3' => '/mp3');

           #returns '/mp3'
           $icy->alias('/home/allenday/mp3');

           #returns 1
           $icy->alias('/usr/local/share/mp3' => '/share/mp3'); #returns 1

           #returns qw(/mp3 /share/mp3)
           $icy->alias();
 Function: this method provides similar behavior to Apache's Alias directive.
           it allows mapping of system paths to virtual paths for usage by,
           for instance, a webserver.  the mapping is simple: when examining
           a file, MP3::Icecast tries to match the beginning of the file's
           full path to a sorted list of aliases.  the first alias to match
           is accepted.  this may cause unexpected behavior in the event that
           a file's path matches multiple alias entries.  patches welcome.
 Returns : see Usage
 Args    : see Usage


=cut

sub alias{
   my ($self,$search,$replace) = @_;

   if(defined($search) and defined($replace)){
     $self->{alias}{$search} = $replace;
   } elsif(defined($search)) {
     return $self->{alias}{$search};
   } else {
     return sort keys %{$self->{alias}};
   }
}

=head2 prefix

 Title   : prefix
 Usage   : $icy->prefix('http://');
 Function: prefix all entries in the playlist with this value.
           this string is *not* uri or system path escaped.
 Returns : value of prefix (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub prefix{
    my $self = shift;

    return $self->{'prefix'} = shift if @_;
    return $self->{'prefix'};
}

=head2 postfix

 Title   : postfix
 Usage   : $obj->postfix($newval)
 Function: postfix all entries in the playlist with this value.
           this string is *not* uri or system path escaped.
           uri escaped.
 Returns : value of postfix (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub postfix{
    my $self = shift;

    return $self->{'postfix'} = shift if @_;
    return $self->{'postfix'};
}

=head2 recursive

 Title   : recursive
 Usage   : $obj->recursive($newval)
 Function: flag determining whether a directory is recursively
           searched for files when passed to ::add_directory().
           default is false (no recursion).
 Example :
 Returns : value of recursive (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub recursive{
    my $self = shift;

    return $self->{'recursive'} = shift if @_;
    return $self->{'recursive'};
}

=head2 shuffle

 Title   : shuffle
 Usage   : $obj->shuffle($newval)
 Function:
 Example :
 Returns : value of shuffle (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub shuffle{
    my $self = shift;

    return $self->{'shuffle'} = shift if @_;
    return $self->{'shuffle'};
}

=head2 description

 Title   : description
 Usage   : $description = $icy->description('/usr/local/mp3/meow.mp3');
 Function: returns a description string of an MP3.  this is extracted
           from the ID3 tags by MP3::Info.  the description format can
           be customized, see the description_format() method.
 Returns : a description string
 Args    : a valid system path


=cut

sub description{
  my $self = shift;
  my $file = shift;
  my $data = new MP3::Info $file;
  my $description;
  my $format = $self->description_format;
  if ($format) {
    ($description = $format) =~ s{%([atfglncrdmsqS%])}
      {$1 eq '%' ? '%'
	 : $data->{$FORMAT_FIELDS{$1}}
       }gxe;
  } else {
    $description = $data->{title} || basename($file, qw(.mp3 .MP3 .mp2 .MP2) );
    $description .= " - $data->{artist}" if $data->{artist};
    $description .= " ($data->{album})"  if $data->{album};
  }
  return $description;
}

=head2 description_format

 Title   : description_format
 Usage   : $icy->description_format($format_string)
 Function:
 Returns : value of description_format (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub description_format{
    my $self = shift;

    return $self->{'description_format'} = shift if @_;
    return $self->{'description_format'};
}
1;