POE::Component::Telephony::CTPort - Non-blocking telephony programming in Perl

	use POE qw(Compoent::Telephony::CTPort);

	POE::Session->create(
		inline_states => {
			_start => sub {
				my $kernel = $_[KERNEL];

				POE::Component::Telephony::CTPort->spawn({
					alias => 'ctport',
					port => 1,
				});

				$kernel->post(ctport => 'connect');
			},
			connected => sub {
				my $kernel = $_[KERNEL];

				print "connected to ctserver on port 1\n";
			},
			input => sub {
				my ($kernel, $in) = @_[KERNEL, ARG0];

				# all events are sent here, this is a good
				# spot to use Data::Dumper
				if ($in->{rly} eq 'ring') {
					$kernel->yield(ring => $in);
				}
			},
			ring => sub {
				my $kernel = $_[KERNEL];

				# pick up phone
				$kernel->post(ctport => 'off_hook');

				# play beep
				$kernel->post(ctport => play => 'beep');

				# record
				$kernel->post(ctport => record =>
					# to this file
					'prompt.wav',
					# for 15 seconds
					15,
					# or until they hit #
					'#',
					# or 3 seconds of silence
					3,
				);

				# play it back to them
				$kernel->post(ctport => play => 'prompt.wav');

				# play 3 beeps
				$kernel->post(ctport => play => 'beep beep beep');

				# hangup
				$kernel->post(ctport => 'on_hook');

				# shutdown
				$kernel->post(ctport => 'disconnect');
				$kernel->post(ctport => 'shutdown');
			},
		}
	);

	POE::Component::Telephony::CTPort->spawn({
		alias => 'ctport',
		port => 1 
	});

	{
		'src' => '3',
		'rly' => 'ctanswer',
		'args' => [
			'OK'
		],
		'dst' => '3',
		'argc' => '1'
	}

	rly=ctanswer src=3 dst=3 arg1=OK argc=1

package POE::Component::Telephony::CTPort;

use strict;

use vars qw($CTSERVER_RUN $VERSION $Default);

$VERSION = '0.03';

$CTSERVER_RUN = 0;

$Default = {
	DEBUG => 0,
	alias => 'ctport',
	ctserver => 'ctserver',
	paths => [],
	default_ext => '.au',
	hostname => 'localhost',
	port => 1,
	reply_to => undef,	# don't touch
	ignore_dtmf => 0,
	reconnect => 5,
	manager_port => undef,
	manager_d => -2,
};

use POE qw(Wheel::SocketFactory Wheel::ReadWrite Driver::SysRW Filter::Line Filter::Stream);
use Socket;
use Proc::ProcessTable;
use File::Basename qw(basename);
use IO::Pty; # for Wheel::Run as a pty

