Perlized.

Support registered channels.

diff --git a/bin/engine-di.fm b/bin/engine-di.fm
index 3d8936b..1355b82 100755 (executable)
--- a/bin/engine-di.fm
+++ b/bin/engine-di.fm
@@ -1,68 +1,165 @@
-#! /bin/bash
+#! /usr/bin/perl
 #
 # $Id$
 
+use strict;
+use warnings;
+require LWP::Simple;
+use Data::Dumper;
+require HTTP::Headers;
+require HTTP::Request;
+require LWP::UserAgent;
+require HTTP::Cookies;
 
-echo >&2 "FIXME: http_proxy"
-unset http_proxy
+my $USERNAME="lace";
+my $PASSWORD=&_priv_postget("di.fm.pwd");
 
+delete $ENV{"http_proxy"};
 
-if [ "$1" = "build" ];then
-       old="`find -maxdepth 1 '(' -name "di.fm-*" -o -name "sky.fm-*" ')' -type l`"
-       if [ -z "$old" ];then echo >&2 "No existing symlinks found.";exit 1;fi
-       for site in di.fm sky.fm;do
-               newdashed="`wget -q -O - http://$site/|tr ' ' '\n' \
-                               |perl -n -e '
-                                               s{^.*"(?:http://www.'$site')?([^":]*(?<!_low)[.](?:pls|asx))".*$}{$1} or next;
-                                               m{^/aacplus/} and next;
-                                               tr{/}{-};
-                                               print;
-                                               ' \
-                               `"
-               if [ -z "$newdashed" ];then echo >&2 "Failed to download the new listing found.";exit 1;fi
-               TARGET="engine-di.fm"
-               if [ ! -x "$TARGET" ];then echo >&2 "Target engine $TARGET not found.";exit 1;fi
-               rm -f $old
-               old=""
-               PREFIX="$site"
-               for pathdashed in $newdashed;do
-                       test -L "$PREFIX$pathdashed" && continue
-                       ln -s "$TARGET" "$PREFIX$pathdashed"
-               done
-       done
-       echo OK
-       exit 0
-fi
+sub _priv_postget($)
+{
+my($base)=@_;
 
-set -ex
-pathslashed="`basename "$0"|tr - /`"
-if false;then
-       stream="`lynx -source http://di.fm${pathslashed}|sed -n 's/^File1=//p'|tr -d '\r'`"
-       exec mplayer -ao oss:/dev/dsp -cache 128 "$stream" "$@"
-       exit 1
-else
-       while :;do
-               streamlist="`lynx -source http://${pathslashed}|sed -n \
-                               -e 's/^File[0-9]*=//p' \
-                               -e 's#^.*"\(mms://[^"]*\)".*$#\1#p' \
-                               |tr -d '\r'`"
-               for stream in $streamlist;do
-                       # Using "set -e" here:
-                       # mplayer rc 0 on failure to read the stream
-                       # mplayer rc 0 on 'q'
-                       # mplayer rc 1 on ctrl-c
-                       ip="`  echo "$stream"|sed -n 's#^http://\([^:/]*\).*$#\1#p'`"
-                       if [ -n "$ip" ];then
-                               port="`echo "$stream"|sed -n 's#^http://[^:/]*:\([0-9][0-9]*\).*$#\1#p'`"
-                               port="${port:-80}"
-                               echo >&2 "Checking $stream -> {$ip}:{$port} ..."
-                               if ! nc -w 2 "$ip" "$port";then
-                                       echo >&2 "TIMEOUT: $stream"
-                                       continue
-                               fi
-                       fi
-                       #mplayer -ao alsa:device=hw=0 -cache 512 "$stream" "$@"
-                       mplayer -cache 512 "$stream" "$@"
-               done
-       done
-fi
+       my $full=$ENV{"HOME"}."/priv/postget.".$base;
+       local *F;
+       open F,$full or die "$full: $!";
+       my $r=do { local $/; <F>; } or die "read \"$full\": $!";
+       close F or die "close \"$full\": $!";
+       chomp $r;
+       return $r;
+}
+
+sub paidget($$)
+{
+       my($url,$site)=@_;
+
+       my $ua=LWP::UserAgent->new() or die "UA: $!";
+       my $jar=HTTP::Cookies->new() or die "jar: $!";
+       $ua->cookie_jar($jar);
+       my $req=HTTP::Request->new(
+               "POST",
+               q{http://}.$site.q{/pro/login.php},
+               HTTP::Headers->new(
+                       "Host"=>$site,
+                       "Content-Type"=>"application/x-www-form-urlencoded",
+               ),
+               join('&',
+                       q{amember_login=}.$USERNAME,
+                       q{amember_pass=}.$PASSWORD,
+                       q{refer_back_url=http://}.$site.q{/},
+                       q{login_attempt_id=}.(0+time()),
+                       q{remember_login=1},
+               ),
+       );
+       my $resp=$ua->request($req) or die "resp(0): $!";
+       die "!success(0)" if !$resp->is_success();
+       die "!content(0)" if !(my $content=$resp->content());
+       $content=~m{You will be redirected to protected area} or die $content;
+       $req=HTTP::Request->new(
+               "GET",
+               $url,
+       );
+       $resp=$ua->request($req) or die "resp(1): $!";
+       die "!success(1)" if !$resp->is_success();
+       die "!content(1)" if !($content=$resp->content());
+       return $content;
+}
+
+if ("build" eq ($ARGV[0]||"")) {
+       my @symlink;
+       local $_;
+       while (<*>) {
+               chomp;
+               next if !/^(?:\Qdi.fm\E|\Qsky.fm\E)-/;
+               -l or next;
+               push @symlink,$_;
+       }
+       @symlink or die "No existing symlinks found";
+       my $TARGET="engine-di.fm";
+       -x $TARGET or die "Target $TARGET not found";
+
+       sub sitedump($$)
+       {
+               my($site,$page)=@_;
+
+               my @newdashed;
+               while ($page=~m{"((?:http://www.'$site')?([^":]*(?<!_low)[.](?:pls|asx)))"}g) {
+                       local $_=$1;
+                       next if m{^/aacplus/};
+                       next if m{/(?:32|56|64|128)k[.]};
+                       tr{/}{-};
+                       push @newdashed,$_;
+               }
+               @newdashed or die "No URLs found";
+               for (@symlink) {
+                       unlink or die "unlink \"$_\": $!";
+               }
+               @symlink=();
+               for (@newdashed) {
+                       my $dest="$site$_";
+                       next if -l $dest;
+                       symlink $TARGET,$dest or die "symlink \"$dest\": $!";
+               }
+       }
+
+       for my $site (qw(di.fm)) {      # FIXME: sky.fm
+               my $freepageurl="http://$site/";
+               my $freepage=LWP::Simple::get($freepageurl) or die $freepageurl;
+               sitedump $site,$freepage;
+               my $paidpage=paidget $freepageurl,$site;
+               sitedump $site,$paidpage;
+       }
+       print "OK\n";
+       exit 0;
+}
+
+my $pathslashed=$0;
+$pathslashed=~s{^.*/}{};
+$pathslashed=~tr{-}{/};
+my $streamlisturl="http://$pathslashed";
+for (;;) {
+
+       sub streamlist_get($)
+       {
+               my($streamlist)=@_;
+
+               my @streamlist;
+               while ($streamlist=~m{^File\d*\s*=\s*"?(\S+?)"?\s*$}gm) {
+                       push @streamlist,$1;
+               }
+               while ($streamlist=~m{<ref\s+href\s*=\s*"(mms://[\S^"]+?)"\s*/>}g) {
+                       my $url=$1;
+                       $url=~s{&amp;}{&};
+                       push @streamlist,$url;
+               }
+               return @streamlist;
+       }
+
+       my $streamlist=LWP::Simple::get($streamlisturl) or die $streamlisturl;
+       my @streamlist=streamlist_get $streamlist;
+       if (!@streamlist) {
+               $streamlist=~m{Digitally Imported :: Login} or die "No streams found (free): $streamlisturl";
+               $streamlist=paidget $streamlisturl,"di.fm";     # FIXME: sky.fm
+               @streamlist=streamlist_get $streamlist;
+               @streamlist or die "No streams found (paid): $streamlisturl: $streamlist";
+       }
+       warn Dumper(\@streamlist);
+       for my $stream (@streamlist) {
+               if (my($host,$port)=($stream=~m{^http://(?:[^@]+@)?([^:/@]+)(?::(\d+))?})) {
+                       $port||=80;
+                       warn "Connecting {$host}:{$port}...\n";
+                       my $tcp=IO::Socket::INET->new(
+                               Proto=>"tcp",
+                               PeerHost=>$host,
+                               PeerPort=>$port,
+                               Timeout=>2,
+                       ) or next;
+                       close $tcp or die "Close TCP: $!";
+               }
+               my $mplayer="mplayer";
+               my @list=($mplayer,qw(-cache 512),$stream);
+               warn Dumper(\@list);
+               system $mplayer @list;
+               exit 0 if $?;
+       }
+}