Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
I've just added a web based playlist configurator to it... :-)

Pretty much via a web page you create a playlist and store it in an array (a fully qualified mp3 name per element) I've then frozen the array with and stored it in a postgres database.

#!/usr/bin/perl -w use strict; use IO::Socket; use MIME::Base64; use DBI; use Data::Dumper; use Storable qw/freeze thaw/; #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); #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,\@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 $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 @user = split(/\:/,decode_base64(@{$ary}[$#{$ary}]) ); @songs = &get_db_playlist(name=>$user[0]); } #seed the rand number generator srand(time / $$); #loop forever (or until the client closes the socket) while() { #print the HTTP header. The only thing really necessary # is the first line and the trailing "\n\n" # depending 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"; #get a random song from your playlist my $song = $songs[ rand @songs ]; #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; } close SONG; unless( defined $print_status ) { $socket->close(); exit(0); } } } sub get_db_playlist { my %user = @_; my ($dbh, $sth, @ary); $dbh = DBI->connect('DBI:Pg:dbname=infomgr', <name> , <passwd>, { +RaiseError => 1, AutoCommit => 0 }) || die "could not connect to database: ".$dbh->errstr;; $sth = $dbh->prepare("SELECT a.playlist from playlist a, users b w +here = ?"); $sth->execute($user{name}); @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}; }

The database table structure is very simple. I have a table of users and a table of playlists. the playlist data comes from a web page where the list songs are stored in an array which is packed and frozen (using It should be simple enuff to reverse, however if you want me to post the code, let me know.

The only thing i havent handled is a non existant name in the database. It should choose a default playlist, but it just bombs out now.

Not the most stylish code for the additions, but it works .. :-)

the usage via xmms is http://username:password@machine:port

My next task is to provide handling of the above scenario, and run it via init.d

In reply to Re: MP3 server with IO::Socket by Ryszard
in thread MP3 server with IO::Socket by perlmonkey

Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?

    What's my password?
    Create A New User
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others lurking in the Monastery: (3)
    As of 2020-08-10 07:04 GMT
    Find Nodes?
      Voting Booth?
      Which rocket would you take to Mars?

      Results (56 votes). Check out past polls.