sub spawn {
	my ($class, $args) = @_;

	my $debug = $args->{DEBUG} || $Default->{DEBUG};
	
	print STDERR "spawn called\n" if ($debug);

	# skip ctserver spawn if already running
	if ($CTSERVER_RUN > 0 || $args->{no_ctserver_fork}) {
		print STDERR "skipping ctserver spawn, already running\n" if ($debug);
		#return _spawn($args);
		return $poe_kernel->post(ctserver => spawn => $args);
	}
	
	print STDERR "spawning ctserver\n" if ($debug);
	
	# only allow 1 session
	$CTSERVER_RUN = 1;
	
	POE::Session->create(
		heap => {
			args => $args,
			DEBUG => $debug,
			ctserver => ($args->{ctserver} || $Default->{ctserver}),
		},
		inline_states => {
			_start => sub {
				my ($kernel, $heap, $args) = @_[KERNEL, HEAP];
				
				# reply_to workaround
				$heap->{reply_to} = $_[SENDER]->ID;
				
				$kernel->sig('INT', 'signals');
				$kernel->sig('TERM', 'signals');
				
				$kernel->alias_set('ctserver');
		
				$heap->{name} = basename($heap->{ctserver});
		
				$heap->{retries} = 0;
				
				my $p = Proc::ProcessTable->new();
				my $t = $p->table();
				foreach my $i ( 0 .. $#{$t} ) {
					next unless (exists($t->[$i]->{fname})
						&& $t->[$i]->{fname} eq $heap->{name});
					
					print STDERR "ctserver already running at pid ".$t->[$i]->{pid}."\n" if ($heap->{DEBUG});
					$kernel->yield(_kill => TERM => $t->[$i]->{pid});
					$heap->{skip_wheel} = 1; # skip wheel setup
				}
				
				# don't kill me because this is hardcoded in ctserver :)
				my $pid;
				if (-e '/var/run/ctserver.pid') {
					open(FH,'/var/run/ctserver.pid');
					$pid = (<FH>)[0];
					close(FH);
				}
				
				if (defined $pid && $pid) {
					if (kill(0,$pid)) {
						print STDERR "ctserver already running\n" if ($heap->{DEBUG});
						# still runnnig
						return $kernel->yield(_kill => TERM => $pid);
					#} else {
						# XXX normal startup
						#print STDERR "ctserver already running, but not responding\n" if ($heap->{DEBUG});
						#return $kernel->yield(_kill => 9 => $pid);
					}
				}
				
				return if ($heap->{skip_wheel});
				
				$kernel->call($_[SESSION] => 'setup_wheel');
			},
			_kill => sub {
				my ($kernel, $heap, $sig, $pid) = @_[KERNEL, HEAP, ARG0, ARG1];

				if ($heap->{"_kill_$pid"}) {

					my $p = Proc::ProcessTable->new();
					my $t = $p->table();
					foreach my $i ( 0 .. $#{$t} ) {
						next unless (exists($t->[$i]->{fname})
							&& $t->[$i]->{fname} eq $heap->{name} && $pid == $t->[$i]->{pid});
						
						print STDERR "ctserver didn't respond to $sig at pid $pid\n" if ($heap->{DEBUG});
						
						if (kill(0,$pid)) {
							# still there...
							if ($sig eq '9') {
								# give up?
								die "cannot kill ctserver at pid $pid!";
							} else {
								$sig = '9';
								kill($sig,$pid);
								# recheck in 5 seconds
								return $kernel->delay_set(_kill => 5 => '9' => $pid);
							}
						}
					}	
				
					delete $heap->{"_kill_$pid"};
				
					# ok, its gone, continue startup
					return $kernel->call($_[SESSION] => 'setup_wheel');
				} else {
					$heap->{"_kill_$pid"} = time();
					
					# DIE DIE DIE!
					kill($sig,$pid);
					
					print STDERR "sending $sig to pid $pid\n" if ($heap->{DEBUG});
					
					# recheck in 5 seconds
					$kernel->delay_set(_kill => 5 => $sig => $pid);
				}
			},
			_stop => sub {
				print STDERR "ctserver session ended\n" if $_[HEAP]->{DEBUG};
			},
			setup_wheel => sub {
				my ($kernel, $heap) = @_[KERNEL, HEAP];

				return if ($heap->{ctserver_wheel});

				if ($heap->{retries} >= 5) {
					warn 'too many restarts of the ctserver wheel, ctserver running already?';
					return;
				}

				print STDERR "setting up ctserver wheel\n" if ($heap->{DEBUG});

				$heap->{ctserver_wheel} = POE::Wheel::Run->new(
					# What we will run in the separate process
					Program			=>  $heap->{ctserver},
					Conduit			=> 'pty',
					#ProgramArgs	=> ["--log $ENV{PWD}/log"],
					# Redirect errors to our error routine
					ErrorEvent		=>  'child_error',
					# Send child died to our child routine
					CloseEvent		=>  'child_closed',
					# Send input from child
					StdoutEvent		=>  'child_STDOUT',
					
					# STDERR not usable for 
					# Send input from child STDERR
					#StderrEvent	=>  'child_STDERR',
					# Set our filters
					#StdinFilter	=>	POE::Filter::Line->new(),
					StdoutFilter	=>	POE::Filter::Line->new(),
					#StderrFilter	=>  POE::Filter::Line->new(),
				);
					
				$heap->{retries}++;
				
				# Check for errors
				if ( ! defined $heap->{ctserver_wheel} ) {
					warn 'Unable to create ctserver wheel';
					$kernel->yield('setup_wheel');
				} else {
					print STDERR "ctserver wheel is up\n" if ($heap->{DEBUG});
				}
			},
			signals => sub {
				my ($kernel, $heap, $signal) = @_[KERNEL,HEAP,ARG0];
			
				return undef unless ($signal eq 'INT' || $signal eq 'TERM');
				
				$heap->{int}++;
				if ($heap->{int} > 1) {
					print "ok, ok, bye!\n";
					exit;
				}
				print "INT signal received, please wait, closing ctserver...\n";
				$kernel->sig_handled();
				$kernel->alarm_remove_all();
				$kernel->call($_[SESSION] => 'shutdown');
				
				return undef;
			},
			shutdown => sub {
				my ($kernel, $heap) = @_[KERNEL, HEAP];
				
				return if ($heap->{shutdown});
				
				$heap->{shutdown} = 1;	

				$kernel->alarm_remove_all();
			
				if (ref($heap->{children}) eq 'HASH') {
					foreach my $c (keys %{$heap->{children}}) {
						print STDERR "telling session $c to shutdown\n" if ($heap->{DEBUG});
						$kernel->call($c => '_shutdown');
					}
				}
				
			},
			drop_wheel => sub {
				my ($kernel, $heap) = @_[KERNEL, HEAP];
			
				if ($heap->{ctserver_wheel}) {
					$heap->{ctserver_wheel}->kill('TERM');
				}
				delete $heap->{ctserver_wheel};
				$kernel->call(ct_man_port => '_shutdown');	
				$kernel->alias_remove();
			},
			'child_error' => sub {
				my ( $operation, $errnum, $errstr ) = @_[ ARG0 .. ARG2 ];
				print STDERR "ctserver got an $operation error $errnum: $errstr\n" if ($_[HEAP]->{DEBUG});
			},
			'child_closed' => sub {
				my ($kernel, $heap) = @_[KERNEL,HEAP];
		
				print STDERR "ctserver wheel closed\n" if ($heap->{DEBUG});
		
				return if ($heap->{shutdown});

				# Emit debugging information
				warn 'ctserver\'s Wheel died! Restarting it...';
	
				# Create the wheel again
				delete $heap->{ctserver_wheel};
				$kernel->call($_[SESSION] => 'setup_wheel');
			},
			'child_STDOUT' => sub {
				my ($kernel, $heap, $input) = @_[KERNEL,HEAP,ARG0];
				
				print STDERR "ctserver Got STDOUT ( $input )\n" if ($heap->{DEBUG});
				
				# when the server is ready to accept connections, then spawn the client to connect
				if ($CTSERVER_RUN == 1 && $input =~ m/Started!/) {
					$CTSERVER_RUN++;
					# internal manager
					$kernel->yield(spawn => {
						DEBUG => $heap->{DEBUG},
						alias => 'ct_man_port',
						reconnect => 1,
						manager_port => 1198,
						manager_d => 1
					});
					# the requested port connect
					$kernel->yield(spawn => $heap->{args});
				} elsif ($input =~ m/Address already in use Giving up/) {
					# TODO search for pid first...
					system("killall -9 ctserver");
				}
			},
			'child_STDERR' => sub {
				my $input = $_[ARG0];
	
				# Skip empty lines 
				if ( $input eq '' ) { return }
	
				print STDERR "ctserver Got STDERR ( $input )\n" if ($_[HEAP]->{DEBUG});
			},
			spawn => sub {
				# reply_to workaround
				if (!$_[ARG0]->{reply_to}) {
					$_[ARG0]->{reply_to} = $_[HEAP]->{reply_to};
				}
				_spawn($_[ARG0]);
			},
			_child => sub {
				print STDERR "ctserver child $_[ARG0] session_id:".$_[ARG1]->ID."\n" if ($_[HEAP]->{DEBUG});
				if ($_[ARG0] eq 'create') {
					#my $s = $_[KERNEL]->alias_resolve('ct_man_port');
					#if (ref($s) && $s->ID != $_[ARG1]->ID) {
						$_[HEAP]->{children}{$_[ARG1]->ID} = 1;
					#}
				} elsif ($_[ARG0] eq 'lose') {
					delete $_[HEAP]->{children}{$_[ARG1]->ID};
				}
			},
		},
	);
}

