Apache::MP3

 
  0 package Apache::MP3;
  1 # file: Apache/MP3.pm
  2 use strict;
  3 use Apache::Constants qw(:common);
  4 use MPEG::MP3Info;
  5 use IO::Dir;
  6 use Apache::File;
  7 # Intercept requests for audio/mpegurl (.pls) files and 
  8 # convert them into an appropriately-formatted playlist.
  9 # Intercept requests for audio/x-shoutcast-stream (.mps)
 10 # and convert them into appropriate shoutcast/icecast 
 11 # output to install:
 12 #
 13 # AddType audio/mpeg .mp3
 14 # AddType audio/mpegurl .pls
 15 # AddType audio/x-shoutcast-stream .mps
 16 #
 17 # <Files ~ "\.(pls|mps)$">
 18 #   SetHandler perl-script
 19 #   PerlHandler Apache::MP3
 20 # </Files>
 21 # entry point for mod_perl
 22 sub handler {
 23   my $r = shift;
 24   my $filename = $r->filename;
 25   # Reconstruct the requested URL.
 26   my $server_url = join '', 'http://',
 27                             $r->server->server_hostname,
 28                             ":",
 29                             $r->get_server_port;
 30   my $filename = $r->filename;
 31   my ($basename) = $filename  =~ m!([^/]+)\.[^/.]*$!;
 32   (my $directory   = $filename) =~ s!/[^/]+$!!;      
 33   (my $virtual_dir = $r->uri)   =~ s!/[^/]+$!!;      
 34   if ($r->content_type eq 'audio/mpegurl') {
 35     # If this is a request for a file of type 
 36     # audio/mpegurl, strip off the extension and look 
 37     # for a directory containing the name.  Generate a 
 38     # playlist from all mp3 files in the directory.
 39     return dir2playlist($r, "$directory/$basename", undef,
 40       "$server_url/$basename/") if -d "$directory/$basename";
 41     # If none found, search for a file of type audio/mpeg 
 42     # sharing the basename, and generate a playlist from that.
 43     return dir2playlist($r, $directory, $basename,
                                   "$server_url$virtual_dir/");
 44   } 
 45   # Otherwise is this a request for stream data?
 46   elsif ($r->content_type eq 'audio/x-shoutcast-stream') {
 47     my ($mp3_file) = search4mp3($r, $directory, $basename);
 48     return DECLINED unless $mp3_file;
 49     return send_stream($r, "$directory/$mp3_file", $server_url);
 50   }
 51 }

 52 # search for an mp3 file that matches a basename
 53 sub search4mp3 {
 54   my ($r, $dir, $basename) = @_;
 55   my $pattern = quotemeta $basename;
 56   my @mp3;
 57   my $dh = IO::Dir->new($dir) || return;
 58   while ( defined($_ = $dh->read) ) {
 59     next if $pattern && !/^$pattern(\.\w+)?$/;
 60     next if $r->lookup_file("$dir/$_")->content_type 
                                           ne 'audio/mpeg';
 61     push (@mp3, $_);
 62   }
 63   return @mp3;
 64 }

 65 # send the playlist...
 66 sub dir2playlist {
 67     my ($r, $dir, $basename, $url) = @_;
 68     my @mp3 = search4mp3($r, $dir, $basename);
 69     return DECLINED unless @mp3;
 70     $r->content_type('audio/mpegurl');
 71     $r->send_http_header;
 72     return OK if $r->header_only;
 73     $r->print ("[playlist]\r\n\r\n");
 74     $r->print ("NumberOfEntries=",scalar(@mp3),"\r\n");
 75     for (my $i=1;$i<=@mp3;$i++) {
 76       (my $file = $mp3[$i-1]) =~ s/(\.[^.]+)?$/.mps/;
 77       $r->print ("File$i=$url$file\r\n");
 78     }
 79     return OK;
 80 }

 81 # send the music stream...
 82 sub send_stream {
 83     my ($r, $file, $url) = @_;
 84     my $tag  = get_mp3tag($file);
 85     my $info = get_mp3info($file);
 86     return DECLINED unless $info;  # not a legit mp3 file?
 87     my $fh = Apache::File->new($file) || return DECLINED;
 88     my $title = $tag->{TITLE} || $url . $r->uri;
 89     foreach ( qw(ARTIST ALBUM YEAR COMMENT) ) {
 90         $title .= ' - ' . $tag->{$_} if $tag->{$_};
 91     }
 92     my $genre = $tag->{GENRE} || 'unknown';
 93     $r->print("ICY 200 OK\r\n");
 94     $r->print("icy-notice1:<BR>This stream requires a 
             shoutcast/icecast compatible player.<BR>\r\n");
 95     $r->print("icy-notice2:Apache::MP3 module<BR>\r\n");
 96     $r->print("icy-name:$title\r\n");
 97     $r->print("icy-genre:$genre\r\n");
 98     $r->print("icy-url:$url\r\n");
 99     $r->print("icy-pub:1\r\n");
100     $r->print("icy-br:$info->{BITRATE}\r\n");
101     $r->print("\r\n");
102     return OK if $r->header_only;
103     $r->send_fd($fh);
104     return OK;
105 }
106 1;
107 __END__