view release on metacpan or  search on metacpan

lib/ARSObject.pm  view on Meta::CPAN

					: defined($a{-labels}->{$_})
					? (length($a{-labels}->{$_}) > $aw ? substr($a{-labels}->{$_},0,$aw) .'...' : $a{-labels}->{$_})
					: '') ."</option>\n"
			} @{&$av()})
	  ."</select>\n"
	  ."<input type=\"submit\" name=\"${n}__S_\" value=\"&lt;\" title=\"set\"$ac$as />"
	  .$s->{-cgi}->button(-value=>'...', -title=>'find', -onClick=>&$fs(3))
	  ."<input type=\"submit\" name=\"${n}__X_\" value=\"X\" title=\"close\"$ac$as />"
	  ."</div>\n"
	  ."<script for=\"window\" event=\"onload\">{window.document.forms[0].${n}__L_.focus()}</script>"
		)
	: ("<input type=\"submit\" name=\"${n}__O_\" value=\"...\" title=\"open\"$ac$as />"
	 .($s->{-cgi}->param("${n}__C_") ||$s->{-cgi}->param("${n}__X_")
		? "<script for=\"window\" event=\"onload\">{window.document.forms[0].${n}__O_.focus()}</script>"
		: ''
		))
	)
}


sub cgiesc {	# escape strings to html
	$_[0]->{-cgi}->escapeHTML(@_[1..$#_])
}


sub cgitfrm {	# table form layot
		# -form =>{form attrs}, -table=>{table attrs}, -tr=>{tr attrs}, -td=>{}, -th=>{}
 my ($s, %a) =$_[0];
 my $i =1;
 while (ref($_[$i]) ne 'ARRAY') {$a{$_[$i]} =$_[$i+1]; $i +=2};
 $s->cgi->start_form(-method=>'POST',-action=>'', $a{-form} ? %{$a{-form}} : ())
	# ,-name=>'test'
 .$s->{-cgi}->table($a{-table} ? $a{-table} : (), "\n"
 .join(''
	, map {	my $r =$_;
		$s->{-cgi}->Tr($a{-tr} ? $a{-tr} : (), "\n"
		.join(''
			, map { ($_ =~/^</
				? $s->{-cgi}->td($a{-td} || {-align=>'left', -valign=>'top'}, $_)
				: $s->{-cgi}->th($a{-th} || $a{-td} || {-align=>'left', -valign=>'top'}, $_)
				) ."\n"
				} @$r)
		) ."\n"
		} @_[$i..$#_])) ."\n"
 .$s->cgi->end_form()
}


sub smtpconnect {# Connect SMTP
 set(@_);	# (-smtphost) -> self->{-smtp}
 set($_[0],-die=>'Carp') if !$_[0]->{-die};
 my $s =shift;
 no warnings;
 local $^W =0; 
 eval('use Net::SMTP; 1') ||return(&{$s->{-die}}($@, $s->efmt('Net::SMTP')));
 $s->{-smtp} =eval {
		local $^W=undef; 
		eval("use Net::SMTP"); 
		$s->{-smtphost}
			? Net::SMTP->new($s->{-smtphost})
			: CORE::die($s->efmt('SMTP host name required'))
	};
 return(&{$s->{-die}}("SMTP host '" .($s->{-smtphost}||'') ."': $@\n")) 
	if !$s->{-smtp} ||$@;
 $s->{-smtp}
}


sub smtp {	# SMTP connection object
 return($_[0]->{-smtp}) if $_[0]->{-smtp};
 smtpconnect(@_)
}


sub smtpsend {	# SMTP mail msg send
		# -from||-sender, -to||-recipient, 
		# -data|| -subject + (-text || -html)
 my ($s, %a) =@_;
 return(&{$s->{-die}}("SMTP host not defined"))
	 if !$s->{-smtphost};
 local $s->{-smtpdomain} =$s->{-smtpdomain} 
			|| ($s->{-smtphost} && $s->smtp(sub{$_[1]->domain()}))
			|| 'nothing.net';
 $a{-from}	=$a{-from} ||$a{-sender} ||$ENV{REMOTE_USER} ||$ENV{USERNAME};
 $a{-from}	=&{$a{-from}}($s,\%a)	if ref($a{-from}) eq 'CODE';
 $a{-to}	=&{$a{-to}}($s,\%a)	if ref($a{-to}) eq 'CODE';
 $a{-to}	=[grep {$_} split /\s*[,;]\s*/, ($a{-to} =~/^\s*(.*)\s*$/ ? $1 : $a{-to})]
					if $a{-to} && !ref($a{-to}) && ($a{-to} =~/[,;]/);
 $a{-sender}	=$a{-sender} ||$a{-from};
 $a{-recipient}	=$a{-recipient} ||$a{-to};
 $a{-recipient}	=&{$a{-recipient}}($s,\%a) if ref($a{-recipient}) eq 'CODE';
 $a{-recipient}	=[grep {$_} split /\s*[,;]\s*/, ($a{-recipient} =~/^\s*(.*)\s*$/ ? $1 : $a{-recipient})]
					if $a{-recipient} && ref($a{-recipient}) && ($a{-recipient} =~/[,;]/);
 return(&{$s->{-die}}("SMTP e-mail recipients not defined"))
	if !$a{-recipient};
 if (!defined($a{-data})) {
	my $koi =(($a{-charset}||$s->charset()||'') =~/1251/);
	$a{-subject} =    ref($a{-subject}) eq 'CODE'
			? &{$a{-subject}}($s,\%a)
			: 'ARSObject'
		if ref($a{-subject}) ||!defined($a{-subject});
	$a{-data}  ='';
	$a{-data} .='From: ' .($koi	? $s->cptran('ansi','koi',$a{-from}) 
					: $a{-from})
			."\cM\cJ";
	$a{-data} .='Subject: '
			.($koi
			? $s->cptran('ansi','koi',$a{-subject})
			: $a{-subject}) ."\cM\cJ";
	$a{-data} .='To: ' 
			.($koi	
			? $s->cptran('ansi','koi', ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to}) 
			: (ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to}))
			."\cM\cJ" 
			if $a{-to};
	foreach my $k (keys %a) {
		next if $k =~/^-(data|subject|html|text|from|to|sender|recipient)$/;
		next if !defined($a{$k});
		my $n =$k =~/^-(.+)/ ? ucfirst($1) .':' : $k;
		$a{-data} .=$n .' ' .$a{$k} ."\cM\cJ";
	}
	$a{-data} .="MIME-Version: 1.0\cM\cJ";
	$a{-data} .='Content-type: '  .($a{-html} ? 'text/html' : 'text/plain')
			.'; charset=' .($a{-charset}||$s->charset())
			."\cM\cJ";
	$a{-data} .='Content-Transfer-Encoding: ' .($a{-encoding} ||'8bit') ."\cM\cJ";
	$a{-data} .="\cM\cJ";
	$a{-data} .=$a{-html} ||$a{-text} ||'';
 }
 local $^W=undef;
 $s->smtp->mail($a{-sender} =~/<\s*([^<>]+)\s*>/ ? $1 : $a{-sender})
	||return(&{$s->{-die}}("SMTP sender \'" .$a{-sender} ."' -> " .($s->smtp->message()||'?')));
 $s->smtp->to(ref($a{-recipient})
		? (map { !$_ ? () : /<\s*([^<>]+)\s*>/ ? $1 : $_ } @{$a{-recipient}})
		: $a{-recipient}, {'SkipBad'=>1}) # , {'SkipBad'=>1}
	|| return(&{$s->{-die}}("SMTP recipient \'" 
		.(ref($a{-recipient}) ? join(', ', (map { !$_ ? () : /<\s*([^<>]+)\s*>/ ? $1 : $_ } @{$a{-recipient}})) : $a{-recipient}) ."' -> " .($s->smtp->message()||'?')));
 $s->smtp->data($a{-data})
	||return(&{$s->{-die}}("SMTP data '" .$a{-data} ."' -> " .($s->smtp->message()||'?')));
 my $r =$s->smtp->dataend()
	||return(&{$s->{-die}}("SMTP dataend -> " .($s->smtp->message()||'?')));
 $r ||1;
}


sub soon {	# Periodical execution of this script
		# (minutes ||sub{}, ?log file, ?run command, ?soon command)
		# minutes: undef - clear sched, run once || sub{} -> number
		# log file: empty || full file name || var file name
		# run  command: empty || 'command line' || [command line] || sub{}
		# soon command: empty || 'command line' || [command line] || []
		# empty run command - only soon command will be scheduled
		# empty soon command - sleep(minutes*60) will be used
		# !defined(minutes) - soon command will be deleted from schedule 
		#	and run command will be executed once
		# [soon command,... [arg,...],...] - schedule cleaning hint:
		#	join(' ',@{[soon,...arg]}) used to clean schedule
		#	join('', @{[arg,...]}) used in soon command
 my ($s, $mm, $lf, $cr, $cs) =@_;
 $lf =$s->vfname($lf) if $lf && ($lf !~/[\\\/]/);
 my $wl;
 if (ref($cs) ? scalar(@$cs) : $cs) {
	return(&{$s->{-die}}("MSWin32 required for `at` in soon()\n"))
		if $^O ne 'MSWin32';
	if (defined($mm) && ($^O eq 'MSWin32') && eval('use Win32::Event; 1')) {
		# MSDN: 'CreateEvent', 'Kernel Object Namespaces'
		my $q =_sooncl($s, $cs, 1);
		my $n =$q;
		   $n =~s/[\\]/!/g;
		   $n ="Global\\$n";
		# sleep(60);
		$wl =Win32::Event->new(0,0,$n);
		# $s->fstore(">>$lf", $s->strtime() ."\t$$\tWin32::Event->new(0,0,$n) -> " .join(', ', $wl &&1 ||0, $^E ? ($^E +0) .".'$^E'" : ()) ."\n")
		#	if $lf;
		if ($wl && $^E && ($^E ==183)) {
			print "Already '$q', done.\n";
			$s->fstore(">>$lf", "\n" .$s->strtime() ."\t$$\tAlready '$q', done.\n")
				if $lf;
			return(0);
		}
	}
	_sooncln($s, $mm, $lf, $wl ? '' : $cr, $cs, 1);
 }
 my $r =1;
 while (1) {
	if (!$cr) {
	}
	elsif (ref($cr) eq 'CODE') {
		local *OLDOUT;
		local *OLDERR;
		if ($lf) {
			eval{fileno(STDOUT) && open(OLDOUT, '>&STDOUT')};
			eval{fileno(STDERR) && open(OLDERR, '>&STDERR')};
			open(STDOUT, ">>$lf");
			open(STDERR, ">>$lf");
		}
		$r =&$cr(@_);
		if ($lf) {
			eval{fileno(OLDOUT) && close(STDOUT) && open(STDOUT, '>&OLDOUT')};
			eval{fileno(OLDERR) && close(STDERR) && open(STDERR, '>&OLDERR')};
		}
	}
	else {
		my $cmd =$cr;
		if (ref($cr) eq 'ARRAY') {
			$cr->[0] =Win32::GetFullPathName($cr->[0])
				if ($^O eq 'MSWin32') && ($cr->[0] !~/[\\\/]/);
			$cr->[0] = $cr->[0]=~/^(.+?)[^\\\/]+$/ ? $1 .'perl.exe' : $cr->[0]
				if $cr->[0] =~/\.dll$/i;
			$cmd =join(' ', @$cr);
		}
		if ($lf) {
			$cmd ="$cmd >>$lf 2>>\&1";
			print(($cs ? '' : "\n") ."$cmd\n");
			$s->fstore(">>$lf", ($cs ? '' : "\n") .$s->strtime() ."\t$$\t$cmd\n");
			if (system($cmd) <0) {
				$r =0;
				print("Error $!\n");
				$s->fstore(">>$lf", $s->strtime() ."\t$$\t$!\n");
			}
		}
		else {
			print(($cs ? '' : "\n") ."$cmd\n");
			if (system(ref($cr) ? @$cr : $cr) <0) {
				$r =0;
				print("Error $!\n");
			}
		}
	}
	last if $cs || !defined($mm);
	my $mmm =ref($mm) eq 'CODE' ? &$mm($s) : $mm;
	print "sleep(", $mmm *60, ")...\n";
	$s->fstore(">>$lf", $s->strtime() ."\t$$\tsleep(" .($mmm*60) .")...\n")
		if $lf;
	sleep($mmm *60);
 }
 if (defined($mm) && (ref($cs) ? scalar(@$cs) : $cs)) {
	_sooncln($s, $mm, $lf, $cr, $cs, 0) if !$wl;
	my $t1 =$s->strtime($s->timeadd(
		sprintf('%.0f', time()/60) *60
		, 0,0,0,0
		, ref($mm) eq 'CODE' ? &$mm($s) : $mm
		));
	$t1 =$1 if $t1 =~/\s([^\s]+)/;
	my $cmd ="at $t1 /interactive " ._sooncl($s, $cs);
	print("$cmd\n");
	$s->fstore(">>$lf", $s->strtime() ."\t$$\t$cmd\n")
		if $lf;
	if (system($cmd) <0) {
		print("Error $!\n");
		$s->fstore(">>$lf", $s->strtime() ."\t$$\t$!\n")
			if $lf;
	}
 }
 $r
}



sub _sooncl {	# soon() command line former
 my ($s, $cs, $q) =@_;
 my $nc;
 my $qry =$cs;
 if (ref($cs)) {
	return(&{$s->{-die}}("MSWin32 required for `at` in soon()\n"))
		if $^O ne 'MSWin32';
	$cs->[0] =Win32::GetFullPathName($cs->[0])
		if ($^O eq 'MSWin32') && ($cs->[0] !~/[\\\/]/);
	$cs->[0] = $cs->[0]=~/^(.+?)[^\\\/]+$/ ? $1 .'perl.exe' : $cs->[0]
		if $cs->[0] =~/\.dll$/i;
	$qry =$q ? join(' ', map {   $nc
				? ()
				: !defined($_)
				? '""'
				: ref($_)
				? (do{$nc =$_->[0]})
				: $_
				} @$cs)
		: join(' ', map {!defined($_) ? '""' : ref($_) ? join('', @$_) : $_
				} @$cs);
 }
 $qry
}


sub _sooncln {	# soon() cleaner
 my ($s, $mm, $lf, $cr, $cs, $strt) =@_;
 $lf =$s->vfname($lf) if $lf && ($lf !~/[\\\/]/);
 if (ref($cs) ? scalar(@$cs) : $cs) {
	my $nc;
	my $qry =_sooncl($s, $cs, 1);
	print "Starting '$qry'...\n" if $strt && defined($mm);
	$s->fstore(">>$lf", "\n" .$s->strtime() ."\t$$\tStarting '$qry'...\n")
		if $strt && $lf && defined($mm);
	sleep(int(rand(20))) if $strt && defined($mm) && $cr;
	foreach my $l (`at`) {
		next if $nc
			? $l !~/\Q$qry\E/i
			: $l !~/\Q$qry\E[\w\d\s]*[\r\n]*$/i;
		next if $l !~/(\d+)/;
		my $v =$1;
		my $cmd ="at $v /d";
		print("$cmd # $l\n");
		$s->fstore(">>$lf", $s->strtime() ."\t$$\t$cmd # $l\n")
			if $lf;
		system($cmd);
	}
 }
 1
}


sub cfpinit {	# Field Player: init data structures
 my ($s) =@_;	# (self) -> self
 $s->{-fphc} ={};
 $s->{-fphd} ={};
 my $dh ={};
 my $dp =undef;
 my $ah ={};
 my $ak;
 my $bf =undef;
 foreach my $f (@{$s->{-fpl}}) {
	if (ref($f) && $f->{-key} && $f->{-namecgi}) {
		$ak =$f->{-namecgi};
		last