sub _spawn {
	my $args = shift;
	POE::Session->create(
		args => [ $args ],
		package_states => [
			'POE::Component::Telephony::CTPort' => [qw(
				_start
				_stop
				_sock_up
				_sock_failed
				_sock_down
				_shutdown

				put
				connect	
				disconnect
				reconnect
		
				input
	
				off_hook
				on_hook
				wait_for_ring
				wait_for_dial_tone
				play_tone
				stop_tone
				play_stop
				play
				_play
				record
				record_stop
				sleep
				clear
				clear_events
				collect
				dial
				wait_for_event
				start_timer
				stop_timer
				join
				bridge
				unbridge
				join_conference
				leave_conference
				start_ring
				stop_ring
				ring_once	
				grunt_on
				grunt_off
				default_ext
				ignore_dtmf
				set_script_name
				send_cid
				listen_for_cid_jp
				listen_for_cid
				read_cid
			
				port_reset
				port_status
				roll_log
				ser_version
				shutdown
			)],
		],
	);
}


sub _start {
	my ($kernel, $heap, $sender, $args) = @_[KERNEL, HEAP, SENDER, ARG0];
	
	$heap->{$_} = $args->{$_} || $Default->{$_} foreach
		qw(DEBUG alias paths default_ext reply_to ignore_dtmf hostname port reconnect manager_port manager_d);

	$heap->{DEBUG} && do {
		print STDERR "params:\n";
		foreach my $h (keys %$heap) {
			print STDERR "$h = $heap->{$h}\n";
		}
	};
	
	$kernel->alias_set($heap->{alias});
#	$kernel->refcount_increment($sender->ID, __PACKAGE__);
	$heap->{reply} = $heap->{reply_to} || $sender->ID;
	$kernel->yield('connect');
}

