#!/usr/bin/perl -w
# Copyright © 2000-2011 Jamie Zawinski <jwz@dnalounge.com>.
#
# Permission to use, copy, modify, distribute, and sell this software and its
# documentation for any purpose is hereby granted without fee, provided that
# the above copyright notice appear in all copies and that both that
# copyright notice and this permission notice appear in supporting
# documentation.  No representations are made about the suitability of this
# software for any purpose.  It is provided "as is" without express or 
# implied warranty.
#
# Created: 20-Jul-2000
# write-metadata.pl --- updates the metadata on an icecast server stream.
# understands both icecast 1.3.x and 2.x.

require 5;
use diagnostics;
use strict;
use LWP::UserAgent;

use Socket;
require POSIX;

my $progname = $0; $progname =~ s@.*/@@g;
my $version = q{ $Revision: 1.9 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;

my $verbose = 0;

sub url_quote {
    die "expected 1 arg to url_quote" unless @_ == 1;
    local $_ = shift;
    s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge;
    return $_;
}

sub url_unquote {
    die "expected 1 arg to url_quote" unless @_ == 1;
    local $_ = shift;
    s/[+]/ /g;
    s/%([a-z0-9]{2})/chr(hex($1))/ige;
    return $_;
}

sub error {
  ($_) = @_;
  print STDERR $_;
  exit 1;
}

sub write_metadata {
  my ($url, $pass, $data) = @_;

  $data = url_quote ($data);

  my $icecast2_p;
  # try and guess which icecast server is running...
  if (-f "/etc/icecast.xml" ||
      -f "/usr/local/icecast/etc/icecast.xml") {
    $icecast2_p = 1;
  } else {
    $icecast2_p = 0;
  }

  my($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4);
  if (! ($url_proto && $url_proto =~ m/^http:$/i)) {
    error "$progname: not an HTTP URL: $url\n";
  }

  $path = "" unless $path;

  my ($them,$port) = split(/:/, $serverstring);
  $port = 80 unless $port;
  my @cmd;

  if ($icecast2_p) {
    $path = "admin/metadata" .
            "?mount=/$path" .
            "&mode=updinfo" .
            "&song=$data";
    $url = "$url_proto//$serverstring/$path";
  } else {
    $path = "admin.cgi" .
            "?mode=updinfo" .
            "&pass=$pass" .
            "&mount=/$path" .
            "&song=$data";
    $url = "$url_proto//$serverstring/$path";
  }

  my $req = HTTP::Request->new (GET => $url);
  $req->authorization_basic ('admin', $pass);
  my $ua = LWP::UserAgent->new;
  $ua->agent ("$progname/$version");
  my $res = $ua->request ($req);
#  my $ret = ($res && $res->code) || 'null';
#  error ("$url: bad response: $ret") unless ($ret eq '200');
#  my $result = $res->content || '';

  print STDERR "$progname: $url\n" if ($verbose);

  exec @cmd;
}


my $usage = "usage: $progname [--verbose] url password metadata\n";

sub main {
  my ($url, $pass, $data);

  while ($_ = $ARGV[0]) {
    shift @ARGV;
    if ($_ eq "-verbose") { $verbose++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif (m/^-/) { print STDERR "$progname: unknown option: \"$_\"\n";
                    print STDERR $usage; exit 1; }
    elsif (!defined($url)) {
      if (! m@^http://@) { print STDERR "$progname: not an HTTP url: \"$_\"\n";
                           print STDERR $usage; exit 1; }
      $url = $_;
    } elsif (!defined($pass)) {
      $pass = $_;
    } elsif (!defined($data)) {
      $data = $_;
    } else {
      print STDERR "$progname: unknown option: \"$_\"\n";
      print STDERR $usage; exit 1;
    }
  }

  if (!$url || !$pass || !$data) {
    print STDERR "$progname: no URL!\n" unless $url;
    print STDERR "$progname: no password!\n" unless $pass;
    print STDERR "$progname: no metadata!\n" unless $data;
    print STDERR $usage;
    exit 1;
  }

  $_ = $url;
  s@^.*/@@;
  $progname =~ s/\.pl$//;
  $progname .= ": $_";

  # don't let the metadata be longer than 126 characters.
  # apparently long metadata makes icecast 1.3.5 hang.
  $data =~ s/^(.{126}).*$/$1/;

  write_metadata ($url, $pass, $data);
}

main;
exit (0);