#!/usr/bin/env perl
# rtsp_server.pl --- 
# Author: Eduardo <eduardo@eduardors.net>
# Created: 2014/12/20 13:29:29
# Version: 0.0.1

use warnings;
use strict;
use Carp;

use IO::Socket::INET;

my @describe = ( 'RTSP/1.0 200 OK',
                 'CSeq: 2',
                 'Date: Fri, 05 Dec 2014 01:31:05 GMT',
                 'Content-Type: application/sdp',
                 'Content-Length: 309',
                 '',
                 'v=0',
                 'o=- 1417743065482550 4201396289678 IN IP4 %s',
                 's=RTSP Session',
                 't=0 0',
                 'i=',
                 'b=AS:2800',
                 'a=type:vod',
                 'a=range:npt=0-5457.661',
                 'c=IN IP4 %s',
                 'a=control:rtsp://%s:554/vod1_diascontadosV2PR.mpi',
                 'm=video 0 RTP/AVP 33',
                 'a=framerate:25.00',
                 'a=pmt:ArAdAALBAADh4fAAG+Hh8AAD4eLwBgoERVNQAJCKMR8=',
                 );

my @setup = ( 'RTSP/1.0 200 OK',
              'CSeq: 3',
              'Session: 3424382056990345778;timeout=180',
              'Transport: MP2T/H2221/UDP;unicast;destination=0.0;client_port=%d-%d',
              );

my @play = ( "RTSP/1.0 200 OK",
             "CSeq: 4",
             "Session: 3424382056990345778;timeout=180",
             "Scale: 1.0",
             "Range: npt=0.000-",
             "x-playNow:",
             "x-noFlush:",
             );

my @teardown = ( 'RTSP/1.0 200 OK',
                 'CSeq: 5',
                 'Session: 3424382056990345778;timeout=180',
                 'Scale: 1.0',
                 'Range: npt=0.000-',
                 'x-playNow:',
                 'x-noFlush:',
                 );

my $server_ip = shift || '192.168.100.33';
my ( $cip, $rtp_port, $rtcp_port ) = ( '192.168.200.33', 0, 0 );

my $ss = IO::Socket::INET->new( Listen    => 5,
                                LocalAddr => $server_ip,
                                LocalPort => 554,
                                Proto     => 'tcp',
                                Reuse     => 1,
                             )
        || die "Error al crear servidor: $!\n";

while ( 1 )
{
   my $cs = $ss->accept();
   my $cpid = fork();

   if ( 0 == $cpid )
   {
      server( $cs );
   }
   else
   {
      print "[*] father $$, child $cpid\n";
   }
}

$ss->close();

exit 0;

# ----------------------------------------------------------------------------

sub server
{
   my ( $cs ) = @_;
   my ( $m, $u, $p, $data );

   my $n = 0;
   while ( 1 )
   {
      $cs->recv( $data, 1024 );
 
      if ( $data =~ /^(\w+)\s+(rtsp[^ ]+)\s+(RTSP\/1\.0)/ )
      {
         $m = lc $1;
         $u = $2;
         $p = $3;
         printf "[%5d] %s %s %s\n", $$, $m, $u, $p;

         {
            no strict;
            &$m( $cs, $data );
         }
      }

      $data = '';
   }
}

# ----------------------------------------------------------------------------

sub describe
{
   my ( $cs, $data ) = @_;
   #my ( $cip, $sip ) = ($cs->peerhost(), $server_ip);
   printf "[%5d] describe tx\n", $$;
   my @tmp;
   foreach ( @describe )
   {
      $_ = sprintf "$_", $cip if /^o=/;
      $_ = sprintf "$_", $server_ip if /^c=/;
      $_ = sprintf "$_", $server_ip if /^a=control:rtsp/;
      push @tmp, $_;
   }
   tx( $cs, @tmp );
}

# ----------------------------------------------------------------------------

sub setup
{
   my ( $cs, $data ) = @_;
   printf "[%5d] setup tx\n", $$;
   $cip = $cs->peerhost();
   if ( $data =~ /client_port=(\d+)-(\d+)/ )
   {
      ( $rtp_port, $rtcp_port ) = ( $1, $2 );
   }
   my @tmp;
   foreach ( @setup )
   {
      $_ = sprintf "$_", $rtp_port, $rtcp_port if /^Transport/;
      push @tmp, $_;
   }
   tx( $cs, @tmp );
}

# ----------------------------------------------------------------------------

sub play
{
   my ( $cs, $data ) = @_;
   tx( $cs, @play );
   my $rtp_pid = fork();
   if ( 0 == $rtp_pid )
   {
      client_rtp( $cip, $rtp_port );
      exit 0;
   }
   print "[*] father $$, child $rtp_pid\n";
   waitpid $rtp_pid, 0;
}

# ----------------------------------------------------------------------------

sub teardown
{
   my ( $cs, $data ) = @_;
   printf "[%5d] teardown tx\n", $$;
   tx( $cs, @teardown );
   shutdown( $cs, 1 );
   exit 0;
}

# ----------------------------------------------------------------------------

sub tx
{
   my ( $s, @msg ) = @_;
   my $msg;

   $msg .= "$_\r\n" foreach @msg;
   $s->send( $msg );
}

# ----------------------------------------------------------------------------

sub client_rtp
{
   my ( $ip, $port ) = @_;

   my $rtp = IO::Socket::INET->new( PeerAddr => $ip,
                                    PeerPort => $port,
                                    Proto    => 'udp',
                                 )
             || die "Error connecting rtp server: $!\n";
   
   $rtp->send( "Hello world!" );

   shutdown( $rtp, 1 );

   $rtp->close();
   exit 0;
}

# ----------------------------------------------------------------------------

__END__

=head1 NAME

rtsp_setup_001.pl - Describe the usage of script briefly

=head1 SYNOPSIS

rtsp_setup_001.pl [options] args

      -opt --long      Option description

=head1 DESCRIPTION

Stub documentation for rtsp_setup_001.pl, 

=head1 AUTHOR

Eduardo, E<lt>eduardo@eduardors.netE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2014 by Eduardo

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.2 or,
at your option, any later version of Perl 5 you may have available.

=head1 CHANGES

 0.0.1  2014-12-20  Init version.

=head1 BUGS

None reported... yet.

=cut