sub _stop {
	print STDERR "ctport session ended\n" if $_[HEAP]->{DEBUG};
}

sub _sock_up {
	my ($kernel, $heap, $socket) = @_[KERNEL, HEAP, ARG0];
	
	print STDERR "sock up for session ".$_[SESSION]->ID."\n" if ($heap->{DEBUG});
	
	$heap->{sock} = POE::Wheel::ReadWrite->new(
		Handle => $socket,
		Driver => POE::Driver::SysRW->new(),
		Filter => POE::Filter::Line->new(Literal => "\n"),
		ErrorEvent => '_sock_down',
		InputEvent => 'input',
	);
	
	$kernel->post($heap->{reply} => 'connected' => splice(@_,ARG0));
}

sub _sock_failed {
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	
	print STDERR "sock failed for session ".$_[SESSION]->ID."\n" if ($heap->{DEBUG});
	
	delete $heap->{sock};
	return if ($heap->{shutdown});
	
	$kernel->post($heap->{reply} => 'socket_error' => splice(@_,ARG0));
	
	if (defined $heap->{reconnect}) {
		$kernel->delay_set('reconnect' => $heap->{reconnect});
	}
}

# sigh, repeat code..
sub _sock_down {
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	
	print STDERR "sock down for session ".$_[SESSION]->ID."\n" if ($heap->{DEBUG});
	
	delete $heap->{sock};
	return if ($heap->{shutdown});
	
	$kernel->post($heap->{reply} => 'disconnected' => splice(@_,ARG0));

	if (defined $heap->{reconnect}) {
		$kernel->delay_set('reconnect' => $heap->{reconnect});
	}
}

sub _shutdown {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$heap->{shutdown} = 1;
	
	print STDERR "_shutdown called on session ".$_[SESSION]->ID."\n" if ($heap->{DEBUG});

	$kernel->call(ct_man_port => send_event => $heap->{port} => 'SHUTTING_DOWN');
	$kernel->call($_[SESSION] => 'on_hook');
	#$kernel->call($_[SESSION] => 'shutdown');
}

sub reconnect {
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	
	print STDERR "reconnect called\n" if ($heap->{DEBUG});
	
	return unless (defined $heap->{hostname} && defined $heap->{port});

	print STDERR "reconnecting to $heap->{hostname} $heap->{port}\n" if ($heap->{DEBUG});

	delete $heap->{sock};
	
	$kernel->yield('connect' => {
		hostname => $heap->{hostname},
		port => $heap->{port},
	});
}

sub put {
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	return unless ($heap->{sock});
	if (ref($heap->{sock}) eq 'POE::Wheel::SocketFactory') {
		# not connected yet!
		print STDERR "not connected yet, queueing command until connect\n" if ($heap->{DEBUG});
		$_[KERNEL]->delay_set(put => 1 => splice(@_,ARG0));
		return;
	}
	my $line = $_[ARG0];
	if ($line !~ m/ $/) {
		$line .= " ";
	}
	$heap->{sock}->put($line);
	print STDERR "put: '$line'\n" if ($heap->{DEBUG});
}

sub input {
	my ($kernel, $heap, $input) = @_[KERNEL, HEAP, ARG0];

	$input =~ s/\0//g;
	
	my %in;
	foreach (split(/ /,$input)) {
		my ($k,$v) = split(/=/);
		if ($k =~ m/^arg(\d+)/) {
			$in{args}->[($1-1)] = $v;
		} else {
			$in{$k} = $v;
		}
	}

	$kernel->post($heap->{reply} => 'ct_input' => \%in => $input);
}

