#!/usr/bin/perl -w

use strict;

use IO::Socket;
use MIME::Base64;
use DBI;
use Data::Dumper;
use Storable qw/freeze thaw/;
use Cache::SharedMemoryCache;

my $songcache = 'songnumber';
my $cache = new Cache::SharedMemoryCache( { 'namespace' => $songcache,
                                            'default_expires_in' => 60
+0 } );

#get the port to bind to or default to 8000
my $port = $ARGV[0] || 8000;

#ignore child processes to prevent zombies
$SIG{CHLD} = 'IGNORE';

#create the listen socket
my $listen_socket = IO::Socket::INET->new(LocalPort => $port,
                                          Listen => 10,
                                          Proto => 'tcp',
                                          Reuse => 1);
open (PIDFILE, '>'.$0.'.pid');
print PIDFILE $$;
close PIDFILE;

#make sure we are bound to the port
die "Cant't create a listening socket: $@" unless $listen_socket;

warn "Server ready. Waiting for connections ... \n";
my (@auth, @ary, $buf, %kids);

#wait for connections at the accept call
while (my $connection = $listen_socket->accept)
{   
    my $child;
    # perform the fork or exit
    die "Can't fork: $!" unless defined ($child = fork());
    if ($child == 0)
    {   #i'm the child!
    
        $connection->recv($buf, 1024);

        @ary = split(/0d0a/,unpack("H*",$buf) );
        foreach (@ary){
            my $line = pack("H*", $_);
            @auth = split(/ /,$line ) if ($line =~ /^Auth/);
        } 
        #close the child's listen socket, we dont need it.
        $listen_socket->close;

        #call the main child rountine
        play_songs($connection, $cache, \@auth);
        
        #if the child returns, then just exit;
        undef $kids{$child};
        exit 0;
    } 
    else
    {   #i'm the parent!

        $kids{$child} = 1;
    
        #who connected?
        warn "Connecton recieved ... ",$connection->peerhost,"\n";

        #close the connection, the parent has already passed
        #   it off to a child.
        $connection->close();
        
    }
    #go back and listen for the next connection!
} 

sub play_songs
{   
    my $socket = shift;

    my $cache  = shift;
    my $ary    = shift;
    my @songs; 

    #get all the possible songs
    if ($#{$ary} == -1) {
        #get default playlist
        local*PLAYLIST;
        open PLAYLIST, "playlist.m3u" or die;
        @songs = <PLAYLIST>;   
        close PLAYLIST;
        chomp @songs;
     } else {
        my @params = split(/\:/,decode_base64(@{$ary}[$#{$ary}]) );
        @songs = &get_db_playlist(NAME=>$params[0], PLAYLIST=>$params[
+1]);
     }

    my $i;
    $cache->set($songcache, $i);

    #seed the rand number generator
    srand(time / $$);

    #loop forever (oruntil the client closes the socket)
    while()
    {
        
        #print the HTTP header.  The only thing really necessary
        #   is the first line and the trailing "\n\n"        #   depen
+ding on your client (like xmms) you can also
        #   send song title etc.
        print $socket "HTTP/1.0 200 OK\n";
        print $socket "Content-Type: audio/x-mp3stream\n";
        print $socket "Cache-Control: no-cache \n";
        print $socket "Pragma: no-cache \n";
        print $socket "Connection: close \n";
        print $socket "x-audiocast-name: My MP3 Server\n\n";
        
print STDERR "1) i=$i songs: $#songs cache: ".$cache->get($songcache).
+" PID: ".$$."\n";

        #get a random song from your playlist
        #my $song = $songs[ rand @songs ];
        $i = $cache->get($songcache);

        if (defined $i) {
            $i++; if ($i > $#songs) {$i=0};
            $cache->set($songcache, $i);
print STDERR "2) i=$i songs: $#songs cache: ".$cache->get($songcache).
+" PID: ".$$."\n";
        } else {
            $i = 0;
            $cache->set($songcache, $i);
        }
print STDERR Dumper $cache;
        my $song = $songs[$i];
        
        #what song are we playing
        warn( "play song: $song\n");
        
        #open the song, or continue to try another one
        open (SONG, $song) || next;

        binmode(SONG); #for windows users

        my $read_status = 1;
        my $print_status = 1;
        my $chunk;

        # This parts print the binary to the socket
        #   as fast as it can.  The buffering will
        #   take place on the client side (it blocks when full)
        #   because this is *not* non-blocking IO
        #
        #the read will return 0 if it has reached eof
        #
        #the print will return undef if it fails
        #   (ie the client stopped listening)
        #        while( $read_status  && $print_status )
        {   
            $read_status = read (SONG, $chunk, 1024);
            if( defined $chunk && defined $read_status)
            {   
                $print_status = print $socket $chunk;
            }
            undef $chunk;
        }
print STDERR "3) i=$i songs: $#songs cache: ".$cache->get($songcache).
+" PID: ".$$."\n";
        close SONG;
        
        unless( defined $print_status )
        {   
            $socket->close();
            exit(0);
        }
    }
}

sub get_db_playlist {
    my %params = @_;

    my ($dbh, $sth, @ary);
    $dbh = DBI->connect('DBI:Pg:dbname=infomgr',uname , password, { Ra
+iseError => 1, AutoCommit => 0 })
           || die "could not connect to database: ".$dbh->errstr;; 
    $sth = $dbh->prepare("SELECT a.playlist from playlist a, users b w
+here b.name = ? 
                          and a.playlist_name = ?");

    $sth->execute($params{NAME},$params{PLAYLIST});
    @ary = $sth->fetchrow_array;
    $sth->finish;
    $dbh->disconnect;
    if ($dbh->errstr) {warn "Error getting playlist: ".$dbh->errstr };
    my $retval =  thaw(pack("H*", @ary) );

    return @{$retval};

}
[download]

Edit Petruchio Thu Feb 7 07:51:18 UTC 2002 - Added READMORE tag