WebSVN - Projects - Blame - Rev 825 - /MissionCockpit/tags/V0.5.3/perl/lib/Win32/SerialPort.pm

Rev	Author	Line No.	Line
825	-	1	package Win32::SerialPort;
		2
		3	use Win32;
		4	use Win32API::CommPort qw( :STAT :PARAM 0.17 );
		5
		6	use Carp;
		7	use strict;
		8
		9	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
		10	$VERSION = '0.19';
		11
		12	require Exporter;
		13	## require AutoLoader;
		14
		15	@ISA = qw( Exporter Win32API::CommPort );
		16	# Items to export into callers namespace by default. Note: do not export
		17	# names by default without a very good reason. Use EXPORT_OK instead.
		18	# Do not simply export all your public functions/methods/constants.
		19
		20	@EXPORT= qw();
		21	@EXPORT_OK= @Win32API::CommPort::EXPORT_OK;
		22	%EXPORT_TAGS = %Win32API::CommPort::EXPORT_TAGS;
		23
		24	# parameters that must be included in a "save" and "checking subs"
		25
		26	my %validate = (
		27	ALIAS => "alias",
		28	BAUD => "baudrate",
		29	BINARY => "binary",
		30	DATA => "databits",
		31	E_MSG => "error_msg",
		32	EOFCHAR => "eof_char",
		33	ERRCHAR => "error_char",
		34	EVTCHAR => "event_char",
		35	HSHAKE => "handshake",
		36	PARITY => "parity",
		37	PARITY_EN => "parity_enable",
		38	RCONST => "read_const_time",
		39	READBUF => "set_read_buf",
		40	RINT => "read_interval",
		41	RTOT => "read_char_time",
		42	STOP => "stopbits",
		43	U_MSG => "user_msg",
		44	WCONST => "write_const_time",
		45	WRITEBUF => "set_write_buf",
		46	WTOT => "write_char_time",
		47	XOFFCHAR => "xoff_char",
		48	XOFFLIM => "xoff_limit",
		49	XONCHAR => "xon_char",
		50	XONLIM => "xon_limit",
		51	intr => "is_stty_intr",
		52	quit => "is_stty_quit",
		53	s_eof => "is_stty_eof",
		54	eol => "is_stty_eol",
		55	erase => "is_stty_erase",
		56	s_kill => "is_stty_kill",
		57	bsdel => "stty_bsdel",
		58	clear => "is_stty_clear",
		59	echo => "stty_echo",
		60	echoe => "stty_echoe",
		61	echok => "stty_echok",
		62	echonl => "stty_echonl",
		63	echoke => "stty_echoke",
		64	echoctl => "stty_echoctl",
		65	istrip => "stty_istrip",
		66	icrnl => "stty_icrnl",
		67	ocrnl => "stty_ocrnl",
		68	opost => "stty_opost",
		69	igncr => "stty_igncr",
		70	inlcr => "stty_inlcr",
		71	onlcr => "stty_onlcr",
		72	isig => "stty_isig",
		73	icanon => "stty_icanon",
		74	DVTYPE => "devicetype",
		75	HNAME => "hostname",
		76	HADDR => "hostaddr",
		77	DATYPE => "datatype",
		78	CFG_1 => "cfg_param_1",
		79	CFG_2 => "cfg_param_2",
		80	CFG_3 => "cfg_param_3",
		81	);
		82
		83	# parameters supported by the stty method
		84
		85	my %opts = ( "intr" => "is_stty_intr:argv_char",
		86	"quit" => "is_stty_quit:argv_char",
		87	"eof" => "is_stty_eof:argv_char",
		88	"eol" => "is_stty_eol:argv_char",
		89	"erase" => "is_stty_erase:argv_char",
		90	"kill" => "is_stty_kill:argv_char",
		91	"echo" => "stty_echo:1",
		92	"-echo" => "stty_echo:0",
		93	"echoe" => "stty_echoe:1",
		94	"-echoe" => "stty_echoe:0",
		95	"echok" => "stty_echok:1",
		96	"-echok" => "stty_echok:0",
		97	"echonl" => "stty_echonl:1",
		98	"-echonl" => "stty_echonl:0",
		99	"echoke" => "stty_echoke:1",
		100	"-echoke" => "stty_echoke:0",
		101	"echoctl" => "stty_echoctl:1",
		102	"-echoctl" => "stty_echoctl:0",
		103	"istrip" => "stty_istrip:1",
		104	"-istrip" => "stty_istrip:0",
		105	"icrnl" => "stty_icrnl:1",
		106	"-icrnl" => "stty_icrnl:0",
		107	"ocrnl" => "stty_ocrnl:1",
		108	"-ocrnl" => "stty_ocrnl:0",
		109	"igncr" => "stty_igncr:1",
		110	"-igncr" => "stty_igncr:0",
		111	"inlcr" => "stty_inlcr:1",
		112	"-inlcr" => "stty_inlcr:0",
		113	"onlcr" => "stty_onlcr:1",
		114	"-onlcr" => "stty_onlcr:0",
		115	"opost" => "stty_opost:1",
		116	"-opost" => "stty_opost:0",
		117	"isig" => "stty_isig:1",
		118	"-isig" => "stty_isig:0",
		119	"icanon" => "stty_icanon:1",
		120	"-icanon" => "stty_icanon:0",
		121	"parenb" => "parity_enable:1",
		122	"-parenb" => "parity_enable:0",
		123	"inpck" => "parity_enable:1",
		124	"-inpck" => "parity:none",
		125	"cs5" => "databits:5",
		126	"cs6" => "databits:6",
		127	"cs7" => "databits:7",
		128	"cs8" => "databits:8",
		129	"cstopb" => "stopbits:2",
		130	"-cstopb" => "stopbits:1",
		131	"parodd" => "parity:odd",
		132	"-parodd" => "parity:even",
		133	"clocal" => "handshake:none",
		134	"-clocal" => "handshake:dtr",
		135	"crtscts" => "handshake:rts",
		136	"-crtscts" => "handshake:none",
		137	"ixon" => "handshake:xoff",
		138	"-ixon" => "handshake:none",
		139	"ixoff" => "handshake:xoff",
		140	"-ixoff" => "handshake:none",
		141	"start" => "xon_char:argv_char",
		142	"stop" => "xoff_char:argv_char",
		143	);
		144
		145	#### Package variable declarations ####
		146
		147	my @binary_opt = (0, 1);
		148	my @byte_opt = (0, 255);
		149
		150	my $cfg_file_sig="Win32::SerialPort_Configuration_File -- DO NOT EDIT --\n";
		151
		152	my $Verbose = 0;
		153
		154	# test*.t only - suppresses default messages
		155	sub set_test_mode_active {
		156	return unless (@_ == 2);
		157	Win32API::CommPort->set_no_messages($_[1]);
		158	# object not defined but :: upsets strict
		159	return (keys %validate);
		160	}
		161
		162	sub new {
		163	my $proto = shift;
		164	my $class = ref($proto) \|\| $proto;
		165	my $device = shift;
		166	my @new_cmd = ($device);
		167	my $quiet = shift;
		168	if ($quiet) {
		169	push @new_cmd, 1;
		170	}
		171	my $self = $class->SUPER::new(@new_cmd);
		172
		173	unless ($self) {
		174	return 0 if ($quiet);
		175	return;
		176	}
		177
		178	# "private" data
		179	$self->{"_DEBUG"} = 0;
		180	$self->{U_MSG} = 0;
		181	$self->{E_MSG} = 0;
		182	$self->{OFS} = "";
		183	$self->{ORS} = "";
		184	$self->{"_T_INPUT"} = "";
		185	$self->{"_LOOK"} = "";
		186	$self->{"_LASTLOOK"} = "";
		187	$self->{"_LASTLINE"} = "";
		188	$self->{"_CLASTLINE"} = "";
		189	$self->{"_SIZE"} = 1;
		190	$self->{"_LMATCH"} = "";
		191	$self->{"_LPATT"} = "";
		192	$self->{"_PROMPT"} = "";
		193	$self->{"_MATCH"} = [];
		194	$self->{"_CMATCH"} = [];
		195	@{ $self->{"_MATCH"} } = "\n";
		196	@{ $self->{"_CMATCH"} } = "\n";
		197	$self->{DVTYPE} = "none";
		198	$self->{HNAME} = "localhost";
		199	$self->{HADDR} = 0;
		200	$self->{DATYPE} = "raw";
		201	$self->{CFG_1} = "none";
		202	$self->{CFG_2} = "none";
		203	$self->{CFG_3} = "none";
		204
		205	# user settable options for lookfor (the "stty" collection)
		206	# defaults like RedHat linux unless indicated
		207	# char to abort nextline subroutine
		208	$self->{intr} = "\cC"; # MUST be single char
		209
		210	# char to abort perl
		211	$self->{quit} = "\cD"; # MUST be single char
		212
		213	# end_of_file char (linux typ: "\cD")
		214	$self->{s_eof} = "\cZ"; # MUST be single char
		215
		216	# end_of_line char
		217	$self->{eol} = "\cJ"; # MUST be single char
		218
		219	# delete one character from buffer (backspace)
		220	$self->{erase} = "\cH"; # MUST be single char
		221
		222	# clear line buffer
		223	$self->{s_kill} = "\cU"; # MUST be single char
		224
		225	# written after erase character
		226	$self->{bsdel} = "\cH \cH";
		227
		228	# written after kill character
		229	my $space76 = " "x76;
		230	$self->{clear} = "\r$space76\r"; # 76 spaces
		231
		232	# echo every character
		233	$self->{echo} = 0;
		234
		235	# echo erase character with bsdel string
		236	$self->{echoe} = 1;
		237
		238	# echo \n after kill character
		239	$self->{echok} = 1;
		240
		241	# echo \n
		242	$self->{echonl} = 0;
		243
		244	# echo clear string after kill character
		245	$self->{echoke} = 1; # linux console yes, serial no
		246
		247	# echo "^Char" for control chars
		248	$self->{echoctl} = 0; # linux console yes, serial no
		249
		250	# strip input to 7-bits
		251	$self->{istrip} = 0;
		252
		253	# map \r to \n on input
		254	$self->{icrnl} = 0;
		255
		256	# map \r to \n on output
		257	$self->{ocrnl} = 0;
		258
		259	# ignore \r on input
		260	$self->{igncr} = 0;
		261
		262	# map \n to \r on input
		263	$self->{inlcr} = 0;
		264
		265	# map \n to \r\n on output
		266	$self->{onlcr} = 1;
		267
		268	# enable output mapping
		269	$self->{opost} = 0;
		270
		271	# enable quit and intr characters
		272	$self->{isig} = 0; # linux actually SUPPORTS signals
		273
		274	# enable erase and kill characters
		275	$self->{icanon} = 0;
		276
		277	my $token;
		278	my @bauds = $self->are_baudrate;
		279	foreach $token (@bauds) { $opts{$token} = "baudrate:$token"; }
		280
		281	# initialize (in CommPort) and write_settings need these defined
		282	$self->{"_N_U_MSG"} = 0;
		283	$self->{"_N_E_MSG"} = 0;
		284	$self->{"_N_ALIAS"} = 0;
		285	$self->{"_N_intr"} = 0;
		286	$self->{"_N_quit"} = 0;
		287	$self->{"_N_s_eof"} = 0;
		288	$self->{"_N_eol"} = 0;
		289	$self->{"_N_erase"} = 0;
		290	$self->{"_N_s_kill"} = 0;
		291	$self->{"_N_bsdel"} = 0;
		292	$self->{"_N_clear"} = 0;
		293	$self->{"_N_echo"} = 0;
		294	$self->{"_N_echoe"} = 0;
		295	$self->{"_N_echok"} = 0;
		296	$self->{"_N_echonl"} = 0;
		297	$self->{"_N_echoke"} = 0;
		298	$self->{"_N_echoctl"} = 0;
		299	$self->{"_N_istrip"} = 0;
		300	$self->{"_N_icrnl"} = 0;
		301	$self->{"_N_ocrnl"} = 0;
		302	$self->{"_N_opost"} = 0;
		303	$self->{"_N_igncr"} = 0;
		304	$self->{"_N_inlcr"} = 0;
		305	$self->{"_N_onlcr"} = 0;
		306	$self->{"_N_isig"} = 0;
		307	$self->{"_N_icanon"} = 0;
		308	$self->{"_N_DVTYPE"} = 0;
		309	$self->{"_N_HNAME"} = 0;
		310	$self->{"_N_HADDR"} = 0;
		311	$self->{"_N_DATYPE"} = 0;
		312	$self->{"_N_CFG_1"} = 0;
		313	$self->{"_N_CFG_2"} = 0;
		314	$self->{"_N_CFG_3"} = 0;
		315
		316	$self->{ALIAS} = $device; # so "\\.\+++" can be changed
		317	$self->{DEVICE} = $device; # clone so NAME stays in CommPort
		318
		319	($self->{MAX_RXB}, $self->{MAX_TXB}) = $self->buffer_max;
		320
		321	bless ($self, $class);
		322	return $self;
		323	}
		324
		325
		326	sub stty_intr {
		327	my $self = shift;
		328	if (@_ == 1) { $self->{intr} = shift; }
		329	return if (@_);
		330	return $self->{intr};
		331	}
		332
		333	sub stty_quit {
		334	my $self = shift;
		335	if (@_ == 1) { $self->{quit} = shift; }
		336	return if (@_);
		337	return $self->{quit};
		338	}
		339
		340	sub is_stty_eof {
		341	my $self = shift;
		342	if (@_ == 1) { $self->{s_eof} = chr(shift); }
		343	return if (@_);
		344	return ord($self->{s_eof});
		345	}
		346
		347	sub is_stty_eol {
		348	my $self = shift;
		349	if (@_ == 1) { $self->{eol} = chr(shift); }
		350	return if (@_);
		351	return ord($self->{eol});
		352	}
		353
		354	sub is_stty_quit {
		355	my $self = shift;
		356	if (@_ == 1) { $self->{quit} = chr(shift); }
		357	return if (@_);
		358	return ord($self->{quit});
		359	}
		360
		361	sub is_stty_intr {
		362	my $self = shift;
		363	if (@_ == 1) { $self->{intr} = chr(shift); }
		364	return if (@_);
		365	return ord($self->{intr});
		366	}
		367
		368	sub is_stty_erase {
		369	my $self = shift;
		370	if (@_ == 1) { $self->{erase} = chr(shift); }
		371	return if (@_);
		372	return ord($self->{erase});
		373	}
		374
		375	sub is_stty_kill {
		376	my $self = shift;
		377	if (@_ == 1) { $self->{s_kill} = chr(shift); }
		378	return if (@_);
		379	return ord($self->{s_kill});
		380	}
		381
		382	sub is_stty_clear {
		383	my $self = shift;
		384	my @chars;
		385	if (@_ == 1) {
		386	@chars = split (//, shift);
		387	for (@chars) {
		388	$_ = chr ( ord($_) - 32 );
		389	}
		390	$self->{clear} = join("", @chars);
		391	return $self->{clear};
		392	}
		393	return if (@_);
		394	@chars = split (//, $self->{clear});
		395	for (@chars) {
		396	$_ = chr ( ord($_) + 32 );
		397	}
		398	my $permute = join("", @chars);
		399	return $permute;
		400	}
		401
		402	sub stty_eof {
		403	my $self = shift;
		404	if (@_ == 1) { $self->{s_eof} = shift; }
		405	return if (@_);
		406	return $self->{s_eof};
		407	}
		408
		409	sub stty_eol {
		410	my $self = shift;
		411	if (@_ == 1) { $self->{eol} = shift; }
		412	return if (@_);
		413	return $self->{eol};
		414	}
		415
		416	sub stty_erase {
		417	my $self = shift;
		418	if (@_ == 1) {
		419	my $tmp = shift;
		420	return unless (length($tmp) == 1);
		421	$self->{erase} = $tmp;
		422	}
		423	return if (@_);
		424	return $self->{erase};
		425	}
		426
		427	sub stty_kill {
		428	my $self = shift;
		429	if (@_ == 1) {
		430	my $tmp = shift;
		431	return unless (length($tmp) == 1);
		432	$self->{s_kill} = $tmp;
		433	}
		434	return if (@_);
		435	return $self->{s_kill};
		436	}
		437
		438	sub stty_bsdel {
		439	my $self = shift;
		440	if (@_ == 1) { $self->{bsdel} = shift; }
		441	return if (@_);
		442	return $self->{bsdel};
		443	}
		444
		445	sub stty_clear {
		446	my $self = shift;
		447	if (@_ == 1) { $self->{clear} = shift; }
		448	return if (@_);
		449	return $self->{clear};
		450	}
		451
		452	sub stty_echo {
		453	my $self = shift;
		454	if (@_ == 1) { $self->{echo} = yes_true ( shift ) }
		455	return if (@_);
		456	return $self->{echo};
		457	}
		458
		459	sub stty_echoe {
		460	my $self = shift;
		461	if (@_ == 1) { $self->{echoe} = yes_true ( shift ) }
		462	return if (@_);
		463	return $self->{echoe};
		464	}
		465
		466	sub stty_echok {
		467	my $self = shift;
		468	if (@_ == 1) { $self->{echok} = yes_true ( shift ) }
		469	return if (@_);
		470	return $self->{echok};
		471	}
		472
		473	sub stty_echonl {
		474	my $self = shift;
		475	if (@_ == 1) { $self->{echonl} = yes_true ( shift ) }
		476	return if (@_);
		477	return $self->{echonl};
		478	}
		479
		480	sub stty_echoke {
		481	my $self = shift;
		482	if (@_ == 1) { $self->{echoke} = yes_true ( shift ) }
		483	return if (@_);
		484	return $self->{echoke};
		485	}
		486
		487	sub stty_echoctl {
		488	my $self = shift;
		489	if (@_ == 1) { $self->{echoctl} = yes_true ( shift ) }
		490	return if (@_);
		491	return $self->{echoctl};
		492	}
		493
		494	sub stty_istrip {
		495	my $self = shift;
		496	if (@_ == 1) { $self->{istrip} = yes_true ( shift ) }
		497	return if (@_);
		498	return $self->{istrip};
		499	}
		500
		501	sub stty_icrnl {
		502	my $self = shift;
		503	if (@_ == 1) { $self->{icrnl} = yes_true ( shift ) }
		504	return if (@_);
		505	return $self->{icrnl};
		506	}
		507
		508	sub stty_ocrnl {
		509	my $self = shift;
		510	if (@_ == 1) { $self->{ocrnl} = yes_true ( shift ) }
		511	return if (@_);
		512	return $self->{ocrnl};
		513	}
		514
		515	sub stty_opost {
		516	my $self = shift;
		517	if (@_ == 1) { $self->{opost} = yes_true ( shift ) }
		518	return if (@_);
		519	return $self->{opost};
		520	}
		521
		522	sub stty_igncr {
		523	my $self = shift;
		524	if (@_ == 1) { $self->{igncr} = yes_true ( shift ) }
		525	return if (@_);
		526	return $self->{igncr};
		527	}
		528
		529	sub stty_inlcr {
		530	my $self = shift;
		531	if (@_ == 1) { $self->{inlcr} = yes_true ( shift ) }
		532	return if (@_);
		533	return $self->{inlcr};
		534	}
		535
		536	sub stty_onlcr {
		537	my $self = shift;
		538	if (@_ == 1) { $self->{onlcr} = yes_true ( shift ) }
		539	return if (@_);
		540	return $self->{onlcr};
		541	}
		542
		543	sub stty_isig {
		544	my $self = shift;
		545	if (@_ == 1) { $self->{isig} = yes_true ( shift ) }
		546	return if (@_);
		547	return $self->{isig};
		548	}
		549
		550	sub stty_icanon {
		551	my $self = shift;
		552	if (@_ == 1) { $self->{icanon} = yes_true ( shift ) }
		553	return if (@_);
		554	return $self->{icanon};
		555	}
		556
		557	sub is_prompt {
		558	my $self = shift;
		559	if (@_ == 1) { $self->{"_PROMPT"} = shift; }
		560	return if (@_);
		561	return $self->{"_PROMPT"};
		562	}
		563
		564	sub are_match {
		565	my $self = shift;
		566	my $pat;
		567	my $patno = 0;
		568	my $reno = 0;
		569	my $re_next = 0;
		570	if (@_) {
		571	@{ $self->{"_MATCH"} } = @_;
		572	if ($] >= 5.005) {
		573	@{ $self->{"_CMATCH"} } = ();
		574	while ($pat = shift) {
		575	if ($re_next) {
		576	$re_next = 0;
		577	eval 'push (@{ $self->{"_CMATCH"} }, qr/$pat/)';
		578	} else {
		579	push (@{ $self->{"_CMATCH"} }, $pat);
		580	}
		581	if ($pat eq "-re") {
		582	$re_next++;
		583	}
		584	}
		585	} else {
		586	@{ $self->{"_CMATCH"} } = @_;
		587	}
		588	}
		589	return @{ $self->{"_MATCH"} };
		590	}
		591
		592
		593	# parse values for start/restart
		594	sub get_start_values {
		595	return unless (@_ == 2);
		596	my $self = shift;
		597	my $filename = shift;
		598
		599	unless ( open CF, "<$filename" ) {
		600	carp "can't open file: $filename";
		601	return;
		602	}
		603	my ($signature, $name, @values) = <CF>;
		604	close CF;
		605
		606	unless ( $cfg_file_sig eq $signature ) {
		607	carp "Invalid signature in $filename: $signature";
		608	return;
		609	}
		610	chomp $name;
		611	unless ( $self->{DEVICE} eq $name ) {
		612	carp "Invalid Port DEVICE=$self->{DEVICE} in $filename: $name";
		613	return;
		614	}
		615	if ($Verbose or not $self) {
		616	print "signature = $signature";
		617	print "name = $name\n";
		618	if ($Verbose) {
		619	print "values:\n";
		620	foreach (@values) { print " $_"; }
		621	}
		622	}
		623	my $item;
		624	my $key;
		625	my $value;
		626	my $gosub;
		627	my $fault = 0;
		628	no strict 'refs'; # for $gosub
		629	foreach $item (@values) {
		630	chomp $item;
		631	($key, $value) = split (/,/, $item);
		632	if ($value eq "") { $fault++ }
		633	else {
		634	$gosub = $validate{$key};
		635	unless (defined &$gosub ($self, $value)) {
		636	carp "Invalid parameter for $key=$value ";
		637	return;
		638	}
		639	}
		640	}
		641	use strict 'refs';
		642	if ($fault) {
		643	carp "Invalid value in $filename";
		644	undef $self;
		645	return;
		646	}
		647	1;
		648	}
		649
		650	sub restart {
		651	return unless (@_ == 2);
		652	my $self = shift;
		653	my $filename = shift;
		654
		655	unless ( $self->init_done ) {
		656	carp "Can't restart before Port has been initialized";
		657	return;
		658	}
		659	get_start_values($self, $filename);
		660	write_settings($self);
		661	}
		662
		663	sub start {
		664	my $proto = shift;
		665	my $class = ref($proto) \|\| $proto;
		666
		667	return unless (@_);
		668	my $filename = shift;
		669
		670	unless ( open CF, "<$filename" ) {
		671	carp "can't open file: $filename";
		672	return;
		673	}
		674	my ($signature, $name, @values) = <CF>;
		675	close CF;
		676
		677	unless ( $cfg_file_sig eq $signature ) {
		678	carp "Invalid signature in $filename: $signature";
		679	return;
		680	}
		681	chomp $name;
		682	my $self = new ($class, $name);
		683	if ($Verbose or not $self) {
		684	print "signature = $signature";
		685	print "class = $class\n";
		686	print "name = $name\n";
		687	if ($Verbose) {
		688	print "values:\n";
		689	foreach (@values) { print " $_"; }
		690	}
		691	}
		692	if ($self) {
		693	if ( get_start_values($self, $filename) ) {
		694	write_settings ($self);
		695	}
		696	else {
		697	carp "Invalid value in $filename";
		698	undef $self;
		699	return;
		700	}
		701	}
		702	return $self;
		703	}
		704
		705	sub write_settings {
		706	my $self = shift;
		707	my @items = keys %validate;
		708
		709	# initialize returns number of faults
		710	if ( $self->initialize(@items) ) {
		711	unless (nocarp) {
		712	carp "write_settings failed, closing port";
		713	$self->close;
		714	}
		715	return;
		716	}
		717
		718	$self->update_DCB;
		719	if ($Verbose) {
		720	print "writing settings to $self->{ALIAS}\n";
		721	}
		722	1;
		723	}
		724
		725	sub save {
		726	my $self = shift;
		727	my $item;
		728	my $getsub;
		729	my $value;
		730
		731	return unless (@_);
		732	unless ($self->init_done) {
		733	carp "can't save until init_done";
		734	return;
		735	}
		736
		737	my $filename = shift;
		738	unless ( open CF, ">$filename" ) {
		739	carp "can't open file: $filename";
		740	return;
		741	}
		742	print CF "$cfg_file_sig";
		743	print CF "$self->{DEVICE}\n";
		744	# used to "reopen" so must be DEVICE=NAME
		745
		746	no strict 'refs'; # for $gosub
		747	while (($item, $getsub) = each %validate) {
		748	chomp $getsub;
		749	$value = scalar &$getsub($self);
		750	print CF "$item,$value\n";
		751	}
		752	use strict 'refs';
		753	close CF;
		754	if ($Verbose) {
		755	print "wrote file $filename for $self->{ALIAS}\n";
		756	}
		757	1;
		758	}
		759
		760	##### tied FileHandle support
		761
		762	sub TIEHANDLE {
		763	my $proto = shift;
		764	my $class = ref($proto) \|\| $proto;
		765
		766	return unless (@_);
		767
		768	my $self = start($class, shift);
		769	return $self;
		770	}
		771
		772	# WRITE this, LIST
		773	# This method will be called when the handle is written to via the
		774	# syswrite function.
		775
		776	sub WRITE {
		777	return if (@_ < 3);
		778	my $self = shift;
		779	my $buf = shift;
		780	my $len = shift;
		781	my $offset = 0;
		782	if (@_) { $offset = shift; }
		783	my $out2 = substr($buf, $offset, $len);
		784	return unless ($self->post_print($out2));
		785	return length($out2);
		786	}
		787
		788	# PRINT this, LIST
		789	# This method will be triggered every time the tied handle is printed to
		790	# with the print() function. Beyond its self reference it also expects
		791	# the list that was passed to the print function.
		792
		793	sub PRINT {
		794	my $self = shift;
		795	return unless (@_);
		796	my $ofs = $, ? $, : "";
		797	if ($self->{OFS}) { $ofs = $self->{OFS}; }
		798	my $ors = $\ ? $\ : "";
		799	if ($self->{ORS}) { $ors = $self->{ORS}; }
		800	my $output = join($ofs,@_);
		801	$output .= $ors;
		802	return $self->post_print($output);
		803	}
		804
		805	sub output_field_separator {
		806	my $self = shift;
		807	my $prev = $self->{OFS};
		808	if (@_) { $self->{OFS} = shift; }
		809	return $prev;
		810	}
		811
		812	sub output_record_separator {
		813	my $self = shift;
		814	my $prev = $self->{ORS};
		815	if (@_) { $self->{ORS} = shift; }
		816	return $prev;
		817	}
		818
		819	sub post_print {
		820	my $self = shift;
		821	return unless (@_);
		822	my $output = shift;
		823	if ($self->stty_opost) {
		824	if ($self->stty_ocrnl) { $output =~ s/\r/\n/osg; }
		825	if ($self->stty_onlcr) { $output =~ s/\n/\r\n/osg; }
		826	}
		827	my $to_do = length($output);
		828	my $done = 0;
		829	my $written = 0;
		830	while ($done < $to_do) {
		831	my $out2 = substr($output, $done);
		832	$written = $self->write($out2);
		833	if (! defined $written) {
		834	$^E = 1121; # ERROR_COUNTER_TIMEOUT
		835	return;
		836	}
		837	return 0 unless ($written);
		838	$done += $written;
		839	}
		840	$^E = 0;
		841	1;
		842	}
		843
		844	# PRINTF this, LIST
		845	# This method will be triggered every time the tied handle is printed to
		846	# with the printf() function. Beyond its self reference it also expects
		847	# the format and list that was passed to the printf function.
		848
		849	sub PRINTF {
		850	my $self = shift;
		851	my $fmt = shift;
		852	return unless ($fmt);
		853	return unless (@_);
		854	my $output = sprintf($fmt, @_);
		855	$self->PRINT($output);
		856	}
		857
		858	# READ this, LIST
		859	# This method will be called when the handle is read from via the read
		860	# or sysread functions.
		861
		862	sub READ {
		863	return if (@_ < 3);
		864	my $buf = \$_[1];
		865	my ($self, $junk, $len, $offset) = @_;
		866	unless (defined $offset) { $offset = 0; }
		867	my $done = 0;
		868	my $count_in = 0;
		869	my $string_in = "";
		870	my $in2 = "";
		871	my $bufsize = $self->internal_buffer;
		872
		873	while ($done < $len) {
		874	my $size = $len - $done;
		875	if ($size > $bufsize) { $size = $bufsize; }
		876	($count_in, $string_in) = $self->read($size);
		877	if ($count_in) {
		878	$in2 .= $string_in;
		879	$done += $count_in;
		880	$^E = 0;
		881	}
		882	elsif ($done) {
		883	$^E = 0;
		884	last;
		885	}
		886	else {
		887	$^E = 1121; # ERROR_COUNTER_TIMEOUT
		888	last;
		889	}
		890	}
		891	my $tail = substr($$buf, $offset + $done);
		892	my $head = substr($$buf, 0, $offset);
		893	if ($self->{icrnl}) { $in2 =~ tr/\r/\n/; }
		894	if ($self->{inlcr}) { $in2 =~ tr/\n/\r/; }
		895	if ($self->{igncr}) { $in2 =~ s/\r//gos; }
		896	$$buf = $head.$in2.$tail;
		897	return $done if ($done);
		898	return;
		899	}
		900
		901	# READLINE this
		902	# This method will be called when the handle is read from via <HANDLE>.
		903	# The method should return undef when there is no more data.
		904
		905	sub READLINE {
		906	my $self = shift;
		907	return if (@_);
		908	my $gotit = "";
		909	my $match = "";
		910	my $was;
		911
		912	if (wantarray) {
		913	my @lines;
		914	for (;;) {
		915	$was = $self->reset_error;
		916	if ($was) {
		917	$^E = 1117; # ERROR_IO_DEVICE
		918	return @lines if (@lines);
		919	return;
		920	}
		921	if (! defined ($gotit = $self->streamline($self->{"_SIZE"}))) {
		922	$^E = 1121; # ERROR_COUNTER_TIMEOUT
		923	return @lines if (@lines);
		924	return;
		925	}
		926	$match = $self->matchclear;
		927	if ( ($gotit ne "") \|\| ($match ne "") ) {
		928	$^E = 0;
		929	$gotit .= $match;
		930	push (@lines, $gotit);
		931	return @lines if ($gotit =~ /$self->{"_CLASTLINE"}/s);
		932	}
		933	}
		934	}
		935	else {
		936	for (;;) {
		937	$was = $self->reset_error;
		938	if ($was) {
		939	$^E = 1117; # ERROR_IO_DEVICE
		940	return;
		941	}
		942	if (! defined ($gotit = $self->lookfor($self->{"_SIZE"}))) {
		943	$^E = 1121; # ERROR_COUNTER_TIMEOUT
		944	return;
		945	}
		946	$match = $self->matchclear;
		947	if ( ($gotit ne "") \|\| ($match ne "") ) {
		948	$^E = 0;
		949	return $gotit.$match; # traditional <HANDLE> behavior
		950	}
		951	}
		952	}
		953	}
		954
		955	# GETC this
		956	# This method will be called when the getc function is called.
		957
		958	sub GETC {
		959	my $self = shift;
		960	my ($count, $in) = $self->read(1);
		961	if ($count == 1) {
		962	$^E = 0;
		963	return $in;
		964	}
		965	else {
		966	$^E = 1121; # ERROR_COUNTER_TIMEOUT
		967	return;
		968	}
		969	}
		970
		971	# CLOSE this
		972	# This method will be called when the handle is closed via the close
		973	# function.
		974
		975	sub CLOSE {
		976	my $self = shift;
		977	my $success = $self->close;
		978	if ($Verbose) { printf "CLOSE result:%d\n", $success; }
		979	return $success;
		980	}
		981
		982	# DESTROY this
		983	# As with the other types of ties, this method will be called when the
		984	# tied handle is about to be destroyed. This is useful for debugging and
		985	# possibly cleaning up.
		986
		987	sub DESTROY {
		988	my $self = shift;
		989	if ($Verbose) { print "SerialPort::DESTROY called.\n"; }
		990	$self->SUPER::DESTROY();
		991	}
		992
		993	###############
		994
		995	sub alias {
		996	my $self = shift;
		997	if (@_) { $self->{ALIAS} = shift; } # should return true for legal names
		998	return $self->{ALIAS};
		999	}
		1000
		1001	sub user_msg {
		1002	my $self = shift;
		1003	if (@_) { $self->{U_MSG} = yes_true ( shift ) }
		1004	return wantarray ? @binary_opt : $self->{U_MSG};
		1005	}
		1006
		1007	sub error_msg {
		1008	my $self = shift;
		1009	if (@_) { $self->{E_MSG} = yes_true ( shift ) }
		1010	return wantarray ? @binary_opt : $self->{E_MSG};
		1011	}
		1012
		1013	sub devicetype {
		1014	my $self = shift;
		1015	if (@_) { $self->{DVTYPE} = shift; } # return true for legal names
		1016	return $self->{DVTYPE};
		1017	}
		1018
		1019	sub hostname {
		1020	my $self = shift;
		1021	if (@_) { $self->{HNAME} = shift; } # return true for legal names
		1022	return $self->{HNAME};
		1023	}
		1024
		1025	sub hostaddr {
		1026	my $self = shift;
		1027	if (@_) { $self->{HADDR} = shift; } # return true for assigned port
		1028	return $self->{HADDR};
		1029	}
		1030
		1031	sub datatype {
		1032	my $self = shift;
		1033	if (@_) { $self->{DATYPE} = shift; } # return true for legal types
		1034	return $self->{DATYPE};
		1035	}
		1036
		1037	sub cfg_param_1 {
		1038	my $self = shift;
		1039	if (@_) { $self->{CFG_1} = shift; } # return true for legal param
		1040	return $self->{CFG_1};
		1041	}
		1042
		1043	sub cfg_param_2 {
		1044	my $self = shift;
		1045	if (@_) { $self->{CFG_2} = shift; } # return true for legal param
		1046	return $self->{CFG_2};
		1047	}
		1048
		1049	sub cfg_param_3 {
		1050	my $self = shift;
		1051	if (@_) { $self->{CFG_3} = shift; } # return true for legal param
		1052	return $self->{CFG_3};
		1053	}
		1054
		1055	sub baudrate {
		1056	my $self = shift;
		1057	if (@_) {
		1058	unless ( defined $self->is_baudrate( shift ) ) {
		1059	if ($self->{U_MSG} or $Verbose) {
		1060	carp "Could not set baudrate on $self->{ALIAS}";
		1061	}
		1062	return;
		1063	}
		1064	}
		1065	return wantarray ? $self->are_baudrate : $self->is_baudrate;
		1066	}
		1067
		1068	sub status {
		1069	my $self = shift;
		1070	my $ok = 0;
		1071	my $fmask = 0;
		1072	my $v1 = $Verbose \| $self->{"_DEBUG"};
		1073	my $v2 = $v1 \| $self->{U_MSG};
		1074	my $v3 = $v1 \| $self->{E_MSG};
		1075
		1076	my @stat = $self->is_status;
		1077	return unless (scalar @stat);
		1078	$fmask=$stat[ST_BLOCK];
		1079	if ($v1) { printf "BlockingFlags= %lx\n", $fmask; }
		1080	if ($v2 && $fmask) {
		1081	printf "Waiting for CTS\n" if ($fmask & BM_fCtsHold);
		1082	printf "Waiting for DSR\n" if ($fmask & BM_fDsrHold);
		1083	printf "Waiting for RLSD\n" if ($fmask & BM_fRlsdHold);
		1084	printf "Waiting for XON\n" if ($fmask & BM_fXoffHold);
		1085	printf "Waiting, XOFF was sent\n" if ($fmask & BM_fXoffSent);
		1086	printf "End_of_File received\n" if ($fmask & BM_fEof);
		1087	printf "Character waiting to TX\n" if ($fmask & BM_fTxim);
		1088	}
		1089	$fmask=$stat[ST_ERROR];
		1090	if ($v1) { printf "Error_BitMask= %lx\n", $fmask; }
		1091	if ($v3 && $fmask) {
		1092	# only prints if error is new (API resets each call)
		1093	printf "Invalid MODE or bad HANDLE\n" if ($fmask & CE_MODE);
		1094	printf "Receive Overrun detected\n" if ($fmask & CE_RXOVER);
		1095	printf "Buffer Overrun detected\n" if ($fmask & CE_OVERRUN);
		1096	printf "Parity Error detected\n" if ($fmask & CE_RXPARITY);
		1097	printf "Framing Error detected\n" if ($fmask & CE_FRAME);
		1098	printf "Break Signal detected\n" if ($fmask & CE_BREAK);
		1099	printf "Transmit Buffer is full\n" if ($fmask & CE_TXFULL);
		1100	}
		1101	return @stat;
		1102	}
		1103
		1104	sub handshake {
		1105	my $self = shift;
		1106	if (@_) {
		1107	unless ( $self->is_handshake(shift) ) {
		1108	if ($self->{U_MSG} or $Verbose) {
		1109	carp "Could not set handshake on $self->{ALIAS}";
		1110	}
		1111	return;
		1112	}
		1113	}
		1114	return wantarray ? $self->are_handshake : $self->is_handshake;
		1115	}
		1116
		1117	sub parity {
		1118	my $self = shift;
		1119	if (@_) {
		1120	unless ( $self->is_parity(shift) ) {
		1121	if ($self->{U_MSG} or $Verbose) {
		1122	carp "Could not set parity on $self->{ALIAS}";
		1123	}
		1124	return;
		1125	}
		1126	}
		1127	return wantarray ? $self->are_parity : $self->is_parity;
		1128	}
		1129
		1130	sub databits {
		1131	my $self = shift;
		1132	if (@_) {
		1133	unless ( $self->is_databits(shift) ) {
		1134	if ($self->{U_MSG} or $Verbose) {
		1135	carp "Could not set databits on $self->{ALIAS}";
		1136	}
		1137	return;
		1138	}
		1139	}
		1140	return wantarray ? $self->are_databits : $self->is_databits;
		1141	}
		1142
		1143	sub stopbits {
		1144	my $self = shift;
		1145	if (@_) {
		1146	unless ( $self->is_stopbits(shift) ) {
		1147	if ($self->{U_MSG} or $Verbose) {
		1148	carp "Could not set stopbits on $self->{ALIAS}";
		1149	}
		1150	return;
		1151	}
		1152	}
		1153	return wantarray ? $self->are_stopbits : $self->is_stopbits;
		1154	}
		1155
		1156	# single value for save/start
		1157	sub set_read_buf {
		1158	my $self = shift;
		1159	if (@_) {
		1160	return unless (@_ == 1);
		1161	my $rbuf = int shift;
		1162	return unless (($rbuf > 0) and ($rbuf <= $self->{MAX_RXB}));
		1163	$self->is_read_buf($rbuf);
		1164	}
		1165	return $self->is_read_buf;
		1166	}
		1167
		1168	# single value for save/start
		1169	sub set_write_buf {
		1170	my $self = shift;
		1171	if (@_) {
		1172	return unless (@_ == 1);
		1173	my $wbuf = int shift;
		1174	return unless (($wbuf >= 0) and ($wbuf <= $self->{MAX_TXB}));
		1175	$self->is_write_buf($wbuf);
		1176	}
		1177	return $self->is_write_buf;
		1178	}
		1179
		1180	sub buffers {
		1181	my $self = shift;
		1182
		1183	if (@_ == 2) {
		1184	my $rbuf = shift;
		1185	my $wbuf = shift;
		1186	unless (defined set_read_buf ($self, $rbuf)) {
		1187	if ($self->{U_MSG} or $Verbose) {
		1188	carp "Can't set read buffer on $self->{ALIAS}";
		1189	}
		1190	return;
		1191	}
		1192	unless (defined set_write_buf ($self, $wbuf)) {
		1193	if ($self->{U_MSG} or $Verbose) {
		1194	carp "Can't set write buffer on $self->{ALIAS}";
		1195	}
		1196	return;
		1197	}
		1198	$self->is_buffers($rbuf, $wbuf) \|\| return;
		1199	}
		1200	elsif (@_) { return; }
		1201	return wantarray ? $self->are_buffers : 1;
		1202	}
		1203
		1204	sub read {
		1205	return unless (@_ == 2);
		1206	my $self = shift;
		1207	my $wanted = shift;
		1208	my $ok = 0;
		1209	my $result = "";
		1210	return unless ($wanted > 0);
		1211
		1212	my $got = $self->read_bg ($wanted);
		1213
		1214	if ($got != $wanted) {
		1215	($ok, $got, $result) = $self->read_done(1); # block until done
		1216	}
		1217	else { ($ok, $got, $result) = $self->read_done(0); }
		1218	print "read=$got\n" if ($Verbose);
		1219	return ($got, $result);
		1220	}
		1221
		1222	sub lookclear {
		1223	my $self = shift;
		1224	if (nocarp && (@_ == 1)) {
		1225	$self->{"_T_INPUT"} = shift;
		1226	}
		1227	$self->{"_LOOK"} = "";
		1228	$self->{"_LASTLOOK"} = "";
		1229	$self->{"_LMATCH"} = "";
		1230	$self->{"_LPATT"} = "";
		1231	return if (@_);
		1232	1;
		1233	}
		1234
		1235	sub linesize {
		1236	my $self = shift;
		1237	if (@_) {
		1238	my $val = int shift;
		1239	return if ($val < 0);
		1240	$self->{"_SIZE"} = $val;
		1241	}
		1242	return $self->{"_SIZE"};
		1243	}
		1244
		1245	sub lastline {
		1246	my $self = shift;
		1247	if (@_) {
		1248	$self->{"_LASTLINE"} = shift;
		1249	if ($] >= 5.005) {
		1250	eval '$self->{"_CLASTLINE"} = qr/$self->{"_LASTLINE"}/';
		1251	} else {
		1252	$self->{"_CLASTLINE"} = $self->{"_LASTLINE"};
		1253	}
		1254	}
		1255	return $self->{"_LASTLINE"};
		1256	}
		1257
		1258	sub matchclear {
		1259	my $self = shift;
		1260	my $found = $self->{"_LMATCH"};
		1261	$self->{"_LMATCH"} = "";
		1262	return if (@_);
		1263	return $found;
		1264	}
		1265
		1266	sub lastlook {
		1267	my $self = shift;
		1268	return if (@_);
		1269	return ( $self->{"_LMATCH"}, $self->{"_LASTLOOK"},
		1270	$self->{"_LPATT"}, $self->{"_LOOK"} );
		1271	}
		1272
		1273	sub lookfor {
		1274	my $self = shift;
		1275	my $size = 0;
		1276	if (@_) { $size = shift; }
		1277	my $loc = "";
		1278	my $count_in = 0;
		1279	my $string_in = "";
		1280	$self->{"_LMATCH"} = "";
		1281	$self->{"_LPATT"} = "";
		1282
		1283	if ( ! $self->{"_LOOK"} ) {
		1284	$loc = $self->{"_LASTLOOK"};
		1285	}
		1286
		1287	if ($size) {
		1288	my ($bbb, $iii, $ooo, $eee) = status($self);
		1289	if ($iii > $size) { $size = $iii; }
		1290	($count_in, $string_in) = $self->read($size);
		1291	return unless ($count_in);
		1292	$loc .= $string_in;
		1293	}
		1294	else {
		1295	$loc .= $self->input;
		1296	}
		1297
		1298	if ($loc ne "") {
		1299	if ($self->{icrnl}) { $loc =~ tr/\r/\n/; }
		1300	my $n_char;
		1301	my $mpos;
		1302	my $erase_is_bsdel = 0;
		1303	my $nl_after_kill = "";
		1304	my $clear_after_kill = 0;
		1305	my $echo_ctl = 0;
		1306	my $lookbuf;
		1307	my $re_next = 0;
		1308	my $got_match = 0;
		1309	my $pat;
		1310	my $lf_erase = "";
		1311	my $lf_kill = "";
		1312	my $lf_eof = "";
		1313	my $lf_quit = "";
		1314	my $lf_intr = "";
		1315	my $nl_2_crnl = 0;
		1316	my $cr_2_nl = 0;
		1317
		1318	if ($self->{opost}) {
		1319	$nl_2_crnl = $self->{onlcr};
		1320	$cr_2_nl = $self->{ocrnl};
		1321	}
		1322
		1323	if ($self->{echo}) {
		1324	$erase_is_bsdel = $self->{echoe};
		1325	if ($self->{echok}) {
		1326	$nl_after_kill = $self->{onlcr} ? "\r\n" : "\n";
		1327	}
		1328	$clear_after_kill = $self->{echoke};
		1329	$echo_ctl = $self->{echoctl};
		1330	}
		1331
		1332	if ($self->{icanon}) {
		1333	$lf_erase = $self->{erase};
		1334	$lf_kill = $self->{s_kill};
		1335	$lf_eof = $self->{s_eof};
		1336	}
		1337
		1338	if ($self->{isig}) {
		1339	$lf_quit = $self->{quit};
		1340	$lf_intr = $self->{intr};
		1341	}
		1342
		1343	my @loc_char = split (//, $loc);
		1344	while (defined ($n_char = shift @loc_char)) {
		1345	## printf STDERR "0x%x ", ord($n_char);
		1346	if ($n_char eq $lf_erase) {
		1347	if ($erase_is_bsdel && (length $self->{"_LOOK"}) ) {
		1348	$mpos = chop $self->{"_LOOK"};
		1349	$self->write($self->{bsdel});
		1350	if ($echo_ctl && (($mpos lt "@")\|($mpos eq chr(127)))) {
		1351	$self->write($self->{bsdel});
		1352	}
		1353	}
		1354	}
		1355	elsif ($n_char eq $lf_kill) {
		1356	$self->{"_LOOK"} = "";
		1357	$self->write($self->{clear}) if ($clear_after_kill);
		1358	$self->write($nl_after_kill);
		1359	$self->write($self->{"_PROMPT"});
		1360	}
		1361	elsif ($n_char eq $lf_intr) {
		1362	$self->{"_LOOK"} = "";
		1363	$self->{"_LASTLOOK"} = "";
		1364	return;
		1365	}
		1366	elsif ($n_char eq $lf_quit) {
		1367	exit;
		1368	}
		1369	else {
		1370	$mpos = ord $n_char;
		1371	if ($self->{istrip}) {
		1372	if ($mpos > 127) { $n_char = chr($mpos - 128); }
		1373	}
		1374	$self->{"_LOOK"} .= $n_char;
		1375	## print $n_char;
		1376	if ($cr_2_nl) { $n_char =~ s/\r/\n/os; }
		1377	if ($nl_2_crnl) { $n_char =~ s/\n/\r\n/os; }
		1378	if (($mpos < 32) && $echo_ctl &&
		1379	($mpos != is_stty_eol($self))) {
		1380	$n_char = chr($mpos + 64);
		1381	$self->write("^$n_char");
		1382	}
		1383	elsif (($mpos == 127) && $echo_ctl) {
		1384	$self->write("^.");
		1385	}
		1386	elsif ($self->{echonl} && ($n_char =~ "\n")) {
		1387	# also writes "\r\n" for onlcr
		1388	$self->write($n_char);
		1389	}
		1390	elsif ($self->{echo}) {
		1391	# also writes "\r\n" for onlcr
		1392	$self->write($n_char);
		1393	}
		1394	$lookbuf = $self->{"_LOOK"};
		1395	if (($lf_eof ne "") and ($lookbuf =~ /$lf_eof$/)) {
		1396	$self->{"_LOOK"} = "";
		1397	$self->{"_LASTLOOK"} = "";
		1398	return $lookbuf;
		1399	}
		1400	$count_in = 0;
		1401	foreach $pat ( @{ $self->{"_CMATCH"} } ) {
		1402	if ($pat eq "-re") {
		1403	$re_next++;
		1404	$count_in++;
		1405	next;
		1406	}
		1407	if ($re_next) {
		1408	$re_next = 0;
		1409	# always at $lookbuf end when processing single char
		1410	if ( $lookbuf =~ s/$pat//s ) {
		1411	$self->{"_LMATCH"} = $&;
		1412	$got_match++;
		1413	}
		1414	}
		1415	elsif (($mpos = index($lookbuf, $pat)) > -1) {
		1416	$got_match++;
		1417	$lookbuf = substr ($lookbuf, 0, $mpos);
		1418	$self->{"_LMATCH"} = $pat;
		1419	}
		1420	if ($got_match) {
		1421	$self->{"_LPATT"} = $self->{"_MATCH"}[$count_in];
		1422	if (scalar @loc_char) {
		1423	$self->{"_LASTLOOK"} = join("", @loc_char);
		1424	## print ".$self->{\"_LASTLOOK\"}.";
		1425	}
		1426	else {
		1427	$self->{"_LASTLOOK"} = "";
		1428	}
		1429	$self->{"_LOOK"} = "";
		1430	return $lookbuf;
		1431	}
		1432	$count_in++;
		1433	}
		1434	}
		1435	}
		1436	}
		1437	return "";
		1438	}
		1439
		1440	sub streamline {
		1441	my $self = shift;
		1442	my $size = 0;
		1443	if (@_) { $size = shift; }
		1444	my $loc = "";
		1445	my $mpos;
		1446	my $count_in = 0;
		1447	my $string_in = "";
		1448	my $re_next = 0;
		1449	my $got_match = 0;
		1450	my $best_pos = 0;
		1451	my $pat;
		1452	my $match = "";
		1453	my $before = "";
		1454	my $after = "";
		1455	my $best_match = "";
		1456	my $best_before = "";
		1457	my $best_after = "";
		1458	my $best_pat = "";
		1459	$self->{"_LMATCH"} = "";
		1460	$self->{"_LPATT"} = "";
		1461
		1462	if ( ! $self->{"_LOOK"} ) {
		1463	$loc = $self->{"_LASTLOOK"};
		1464	}
		1465
		1466	if ($size) {
		1467	my ($bbb, $iii, $ooo, $eee) = status($self);
		1468	if ($iii > $size) { $size = $iii; }
		1469	($count_in, $string_in) = $self->read($size);
		1470	return unless ($count_in);
		1471	$loc .= $string_in;
		1472	}
		1473	else {
		1474	$loc .= $self->input;
		1475	}
		1476
		1477	if ($loc ne "") {
		1478	$self->{"_LOOK"} .= $loc;
		1479	$count_in = 0;
		1480	foreach $pat ( @{ $self->{"_CMATCH"} } ) {
		1481	if ($pat eq "-re") {
		1482	$re_next++;
		1483	$count_in++;
		1484	next;
		1485	}
		1486	if ($re_next) {
		1487	$re_next = 0;
		1488	if ( $self->{"_LOOK"} =~ /$pat/s ) {
		1489	( $match, $before, $after ) = ( $&, $`, $' );
		1490	$got_match++;
		1491	$mpos = length($before);
		1492	if ($mpos) {
		1493	next if ($best_pos && ($mpos > $best_pos));
		1494	$best_pos = $mpos;
		1495	$best_pat = $self->{"_MATCH"}[$count_in];
		1496	$best_match = $match;
		1497	$best_before = $before;
		1498	$best_after = $after;
		1499	} else {
		1500	$self->{"_LPATT"} = $self->{"_MATCH"}[$count_in];
		1501	$self->{"_LMATCH"} = $match;
		1502	$self->{"_LASTLOOK"} = $after;
		1503	$self->{"_LOOK"} = "";
		1504	return $before;
		1505	# pattern at start will be best
		1506	}
		1507	}
		1508	}
		1509	elsif (($mpos = index($self->{"_LOOK"}, $pat)) > -1) {
		1510	$got_match++;
		1511	$before = substr ($self->{"_LOOK"}, 0, $mpos);
		1512	if ($mpos) {
		1513	next if ($best_pos && ($mpos > $best_pos));
		1514	$best_pos = $mpos;
		1515	$best_pat = $pat;
		1516	$best_match = $pat;
		1517	$best_before = $before;
		1518	$mpos += length($pat);
		1519	$best_after = substr ($self->{"_LOOK"}, $mpos);
		1520	} else {
		1521	$self->{"_LPATT"} = $pat;
		1522	$self->{"_LMATCH"} = $pat;
		1523	$before = substr ($self->{"_LOOK"}, 0, $mpos);
		1524	$mpos += length($pat);
		1525	$self->{"_LASTLOOK"} = substr ($self->{"_LOOK"}, $mpos);
		1526	$self->{"_LOOK"} = "";
		1527	return $before;
		1528	# match at start will be best
		1529	}
		1530	}
		1531	$count_in++;
		1532	}
		1533	if ($got_match) {
		1534	$self->{"_LPATT"} = $best_pat;
		1535	$self->{"_LMATCH"} = $best_match;
		1536	$self->{"_LASTLOOK"} = $best_after;
		1537	$self->{"_LOOK"} = "";
		1538	return $best_before;
		1539	}
		1540	}
		1541	return "";
		1542	}
		1543
		1544	sub input {
		1545	return unless (@_ == 1);
		1546	my $self = shift;
		1547	my $result = "";
		1548	if (nocarp && $self->{"_T_INPUT"}) {
		1549	$result = $self->{"_T_INPUT"};
		1550	$self->{"_T_INPUT"} = "";
		1551	return $result;
		1552	}
		1553	my $ok = 0;
		1554	my $got_p = " "x4;
		1555	my ($bbb, $wanted, $ooo, $eee) = status($self);
		1556	return "" if ($eee);
		1557	return "" unless $wanted;
		1558
		1559	my $got = $self->read_bg ($wanted);
		1560
		1561	if ($got != $wanted) {
		1562	# block if unexpected happens
		1563	($ok, $got, $result) = $self->read_done(1); # block until done
		1564	}
		1565	else { ($ok, $got, $result) = $self->read_done(0); }
		1566	### print "input: got= $got result=$result\n";
		1567	return $got ? $result : "";
		1568	}
		1569
		1570	sub write {
		1571	return unless (@_ == 2);
		1572	my $self = shift;
		1573	my $wbuf = shift;
		1574	my $ok = 1;
		1575
		1576	return 0 if ($wbuf eq "");
		1577	my $lbuf = length ($wbuf);
		1578
		1579	my $written = $self->write_bg ($wbuf);
		1580
		1581	if ($written != $lbuf) {
		1582	($ok, $written) = $self->write_done(1); # block until done
		1583	}
		1584	if ($Verbose) {
		1585	print "wbuf=$wbuf\n";
		1586	print "lbuf=$lbuf\n";
		1587	print "written=$written\n";
		1588	}
		1589	return unless ($ok);
		1590	return $written;
		1591	}
		1592
		1593	sub transmit_char {
		1594	my $self = shift;
		1595	return unless (@_ == 1);
		1596	my $v = int shift;
		1597	return if (($v < 0) or ($v > 255));
		1598	return unless $self->xmit_imm_char ($v);
		1599	return wantarray ? @byte_opt : 1;
		1600	}
		1601
		1602	sub xon_char {
		1603	my $self = shift;
		1604	if (@_ == 1) {
		1605	my $v = int shift;
		1606	return if (($v < 0) or ($v > 255));
		1607	$self->is_xon_char($v);
		1608	}
		1609	return wantarray ? @byte_opt : $self->is_xon_char;
		1610	}
		1611
		1612	sub xoff_char {
		1613	my $self = shift;
		1614	if (@_ == 1) {
		1615	my $v = int shift;
		1616	return if (($v < 0) or ($v > 255));
		1617	$self->is_xoff_char($v);
		1618	}
		1619	return wantarray ? @byte_opt : $self->is_xoff_char;
		1620	}
		1621
		1622	sub eof_char {
		1623	my $self = shift;
		1624	if (@_ == 1) {
		1625	my $v = int shift;
		1626	return if (($v < 0) or ($v > 255));
		1627	$self->is_eof_char($v);
		1628	}
		1629	return wantarray ? @byte_opt : $self->is_eof_char;
		1630	}
		1631
		1632	sub event_char {
		1633	my $self = shift;
		1634	if (@_ == 1) {
		1635	my $v = int shift;
		1636	return if (($v < 0) or ($v > 255));
		1637	$self->is_event_char($v);
		1638	}
		1639	return wantarray ? @byte_opt : $self->is_event_char;
		1640	}
		1641
		1642	sub error_char {
		1643	my $self = shift;
		1644	if (@_ == 1) {
		1645	my $v = int shift;
		1646	return if (($v < 0) or ($v > 255));
		1647	$self->is_error_char($v);
		1648	}
		1649	return wantarray ? @byte_opt : $self->is_error_char;
		1650	}
		1651
		1652	sub xon_limit {
		1653	my $self = shift;
		1654	if (@_ == 1) {
		1655	my $v = int shift;
		1656	return if (($v < 0) or ($v > SHORTsize));
		1657	$self->is_xon_limit($v);
		1658	}
		1659	return wantarray ? (0, SHORTsize) : $self->is_xon_limit;
		1660	}
		1661
		1662	sub xoff_limit {
		1663	my $self = shift;
		1664	if (@_ == 1) {
		1665	my $v = int shift;
		1666	return if (($v < 0) or ($v > SHORTsize));
		1667	$self->is_xoff_limit($v);
		1668	}
		1669	return wantarray ? (0, SHORTsize) : $self->is_xoff_limit;
		1670	}
		1671
		1672	sub read_interval {
		1673	my $self = shift;
		1674	if (@_) {
		1675	return unless defined $self->is_read_interval( shift );
		1676	}
		1677	return wantarray ? (0, LONGsize) : $self->is_read_interval;
		1678	}
		1679
		1680	sub read_char_time {
		1681	my $self = shift;
		1682	if (@_) {
		1683	return unless defined $self->is_read_char_time( shift );
		1684	}
		1685	return wantarray ? (0, LONGsize) : $self->is_read_char_time;
		1686	}
		1687
		1688	sub read_const_time {
		1689	my $self = shift;
		1690	if (@_) {
		1691	return unless defined $self->is_read_const_time( shift );
		1692	}
		1693	return wantarray ? (0, LONGsize) : $self->is_read_const_time;
		1694	}
		1695
		1696	sub write_const_time {
		1697	my $self = shift;
		1698	if (@_) {
		1699	return unless defined $self->is_write_const_time( shift );
		1700	}
		1701	return wantarray ? (0, LONGsize) : $self->is_write_const_time;
		1702	}
		1703
		1704	sub write_char_time {
		1705	my $self = shift;
		1706	if (@_) {
		1707	return unless defined $self->is_write_char_time( shift );
		1708	}
		1709	return wantarray ? (0, LONGsize) : $self->is_write_char_time;
		1710	}
		1711
		1712
		1713	# true/false parameters
		1714
		1715	sub binary {
		1716	my $self = shift;
		1717	if (@_) {
		1718	return unless defined $self->is_binary( shift );
		1719	}
		1720	return $self->is_binary;
		1721	}
		1722
		1723	sub parity_enable {
		1724	my $self = shift;
		1725	if (@_) {
		1726	if ( $self->can_parity_enable ) {
		1727	$self->is_parity_enable( shift );
		1728	}
		1729	elsif ($self->{U_MSG}) {
		1730	carp "Can't set parity enable on $self->{ALIAS}";
		1731	}
		1732	}
		1733	return $self->is_parity_enable;
		1734	}
		1735
		1736	sub modemlines {
		1737	return unless (@_ == 1);
		1738	my $self = shift;
		1739	my $result = $self->is_modemlines;
		1740	if ($Verbose) {
		1741	print "CTS is ON\n" if ($result & MS_CTS_ON);
		1742	print "DSR is ON\n" if ($result & MS_DSR_ON);
		1743	print "RING is ON\n" if ($result & MS_RING_ON);
		1744	print "RLSD is ON\n" if ($result & MS_RLSD_ON);
		1745	}
		1746	return $result;
		1747	}
		1748
		1749	sub stty {
		1750	my $ob = shift;
		1751	my $token;
		1752	if (@_) {
		1753	my $ok = 1;
		1754	no strict 'refs'; # for $gosub
		1755	while ($token = shift) {
		1756	if (exists $opts{$token}) {
		1757	## print " $opts{$token}\n";
		1758	my ($gosub, $value) = split (':', $opts{$token});
		1759	if ($value eq "argv_char") { $value = &argv_char(shift); }
		1760	if (defined $value) {
		1761	&$gosub($ob, $value);
		1762	} else {
		1763	nocarp or carp "bad value for parameter $token\n";
		1764	$ok = 0;
		1765	}
		1766	}
		1767	else {
		1768	nocarp or carp "parameter $token not found\n";
		1769	$ok = 0;
		1770	}
		1771	}
		1772	use strict 'refs';
		1773	return $ok;
		1774	}
		1775	else {
		1776	my @settings; # array returned by ()
		1777	my $current = $ob->baudrate;
		1778	push @settings, "$current";
		1779
		1780	push @settings, "intr";
		1781	push @settings, cntl_char($ob->stty_intr);
		1782	push @settings, "quit";
		1783	push @settings, cntl_char($ob->stty_quit);
		1784	push @settings, "erase";
		1785	push @settings, cntl_char($ob->stty_erase);
		1786	push @settings, "kill";
		1787	push @settings, cntl_char($ob->stty_kill);
		1788	push @settings, "eof";
		1789	push @settings, cntl_char($ob->stty_eof);
		1790	push @settings, "eol";
		1791	push @settings, cntl_char($ob->stty_eol);
		1792	push @settings, "start";
		1793	push @settings, cntl_char(chr $ob->xon_char);
		1794	push @settings, "stop";
		1795	push @settings, cntl_char(chr $ob->xoff_char);
		1796	# "stop" is last CHAR type
		1797
		1798	push @settings, ($ob->stty_echo ? "" : "-")."echo";
		1799	push @settings, ($ob->stty_echoe ? "" : "-")."echoe";
		1800	push @settings, ($ob->stty_echok ? "" : "-")."echok";
		1801	push @settings, ($ob->stty_echonl ? "" : "-")."echonl";
		1802	push @settings, ($ob->stty_echoke ? "" : "-")."echoke";
		1803	push @settings, ($ob->stty_echoctl ? "" : "-")."echoctl";
		1804	push @settings, ($ob->stty_istrip ? "" : "-")."istrip";
		1805	push @settings, ($ob->stty_icrnl ? "" : "-")."icrnl";
		1806	push @settings, ($ob->stty_ocrnl ? "" : "-")."ocrnl";
		1807	push @settings, ($ob->stty_igncr ? "" : "-")."igncr";
		1808	push @settings, ($ob->stty_inlcr ? "" : "-")."inlcr";
		1809	push @settings, ($ob->stty_onlcr ? "" : "-")."onlcr";
		1810	push @settings, ($ob->stty_opost ? "" : "-")."opost";
		1811	push @settings, ($ob->stty_isig ? "" : "-")."isig";
		1812	push @settings, ($ob->stty_icanon ? "" : "-")."icanon";
		1813
		1814	$current = $ob->databits;
		1815	push @settings, "cs$current";
		1816	push @settings, (($ob->stopbits == 2) ? "" : "-")."cstopb";
		1817
		1818	$current = $ob->handshake;
		1819	push @settings, (($current eq "dtr") ? "" : "-")."clocal";
		1820	push @settings, (($current eq "rts") ? "" : "-")."crtscts";
		1821	push @settings, (($current eq "xoff") ? "" : "-")."ixoff";
		1822	push @settings, (($current eq "xoff") ? "" : "-")."ixon";
		1823
		1824	my $parity = $ob->parity;
		1825	if ($parity eq "none") {
		1826	push @settings, "-parenb";
		1827	push @settings, "-parodd";
		1828	push @settings, "-inpck";
		1829	}
		1830	else {
		1831	$current = $ob->is_parity_enable;
		1832	push @settings, ($current ? "" : "-")."parenb";
		1833	push @settings, (($parity eq "odd") ? "" : "-")."parodd";
		1834	push @settings, ($current ? "" : "-")."inpck";
		1835	# mark and space not supported
		1836	}
		1837	return @settings;
		1838	}
		1839	}
		1840
		1841	sub cntl_char {
		1842	my $n_char = shift;
		1843	return "<undef>" unless (defined $n_char);
		1844	my $pos = ord $n_char;
		1845	if ($pos < 32) {
		1846	$n_char = "^".chr($pos + 64);
		1847	}
		1848	if ($pos > 126) {
		1849	$n_char = sprintf "0x%x", $pos;
		1850	}
		1851	return $n_char;
		1852	}
		1853
		1854	sub argv_char {
		1855	my $n_char = shift;
		1856	return unless (defined $n_char);
		1857	my $pos = $n_char;
		1858	if ($n_char =~ s/^\^//) {
		1859	$pos = ord($n_char) - 64;
		1860	}
		1861	elsif ($n_char =~ s/^0x//) {
		1862	$pos = hex($n_char);
		1863	}
		1864	elsif ($n_char =~ /^0/) {
		1865	$pos = oct($n_char);
		1866	}
		1867	## print "pos = $pos\n";
		1868	return $pos;
		1869	}
		1870
		1871	sub debug {
		1872	my $self = shift;
		1873	if (ref($self)) {
		1874	if (@_) { $self->{"_DEBUG"} = yes_true ( shift ); }
		1875	else {
		1876	my $tmp = $self->{"_DEBUG"};
		1877	nocarp \|\| carp "Debug level: $self->{ALIAS} = $tmp";
		1878	$self->debug_comm($tmp);
		1879	return $self->{"_DEBUG"};
		1880	}
		1881	} else {
		1882	$Verbose = yes_true ($self);
		1883	nocarp \|\| carp "SerialPort Debug Class = $Verbose";
		1884	Win32API::CommPort::debug_comm($Verbose);
		1885	return $Verbose;
		1886	}
		1887	}
		1888
		1889	sub close {
		1890	my $self = shift;
		1891
		1892	return unless (defined $self->{ALIAS});
		1893
		1894	if ($Verbose or $self->{"_DEBUG"}) {
		1895	carp "Closing $self " . $self->{ALIAS};
		1896	}
		1897	my $success = $self->SUPER::close;
		1898	$self->{DEVICE} = undef;
		1899	$self->{ALIAS} = undef;
		1900	if ($Verbose) {
		1901	printf "SerialPort close result:%d\n", $success;
		1902	}
		1903	return $success;
		1904	}
		1905
		1906	1; # so the require or use succeeds
		1907
		1908	# Autoload methods go after =cut, and are processed by the autosplit program.
		1909
		1910	__END__
		1911
		1912	=pod
		1913
		1914	=head1 NAME
		1915
		1916	Win32::SerialPort - User interface to Win32 Serial API calls
		1917
		1918	=head1 SYNOPSIS
		1919
		1920	require 5.003;
		1921	use Win32::SerialPort qw( :STAT 0.19 );
		1922
		1923	=head2 Constructors
		1924
		1925	$PortObj = new Win32::SerialPort ($PortName, $quiet)
		1926	\|\| die "Can't open $PortName: $^E\n"; # $quiet is optional
		1927
		1928	$PortObj = start Win32::SerialPort ($Configuration_File_Name)
		1929	\|\| die "Can't start $Configuration_File_Name: $^E\n";
		1930
		1931	$PortObj = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name)
		1932	\|\| die "Can't tie using $Configuration_File_Name: $^E\n";
		1933
		1934
		1935	=head2 Configuration Utility Methods
		1936
		1937	$PortObj->alias("MODEM1");
		1938
		1939	# before using start, restart, or tie
		1940	$PortObj->save($Configuration_File_Name)
		1941	\|\| warn "Can't save $Configuration_File_Name: $^E\n";
		1942
		1943	# after new, must check for failure
		1944	$PortObj->write_settings \|\| undef $PortObj;
		1945	print "Can't change Device_Control_Block: $^E\n" unless ($PortObj);
		1946
		1947	# rereads file to either return open port to a known state
		1948	# or switch to a different configuration on the same port
		1949	$PortObj->restart($Configuration_File_Name)
		1950	\|\| warn "Can't reread $Configuration_File_Name: $^E\n";
		1951
		1952	# "app. variables" saved in $Configuration_File, not used internally
		1953	$PortObj->devicetype('none'); # CM11, CM17, 'weeder', 'modem'
		1954	$PortObj->hostname('localhost'); # for socket-based implementations
		1955	$PortObj->hostaddr(0); # false unless specified
		1956	$PortObj->datatype('raw'); # in case an application needs_to_know
		1957	$PortObj->cfg_param_1('none'); # null string '' hard to save/restore
		1958	$PortObj->cfg_param_2('none'); # 3 spares should be enough for now
		1959	$PortObj->cfg_param_3('none'); # one may end up as a log file path
		1960
		1961	# specials for test suite only
		1962	@necessary_param = Win32::SerialPort->set_test_mode_active(1);
		1963	$PortObj->lookclear("loopback to next 'input' method");
		1964
		1965	=head2 Configuration Parameter Methods
		1966
		1967	# most methods can be called three ways:
		1968	$PortObj->handshake("xoff"); # set parameter
		1969	$flowcontrol = $PortObj->handshake; # current value (scalar)
		1970	@handshake_opts = $PortObj->handshake; # permitted choices (list)
		1971
		1972	# similar
		1973	$PortObj->baudrate(9600);
		1974	$PortObj->parity("odd");
		1975	$PortObj->databits(8);
		1976	$PortObj->stopbits(1);
		1977
		1978	# range parameters return (minimum, maximum) in list context
		1979	$PortObj->xon_limit(100); # bytes left in buffer
		1980	$PortObj->xoff_limit(100); # space left in buffer
		1981	$PortObj->xon_char(0x11);
		1982	$PortObj->xoff_char(0x13);
		1983	$PortObj->eof_char(0x0);
		1984	$PortObj->event_char(0x0);
		1985	$PortObj->error_char(0); # for parity errors
		1986
		1987	$PortObj->buffers(4096, 4096); # read, write
		1988	# returns current in list context
		1989
		1990	$PortObj->read_interval(100); # max time between read char (milliseconds)
		1991	$PortObj->read_char_time(5); # avg time between read char
		1992	$PortObj->read_const_time(100); # total = (avg * bytes) + const
		1993	$PortObj->write_char_time(5);
		1994	$PortObj->write_const_time(100);
		1995
		1996	# true/false parameters (return scalar context only)
		1997
		1998	$PortObj->binary(T); # just say Yes (Win 3.x option)
		1999	$PortObj->parity_enable(F); # faults during input
		2000	$PortObj->debug(0);
		2001
		2002	=head2 Operating Methods
		2003
		2004	($BlockingFlags, $InBytes, $OutBytes, $LatchErrorFlags) = $PortObj->status
		2005	\|\| warn "could not get port status\n";
		2006
		2007	if ($BlockingFlags) { warn "Port is blocked"; }
		2008	if ($BlockingFlags & BM_fCtsHold) { warn "Waiting for CTS"; }
		2009	if ($LatchErrorFlags & CE_FRAME) { warn "Framing Error"; }
		2010	# The API resets errors when reading status, $LatchErrorFlags
		2011	# is all $ErrorFlags seen since the last reset_error
		2012
		2013	Additional useful constants may be exported eventually. If the only fault
		2014	action desired is a message, B<status> provides I<Built-In> BitMask processing:
		2015
		2016	$PortObj->error_msg(1); # prints hardware messages like "Framing Error"
		2017	$PortObj->user_msg(1); # prints function messages like "Waiting for CTS"
		2018
		2019	($count_in, $string_in) = $PortObj->read($InBytes);
		2020	warn "read unsuccessful\n" unless ($count_in == $InBytes);
		2021
		2022	$count_out = $PortObj->write($output_string);
		2023	warn "write failed\n" unless ($count_out);
		2024	warn "write incomplete\n" if ( $count_out != length($output_string) );
		2025
		2026	if ($string_in = $PortObj->input) { PortObj->write($string_in); }
		2027	# simple echo with no control character processing
		2028
		2029	$PortObj->transmit_char(0x03); # bypass buffer (and suspend)
		2030
		2031	$ModemStatus = $PortObj->modemlines;
		2032	if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected"; }
		2033
		2034	=head2 Methods used with Tied FileHandles
		2035
		2036	$PortObj = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name)
		2037	\|\| die "Can't tie: $^E\n"; ## TIEHANDLE ##
		2038
		2039	print FH "text"; ## PRINT ##
		2040	$char = getc FH; ## GETC ##
		2041	syswrite FH, $out, length($out), 0; ## WRITE ##
		2042	$line = <FH>; ## READLINE ##
		2043	@lines = <FH>; ## READLINE ##
		2044	printf FH "received: %s", $line; ## PRINTF ##
		2045	read (FH, $in, 5, 0) or die "$^E"; ## READ ##
		2046	sysread (FH, $in, 5, 0) or die "$^E"; ## READ ##
		2047	close FH \|\| warn "close failed"; ## CLOSE ##
		2048	undef $PortObj;
		2049	untie *FH; ## DESTROY ##
		2050
		2051	$PortObj->linesize(10); # with READLINE
		2052	$PortObj->lastline("_GOT_ME_"); # with READLINE, list only
		2053
		2054	$old_ors = $PortObj->output_record_separator("RECORD"); # with PRINT
		2055	$old_ofs = $PortObj->output_field_separator("COMMA"); # with PRINT
		2056
		2057	=head2 Destructors
		2058
		2059	$PortObj->close \|\| warn "close failed";
		2060	# passed to CommPort to release port to OS - needed to reopen
		2061	# close will not usually DESTROY the object
		2062	# also called as: close FH \|\| warn "close failed";
		2063
		2064
		2065	undef $PortObj;
		2066	# preferred unless reopen expected since it triggers DESTROY
		2067	# calls $PortObj->close but does not confirm success
		2068	# MUST precede untie - do all three IN THIS SEQUENCE before re-tie.
		2069
		2070	untie *FH;
		2071
		2072	=head2 Methods for I/O Processing
		2073
		2074	$PortObj->are_match("text", "\n"); # possible end strings
		2075	$PortObj->lookclear; # empty buffers
		2076	$PortObj->write("Feed Me:"); # initial prompt
		2077	$PortObj->is_prompt("More Food:"); # new prompt after "kill" char
		2078
		2079	my $gotit = "";
		2080	my $match1 = "";
		2081	until ("" ne $gotit) {
		2082	$gotit = $PortObj->lookfor; # poll until data ready
		2083	die "Aborted without match\n" unless (defined $gotit);
		2084	last if ($gotit);
		2085	$match1 = $PortObj->matchclear; # match is first thing received
		2086	last if ($match1);
		2087	sleep 1; # polling sample time
		2088	}
		2089
		2090	printf "gotit = %s\n", $gotit; # input BEFORE the match
		2091	my ($match, $after, $pattern, $instead) = $PortObj->lastlook;
		2092	# input that MATCHED, input AFTER the match, PATTERN that matched
		2093	# input received INSTEAD when timeout without match
		2094
		2095	if ($match1) {
		2096	$match = $match1;
		2097	}
		2098	printf "lastlook-match = %s -after = %s -pattern = %s\n",
		2099	$match, $after, $pattern;
		2100
		2101	$gotit = $PortObj->lookfor($count); # block until $count chars received
		2102
		2103	$PortObj->are_match("-re", "pattern", "text");
		2104	# possible match strings: "pattern" is a regular expression,
		2105	# "text" is a literal string
		2106
		2107	$gotit = $PortObj->streamline; # poll until data ready
		2108	$gotit = $PortObj->streamline($count);# block until $count chars received
		2109	# fast alternatives to lookfor with no character processing
		2110
		2111	$PortObj->stty_intr("\cC"); # char to abort lookfor method
		2112	$PortObj->stty_quit("\cD"); # char to abort perl
		2113	$PortObj->stty_eof("\cZ"); # end_of_file char
		2114	$PortObj->stty_eol("\cJ"); # end_of_line char
		2115	$PortObj->stty_erase("\cH"); # delete one character from buffer (backspace)
		2116	$PortObj->stty_kill("\cU"); # clear line buffer
		2117
		2118	$PortObj->is_stty_intr(3); # ord(char) to abort lookfor method
		2119	$qc = $PortObj->is_stty_quit; # ($qc == 4) for "\cD"
		2120	$PortObj->is_stty_eof(26);
		2121	$PortObj->is_stty_eol(10);
		2122	$PortObj->is_stty_erase(8);
		2123	$PortObj->is_stty_kill(21);
		2124
		2125	my $air = " "x76;
		2126	$PortObj->stty_clear("\r$air\r"); # written after kill character
		2127	$PortObj->is_stty_clear; # internal version for config file
		2128	$PortObj->stty_bsdel("\cH \cH"); # written after erase character
		2129
		2130	$PortObj->stty_echo(0); # echo every character
		2131	$PortObj->stty_echoe(1); # if echo erase character with bsdel string
		2132	$PortObj->stty_echok(1); # if echo \n after kill character
		2133	$PortObj->stty_echonl(0); # if echo \n
		2134	$PortObj->stty_echoke(1); # if echo clear string after kill character
		2135	$PortObj->stty_echoctl(0); # if echo "^Char" for control chars
		2136	$PortObj->stty_istrip(0); # strip input to 7-bits
		2137	$PortObj->stty_icrnl(0); # map \r to \n on input
		2138	$PortObj->stty_ocrnl(0); # map \r to \n on output
		2139	$PortObj->stty_igncr(0); # ignore \r on input
		2140	$PortObj->stty_inlcr(0); # map \n to \r on input
		2141	$PortObj->stty_onlcr(1); # map \n to \r\n on output
		2142	$PortObj->stty_opost(0); # enable output mapping
		2143	$PortObj->stty_isig(0); # enable quit and intr characters
		2144	$PortObj->stty_icanon(0); # enable erase and kill characters
		2145
		2146	$PortObj->stty("-icanon"); # disable eof, erase and kill char, Unix-style
		2147	@stty_all = $PortObj->stty(); # get all the parameters, Perl-style
		2148
		2149	=head2 Capability Methods inherited from Win32API::CommPort
		2150
		2151	These return scalar context only.
		2152
		2153	can_baud can_databits can_stopbits
		2154	can_dtrdsr can_handshake can_parity_check
		2155	can_parity_config can_parity_enable can_rlsd
		2156	can_16bitmode is_rs232 is_modem
		2157	can_rtscts can_xonxoff can_xon_char
		2158	can_spec_char can_interval_timeout can_total_timeout
		2159	buffer_max can_rlsd_config
		2160
		2161	=head2 Operating Methods inherited from Win32API::CommPort
		2162
		2163	write_bg write_done read_bg
		2164	read_done reset_error suspend_tx
		2165	resume_tx dtr_active rts_active
		2166	break_active xoff_active xon_active
		2167	purge_all purge_rx purge_tx
		2168	pulse_rts_on pulse_rts_off pulse_dtr_on
		2169	pulse_dtr_off ignore_null ignore_no_dsr
		2170	subst_pe_char abort_on_error output_xoff
		2171	output_dsr output_cts tx_on_xoff
		2172	input_xoff get_tick_count
		2173
		2174
		2175	=head1 DESCRIPTION
		2176
		2177
		2178	This module uses Win32API::CommPort for raw access to the API calls and
		2179	related constants. It provides an object-based user interface to allow
		2180	higher-level use of common API call sequences for dealing with serial
		2181	ports.
		2182
		2183	Uses features of the Win32 API to implement non-blocking I/O, serial
		2184	parameter setting, event-loop operation, and enhanced error handling.
		2185
		2186	To pass in C<NULL> as the pointer to an optional buffer, pass in C<$null=0>.
		2187	This is expected to change to an empty list reference, C<[]>, when Perl
		2188	supports that form in this usage.
		2189
		2190	=head2 Initialization
		2191
		2192	The primary constructor is B<new> with a F<PortName> (as the Registry
		2193	knows it) specified. This will create an object, and get the available
		2194	options and capabilities via the Win32 API. The object is a superset
		2195	of a B<Win32API::CommPort> object, and supports all of its methods.
		2196	The port is not yet ready for read/write access. First, the desired
		2197	I<parameter settings> must be established. Since these are tuning
		2198	constants for an underlying hardware driver in the Operating System,
		2199	they are all checked for validity by the methods that set them. The
		2200	B<write_settings> method writes a new I<Device Control Block> to the
		2201	driver. The B<write_settings> method will return true if the port is
		2202	ready for access or C<undef> on failure. Ports are opened for binary
		2203	transfers. A separate C<binmode> is not needed. The USER must release
		2204	the object if B<write_settings> does not succeed.
		2205
		2206	Version 0.15 adds an optional C<$quiet> parameter to B<new>. Failure
		2207	to open a port prints a error message to STDOUT by default. Since only
		2208	one application at a time can "own" the port, one source of failure was
		2209	"port in use". There was previously no way to check this without getting
		2210	a "fail message". Setting C<$quiet> disables this built-in message. It
		2211	also returns 0 instead of C<undef> if the port is unavailable (still FALSE,
		2212	used for testing this condition - other faults may still return C<undef>).
		2213	Use of C<$quiet> only applies to B<new>.
		2214
		2215	=over 8
		2216
		2217	Certain parameters I<MUST> be set before executing B<write_settings>.
		2218	Others will attempt to deduce defaults from the hardware or from other
		2219	parameters. The I<Required> parameters are:
		2220
		2221	=item baudrate
		2222
		2223	Any legal value.
		2224
		2225	=item parity
		2226
		2227	One of the following: "none", "odd", "even", "mark", "space".
		2228	If you select anything except "none", you will need to set B<parity_enable>.
		2229
		2230	=item databits
		2231
		2232	An integer from 5 to 8.
		2233
		2234	=item stopbits
		2235
		2236	Legal values are 1, 1.5, and 2. But 1.5 only works with 5 databits, 2 does
		2237	not work with 5 databits, and other combinations may not work on all
		2238	hardware if parity is also used.
		2239
		2240	=back
		2241
		2242	The B<handshake> setting is recommended but no longer required. Select one
		2243	of the following: "none", "rts", "xoff", "dtr".
		2244
		2245	Some individual parameters (eg. baudrate) can be changed after the
		2246	initialization is completed. These will be validated and will
		2247	update the I<Device Control Block> as required. The B<save>
		2248	method will write the current parameters to a file that B<start, tie,> and
		2249	B<restart> can use to reestablish a functional setup.
		2250
		2251	$PortObj = new Win32::SerialPort ($PortName, $quiet)
		2252	\|\| die "Can't open $PortName: $^E\n"; # $quiet is optional
		2253
		2254	$PortObj->user_msg(ON);
		2255	$PortObj->databits(8);
		2256	$PortObj->baudrate(9600);
		2257	$PortObj->parity("none");
		2258	$PortObj->stopbits(1);
		2259	$PortObj->handshake("rts");
		2260	$PortObj->buffers(4096, 4096);
		2261
		2262	$PortObj->write_settings \|\| undef $PortObj;
		2263
		2264	$PortObj->save($Configuration_File_Name);
		2265
		2266	$PortObj->baudrate(300);
		2267	$PortObj->restart($Configuration_File_Name); # back to 9600 baud
		2268
		2269	$PortObj->close \|\| die "failed to close";
		2270	undef $PortObj; # frees memory back to perl
		2271
		2272	The F<PortName> maps to both the Registry I<Device Name> and the
		2273	I<Properties> associated with that device. A single I<Physical> port
		2274	can be accessed using two or more I<Device Names>. But the options
		2275	and setup data will differ significantly in the two cases. A typical
		2276	example is a Modem on port "COM2". Both of these F<PortNames> open
		2277	the same I<Physical> hardware:
		2278
		2279	$P1 = new Win32::SerialPort ("COM2");
		2280
		2281	$P2 = new Win32::SerialPort ("\\\\.\\Nanohertz Modem model K-9");
		2282
		2283	$P1 is a "generic" serial port. $P2 includes all of $P1 plus a variety
		2284	of modem-specific added options and features. The "raw" API calls return
		2285	different size configuration structures in the two cases. Win32 uses the
		2286	"\\.\" prefix to identify "named" devices. Since both names use the same
		2287	I<Physical> hardware, they can not both be used at the same time. The OS
		2288	will complain. Consider this A Good Thing. Use B<alias> to convert the
		2289	name used by "built-in" messages.
		2290
		2291	$P2->alias("FIDO");
		2292
		2293	The second constructor, B<start> is intended to simplify scripts which
		2294	need a constant setup. It executes all the steps from B<new> to
		2295	B<write_settings> based on a previously saved configuration. This
		2296	constructor will return C<undef> on a bad configuration file or failure
		2297	of a validity check. The returned object is ready for access.
		2298
		2299	$PortObj2 = start Win32::SerialPort ($Configuration_File_Name)
		2300	\|\| die;
		2301
		2302	The third constructor, B<tie>, combines the B<start> with Perl's
		2303	support for tied FileHandles (see I<perltie>). Win32::SerialPort
		2304	implements the complete set of methods: TIEHANDLE, PRINT, PRINTF,
		2305	WRITE, READ, GETC, READLINE, CLOSE, and DESTROY. Tied FileHandle
		2306	support was new with Version 0.14.
		2307
		2308	$PortObj2 = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name)
		2309	\|\| die;
		2310
		2311	The implementation attempts to mimic STDIN/STDOUT behaviour as closely
		2312	as possible: calls block until done, data strings that exceed internal
		2313	buffers are divided transparently into multiple calls, and B<stty_onlcr>
		2314	and B<stty_ocrnl> are applied to output data (WRITE, PRINT, PRINTF) when
		2315	B<stty_opost> is true. In Version 0.17, the output separators C<$,> and
		2316	C<$\> are also applied to PRINT if set. Since PRINTF is treated internally
		2317	as a single record PRINT, C<$\> will be applied. Output separators are not
		2318	applied to WRITE (called as C<syswrite FH, $scalar, $length, [$offset]>).
		2319
		2320	The B<output_record_separator> and B<output_field_separator> methods can set
		2321	I<Port-FileHandle-Specific> versions of C<$,> and C<$\> if desired.
		2322	The input_record_separator C<$/> is not explicitly supported - but an
		2323	identical function can be obtained with a suitable B<are_match> setting.
		2324	Record separators are experimental in Version 0.17. They are not saved
		2325	in the configuration_file.
		2326
		2327	The tied FileHandle methods may be combined with the Win32::SerialPort
		2328	methods for B<read, input>, and B<write> as well as other methods. The
		2329	typical restrictions against mixing B<print> with B<syswrite> do not
		2330	apply. Since both B<(tied) read> and B<sysread> call the same C<$ob-E<gt>READ>
		2331	method, and since a separate C<$ob-E<gt>read> method has existed for some
		2332	time in Win32::SerialPort, you should always use B<sysread> with the
		2333	tied interface. Beginning in Version 0.17, B<sysread> checks the input
		2334	against B<stty_icrnl>, B<stty_inlcr>, and B<stty_igncr>. With B<stty_igncr>
		2335	active, the B<sysread> returns the count of all characters received including
		2336	and C<\r> characters subsequently deleted.
		2337
		2338	Because all the tied methods block, they should ALWAYS be used with
		2339	timeout settings and are not suitable for background operations and
		2340	polled loops. The B<sysread> method may return fewer characters than
		2341	requested when a timeout occurs. The method call is still considered
		2342	successful. If a B<sysread> times out after receiving some characters,
		2343	the actual elapsed time may be as much as twice the programmed limit.
		2344	If no bytes are received, the normal timing applies.
		2345
		2346	=head2 Configuration and Capability Methods
		2347
		2348	Starting in Version 0.18, a number of I<Application Variables> are saved
		2349	in B<$Configuration_File>. These parameters are not used internally. But
		2350	methods allow setting and reading them. The intent is to facilitate the
		2351	use of separate I<configuration scripts> to create the files. Then an
		2352	application can use B<start> as the Constructor and not bother with
		2353	command line processing or managing its own small configuration file.
		2354	The default values and number of parameters is subject to change.
		2355
		2356	$PortObj->devicetype('none');
		2357	$PortObj->hostname('localhost'); # for socket-based implementations
		2358	$PortObj->hostaddr(0); # a "false" value
		2359	$PortObj->datatype('raw'); # 'record' is another possibility
		2360	$PortObj->cfg_param_1('none');
		2361	$PortObj->cfg_param_2('none'); # 3 spares should be enough for now
		2362	$PortObj->cfg_param_3('none');
		2363
		2364	The Win32 Serial Comm API provides extensive information concerning
		2365	the capabilities and options available for a specific port (and
		2366	instance). "Modem" ports have different capabilties than "RS-232"
		2367	ports - even if they share the same Hardware. Many traditional modem
		2368	actions are handled via TAPI. "Fax" ports have another set of options -
		2369	and are accessed via MAPI. Yet many of the same low-level API commands
		2370	and data structures are "common" to each type ("Modem" is implemented
		2371	as an "RS-232" superset). In addition, Win95 supports a variety of
		2372	legacy hardware (e.g fixed 134.5 baud) while WinNT has hooks for ISDN,
		2373	16-data-bit paths, and 256Kbaud.
		2374
		2375	=over 8
		2376
		2377	Binary selections will accept as I<true> any of the following:
		2378	C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case)
		2379	Anything else is I<false>.
		2380
		2381	There are a large number of possible configuration and option parameters.
		2382	To facilitate checking option validity in scripts, most configuration
		2383	methods can be used in three different ways:
		2384
		2385	=item method called with an argument
		2386
		2387	The parameter is set to the argument, if valid. An invalid argument
		2388	returns I<false> (undef) and the parameter is unchanged. The function
		2389	will also I<carp> if B<$user_msg> is I<true>. After B<write_settings>,
		2390	the port will be updated immediately if allowed. Otherwise, the value
		2391	will be applied when B<write_settings> is called.
		2392
		2393	=item method called with no argument in scalar context
		2394
		2395	The current value is returned. If the value is not initialized either
		2396	directly or by default, return "undef" which will parse to I<false>.
		2397	For binary selections (true/false), return the current value. All
		2398	current values from "multivalue" selections will parse to I<true>.
		2399	Current values may differ from requested values until B<write_settings>.
		2400	There is no way to see requests which have not yet been applied.
		2401	Setting the same parameter again overwrites the first request. Test
		2402	the return value of the setting method to check "success".
		2403
		2404	=item method called with no argument in list context
		2405
		2406	Return a list consisting of all acceptable choices for parameters with
		2407	discrete choices. Return a list C<(minimum, maximum)> for parameters
		2408	which can be set to a range of values. Binary selections have no need
		2409	to call this way - but will get C<(0,1)> if they do. Beginning in
		2410	Version 0.16, Binary selections inherited from Win32API::CommPort may
		2411	not return anything useful in list context. The null list C<(undef)>
		2412	will be returned for failed calls in list context (e.g. for an invalid
		2413	or unexpected argument).
		2414
		2415	=item Asynchronous (Background) I/O
		2416
		2417	The module handles Polling (do if Ready), Synchronous (block until
		2418	Ready), and Asynchronous Modes (begin and test if Ready) with the timeout
		2419	choices provided by the API. No effort has yet been made to interact with
		2420	Windows events. But background I/O has been used successfully with the
		2421	Perl Tk modules and callbacks from the event loop.
		2422
		2423	=item Timeouts
		2424
		2425	The API provides two timing models. The first applies only to reading and
		2426	essentially determines I<Read Not Ready> by checking the time between
		2427	consecutive characters. The B<ReadFile> operation returns if that time
		2428	exceeds the value set by B<read_interval>. It does this by timestamping
		2429	each character. It appears that at least one character must by received in
		2430	I<every> B<read> I<call to the API> to initialize the mechanism. The timer
		2431	is then reset by each succeeding character. If no characters are received,
		2432	the read will block indefinitely.
		2433
		2434	Setting B<read_interval> to C<0xffffffff> will do a non-blocking read.
		2435	The B<ReadFile> returns immediately whether or not any characters are
		2436	actually read. This replicates the behavior of the API.
		2437
		2438	The other model defines the total time allowed to complete the operation.
		2439	A fixed overhead time is added to the product of bytes and per_byte_time.
		2440	A wide variety of timeout options can be defined by selecting the three
		2441	parameters: fixed, each, and size.
		2442
		2443	Read_Total = B<read_const_time> + (B<read_char_time> * bytes_to_read)
		2444
		2445	Write_Total = B<write_const_time> + (B<write_char_time> * bytes_to_write)
		2446
		2447	When reading a known number of characters, the I<Read_Total> mechanism is
		2448	recommended. This mechanism I<MUST> be used with I<tied FileHandles> because
		2449	the tie methods can make multiple internal API calls in response to a single
		2450	B<sysread> or B<READLINE>. The I<Read_Interval> mechanism is suitable for
		2451	a B<read> method that expects a response of variable or unknown size. You
		2452	should then also set a long I<Read_Total> timeout as a "backup" in case
		2453	no bytes are received.
		2454
		2455	=back
		2456
		2457	=head2 Exports
		2458
		2459	Nothing is exported by default. Nothing is currently exported. Optional
		2460	tags from Win32API::CommPort are passed through.
		2461
		2462	=over 4
		2463
		2464	=item :PARAM
		2465
		2466	Utility subroutines and constants for parameter setting and test:
		2467
		2468	LONGsize SHORTsize nocarp yes_true
		2469	OS_Error internal_buffer
		2470
		2471	=item :STAT
		2472
		2473	Serial communications constants from Win32API::CommPort. Included are the
		2474	constants for ascertaining why a transmission is blocked:
		2475
		2476	BM_fCtsHold BM_fDsrHold BM_fRlsdHold BM_fXoffHold
		2477	BM_fXoffSent BM_fEof BM_fTxim BM_AllBits
		2478
		2479	Which incoming bits are active:
		2480
		2481	MS_CTS_ON MS_DSR_ON MS_RING_ON MS_RLSD_ON
		2482
		2483	What hardware errors have been detected:
		2484
		2485	CE_RXOVER CE_OVERRUN CE_RXPARITY CE_FRAME
		2486	CE_BREAK CE_TXFULL CE_MODE
		2487
		2488	Offsets into the array returned by B<status:>
		2489
		2490	ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR
		2491
		2492	=back
		2493
		2494	=head2 Stty Emulation
		2495
		2496	Nothing wrong with dreaming! A subset of stty options is available
		2497	through a B<stty> method. The purpose is support of existing serial
		2498	devices which have embedded knowledge of Unix communication line and
		2499	login practices. It is also needed by Tom Christiansen's Perl Power Tools
		2500	project. This is new and experimental in Version 0.15. The B<stty> method
		2501	returns an array of "traditional stty values" when called with no
		2502	arguments. With arguments, it sets the corresponding parameters.
		2503
		2504	$ok = $PortObj->stty("-icanon"); # equivalent to stty_icanon(0)
		2505	@stty_all = $PortObj->stty(); # get all the parameters, Perl-style
		2506	$ok = $PortObj->stty("cs7",19200); # multiple parameters
		2507	$ok = $PortObj->stty(@stty_save); # many parameters
		2508
		2509	The distribution includes a demo script, stty.plx, which gives details
		2510	of usage. Not all Unix parameters are currently supported. But the array
		2511	will contain all those which can be set. The order in C<@stty_all> will
		2512	match the following pattern:
		2513
		2514	baud, # numeric, always first
		2515	"intr", character, # the parameters which set special characters
		2516	"name", character, ...
		2517	"stop", character, # "stop" will always be the last "pair"
		2518	"parameter", # the on/off settings
		2519	"-parameter", ...
		2520
		2521	Version 0.13 added the primitive functions required to implement this
		2522	feature. A number of methods named B<stty_xxx> do what an
		2523	I<experienced stty user> would expect.
		2524	Unlike B<stty> on Unix, the B<stty_xxx> operations apply only to I/O
		2525	processed via the B<lookfor> method or the I<tied FileHandle> methods.
		2526	The B<read, input, read_done, write> methods all treat data as "raw".
		2527
		2528
		2529	The following stty functions have related SerialPort functions:
		2530	---------------------------------------------------------------
		2531	stty (control) SerialPort Default Value
		2532	---------------- ------------------ -------------
		2533	parenb inpck parity_enable from port
		2534
		2535	parodd parity from port
		2536
		2537	cs5 cs6 cs7 cs8 databits from port
		2538
		2539	cstopb stopbits from port
		2540
		2541	clocal crtscts handshake from port
		2542	ixon ixoff handshake from port
		2543
		2544	time read_const_time from port
		2545
		2546	110 300 600 1200 2400 baudrate from port
		2547	4800 9600 19200 38400 baudrate
		2548
		2549	75 134.5 150 1800 fixed baud only - not selectable
		2550
		2551	g, "stty < /dev/x" start, save none
		2552
		2553	sane restart none
		2554
		2555
		2556
		2557	stty (input) SerialPort Default Value
		2558	---------------- ------------------ -------------
		2559	istrip stty_istrip off
		2560
		2561	igncr stty_igncr off
		2562
		2563	inlcr stty_inlcr off
		2564
		2565	icrnl stty_icrnl on
		2566
		2567	parmrk error_char from port (off typ)
		2568
		2569
		2570
		2571	stty (output) SerialPort Default Value
		2572	---------------- ------------------ -------------
		2573	ocrnl stty_ocrnl off if opost
		2574
		2575	onlcr stty_onlcr on if opost
		2576
		2577	opost stty_opost off
		2578
		2579
		2580
		2581	stty (local) SerialPort Default Value
		2582	---------------- ------------------ -------------
		2583	raw read, write, input none
		2584
		2585	cooked lookfor none
		2586
		2587	echo stty_echo off
		2588
		2589	echoe stty_echoe on if echo
		2590
		2591	echok stty_echok on if echo
		2592
		2593	echonl stty_echonl off
		2594
		2595	echoke stty_echoke on if echo
		2596
		2597	echoctl stty_echoctl off
		2598
		2599	isig stty_isig off
		2600
		2601	icanon stty_icanon off
		2602
		2603
		2604
		2605	stty (char) SerialPort Default Value
		2606	---------------- ------------------ -------------
		2607	intr stty_intr "\cC"
		2608	is_stty_intr 3
		2609
		2610	quit stty_quit "\cD"
		2611	is_stty_quit 4
		2612
		2613	erase stty_erase "\cH"
		2614	is_stty_erase 8
		2615
		2616	(erase echo) stty_bsdel "\cH \cH"
		2617
		2618	kill stty_kill "\cU"
		2619	is_stty_kill 21
		2620
		2621	(kill echo) stty_clear "\r {76}\r"
		2622	is_stty_clear "-@{76}-"
		2623
		2624	eof stty_eof "\cZ"
		2625	is_stty_eof 26
		2626
		2627	eol stty_eol "\cJ"
		2628	is_stty_eol 10
		2629
		2630	start xon_char from port ("\cQ" typ)
		2631	is_xon_char 17
		2632
		2633	stop xoff_char from port ("\cS" typ)
		2634	is_xoff_char 19
		2635
		2636
		2637
		2638	The following stty functions have no equivalent in SerialPort:
		2639	--------------------------------------------------------------
		2640	[-]hup [-]ignbrk [-]brkint [-]ignpar
		2641	[-]tostop susp 0 50
		2642	134 200 exta extb
		2643	[-]cread [-]hupcl
		2644
		2645	The stty function list is taken from the documentation for IO::Stty by
		2646	Austin Schutz.
		2647
		2648	=head2 Lookfor and I/O Processing
		2649
		2650	Many of the B<stty_xxx> methods support features which are necessary for
		2651	line-oriented input (such as command-line handling). These include methods
		2652	which select control-keys to delete characters (B<stty_erase>) and lines
		2653	(B<stty_kill>), define input boundaries (B<stty_eol, stty_eof>), and abort
		2654	processing (B<stty_intr, stty_quit>). These keys also have B<is_stty_xxx>
		2655	methods which convert the key-codes to numeric equivalents which can be
		2656	saved in the configuration file.
		2657
		2658	Some communications programs have a different but related need - to collect
		2659	(or discard) input until a specific pattern is detected. For lines, the
		2660	pattern is a line-termination. But there are also requirements to search
		2661	for other strings in the input such as "username:" and "password:". The
		2662	B<lookfor> method provides a consistant mechanism for solving this problem.
		2663	It searches input character-by-character looking for a match to any of the
		2664	elements of an array set using the B<are_match> method. It returns the
		2665	entire input up to the match pattern if a match is found. If no match
		2666	is found, it returns "" unless an input error or abort is detected (which
		2667	returns undef).
		2668
		2669	The actual match and the characters after it (if any) may also be viewed
		2670	using the B<lastlook> method. In Version 0.13, the match test included
		2671	a C<s/$pattern//s> test which worked fine for literal text but returned
		2672	the I<Regular Expression> that matched when C<$pattern> contained any Perl
		2673	metacharacters. That was probably a bug - although no one reported it.
		2674
		2675	In Version 0.14, B<lastlook> returns both the input and the pattern from
		2676	the match test. It also adopts the convention from Expect.pm that match
		2677	strings are literal text (tested using B<index>) unless preceeded in the
		2678	B<are_match> list by a B<"-re",> entry. The default B<are_match> list
		2679	is C<("\n")>, which matches complete lines.
		2680
		2681	my ($match, $after, $pattern, $instead) = $PortObj->lastlook;
		2682	# input that MATCHED, input AFTER the match, PATTERN that matched
		2683	# input received INSTEAD when timeout without match ("" if match)
		2684
		2685	$PortObj->are_match("text1", "-re", "pattern", "text2");
		2686	# possible match strings: "pattern" is a regular expression,
		2687	# "text1" and "text2" are literal strings
		2688
		2689	The I<Regular Expression> handling in B<lookfor> is still
		2690	experimental. Please let me know if you use it (or can't use it), so
		2691	I can confirm bug fixes don't break your code. For literal strings,
		2692	C<$match> and C<$pattern> should be identical. The C<$instead> value
		2693	returns the internal buffer tested by the match logic. A successful
		2694	match or a B<lookclear> resets it to "" - so it is only useful for error
		2695	handling such as timeout processing or reporting unexpected responses.
		2696
		2697	The B<lookfor> method is designed to be sampled periodically (polled). Any
		2698	characters after the match pattern are saved for a subsequent B<lookfor>.
		2699	Internally, B<lookfor> is implemented using the nonblocking B<input> method
		2700	when called with no parameter. If called with a count, B<lookfor> calls
		2701	C<$PortObj-E<gt>read(count)> which blocks until the B<read> is I<Complete> or
		2702	a I<Timeout> occurs. The blocking alternative should not be used unless a
		2703	fault time has been defined using B<read_interval, read_const_time, and
		2704	read_char_time>. It exists mostly to support the I<tied FileHandle>
		2705	functions B<sysread, getc,> and B<E<lt>FHE<gt>>.
		2706
		2707	The internal buffers used by B<lookfor> may be purged by the B<lookclear>
		2708	method (which also clears the last match). For testing, B<lookclear> can
		2709	accept a string which is "looped back" to the next B<input>. This feature
		2710	is enabled only when C<set_test_mode_active(1)>. Normally, B<lookclear>
		2711	will return C<undef> if given parameters. It still purges the buffers and
		2712	last_match in that case (but nothing is "looped back"). You will want
		2713	B<stty_echo(0)> when exercising loopback.
		2714
		2715	Version 0.15 adds a B<matchclear> method. It is designed to handle the
		2716	"special case" where the match string is the first character(s) received
		2717	by B<lookfor>. In this case, C<$lookfor_return == "">, B<lookfor> does
		2718	not provide a clear indication that a match was found. The B<matchclear>
		2719	returns the same C<$match> that would be returned by B<lastlook> and
		2720	resets it to "" without resetting any of the other buffers. Since the
		2721	B<lookfor> already searched I<through> the match, B<matchclear> is used
		2722	to both detect and step-over "blank" lines.
		2723
		2724	The character-by-character processing used by B<lookfor> to support the
		2725	I<stty emulation> is fine for interactive activities and tasks which
		2726	expect short responses. But it has too much "overhead" to handle fast
		2727	data streams. Version 0.15 adds a B<streamline> method which is a fast,
		2728	line-oriented alternative with no echo support or input handling except
		2729	for pattern searching. Exact benchmarks will vary with input data and
		2730	patterns, but my tests indicate B<streamline> is 10-20 times faster then
		2731	B<lookfor> when uploading files averaging 25-50 characters per line.
		2732	Since B<streamline> uses the same internal buffers, the B<lookclear,
		2733	lastlook, are_match, and matchclear> methods act the same in both cases.
		2734	In fact, calls to B<streamline> and B<lookfor> can be interleaved if desired
		2735	(e.g. an interactive task that starts an upload and returns to interactive
		2736	activity when it is complete).
		2737
		2738	Beginning in Version 0.15, the B<READLINE> method supports "list context".
		2739	A tied FileHandle can slurp in a whole file with an "@lines = E<lt>FHE<gt>"
		2740	construct. In "scalar context", B<READLINE> calls B<lookfor>. But it calls
		2741	B<streamline> in "list context". Both contexts also call B<matchclear>
		2742	to detect "empty" lines and B<reset_error> to detect hardware problems.
		2743	The existance of a hardware fault is reported with C<$^E>, although the
		2744	specific fault is only reported when B<error_msg> is true.
		2745
		2746	There are two additional methods for supporting "list context" input:
		2747	B<lastline> sets an "end_of_file" I<Regular Expression>, and B<linesize>
		2748	permits changing the "packet size" in the blocking read operation to allow
		2749	tuning performance to data characteristics. These two only apply during
		2750	B<READLINE>. The default for B<linesize> is 1. There is no default for
		2751	the B<lastline> method.
		2752
		2753	In Version 0.15, I<Regular Expressions> set by B<are_match> and B<lastline>
		2754	will be pre-compiled using the I<qr//> construct on Perl 5.005 and higher.
		2755	This doubled B<lookfor> and B<streamline> speed in my tests with
		2756	I<Regular Expressions> - but actual improvements depend on both patterns
		2757	and input data.
		2758
		2759	The functionality of B<lookfor> includes a limited subset of the capabilities
		2760	found in Austin Schutz's I<Expect.pm> for Unix (and Tcl's expect which it
		2761	resembles). The C<$before, $match, $pattern, and $after> return values are
		2762	available if someone needs to create an "expect" subroutine for porting a
		2763	script. When using multiple patterns, there is one important functional
		2764	difference: I<Expect.pm> looks at each pattern in turn and returns the first
		2765	match found; B<lookfor> and B<streamline> test all patterns and return the
		2766	one found I<earliest> in the input if more than one matches.
		2767
		2768	Because B<lookfor> can be used to manage a command-line environment much
		2769	like a Unix serial login, a number of "stty-like" methods are included to
		2770	handle the issues raised by serial logins. One issue is dissimilar line
		2771	terminations. This is addressed by the following methods:
		2772
		2773	$PortObj->stty_icrnl; # map \r to \n on input
		2774	$PortObj->stty_igncr; # ignore \r on input
		2775	$PortObj->stty_inlcr; # map \n to \r on input
		2776	$PortObj->stty_ocrnl; # map \r to \n on output
		2777	$PortObj->stty_onlcr; # map \n to \r\n on output
		2778	$PortObj->stty_opost; # enable output mapping
		2779
		2780	The default specifies a raw device with no input or output processing.
		2781	In Version 0.14, the default was a device which sends "\r" at the end
		2782	of a line, requires "\r\n" to terminate incoming lines, and expects the
		2783	"host" to echo every keystroke. Many "dumb terminals" act this way and
		2784	the defaults were similar to Unix defaults. But some users found this
		2785	ackward and confusing.
		2786
		2787	Sometimes, you want perl to echo input characters back to the serial
		2788	device (and other times you don't want that).
		2789
		2790	$PortObj->stty_echo; # echo every character
		2791	$PortObj->stty_echoe; # if echo erase with bsdel string (default)
		2792	$PortObj->stty_echok; # if echo \n after kill character (default)
		2793	$PortObj->stty_echonl; # echo \n even if stty_echo(0)
		2794	$PortObj->stty_echoke; # if echo clear string after kill (default)
		2795	$PortObj->stty_echoctl; # if echo "^Char" for control chars
		2796
		2797	$PortObj->stty_istrip; # strip input to 7-bits
		2798
		2799	my $air = " "x76; # overwrite entire line with spaces
		2800	$PortObj->stty_clear("\r$air\r"); # written after kill character
		2801	$PortObj->is_prompt("PROMPT:"); # need to write after kill
		2802	$PortObj->stty_bsdel("\cH \cH"); # written after erase character
		2803
		2804	# internal method that permits clear string with \r in config file
		2805	my $plus32 = "@"x76; # overwrite line with spaces (ord += 32)
		2806	$PortObj->is_stty_clear("-$plus32-"); # equivalent to stty_clear
		2807
		2808
		2809	=head1 NOTES
		2810
		2811	The object returned by B<new> or B<start> is NOT a I<FileHandle>. You
		2812	will be disappointed if you try to use it as one. If you need a
		2813	I<FileHandle>, you must use B<tie> as the constructor.
		2814
		2815	e.g. the following is WRONG!!____C<print $PortObj "some text";>
		2816
		2817	You need something like this (Perl 5.005):
		2818
		2819	# construct
		2820	$tie_ob = tie(*FOO,'Win32::SerialPort', $cfgfile)
		2821	or die "Can't start $cfgfile\n";
		2822
		2823	print FOO "enter char: "; # destination is FileHandle, not Object
		2824	my $in = getc FOO;
		2825	syswrite FOO, "$in\n", 2, 0;
		2826	print FOO "enter line: ";
		2827	$in = <FOO>;
		2828	printf FOO "received: %s\n", $in;
		2829	print FOO "enter 5 char: ";
		2830	sysread (FOO, $in, 5, 0) or die;
		2831	printf FOO "received: %s\n", $in;
		2832
		2833	# destruct
		2834	close FOO \|\| print "close failed\n";
		2835	undef $tie_ob; # Don't forget this one!!
		2836	untie *FOO;
		2837
		2838	Always include the C<undef $tie_ob> before the B<untie>. See the I<Gotcha>
		2839	description in I<perltie>.
		2840
		2841	The Perl 5.004 implementation of I<tied FileHandles> is missing
		2842	B<close> and B<syswrite>. The Perl 5.003 version is essentially unusable.
		2843	If you need these functions, consider Perl 5.005 seriously.
		2844
		2845	An important note about Win32 filenames. The reserved device names such
		2846	as C< COM1, AUX, LPT1, CON, PRN > can NOT be used as filenames. Hence
		2847	I<"COM2.cfg"> would not be usable for B<$Configuration_File_Name>.
		2848
		2849	Thanks to Ken White for testing on NT.
		2850
		2851	There is a linux clone of this module implemented using I<POSIX.pm>.
		2852	It also runs on AIX and Solaris, and will probably run on other POSIX
		2853	systems as well. It does not currently support the complete set of methods -
		2854	although portability of user programs is excellent for the calls it does
		2855	support. It is available from CPAN as I<Device::SerialPort>.
		2856
		2857	=head1 KNOWN LIMITATIONS
		2858
		2859	Since everything is (sometimes convoluted but still pure) Perl, you can
		2860	fix flaws and change limits if required. But please file a bug report if
		2861	you do. This module has been tested with each of the binary perl versions
		2862	for which Win32::API is supported: AS builds 315, 316, 500-509 and GS
		2863	5.004_02. It has only been tested on Intel hardware.
		2864
		2865	Although the B<lookfor, stty_xxx, and Tied FileHandle> mechanisms are
		2866	considered stable, they have only been tested on a small subset of possible
		2867	applications. While "\r" characters may be included in the clear string
		2868	using B<is_stty_clear> internally, "\n" characters may NOT be included
		2869	in multi-character strings if you plan to save the strings in a configuration
		2870	file (which uses "\n" as an internal terminator).
		2871
		2872	=over 4
		2873
		2874	=item Tutorial
		2875
		2876	With all the options, this module needs a good tutorial. It doesn't
		2877	have a complete one yet. A I<"How to get started"> tutorial appeared
		2878	B<The Perl Journal #13> (March 1999). Examples from the article are
		2879	available from http://tpj.com and from http://members.aol.com/Bbirthisel.
		2880	The demo programs in the distribution are a good starting point for
		2881	additional examples.
		2882
		2883	=item Buffers
		2884
		2885	The size of the Win32 buffers are selectable with B<buffers>. But each read
		2886	method currently uses a fixed internal buffer of 4096 bytes. This can be
		2887	changed in the Win32API::CommPort source and read with B<internal_buffer>.
		2888	The XS version will support dynamic buffer sizing. Large operations are
		2889	automatically converted to multiple smaller ones by the B<tied FileHandle>
		2890	methods.
		2891
		2892	=item Modems
		2893
		2894	Lots of modem-specific options are not supported. The same is true of
		2895	TAPI, MAPI. I<API Wizards> are welcome to contribute.
		2896
		2897	=item API Options
		2898
		2899	Lots of options are just "passed through from the API". Some probably
		2900	shouldn't be used together. The module validates the obvious choices when
		2901	possible. For something really fancy, you may need additional API
		2902	documentation. Available from I<Micro$oft Pre$$>.
		2903
		2904	=back
		2905
		2906	=head1 BUGS
		2907
		2908	On Win32, a port must B<close> before it can be reopened again by the same
		2909	process. If a physical port can be accessed using more than one name (see
		2910	above), all names are treated as one. The perl script can also be run
		2911	multiple times within a single batch file or shell script. The I<Makefile.PL>
		2912	spawns subshells with backticks to run the test suite on Perl 5.003 - ugly,
		2913	but it works.
		2914
		2915	On NT, a B<read_done> or B<write_done> returns I<False> if a background
		2916	operation is aborted by a purge. Win95 returns I<True>.
		2917
		2918	EXTENDED_OS_ERROR ($^E) is not supported by the binary ports before 5.005.
		2919	It "sort-of-tracks" B<$!> in 5.003 and 5.004, but YMMV.
		2920
		2921	A few NT systems seem to set B<can_parity_enable> true, but do not actually
		2922	support setting B<parity_enable>. This may be a characteristic of certain
		2923	third-party serial drivers.
		2924
		2925	__Please send comments and bug reports to wcbirthisel@alum.mit.edu.
		2926
		2927	=head1 AUTHORS
		2928
		2929	Bill Birthisel, wcbirthisel@alum.mit.edu, http://members.aol.com/Bbirthisel/.
		2930
		2931	Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/.
		2932
		2933	=head1 SEE ALSO
		2934
		2935	Win32API::CommPort - the low-level API calls which support this module
		2936
		2937	Win32API::File I<when available>
		2938
		2939	Win32::API - Aldo Calpini's "Magic", http://www.divinf.it/dada/perl/
		2940
		2941	Perltoot.xxx - Tom (Christiansen)'s Object-Oriented Tutorial
		2942
		2943	Expect.pm - Austin Schutz's adaptation of TCL's "expect" for Unix Perls
		2944
		2945	=head1 COPYRIGHT
		2946
		2947	Copyright (C) 1999, Bill Birthisel. All rights reserved.
		2948
		2949	This module is free software; you can redistribute it and/or modify it
		2950	under the same terms as Perl itself.
		2951
		2952	=head2 COMPATIBILITY
		2953
		2954	Most of the code in this module has been stable since version 0.12.
		2955	Except for items indicated as I<Experimental>, I do not expect functional
		2956	changes which are not fully backwards compatible. However, Version 0.16
		2957	removes the "dummy (0, 1) list" which was returned by many binary methods
		2958	in case they were called in list context. I do not know of any use outside
		2959	the test suite for that feature.
		2960
		2961	Version 0.12 added an I<Install.PL> script to put modules into the documented
		2962	Namespaces. The script uses I<MakeMaker> tools not available in
		2963	ActiveState 3xx builds. Users of those builds will need to install
		2964	differently (see README). Programs in the test suite are modified for
		2965	the current version. Additions to the configurtion files generated by
		2966	B<save> prevent those created by Version 0.18 from being used by earlier
		2967	Versions. 4 November 1999.
		2968
		2969	=cut

Subversion Repositories Projects

(root)/MissionCockpit/tags/V0.5.3/perl/lib/Win32/SerialPort.pm - Rev 825