sub connect {
	my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
	$heap->{$_} = $args->{$_} || $heap->{$_} foreach qw(hostname port);

#	return if $heap->{sock};
	
	my $conport = $heap->{port} + 1199;
	
	$heap->{handle} = $heap->{port} - 1;
	$heap->{d_handle} = $heap->{port} - 1;
	
	if ($heap->{manager_port} && $heap->{manager_port} > 0) {
		$conport = $heap->{manager_port};
		$heap->{port} = -2;
		$heap->{handle} = -2;
		$heap->{d_handle} = $heap->{manager_d};
	}
	
	$heap->{sock} = POE::Wheel::SocketFactory->new(
		SocketDomain => AF_INET,
		SocketType => SOCK_STREAM,
		SocketProtocol => 'tcp',
		RemoteAddress => $heap->{hostname},
		RemotePort => $conport,
		SuccessEvent => '_sock_up',
		FailureEvent => '_sock_failed',
	);
}

sub disconnect {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	delete $heap->{sock};
}

#	"ctanswer"
#		SUMMARY:	takes the port off hook [non-blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub off_hook {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctanswer src=%d dst=%d argc=0',$heap->{handle},$heap->{d_handle}));
}

#	"cthangup"
#		SUMMARY:	places the port on hook [non-blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub on_hook {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=cthangup src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

#	"ctwaitforring"
#		SUMMARY: 	Waits for a ring event and returns the caller ID if
#				available [blocking]
#		ARGS: 		arg1=<number of rings to wait for (def 2)>
#		RETURN ARGS: 	arg1=[OK|ERROR|EVENT]
#				arg2=<Caller ID>
#				arg3=<event>

sub wait_for_ring {
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	my $rings = $_[ARG0] || 2;
	my $ird = $_[ARG1] || 0;

	$kernel->yield(put =>
		sprintf('cmd=ctwaitforring src=%d dst=%d arg1=%d arg2=%s argc=2',
		$heap->{handle},$heap->{d_handle},$rings,$ird));
}

#	"ctwaitfordial"
#		SUMMARY:	Waits for a dialtone for a max of 10 seconds [blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub wait_for_dial_tone {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctwaitfordial src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

#	"ctplaytoneasync"
#		SUMMARY:	plays a tone asyncronously [non-blocking]
#		ARGS: 		arg1=<tone type>
#		RETURN ARGS:	arg1=[OK|ERROR]

sub play_tone {
	my ($kernel, $heap, $type) = @_[KERNEL, HEAP, ARG0];
	$type = lc($type);
	
	my $found = 0;
	foreach my $t (qw(busy dialx dial ringback)) {
		$found = 1 if ($type eq $t);
	}
	unless ($found) {
		warn "play_tone: ctserver does not support tone $type";
		return;
	}

	$kernel->yield(put => sprintf('cmd=ctplaytoneasync src=%d dst=%d arg1=%s argc=1',
		$heap->{handle},$heap->{d_handle},$type));
}

#	"ctstoptone"
#		SUMMARY:	stops an asynronous tone playing [non-blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub stop_tone {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctstoptone src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

#	"ctplay_stop"
#		SUMMARY:	Stops an asyncronous play [non-blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub play_stop {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctplay_stop src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

# see below for $async flag 
sub play {
	my ($kernel, $files, $async) = @_[KERNEL, ARG0, ARG1];

	return unless ($files);
	
	$files = join(' ',@{$files}) if (ref($files) eq 'ARRAY');

	foreach my $f (split(/ /,$files)) {
		$kernel->yield(_play => $f => $async);
	}
}

#	"ctplay"
#		SUMMARY:	Plays a file and deals with events [blocking]
#		ARGS: 		arg1=<file to play>
#		RETURN ARGS:	arg1=[OK|ERROR|EVENT]
#				arg2=<digits>
#				arg3=<event>
#
#	"ctplay_async"
#		SUMMARY:	Plays a file asyncronously [non-blocking]
#		ARGS: 		arg1=<file to play>
#		RETURN ARGS:	arg1=[OK|ERROR]

