#
# 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__

=pod

=head1 NAME

RTSP::Lite - Lightweight RTSP implementation

=head1 SYNOPSIS

  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();

=head1 DESCRIPTION

RTSP::Lite is a stand-alone lightweight RTSP/1.0 module for Perl. It
is based on Roy Hooper's HTTP::Lite (RTSP protocol is very similar to
HTTP protocol. I simply modified it to support RTSP).

The main focus of the module is to help you write simple RTSP clients
for monitoring and debugging streaming server. So far, full streaming
clients that need RTP handling are out of my scope.

The main modifications from the HTTP::Lite 2.1.4 are: 
 + Supports continuous requests. Therefore explicit open operation is
 now required.
 + Supports multiple debug level.
 + Callback function is not supported.
 + Deletes http style proxy support. Because RTSP requests to proxy
 are the same style of  requests to server. 

=head1 METHODS

=item B<debug ( $level)>

Set the debug level. 
  0: no debug message (default), 
  1: display all network write and read
  2: display all debug message

=item B<open ( $host, $port )>

Open a connection to $host:$port.  $port can be left out.

=item B<method ( $method )>

Set the method name (OPTIONS, DESCRIBE, PLAY, ...). 

=item B<add_req_header ( $header, $value )>

=item B<get_req_header ( $header )>

=item B<delete_req_header ( $header )>

Add, Delete, or  get RTSP header(s) for the request. 

=item B<user_agent( $agent_name)>

Set the agent name (Default is "RTSP::Lite 0.1"). 

=item B<request ( $url )>

Send a request to the connected host. If an I/O error is encountered,
it returns undef, otherwise RTSP status code is returned. 

Note: user-agent and cseq headers are automatically added. If user
agent header is specified by add_req_header (), it overwrites the
user_agent () variable;

=item B<body ()>

Returns the body of the response. 

=item B<status ()>

Returns the status code received from the RTSP server

=item B<status_message ()>

Returns the textual description of the status code received from the
RTSP server.

=item B<headers_array ()>

Returns an array of the RTSP headers received from the RTSP server.

=item B<headers_string>

Returns a string representation of the RTSP headers received from the
RTSP server.

=item B<get_header ( $header )>

Returns an array of values for the received response. 

=item B<reset ()>

You must call this prior to re-using an RTSP::Lite file handle,
otherwise the results are undefined.

=item B<local_addr ( $ip )>

=item B<local_port ( $port )>

Explicitly select the local IP address (default 0.0.0.0) and the local port (default 0: automatic selected by system).

=head1 EXAMPLES

rtsp-request: command line RTSP request tool
(http://www.kosho.org/tools/rtsp-request/).

sample scripts that included in the distribution file
  describe.pl
  play.pl

SETUP & PLAY sample
  #!/usr/bin/perl
  use RTSP::Lite;
  $url = "rtsp://192.168.0.1/realqt.mov";
  $rtsp = new RTSP::Lite;
  ## open the connection
  $req = $rtsp->open("192.168.0.1",554) or   die "Unable to open: $!";

  ## 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";
    }
  }

=head1 AUTHOR

Masaaki NABESHIMA <http://www.kosho.org/>

=head1 SEE ALSO

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

=head1 ACKNOWLEDGEMENTS

This module is a deviation of HTTP::Lite, maintained by Roy
Hooper. Without it this module never exist.

=head1 COPYRIGHT

Copyright (c) 2003, Masaaki NABESHIMA. 
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.


=head1 AVAILABILITY

The latest version of this module is available at: 
http://www.kosho.org/tools/rtsp-lite/

=cut