RTSP::Lite - Lightweight RTSP implementation

  use RTSP::Lite;
  $rtsp = new RTSP::Lite;
  $rtsp->open("192.168.0.1",554);
  $rtsp->method("DESCRIBE");
  $rtsp->request("rtsp://192.168.0.1/realqt.mov");
  $status_code = $rtsp->status();
  $status_message = $rtsp->status_message();
  print "$status_code $status_message\n";
  print $rtsp->body();

  ## SETUP
  $rtsp->method("SETUP");
  $rtsp->add_req_header("Transport","RTP/AVP;unicast;client_port=6970-6971");
  $req = $rtsp->request($url."/streamid=0");

  my $se = $rtsp->get_header("Session");
  $session = @$se[0];
  print $rtsp->status_message();
  print_headers();
  ## Play
  $rtsp->reset();
  $rtsp->method("PLAY");
  $rtsp->add_req_header("Session","$session");
  $rtsp->add_req_header("Range","npt=0.000000-5.200000");
  $req = $rtsp->request($url);
  print $rtsp->status_message();
  print_headers();
  ## You will get RTP/RTCP packets, you need to have codes for them.
  exit;
  sub print_headers {
    my @headers = $rtsp->headers_array();
    my $body = $rtsp->body();
    foreach $header (@headers) {
      print "$header\n";
    }
  }

 RFC 2326 - Real Time Streaming Protocol (RTSP)
 HTTP::Lite module (http://www.thetoybox.org/http-lite/)

#
# RTSP-Lite.pm 0.1
#   Lightweight RTSP implementation
#   http://www.kosho.org/tools/rtsp-lite/
#

package RTSP::Lite;

use vars qw($VERSION);
use strict qw(vars);

$VERSION = "0.1";
my $BLOCKSIZE = 65536;
my $CRLF = "\r\n";
my $FH;

# Required modules for Network I/O
use Socket 1.3;
use Fcntl;
use Errno qw(EAGAIN);

# Forward declarations
sub rtsp_write;
sub rtsp_readline;
sub rtsp_read;
sub rtsp_readbytes;

sub new 
{
    my $self = {};
    bless $self;
    $self->initialize();
    return $self;
}

sub initialize
{
    my $self = shift;
    $self->{timeout} = 120;
    $self->{DEBUG} = 0;
    $self->{cseq} = 0;
    $self->{user_agent} = "RTSP::Lite 0.1";
    $self->reset;
}

sub local_addr
{
    my $self = shift;
    my $val = shift;
    my $oldval = $self->{'local_addr'};
    if (defined($val)) {
	$self->{'local_addr'} = $val;
    }
    return $oldval;
}

sub local_port
{
    my $self = shift;
    my $val = shift;
    my $oldval = $self->{'local_port'};
    if (defined($val)) {
	$self->{'local_port'} = $val;
    }
    return $oldval;
}

sub method
{
    my $self=shift;
    my $method = shift;
    my $method = uc($method);
    $self->{method} = $method;
}

sub user_agent
{
    my $self=shift;
    my $user_agent = shift;
    $self->{user_agent} = $user_agent;
}

sub debug
{
    my $self = shift;
    my $debug = shift;
    $self->{DEBUG} = $debug;
}

sub DEBUG
{
    my $self = shift;
    if ($self->{DEBUG}) {
	print STDERR join(" ", @_),"\n";
    }
}

sub all_reset
{
	
}

sub reset
{
    my $self = shift;
    foreach my $var ("body", "request", "content", "status", "error-message",
		     "resp-headers", "headers","headermap","CBARGS",
		     "callback_function", "callback_params")
    {
	delete($self->{$var});
    }

    $self->{RTSPReadBuffer} = "";
    $self->{method} = "DESCRIBE";
}


# URL-encode data
sub escape 
{
    my $toencode = shift;
    $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
    return $toencode;
}

sub set_callback
{
    my ($self, $callback, @callbackparams) = @_;
    $self->{'callback_function'} = $callback;
    $self->{'callback_params'} = [ @callbackparams ];
}

sub open
{
    my ($self, $host,$port) = @_;

    if (!defined($port)) {
	$port = 554;
    }

    # Setup the connection
    my $proto = getprotobyname('tcp');

    socket(FH, PF_INET, SOCK_STREAM, $proto);

    my $addr = inet_aton($host);
    if (!$addr) {
	close(FH);
	return undef;
    }

    # choose local port and address
    my $local_addr = INADDR_ANY; 
    my $local_port = "0";
    if (defined($self->{'local_addr'})) {
	$local_addr = $self->{'local_addr'};
	if ($local_addr eq "0.0.0.0" || $local_addr eq "0") {
	    $local_addr = INADDR_ANY;
	} else {
	    $local_addr = inet_aton($local_addr);
	}
    }
    if (defined($self->{'local_port'})) {
	$local_port = $self->{'local_port'};
    }
    my $paddr = pack_sockaddr_in($local_port, $local_addr); 
    bind(FH, $paddr) || return undef;  # Failing to bind is fatal.

    my $sin = sockaddr_in($port,$addr);
    connect(FH, $sin) || return undef;

    # Set nonblocking IO on the handle to allow timeouts

    if ( $^O ne "MSWin32" ) {
	fcntl(FH, F_SETFL, O_NONBLOCK);
    }
	
}

sub close
{
    close FH;
}

sub request
{
    my ($self, $url, $data_callback, $cbargs) = @_;
  
    my $method = $self->{method};

    if (defined($cbargs)) {
	$self->{CBARGS} = $cbargs;
    }

    $self->{cseq}++;

    my $callback_func = $self->{'callback_function'};
    my $callback_params = $self->{'callback_params'};

    my $object = "$url";

    if (defined($callback_func)) {
	&$callback_func($self, "connect", undef, @$callback_params);
    }  

    # Add some required headers

    $self->add_req_header("CSEQ", $self->{cseq});    

    if (!($self->get_req_header("User-Agent"))) {
	$self->add_req_header("User-Agent",$self->{user_agent});
    }

    # Start the request 

    $self->rtsp_write(*FH, "$method $object RTSP/1.0$CRLF");
  
    # Output headers
    foreach my $header ($self->enum_req_headers())
    {
	my $value = $self->get_req_header($header);

	$self->rtsp_write(*FH, $header.": ".$value."$CRLF");

    }
  
    my $content_length;
    if (defined($self->{content}))
    {
	$content_length = length($self->{content});
    }
    if (defined($callback_func)) {
	my $ncontent_length = &$callback_func($self, "content-length", undef, @$callback_params);
	if (defined($ncontent_length)) {
	    $content_length = $ncontent_length;
	}
    }  

#  if ($content_length) {
#    rtsp_write(*FH, "Content-Length: $content_length$CRLF");
#  }
  
    if (defined($callback_func)) {
	&$callback_func($self, "done-headers", undef, @$callback_params);
    }  
    # End of headers
    $self->rtsp_write(*FH, "$CRLF");

  
    my $content_out = 0;
    if (defined($callback_func)) {
	while (my $content = &$callback_func($self, "content", undef, @$callback_params)) {
	    $self->rtsp_write(*FH, $content);
	    $content_out++;
	}
    } 
  
    # Output content, if any
    if (!$content_out && defined($self->{content}))
    {
	$self->rtsp_write(*FH, $self->{content});
    }
  
    if (defined($callback_func)) {
	&$callback_func($self, "content-done", undef, @$callback_params);
    }  

    # Read response from server
    my $headmode=1;
    my $chunkmode=0;
    my $chunksize=0;
    my $chunklength=0;
    my $chunk;
    my $line = 0;
    my $data;

    while ($data = $self->rtsp_read(*FH,$headmode,$chunkmode,$chunksize))
    {
	if ($self->{DEBUG}>1) {
	    $self->DEBUG("reading: $chunkmode, $chunksize, ".
			 "$chunklength, $headmode, ".length($self->{'body'}));
	    foreach my $var ("body", "request", "content", "status",
			     "error-message","resp-headers",
			     "CBARGS", "RTSPReadBuffer") 
	    {
		$self->DEBUG("state $var ".length($self->{$var}));
	    }
	}
	$line++;

	# Response Line;
	if ($line == 1) {
	    my ($proto,$status,$message) = split(' ', $$data, 3);
	    ($self->{DEBUG}>1) && $self->DEBUG("header $$data");
	    $self->{status}=$status;
	    $self->{'error-message'}=$message;
	    next;
	} 

	# after a blank line, its a body
	if (($headmode || $chunkmode eq "entity-header") &&
	    $$data =~ /^[\r\n]*$/) {
	    if ($chunkmode)  {
		$chunkmode = 0;
	    }
	    $headmode = 0;
      
	    #oops, [0] is not good
	    # in case of no body, Content-Length is not sent by server;
			
	    my $cl = $self->get_header('Content-Length');
	    if (defined($cl)) {
		$chunksize = @$cl[0];
		if ($chunksize>0) {
		    $chunkmode = "chunk";
		}
	    } else {
		return $self->{status};				
	    }

#      # Check for Transfer-Encoding (RTSP does not define it. Comment out)
#
#      my $te = $self->get_header("Transfer-Encoding");
#      if (defined($te)) {
#        my $header = join(' ',@{$te});
#        if ($header =~ /chunked/i)
#        {
#          $chunkmode = "chunksize";
#        }
#      }
	    next;
	}

	# Parse the entity-header

	if ($headmode || $chunkmode eq "entity-header") {
	    my ($var,$datastr) = $$data =~ /^([^:]*):\s*(.*)$/;
	    if (defined($var)) {
		$datastr =~s/[\r\n]$//g;
		$var = lc($var);
		$var =~ s/^(.)/&upper($1)/ge;
		$var =~ s/(-.)/&upper($1)/ge;
		my $hr = ${$self->{'resp-headers'}}{$var};
	    if (!ref($hr)) {
		$hr = [ $datastr ];
	    } else {
		push @{ $hr }, $datastr;
	    }
	    ${$self->{'resp-headers'}}{$var} = $hr;
        }
    } elsif ($chunkmode) {
	if ($chunkmode eq "chunksize")	{
	    $chunksize = $$data;
	    $chunksize =~ s/^\s*|;.*$//g;
	    $chunksize =~ s/\s*$//g;
	    my $cshx = $chunksize;
	    if (length($chunksize) > 0) {
		# read another line
		if ($chunksize !~ /^[a-f0-9]+$/i) {
		    ($self->{DEBUG}>1) &&
			$self->DEBUG("chunksize not a hex string");
		}
		$chunksize = hex($chunksize);
		($self->{DEBUG}>1) &&
		    $self->DEBUG("chunksize was $chunksize (HEX was $cshx)");
		if ($chunksize == 0)
		{
		    $chunkmode = "entity-header";
		} else {
		    $chunkmode = "chunk";
		    $chunklength = 0;
		}
	    } else {
		($self->{DEBUG}>1) &&
		    $self->DEBUG("chunksize empty string, checking next line!");
	    }
	} elsif ($chunkmode eq "chunk") {
	    $chunk .= $$data;
	    $chunklength += length($$data);
	    if ($chunklength >= $chunksize) {
		$chunkmode = "chunksize";
		if ($chunklength > $chunksize) {
		    $chunk = substr($chunk,0,$chunksize);
		} elsif ($chunklength == $chunksize && $chunk !~ /$CRLF$/) {
		    # chunk data is exactly chunksize -- need CRLF still
		    $chunkmode = "ignorecrlf";
		}
		$self->add_to_body(\$chunk, $data_callback);
		$chunk="";
		$chunklength = 0;
		$chunksize = "";
	    }
	    return $self->{status};

	} elsif ($chunkmode eq "ignorecrlf") {
	    $chunkmode = "chunksize";
	}
    } else {
	$self->add_to_body($data, $data_callback);
    }
  }
  if (defined($callback_func)) {
    &$callback_func($self, "done", undef, @$callback_params);
  }
  close(FH);
  return $self->{status};
}

sub add_to_body
{
    my $self = shift;
    my ($dataref, $data_callback) = @_;
  
    my $callback_func = $self->{'callback_function'};
    my $callback_params = $self->{'callback_params'};

    if (!defined($data_callback) && !defined($callback_func)) {
	($self->{DEBUG}>1) && $self->DEBUG("no callback");
	$self->{'body'}.=$$dataref;
    } else {
	my $newdata;
	if (defined($callback_func)) {
	    $newdata = &$callback_func($self, "data", $dataref, @$callback_params);
	} else {
	    $newdata = &$data_callback($self, $dataref, $self->{CBARGS});
	}
	if ($self->{DEBUG}>1) {
	    $self->DEBUG("callback got back a ".ref($newdata));
	    if (ref($newdata) eq "SCALAR") {
		$self->DEBUG("callback got back ".length($$newdata)." bytes");
	    }
	}
	if (defined($newdata) && ref($newdata) eq "SCALAR") {
	    $self->{'body'} .= $$newdata;
	}
    }
}

sub add_req_header
{
    my $self = shift;
    my ($header, $value) = @_;
  
    my $lcheader = lc($header);
    ($self->{DEBUG}>1) && $self->DEBUG("add_req_header $header $value");
    ${$self->{headers}}{$lcheader} = $value;
    ${$self->{headermap}}{$lcheader} = $header;
}

sub get_req_header
{
    my $self = shift;
    my ($header) = @_;
  
    return $self->{headers}{lc($header)};
}

sub delete_req_header
{
    my $self = shift;
    my ($header) = @_;
  
    my $exists;
    if ($exists=defined(${$self->{headers}}{lc($header)})) {
        delete ${$self->{headers}}{lc($header)};
        delete ${$self->{headermap}}{lc($header)};
    }
    return $exists;
}

sub enum_req_headers
{
    my $self = shift;
    my ($header) = @_;
  
    my $exists;
    return keys %{$self->{headermap}};
}

sub body
{
    my $self = shift;
    return $self->{'body'};
}

sub status
{
    my $self = shift;
    return $self->{status};
}


sub status_message
{
    my $self = shift;
    return $self->{'error-message'};
}


sub headers_array
{
    my $self = shift;
  
    my @array = ();
  
    foreach my $header (keys %{$self->{'resp-headers'}}) {
	my $aref = ${$self->{'resp-headers'}}{$header};
        foreach my $value (@$aref) {
	    push @array, "$header: $value";
	}
    }
    return @array;
}

sub headers_string
{
    my $self = shift;
  
    my $string = "";
  
    foreach my $header (keys %{$self->{'resp-headers'}}) {
	my $aref = ${$self->{'resp-headers'}}{$header};
        foreach my $value (@$aref) {
	    $string .= "$header: $value\n";
	}
    }
    return $string;
}

sub get_header
{
    my $self = shift;
    my $header = shift;

    return $self->{'resp-headers'}{$header};
}

sub rtsp_write
{
    my $self = shift;
    my ($fh,$line) = @_;

    my $size = length($line);

    $self->{DEBUG} && print STDERR ("write: $line");

    my $bytes = syswrite($fh, $line, $size, 0 );

    while ( ($size - $bytes) > 0) {
	$bytes += syswrite($fh, $line, 4096, $bytes );
    }
}
 
sub rtsp_read
{
    my $self = shift;
    my ($fh,$headmode,$chunkmode,$chunksize) = @_;

    ($self->{DEBUG}>1) &&
	$self->DEBUG("read handle=$fh, headm=$headmode, chunkm=$chunkmode, chunksize=$chunksize");

    my $res;
    if (($headmode == 0 && $chunkmode eq "0") || ($chunkmode eq "chunk")) {
	my $bytes_to_read = $chunkmode eq "chunk" ?
	    ($chunksize < $BLOCKSIZE ? $chunksize : $BLOCKSIZE) :
	    $BLOCKSIZE;
	$res = $self->rtsp_readbytes($fh,$self->{timeout},$bytes_to_read);
    } else {
	$res = $self->rtsp_readline($fh,$self->{timeout});
    }

    if ($res) {
	if ($self->{DEBUG}) {
	    if ($self->{DEBUG}>1) {
		$self->DEBUG("read got ".length($$res)." bytes");
	    }
	    my $str = $$res;
	    $str =~ s{([\x00-\x1F\x7F-\xFF])}{.}g;
	    $self->DEBUG("read: ".$str);
	}
    }
    return $res;
}

sub rtsp_readline
{
    my $self = shift;
    my ($fh, $timeout) = @_;
    my $EOL = "\n";

    ($self->{DEBUG}>1) &&
	$self->DEBUG("readline handle=$fh, timeout=$timeout");
  
    # is there a line in the buffer yet?
    while ($self->{RTSPReadBuffer} !~ /$EOL/) {
	# nope -- wait for incoming data
	my ($inbuf,$bits,$chars) = ("","",0);
	vec($bits,fileno($fh),1)=1;
	my $nfound = select($bits, undef, $bits, $timeout);
	if ($nfound == 0) {
	    # Timed out
	    return undef;
	} else {
	    # Get the data
	    $chars = sysread($fh, $inbuf, $BLOCKSIZE);
	    ($self->{DEBUG}>1) && $self->DEBUG("sysread $chars bytes");
	}
	# End of stream?
	if ($chars <= 0 && !$!{EAGAIN}) {
	    last;
	}
	# tag data onto end of buffer
	$self->{RTSPReadBuffer}.=$inbuf;
    }
    # get a single line from the buffer
    my $nlat = index($self->{RTSPReadBuffer}, $EOL);
    my $newline;
    my $oldline;
    if ($nlat > -1) {
	$newline = substr($self->{RTSPReadBuffer},0,$nlat+1);
	$oldline = substr($self->{RTSPReadBuffer},$nlat+1);
    } else {
	$newline = substr($self->{RTSPReadBuffer},0);
	$oldline = "";
    }
    # and update the buffer
    $self->{RTSPReadBuffer}=$oldline;
    return length($newline) ? \$newline : 0;
}

sub rtsp_readbytes
{
    my $self = shift;
    my ($fh, $timeout, $bytes) = @_;
    my $EOL = "\n";

    ($self->{DEBUG}>1) &&
	$self->DEBUG("readbytes handle=$fh, timeout=$timeout, bytes=$bytes");
  
    # is there enough data in the buffer yet?
    while (length($self->{RTSPReadBuffer}) < $bytes) {
	# nope -- wait for incoming data
	my ($inbuf,$bits,$chars) = ("","",0);
	vec($bits,fileno($fh),1)=1;
	my $nfound = select($bits, undef, $bits, $timeout);
	if ($nfound == 0) {
	    # Timed out
	    return undef;
	} else {
	    # Get the data
	    $chars = sysread($fh, $inbuf, $BLOCKSIZE);
	    $self->{DEBUG} && $self->DEBUG("sysread $chars bytes");
	}
	# End of stream?
	if ($chars <= 0 && !$!{EAGAIN}) {
	    last;
	}
	# tag data onto end of buffer
	$self->{RTSPReadBuffer}.=$inbuf;
    }

    my $newline;
    my $buflen;
    if (($buflen=length($self->{RTSPReadBuffer})) >= $bytes) {
	$newline = substr($self->{RTSPReadBuffer},0,$bytes+1);
	if ($bytes+1 < $buflen) {
	    $self->{RTSPReadBuffer} = substr($self->{RTSPReadBuffer},$bytes+1);
	} else {
	    $self->{RTSPReadBuffer} = "";
	}
    } else {
	$newline = substr($self->{RTSPReadBuffer},0);
	$self->{RTSPReadBuffer} = "";
    }
    return length($newline) ? \$newline : 0;
}

sub upper
{
    my ($str) = @_;
    if (defined($str)) {
	return uc($str);
    } else {
	return undef;
    }
}

1;

__END__