sub _play {
	my ($kernel, $heap, $file, $async) = @_[KERNEL, HEAP, ARG0, ARG1];

	# TODO verify this works
	unless ($file =~ m/\./) {
		$file .= $heap->{default_ext};
	}
	my @path;

	if ($file =~ /^\//) {
		push(@path,$file);
	}

	# user supplied paths
	if ($heap->{paths}) {
		my $pt = $heap->{paths};
		for my $i ( 0 .. $#{$pt} ) {
			# make sure there's a slash on the end
			$pt->[$i] .= "/" unless ($pt->[$i] =~ m/\/$/);
			$pt->[$i] .= $file;
		}
		push(@path,@{$pt});
	}
	# undocumented feature...search only supplied path
	# TODO doc this
	unless ($heap->{paths_only}) {
		# current directory (at program start)
		push(@path,"$ENV{PWD}/$file");
		# prompts subdir
		push(@path,"$ENV{PWD}/prompts/$file");
		# default ctserver english (use 'paths' above to avoid english)
		push(@path,"/var/ctserver/USEngM/$file");
	}
	
	foreach my $p (@path) {
		if (-e "$p") {
			my ($extra,$num) = ('',1);
			# check for the ignore dtmf option
			if ($heap->{ignore_dtmf}) {
				$extra = ' arg2=ignore_dtmf';
				$num = 2;
			}
			if (defined($async)) {
				$kernel->yield(put => sprintf('cmd=ctplayasync src=%d dst=%d arg1=%s%s argc=%d',
					$heap->{handle},$heap->{d_handle},$p,$extra,$num));
			} else {
				$kernel->yield(put => sprintf('cmd=ctplay src=%d dst=%d arg1=%s%s argc=%d',
					$heap->{handle},$heap->{d_handle},$p,$extra,$num));
			}
			return;
		}
	}
	
	warn "play: File(s) not found: ".join(';',@path);
}

#	"ctrecord"
#		SUMMARY:	Records audio to a file [blocking]
#		ARGS: 		arg1=<file to record to>
#				arg2=<time out>
#				arg3=<terminating digits>
#				arg4=<silence timeout>
#		RETURN ARGS:	arg1=[OK|ERROR|EVENT]
#				arg2=<digits>
#				arg3=<event>

sub record {
	my ($kernel, $heap, $file) = @_[KERNEL, HEAP, ARG0];
	
	# TODO does duration 0 mean until a digit is pressed?
	my $timeout = @_[ARG1] || 0;
	my $digits = @_[ARG2] || '';
	my $silence = @_[ARG3] || 0;

	if ($file !~ m/^\//) {
		$file = "$ENV{PWD}/$file";
	}

	$kernel->yield(put => sprintf('cmd=ctrecord src=%d dst=%d arg1=%s arg2=%d arg3=%s arg4=%d argc=4',
		$heap->{handle},$heap->{d_handle},$file,$timeout,$digits,$silence));
}

sub record_stop {
	my ($kernel, $heap, $file) = @_[KERNEL, HEAP, ARG0];
	
	# since ctserver doesn't have a direct way to call vpb_record_terminate, we use this work around
	# a user message sent to the port while recording causes it to stop

	$kernel->post(ct_man_port => send_event => $heap->{port} => 'RECORD_STOP');
}

#	"ctsleep"
#		SUMMARY:	Sleep for N seconds [blocking]
#		ARGS: 		arg1=<seconds>
#		RETURN ARGS:	arg1=[OK|ERROR|EVENT]
#				arg2=<digits>
#				arg3=<event>

sub sleep {
	my ($kernel, $heap, $secs) = @_[KERNEL, HEAP, ARG0];

	unless ($secs =~ m/^\d+$/) {
		warn "sleep: Seconds must be a number, ie '2' not 'two' :)";
		return;
	}
	
	$kernel->yield(put => sprintf('cmd=ctsleep src=%d dst=%d arg1=%d argc=1',
		$heap->{handle},$heap->{d_handle},$secs));
}

#	"ctclear"
#		SUMMARY:	Clears the digit buffer [non-blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub clear {
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	
	$kernel->yield(put => sprintf('cmd=ctclear src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
	delete $heap->{buffer};
}

#	"ctclearevents"
#		SUMMARY:	Clears the event queue [non-blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub clear_events {
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	
	$kernel->yield(put => sprintf('cmd=ctclearevents src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

#	"ctcollect"
#		SUMMARY:	Collects digits [blocking]
#		ARGS: 		arg1=<number of digits to collect>
#				arg2=<time out>
#				arg3=<inter digit delay>
#		RETURN ARGS:	arg1=[OK|ERROR|EVENT]
#				arg2=<digits>
#				arg3=<event>

# XXX hmm, how do we do this in an event model?
sub collect {
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	my $maxdigits = $_[ARG0] || 0;
	my $maxseconds  = $_[ARG1] || 0;
	my $maxinter = $_[ARG2] || 0;
	
	$kernel->yield(put => sprintf('cmd=ctcollect src=%d dst=%d arg1=%d arg2=%d arg3=%d argc=3',
		$heap->{handle},$heap->{d_handle},$maxdigits,$maxseconds,$maxinter));
}

#	"ctdial"
#		SUMMARY:	Dials a string of digits [blocking]
#		ARGS: 		arg1=<digits to dial>
#		RETURN ARGS:	arg1=[OK|ERROR|EVENT]
#				arg2=<event>

sub dial {
	my ($kernel, $heap, $dial) = @_[KERNEL, HEAP, ARG0];

	#$dial =~ s/\D//g;
	
	$kernel->yield(put => sprintf('cmd=ctdial src=%d dst=%d arg1=%s argc=1',
		$heap->{handle},$heap->{d_handle},$dial));
}

#	"ctwaitforevent"
#		SUMMARY:	waits for an event [blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]
#				arg2=<event>

sub wait_for_event {
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	
	$kernel->yield(put => sprintf('cmd=ctwaitforevent src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

#	"ctsendevent"
#		SUMMARY:	sends an event/message to another port [non-blocking]
#		ARGS: 		arg1=<message>
#				...
#				arg9=<message>
#		RETURN ARGS:	arg1=[OK|ERROR]

sub send_event {
	my ($kernel, $heap, $port, $msg) = @_[KERNEL, HEAP, ARG0, ARG1];
	
	$kernel->yield(put => sprintf('cmd=ctsendevent src=%d dst=%d arg1=%s argc=1',
		$heap->{handle},$port,$msg));
}

#	"ctstarttimerasync"
#		SUMMARY:	starts an asyncronous timer [non-blocking]
#		ARGS: 		arg1=<time in seconds>
#		RETURN ARGS:	arg1=[OK|ERROR]

sub start_timer {
	my ($kernel, $heap, $secs) = @_[KERNEL, HEAP, ARG0];
	
	$kernel->yield(put => sprintf('cmd=ctstarttimerasync src=%d dst=%d arg1=%d argc=1',
		$heap->{handle},$heap->{d_handle},$secs));
}

#	"ctstoptimer"
#		SUMMARY:	stops an asyncronous timer [non-blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub stop_timer {
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	
	$kernel->yield(put => sprintf('cmd=ctstoptimer src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

#	"ctjoin"
#		SUMMARY:	bridges two ports [non-blocking]
#		ARGS: 		arg1=<first port>
#				arg2=<second port>
#		RETURN ARGS:	arg1=[OK|ERROR]

sub join {
	my ($kernel, $heap, $port1, $port2) = @_[KERNEL, HEAP, ARG0, ARG1];

	$kernel->yield(put => sprintf('cmd=ctjoin src=%d dst=%d arg1=%d arg2=%d argc=2',
		$heap->{handle},$heap->{d_handle},$port1,$port2));
}

#	"ctbridge"
#		SUMMARY:	hardware bridges this port with one supplied [non-blocking]
#		ARGS: 		arg1=<other port>
#		RETURN ARGS:	arg1=[OK|ERROR]

sub bridge {
	my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0];

	$kernel->yield(put => sprintf('cmd=ctbridge src=%d dst=%d arg1=%d argc=1',
		$heap->{handle},$heap->{d_handle},$port));
}

#	"ctunbridge"
#		SUMMARY:	Unbridges this port with one supplied [non-blocking]
#		ARGS: 		arg1=<other port>
#		RETURN ARGS:	arg1=[OK|ERROR]

sub unbridge {
	my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0];

	$kernel->yield(put => sprintf('cmd=ctunbridge src=%d dst=%d arg1=%d argc=1',
		$heap->{handle},$heap->{d_handle},$port));
}

#	"ctjoinconference"
#		SUMMARY:	Joins a port to a conference.
#		ARGS:		arg1=<other port>
#		RETURN ARGS:	arg1=[OK|ERROR]

sub join_conference {
	my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0];

	$kernel->yield(put => sprintf('cmd=ctjoinconference src=%d dst=%d arg1=%d argc=1',
		$heap->{handle},$heap->{d_handle},$port));
}

#	"ctleaveconference"
#		SUMMARY:	Removes a port from a conference.
#		ARGS:		arg1=<other port>
#		RETURN ARGS:	arg1=[OK|ERROR]

sub leave_conference {
	my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0];

	$kernel->yield(put => sprintf('cmd=ctleaveconference src=%d dst=%d arg1=%d argc=1',
		$heap->{handle},$heap->{d_handle},$port));
}

#	"ctstartringasync"
#		SUMMARY:	Starts this port ringing [non-blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub start_ring {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctstartringasync src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

#	"ctstopring"
#		SUMMARY:	Stops this port from ringing [non-blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub stop_ring {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctstopring src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

#	"ctstartringonceasync"
#		SUMMARY:	Ring this port once [non-blocking]
#		ARGS: 		none
#		RETURN ARGS:	arg1=[OK|ERROR]

sub ring_once {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctstartringonceasync src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

sub grunt_on {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctgrunton src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

sub grunt_off {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctgruntoff src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

sub default_ext {
	my ($kernel, $heap, $arg) = @_[KERNEL, HEAP, ARG0];

	unless (defined($arg)) {
		warn 'You must specify an extension to default_ext';
		return;
	}

	if ($arg !~ m/^\./) {
		$arg = ".$arg";
	}
	
	$heap->{default_ext} = $arg;
}

sub ignore_dtmf {
	my ($kernel, $heap, $arg) = @_[KERNEL, HEAP, ARG0];

	unless (defined($arg)) {
		warn 'You must specify \'on\' / \'off\' or 1 / 0 to ignore_dtmf';
		return;
	}
	
	$heap->{ignore_dtmf} = ($arg =~ m/on/i || $arg =~ m/^1$/) ? 1 : 0;
}

# WTF is this useful for?

sub set_script_name {
	my ($kernel, $heap, $name) = @_[KERNEL, HEAP, ARG0];

	$kernel->yield(put => sprintf('cmd=ctsetscript src=%d dst=%d arg1=%s argc=1',
		$heap->{handle},$heap->{d_handle},$name));
}

sub send_cid {
	my ($kernel, $heap, $number, $name) = @_[KERNEL, HEAP, ARG0, ARG1];

	$number =~ tr/\D//;

	$kernel->yield(put => sprintf('cmd=ctsetscript src=%d dst=%d arg1=%d arg2=%s argc=2',
		$heap->{handle},$heap->{d_handle},$number,$name));
}

# XXX you shouldn't have to do the timing yourself
# what is the dif between the jpcid and just cid cmds?

sub listen_for_cid_jp {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctlistenforjpcid src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

sub listen_for_cid {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctlistenforcid src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

sub read_cid {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=ctreadcid src=%d dst=%d argc=0',
		$heap->{handle},$heap->{d_handle}));
}

# XXX management commands

#	"portreset"
#		SUMMARY:	Reset a port
#		DST:		<port>
#		ARGS:		none
#		RETURN ARGS:	none

sub port_reset {
	my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0];

	$kernel->yield(put => sprintf('cmd=portstatus src=%d dst=%d argc=0',
		$heap->{handle},$port));
}

#	"portstatus"
#		SUMMARY:        Querys server for status of each port
#		DST:            -2 [mandatory]
#		ARGS:           none
#		RETURN ARGS:    none

# XXX I was reading server.cpp... you CAN send portstatus to a port to
# get the status for 1 port or send portstatus to the manager and get
# the status for all ports

sub port_status {
	my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0];

	# -2 means all
	$port = (defined($port)) ? $port : -2;
	
	$kernel->yield(put => sprintf('cmd=portstatus src=%d dst=%d argc=0',
		$heap->{handle},$port));
}

#	"rolllog"
#		SUMMARY:        Close current  ctserver log and open new log with current date
#		DST:            -2 [mandatory]
#		ARGS:           none
#		RETURN ARGS:    none

sub roll_log {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=rolllog src=%d dst=-2 argc=0',
		$heap->{handle}));
}

#	"serversion"
#		SUMMARY:	Querys server for CVS identification strings
#		DST:		-2 [mandatory]
#		ARGS:		none
#		RETURN ARGS:	none

sub ser_version {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=serversion src=%d dst=-2 argc=0',
		$heap->{handle}));
}

#	"shutdown"
#		SUMMARY:	Shutdown server.
#		DST:		-2 [mandatory]
#		ARGS:		none
#		RETURN ARGS:	none

sub shutdown {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	$kernel->yield(put => sprintf('cmd=shutdown src=%d dst=-2 argc=0',
		$heap->{handle}));
	$kernel->alarm_remove_all();
	$kernel->alias_remove();
}

1;
__END__