[28121] in Perl-Users-Digest
Perl-Users Digest, Issue: 9485 Volume: 10
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Mon Jul 17 00:05:41 2006
Date: Sun, 16 Jul 2006 21:05:04 -0700 (PDT)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Sun, 16 Jul 2006 Volume: 10 Number: 9485
Today's topics:
Re: Can I compare array with array? <mritty@gmail.com>
Re: Can I compare array with array? <jurgenex@hotmail.com>
Re: CPANPLUS on debian headache <hobosalesman@gmail.com>
Re: How get UTF-8 from urlencoded web form <jwkenne@attglobal.net>
Re: Net::Telnet - Library Application <laff7430@bellsouth.net>
Re: Net::Telnet - Library Application robic0
RegEx: odd number of slashes? and too many slashes? <nibbles.bits@verizon.net>
Re: RegEx: odd number of slashes? and too many slashes? robic0
Re: Requirements for Perl on Windows XP? <WGSGNUAYHTTE@spammotel.com>
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: 16 Jul 2006 19:29:08 -0700
From: "Paul Lalli" <mritty@gmail.com>
Subject: Re: Can I compare array with array?
Message-Id: <1153103348.415146.141050@b28g2000cwb.googlegroups.com>
Dr.Ruud wrote:
> A. Sinan Unur schreef:
>
> > $#a is one less than the number of
> > elements in @a.
>
> Generally yes, as it is the last index in the array.
"Generally"? Can you please explain? In what situation do you believe
the condition:
@a - 1 == $#a
to return a false value?
> > my @a = qw(one two three);
> > my @b = qw(one two three);
>
> perl -wle '
> $, = qq/\t/;
> @a = qw(a b c);
> @b = (qq/a$"b$"c/);
> print qq/@a/ eq qq/@b/, 0+@a, 0+@b
> '
What, exactly, are you attempting to prove here? That "@a" eq "@b" is
not a good enough check to prove that @a and @b actually contain the
same values? While I completely agree with you, I'm trying to figure
out what that has to do with anything else you said.
Please explain.
Paul Lalli
------------------------------
Date: Mon, 17 Jul 2006 03:04:21 GMT
From: "Jürgen Exner" <jurgenex@hotmail.com>
Subject: Re: Can I compare array with array?
Message-Id: <V6Dug.5375$Ss2.4651@trnddc01>
Paul Lalli wrote:
> Dr.Ruud wrote:
>> A. Sinan Unur schreef:
>>
>>> $#a is one less than the number of
>>> elements in @a.
>>
>> Generally yes, as it is the last index in the array.
>
> "Generally"? Can you please explain? In what situation do you
> believe the condition:
> @a - 1 == $#a
> to return a false value?
Every time someone messed around with $[
Of course use of $[ is highly discouraged, but that doesn't mean that some
people aren't stupid enough to try it nevertheless.
jue
------------------------------
Date: 16 Jul 2006 20:27:12 -0700
From: "Hobo Salesman" <hobosalesman@gmail.com>
Subject: Re: CPANPLUS on debian headache
Message-Id: <1153106832.651356.216440@75g2000cwc.googlegroups.com>
BZ wrote:
> Hobo Salesman wrote in comp.lang.perl.misc:
> > Default debian distribution doesn't seem to give any way to search for
> > perl modules, the best it does is (sometimes) mention modules in the
> > description of a package.
>
> Uhm, Debian packages of perl modules are just consistently named;
> there's therefor no need to search.
> Just use dpkg -l lib\*-perl or so to list all available modules.
Maybe I'm not understanding, but I can't see how that tells me what
package I need if I want to use, say, Config::General. I'd also like to
use one system for managing perl modules, and I don't think I could
find a debian package for, say... Petal. Maybe I could if I used the
CPAN debian packages (maybe, dont know how complete it is), but I'd
imagine it would be like the CPANPLUS package they have - outdated,
buggy, and 100 times more trouble than it's worth.
------------------------------
Date: Sun, 16 Jul 2006 23:00:26 -0400
From: "John W. Kennedy" <jwkenne@attglobal.net>
Subject: Re: How get UTF-8 from urlencoded web form
Message-Id: <C4Dug.9671$F_6.6600@fe12.lga>
Bart Van der Donck wrote:
> Dr.Ruud wrote:
>
>> Bart Van der Donck schreef:
>>
>>> You can't compare (n vs. \n) to (é vs. %E9).
>> You can compare (<LF> vs. "\n") to (<é> vs. "%E9"). Often, such
>> translations use a table in memory.
>
> Yes, exactly, like:
> LF -> %0A
> é -> %E9
>
> <LF> refers to hex 0A by definition, but I'm not sure whether "\n"
> always refers to hex 0A on various operating systems.
"\n" is 0x0A on all systems.
However, when writing a file in text mode, 0x0A may be translated on the
file into 0x0D,an 0x0D0A, or (on an IBM mainframe) a logical record end.
Similarly, an 0x0D, an 0x0D0A, or a logical record end can be translated
into an 0x0A when reading a file in text mode.
Add the extra zeroes for Unicode as needed.
--
John W. Kennedy
"The blind rulers of Logres
Nourished the land on a fallacy of rational virtue."
-- Charles Williams. "Taliessin through Logres: Prelude"
------------------------------
Date: Sun, 16 Jul 2006 21:34:44 -0400
From: Carl Lafferty <laff7430@bellsouth.net>
Subject: Re: Net::Telnet - Library Application
Message-Id: <XNBug.7632$Bx.6009@bignews5.bellsouth.net>
>
> ($info) = $galaxy->waitfor(qr/\x5C\x62/);
>
> Or try:
> ($info) = $galaxy->waitfor('/\\\b/');
>
Couldn't get the top one to work BUT the bottom one worked like a charm!!
Thank you!!!!!!!
------------------------------
Date: Sun, 16 Jul 2006 19:06:38 -0700
From: robic0
Subject: Re: Net::Telnet - Library Application
Message-Id: <0dplb29k4somddvsvnf6e8kk8cphmsth3h@4ax.com>
On Sun, 16 Jul 2006 19:03:43 -0400, Carl Lafferty <laff7430@bellsouth.net> wrote:
>I have a problem with something I am doing using net::telnet in perl.
>I am trying to write a script that will access an automated library
>system via telnet and basically mimic what the company that sold us the
>system did in VB. I am basically reverse engineering their code only in
>perl.. anyway... My problem is that I am having to search for
>different flags using waitfor. sometimes it is the word Description,
>sometimes it is \x8f (I have no idea why but they seem to use that as a
>delimiter quite often) My problem is that when I get to a particular
>piece of data, I am not getting everything from the stream in my waitfor
>variable.
>
>This is a snippit of the code
>
>#cleaning out the buffer
> ($info) = $galaxy->waitfor("/\x8f/");
> print "1 $info\n";
>
> ($info) = $galaxy->waitfor("/\x8f/");
> print "2 $info\n";
>
>
> $galaxy->print("5000 5018 30 0 0 ");
>
> ($info) = $galaxy->waitfor("/\x8f/");
> $info =~ s/\\b/\n/g;
> $info =~ s/\\B/\<b\>/g;
> $info =~ s/\n/\<\/b\>\n/g;
> print "$info\n";
>
>
> ($info) = $galaxy->waitfor("/Description/");
> $info =~ s/\\b/\n/g;
> $info =~ s/\\B/\<b\>/g;
> $info =~ s/\n/\<\/b\>\n/g;
> print "$info\n";
>
>#got stuff up to description now
> ($info) = $galaxy->waitfor("/\x5C\x62/");
> $info =~ s/\\b/\n/g;
> $info =~ s/\\B/\<b\>/g;
> $info =~ s/\n/\<\/b\>\n/g;
> print "Description: $info\n";
>
>
>print "\nLogging out of galaxy\n";
>#$ok = $galaxy->waitfor("/\x8f/");
>$ok = $galaxy->print("999");
>$ok = $galaxy->print("0005 GALAXY||20");
>$ok = $galaxy->print("0010 ");
>
>$galaxy->close;
>-----------------------------------
>0x000e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
>0x000f0: 20 5c 62 20 20 54 79 70 65 2f 6c 61 6e 67 75 61 \b
>Type/langua
>0x00100: 67 65 3a 20 5c 42 42 6f 6f 6b 2f 65 6e 67 5c 62 ge:
>\BBook/eng\b
>0x00110: 0d 20 20 20 49 53 42 4e 2f 49 53 53 4e 3a 20 5c .
>ISBN/ISSN: \
>0x00120: 42 2f 5c 62 0d 20 44 65 73 63 72 69 70 74 69 6f B/\b.
>Descriptio
>0x00130: 6e 3a 20 5c 42 31 37 38 20 70 2e 2c 20 32 30 20 n: \B178 p.. 20
>0x00140: 63 6d 2e 20 20 20 20 20 20 20 20 20 5c 62 cm. \b
>
>0x00000: 39 39 39 0d 999.
>
>0x00000: 30 30 30 35 20 47 41 4c 41 58 59 7c 7c 32 30 0d 0005
>GALAXY||20.
>
>0x00000: 30 30 31 30 20 0d 0010 .
>
>----------------------------------------------
>above is the dump file (a little difficult to read :( )
>
>
>it SEES the word description and gives me the info up to that.. BUT
>after description the delimiter is \b (\x5c\x62) which is what I do a
>waitfor on. all I get is a \
>
>Everything after 0x00140: is my program signing out of the telnet session..
>
>Any way to get that information into my variable?? Ive been beating my
>head for 4 days now... any help is appreciated.
>
>
>Carl Lafferty
>System Admin
>Floyd County Public Library
>Prestonsburg, KY
Net::Telnet is a just an ok module. The fact is that no module can
correct the inherrant flaws of Telnet in general. For what it does,
I give the author a thumbs up. He trully has written a awsome piece of code.
The flaws of Telnet across OS's compounds the problem. The translation of
newlines (and other control codes) alone in these terminal emulators
(across OS's) is the death nail. Other nails are there, the big one is
discovery handshaking and progrmability (mode setting). So implementation
was the big deathnail to Telnet. That is of course on the level that you
need to use it at because, there are plenty of smooth running Telnet
automations out there, be it in C or Perl modules.
In general, to design a piece of code for the Telnet module, you will have
to know, to be able to anchor with certainty. This involves alot of work by
hand ahead of time. Using the module capture "all" in several attempts for
a statistical overview of your objective.
What you reliably "waitfor" may not be the EOT (end of transmission).
And the eot may not be a static thing.
Whatever your waiting for it doesen't matter. What matters is that you want
to capture some data, be it binary (not control) or printable. You don't want
to capture the data of interest directly! You want some assurance that "it"
can be gleened later on and you want to be immediatly ready to repeat the
sequence.
So many folks try to capture that "single" piece of data on the fly, but never
get framed for it as the boxcars roll down the track (possibly several times).
In actuality (this is the truth), some Telnet servers don't even send
a frame down for a single data change. What you have to know is that when the handshaking
is done what the full outcome of a frame request will be.
You can force Telnet servers to re-send all the info in the frame however.
I had written a wrapper module a very long time ago, that covers Win<->win, Nx<->Win.
You can imbedd binary in the waitfor string (but its not necessary).
I am posting it here (again) from along time ago. When I wrote this, I only had like
1 year of Perl and 16 years of C/C++. What is here is stuff that works. I can take no
cudo's for the code and I am not in the biz of re-writing code (for free).
So here it is, a pm and pl file that "can" get what you wan't. If you don't use it
its ok with me. It has worked for me in several Telnet automations within/across platform.
Any usage questions, let me know.
Just glanceing at the old examples, read through the lines on the intent, I don't want to
revisit or modify this crap, even though it works. You will get the jist.
robic0
==================================================
TlnSvr.pm
==================================================
package TlnSrv;
use strict;
#my $console_mode = 1;
use Net::Telnet ();
use Cwd;
my $VERSION = 1.00;
my $tln = undef;
$|=1;
# CONSOLE MODE ????? Info --
# We need line-mode or stream!!
# In console mode, the screen is treated
# as a buffer X by Y where the display is
# controlloed by ansi escape sequences.
# This is bad when expecting specific output (prompts)
# that may never come because those chars are already
# in screen buffer.
# Always make the server NON-Console, ie: use stream!!
# If not, as a workaround, between real commands,
# we can clear screen, then send return.
# -------------------------------------------------------
# Note that all 'Prompts' strings are single quote Regex
# parameters.
# Global variables
sub new ($$$$$)
{
my $class = shift;
my $self = {};
$self->{'TlnServer'} = shift; # Telnet server address. IP or computer name
$self->{'TlnUser'} = shift; # User name
$self->{'TlnUser'} = "administrator" unless (defined $self->{'TlnUser'});
$self->{'TlnPass'} = shift; # Password
$self->{'TlnPass'} = "password" unless (defined $self->{'TlnPass'});
$self->{'LogDir'} = shift;
$self->{'LogDir'} = cwd() unless (defined $self->{'LogDir'});
$self->{'Debug'} = 0;
$self->{'Show_Prematch'} = 'no'; # Show reply up to 'match' (used in SendCommand only)
$self->{'Port'} = 23;
$self->{'Prompt'} = '/[\$%#>] $/'; # or '/c:\\\\>/i for dos
$self->{'Timeout'} = 10;
$self->{'ClearCmd'} = ''; # Clear screen shell command (or "" if not used)
$self->{'Waitsecs'} = 10; # (see SendCommand)
$self->{'Show_Wait'} = 'yes'; # Print line that counts off 'Waitsecs'
$self->{'Error'} = '';
bless ($self, $class);
return $self;
}
#######################################
# SetVal
#######################################
sub SetVal
{
my ($self, @args) = @_;
my $val;
if (@args > 0)
{
while (($_, $val) = splice @args, 0, 2) {
if (/^Debug$/i) {
$self->{'Debug'} = $val;
}
elsif (/^Show_Prematch$/i) {
$self->{'Show_Prematch'} = $val;
}
elsif (/^Port$/i) {
$self->{'Port'} = $val;
}
elsif (/^Prompt$/i) {
$self->{'Prompt'} = $val;
}
elsif (/^Timeout$/i) {
$self->{'Timeout'} = $val;
}
elsif (/^ClearCmd$/i) {
$self->{'ClearCmd'} = $val;
}
elsif (/^Waitsecs$/i) {
$self->{'Waitsecs'} = $val;
}
elsif (/^Show_Wait$/i) {
$self->{'Show_Wait'} = $val;
}
}
}
$self->{'Error'} = '';
return 1;
}
#######################################
# Open telnet session
#######################################
sub OpenSession($$)
{
my $self = shift;
my $logging = shift;
## default prompt and timeout for this session
my $timeout = $self->{'Timeout'};
my $prompt = $self->{'Prompt'};
my $logging = 1 unless (defined $logging);
if (defined $tln) {$tln->close;}
$tln = undef;
$tln = new Net::Telnet (Timeout => $self->{'Timeout'}, Prompt => $self->{'Prompt'});
$tln->errmode ('return');
## logging is turned off by default
## if enabled, a new log is created each time
if ($logging) {
$tln->option_log ("$self->{'LogDir'}/option.log");
$tln->dump_log ("$self->{'LogDir'}/dump.log");
$tln->input_log ("$self->{'LogDir'}/input.log");
}
$tln->buffer_empty;
$tln->cmd_remove_mode (0);
if (!$tln->open(Host => $self->{'TlnServer'}, Port => $self->{'Port'})) {
$self->{'Error'} = "Could not connect to: $self->{'TlnServer'}";
$tln = undef;
return 0;
}
if (!$tln->login ($self->{'TlnUser'}, $self->{'TlnPass'})) {
$self->{'Error'} = "Login failed on $self->{'TlnServer'} (name|password): $self->{'TlnUser'}, $self->{'TlnPass'}";
$tln = undef;
return 0;
}
$self->{'Error'} = '';
return 1;
}
#######################################
# Close telnet session
#######################################
sub CloseSession($)
{
my $self = shift;
if (defined $tln) {$tln->close;}
$tln = undef;
$self->{'Error'} = '';
return 1;
}
#######################################
# Clear screen
# use as console mode workaround
#######################################
sub ClearScreen ($$$$)
{
my ($self, $cmd, $timeout, $prompt) = @_;
my ($pre, $match);
if (!defined $tln) {
$self->{'Error'} = "Session not open";
return 0;
}
$cmd = $self->{'ClearCmd'} unless defined $cmd;
$timeout = $self->{'Timeout'} unless defined $timeout;
$prompt = $self->{'Prompt'} unless defined $prompt;
$tln->print ($cmd);
$tln->waitfor (Match => $prompt, Timeout => $timeout);
$tln->print ("");
($pre, $match) = $tln->waitfor (Match => $prompt, Timeout => $timeout);
print "Sent clear screen ... recieved: $match\n" if ($self->{'Debug'});
$tln->buffer_empty; # empty recieve buffer after clear
$self->{'Error'} = '';
return 1;
}
#######################################
# Empty recieve buffer
#######################################
sub EmptyBuffer($)
{
my $self = shift;
if (!defined $tln) {
$self->{'Error'} = "Session not open";
return 0;
}
$tln->buffer_empty;
$self->{'Error'} = '';
return 1;
}
#####################################################
# Send command and wait for reply
# - May wait for one of many reply regxs' passed in
# via the 'Reply' array. Each MUST be single
# quoted regex expressions. ie: '/any/i'
# IN:
# cmd - the shell command or program
# waitsecs - total secs willing to wait (up to)
# show_wait - 'yes' shows the seconds while waiting
# Reply - list of matches will wait for
# OUT:
# Returns index+1 into the 'Reply' list passed in,
# of the first match found in reply stream.
# Otherwise returns 0, meaning timeout or other
# error (check $self->{'Error'})
#####################################################
sub SendCommand
{
my ($self, $cmd, $waitsecs, $show_wait, @Reply) = @_;
my ($pre, $match);
if (!defined $tln) {
$self->{'Error'} = "Session not open";
return 0;
}
$waitsecs = $self->{'Waitsecs'} unless (defined $waitsecs);
$show_wait = $self->{'Show_Wait'} unless (defined $show_wait);
my @args = ('Timeout', 0);
if (@Reply == 0) { push (@Reply, $self->{'Prompt'}) }
for (@Reply) {
push (@args, 'Match');
push (@args, $_);
}
my $savedtimeout = $tln->timeout(0);
$tln->print ($cmd);
print "Sent: $cmd\n" if ($self->{'Debug'});
for (my $i = 0; $i < $waitsecs; $i++) {
($pre, $match) = $tln->waitfor(@args);
if (!$tln->timed_out) {
print "\rRecieved ($i seconds): $match \n" if ($self->{'Debug'});
print "\n$pre\n" if (lc($self->{'Show_Prematch'}) eq 'yes');
last;
}
sleep (1);
if ($show_wait eq lc('yes')) {
print "\rWait progress: ".($i+1)." seconds " ;
print "\n" if ($i == ($waitsecs-1));
}
}
$tln->timeout($savedtimeout);
## check if timed out
if ($tln->timed_out) {
print "\r** WAIT EXPIRED - $waitsecs seconds ** \n" if ($self->{'Debug'});
$self->{'Error'} = "Timed out ($waitsecs) executing command: $cmd";
return 0;
}
## return the index of the matched @Reply
#return 1 if (!@Reply);
my $pos = 0;
for (@Reply) {
$pos++;
my $patcheck = "last if (\$match =~ $_);"; # pattern match check
#print "$patcheck\n";
eval $patcheck;
}
$self->{'Error'} = '';
return $pos;
}
1;
==================================================
tln.pl
==================================================
use strict;
use Net::Telnet;
use sort 'stable';
my $current = sort::current();
use Net::Telnet qw(TELOPT_TTYPE);
if (1)
{
my $Term = "ascii";
my $Telopt_ttype_ok = '';
my ($outline, $inline);
my $tln = new Net::Telnet (Timeout => 1, Prompt => '/C:\\\\>/');
my $savederrmode = $tln->errmode ('return');
$tln->option_log('option.log');
## Set up callbacks to negotiate terminal type.
if ($tln->open("155.64.151.193"))
{
$tln->login("administrator", "password");
#print "$savederrmode\n";
#my @aOut = $tln->cmd ( "help\n" );
#print (join "\n", @aOut);
#print "\n\n\ndid u see it?\n\n\n\n";
#<>;
$outline = "";
while ($outline !~ /quit/i)
{
do {
$inline = $tln->get();
#chomp ($inline);
print "$inline";
} while (defined $inline);
$outline = <STDIN>;
chomp ($outline);
# print $outline;
$tln->print ($outline);
}
} else {
print "Could not connect to host\n";
}
$tln->close;
print "done!\n";
###################################
# Option negotation callbacks
####################################
sub opt_callback
{
my ($obj, $option, $is_remote,
$is_enabled, $was_enabled, $buf_position) = @_;
if ($option == TELOPT_TTYPE and $is_enabled and !$is_remote) {
$Telopt_ttype_ok = 1;
}
1;
}
sub subopt_callback
{
my ($obj, $option, $parameters) = @_;
my $ors_old;
if ($option == TELOPT_TTYPE) {
$ors_old = $obj->output_record_separator("");
$obj->print("\xff\xfa", pack("CC", $option, 0), $Term, "\xff\xf0");
$obj->output_record_separator($ors_old);
}
1;
}
}
if (0)
{
## Module import.
use Net::Telnet qw(TELOPT_TTYPE);
## Global variables.
my $Term = "vt100";
my $Telopt_ttype_ok = '';
## Main program.
{
my $t;
my ($host, $username, $passwd) = @ARGV;
die "usage: $0 host username passwd\n" unless @ARGV == 3;
$t = new Net::Telnet (Prompt => '/\$ $/',
Dump_log => "/tmp/dump.log",
Option_log => "/tmp/option.log");
## Set up callbacks to negotiate terminal type.
$t->option_callback(\&opt_callback);
$t->option_accept(Do => TELOPT_TTYPE);
$t->suboption_callback(\&subopt_callback);
$t->open($host);
$t->login($username, $passwd);
print "TERM=", $t->cmd("printenv TERM");
$t->close;
exit;
} # end main program
sub opt_callback {
my ($obj, $option, $is_remote,
$is_enabled, $was_enabled, $buf_position) = @_;
if ($option == TELOPT_TTYPE and $is_enabled and !$is_remote) {
$Telopt_ttype_ok = 1;
}
1;
}
sub subopt_callback {
my ($obj, $option, $parameters) = @_;
my $ors_old;
if ($option == TELOPT_TTYPE) {
$ors_old = $obj->output_record_separator("");
$obj->print("\xff\xfa", pack("CC", $option, 0), $Term, "\xff\xf0");
$obj->output_record_separator($ors_old);
}
1;
}
}
=============================================
tln2.pl
=============================================
use strict;
use Net::Telnet;
use sort 'stable';
my $VERSION = 1.00;
my $current = sort::current();
#print "\n==> sort : $current\n\n";
use Net::Telnet ();
my $tln = undef;
my $debug = 1;
my $console_mode = 1;
# CONSOLE MODE ????? Info --
# We need line-mode or stream!!
# In console mode, the screen is treated
# as a buffer X by Y where the display is
# controlloed by ansi escape sequences.
# This is bad when expecting specific output (prompts)
# that may never come because those chars are already
# in your screen buffer.
# Always make the server NON-Console, ie: use stream!!
# If not, as a workaround we will clear screen cmd,
# then return cmd, between real commands.
if (1)
{
$tln = new Net::Telnet (Timeout => 2, Prompt => '/c:\\\\>/i');
$tln->errmode ('return');
$tln->option_log ('option.log');
$tln->dump_log ('dump.log');
$tln->input_log ('input.log');
$tln->buffer_empty;
$tln->cmd_remove_mode (0);
my $prompt = '/c:\\\\>/i';
if ($tln->open("155.64.151.193"))
{
$tln->prompt ($prompt);
$tln->login ("administrator", "password");
$tln->cmd_remove_mode (0);
## test loop
for (my $t = 0; $t < 3; $t++)
{
$tln->timeout(2);
my $ret;
TlNet_ClearScreen ('cls', $prompt, 2);
$ret = TlNet_Send ( "ping 155.64.151.193", 10, 'yes', '/asfdgbasdfgas/i', '/c:\\\\>/i');
#print "send returned prompt #: $ret\n";
TlNet_ClearScreen ('cls', $prompt, 2);
$ret = TlNet_Send ( "dir", 10, 'yes', '/c:\\\\>/i', '/asfdgbasdfgas/i');
#print "send returned prompt #: $ret\n";
TlNet_ClearScreen ('cls', $prompt, 2);
$ret = TlNet_Send ( "help\n\n\n\n\n\n", 5, 'yes', '/c:\\\\>/i', '/MORE ---/i');
my $retry = 5;
while ($ret != 1 && $retry-- > 0)
{
$ret = TlNet_Send ( "", 1, 'yes', '/c:\\\\>/i', '/MORE ---/i');
#print "send returned prompt #: $ret\n";
}
$ret = TlNet_Send ( "echo hi\necho and\necho hello\necho there\n", 15, 'yes', '/c:\\\\>/i', '/MORE ---/i');
TlNet_ClearScreen ('cls', $prompt, 2);
TlNet_ClearScreen ('cls', $prompt, 2);
}
} else {
print "Could not connect to host\n";
}
$tln->close;
print "\nPress return. ";<>;
print "done!\n";
}
## send
sub TlNet_Send
{
my ($cmd, $waitsecs, $showsecs, @prompt) = @_;
my ($pre, $match);
return 0 if (!defined $tln or !defined $cmd);
$waitsecs = 2 unless (defined $waitsecs);
$showsecs = 'yes' unless (defined $showsecs);
my @args = ();
@args = ('Match', '') if (@prompt == 0);
for (@prompt) {
push (@args, 'Match');
push (@args, $_);
}
$tln->timeout(0); # save old timeout ??
$tln->print ($cmd);
print "Sent: $cmd\n" if (defined $debug);
for (my $i = 0; $i < $waitsecs; $i++) {
($pre, $match) = $tln->waitfor(@args);
if (!$tln->timed_out) {
print "\rRecieved ($i seconds): $match \n" if (defined $debug);
#print "\n$prematch\n";
last;
}
sleep (1);
print "\rWait progress: ".($i+1)." second " if ($showsecs eq lc ('yes'));
}
## check time out
if ($tln->timed_out) {
print "\r** TIMED OUT ** after $waitsecs seconds -- add more time or change prompt ? \n" if (defined $debug);
return 0;
}
## return the index of the matched @prompt
return 1 if (!@prompt); # no prompt entered, assume first returned
my $pos = 0;
for (@prompt) {
$pos++;
my $patcheck = "last if (\$match =~ $_);"; # pattern match check
#print "$patcheck\n";
eval $patcheck;
}
return $pos;
}
## clear screen
sub TlNet_ClearScreen
{
my ($cmd, $prompt, $timeout) = @_;
my ($pre, $match);
return 0 if (!defined $tln or !defined $cmd);
$prompt = '' unless (defined $prompt);
$timeout = 2 unless (defined $timeout);
$tln->timeout($timeout);
$tln->print ($cmd);
$tln->waitfor ($prompt);
$tln->print("");
($pre, $match) = $tln->waitfor ($prompt);
print "Sent clear screen ... recieved: $match\n" if (defined $debug);
$tln->buffer_empty; # empty recieve buffer between commands
return $match;
}
====================================================
tln_unix.pl
====================================================
use strict;
#########################################
# unixrun.pl - tests the TlnSrv module
# R. Chalaire - 10/21/04
#########################################
require TlnSrv;
$|=1;
#############################################
# CONSOLE MODE ????? Info --
# We need line-mode or stream!!
# In console mode, the screen is treated
# as a buffer X by Y where the display is
# controlloed by ansi escape sequences.
# This is bad when expecting specific output (prompts)
# that may never come because those chars are already
# in screen buffer.
# Always make the server NON-Console, ie: use stream!!
# If not, as a workaround, between real commands,
# we can clear screen, then send return.
# -------------------------------------------------------
# Note that all 'Prompts' strings are single quote Regex
# parameters.
#############################################
# Default parameters on some methods are take from the class variables
# if those parameters are not passed in with the call.
# Set the class variables with SetVal() function.
# Values passed into the functions are not assigned to class variables.
# ----------------------------------
# SetVal() will find these keys:
# ----------------------------------
# Debug 1/0 (default: 0)
# Show_Prematch yes/no (default: no)
# Port # (default: 23)
# Prompt /regex/ (default: /[\$%#>] $/)
# Timeout # (default: 10 secs)
# ClearCmd (default: '')
# Waitsecs # (default: 10 secs)
# Show_Wait yes/no (default: yes)
#############################################
# TlnSrv::new (server, user, pwd, logdir);
#############################################
my $prompt = '/# $/i';
my @p_cls = ("", 3, $prompt);
my $ret;
my $tln = new TlnSrv ("172.0.15.1", "x098", "sys2");
$tln->SetVal (
Port => 1023,
Debug => 1,
Waitsecs => 15,
ClearCmd => '',
Prompt => $prompt,
Timeout => 10
);
if ($tln->OpenSession(1)) # 1 = enable logging, 0 = disable
{
$tln->EmptyBuffer();
$tln->ClearScreen (@p_cls);
$ret = $tln->SendCommand ( "cd /share/here"); # the values from above are used when nothing passed in
print "$tln->{'Error'}\n" if (!$ret);
$ret = $tln->SendCommand ("ls");
print "$tln->{'Error'}\n" if (!$ret);
$ret = $tln->SendCommand ( "cd /share/there"); # 1 will be returned here, if 0, its either timeout or some other error
print "$tln->{'Error'}\n" if (!$ret);
$ret = $tln->SendCommand ("ls");
print "$tln->{'Error'}\n" if (!$ret);
$ret = $tln->SendCommand ( "cd /share/and_here", 10, 'yes', '/asfdgbasdfgas/i', '/c:\\\\>/i', $prompt); # 3 will be returned here
print "$tln->{'Error'}\n" if (!$ret);
$ret = $tln->SendCommand ("ls");
print "$tln->{'Error'}\n" if (!$ret);
$tln->CloseSession();
}
else
{
print "Open Session error: $tln->{'Error'}\n";
}
print "\nPress return. ";<>;
print "done!\n";
------------------------------
Date: Mon, 17 Jul 2006 03:20:44 GMT
From: Dan Wilkin <nibbles.bits@verizon.net>
Subject: RegEx: odd number of slashes? and too many slashes?
Message-Id: <gmDug.3008$rT6.56@trnddc03>
Why does the following code work to find the literal UNC path specified.
altPath should have worked, right? It looks like the regex engine is
gobbling up slashes!! Perl 5.x
#my $altPath = '\\\\websrv\\VMServer\\cvs\\SAMS\\archives';
my $rootPath = '\\\\\\\websrv\\\VMServer\\\cvs\\\SAMS\\\archives';
# load the list of obsolete files
sub loadObsoletes {
my $i = 0;
my $line;
open SRC, $src_name or die "Can't open file '$src_name'";
while (<SRC>) {
chomp;
/$rootPath(.+?)-arc - (.+)/o; # extract the filenames
into an array
print "Matched: <$`> $& <$'>\n";
print "Parsed line $i as: {$1}{$2}\n" if $verbose;
$line = $1;
$line =~ s[\\][/]g;
print "Subst as: {$line}\n" if $verbose;
$LoF[$i] = $line;
$i++;
}
close SRC;
print "Listed source file as: @LoF" if $verbose;
}
Thnx,
Dan
------------------------------
Date: Sun, 16 Jul 2006 20:47:32 -0700
From: robic0
Subject: Re: RegEx: odd number of slashes? and too many slashes?
Message-Id: <312mb2htpdofnovs9vqmbv6jrknb1gdj2f@4ax.com>
On Mon, 17 Jul 2006 03:20:44 GMT, Dan Wilkin <nibbles.bits@verizon.net> wrote:
>Why does the following code work to find the literal UNC path specified.
> altPath should have worked, right? It looks like the regex engine is
>gobbling up slashes!! Perl 5.x
>
>
>#my $altPath = '\\\\websrv\\VMServer\\cvs\\SAMS\\archives';
>my $rootPath = '\\\\\\\websrv\\\VMServer\\\cvs\\\SAMS\\\archives';
>
># load the list of obsolete files
>sub loadObsoletes {
> my $i = 0;
> my $line;
> open SRC, $src_name or die "Can't open file '$src_name'";
> while (<SRC>) {
> chomp;
> /$rootPath(.+?)-arc - (.+)/o; # extract the filenames
>into an array
> print "Matched: <$`> $& <$'>\n";
> print "Parsed line $i as: {$1}{$2}\n" if $verbose;
> $line = $1;
> $line =~ s[\\][/]g;
> print "Subst as: {$line}\n" if $verbose;
> $LoF[$i] = $line;
> $i++;
> }
> close SRC;
> print "Listed source file as: @LoF" if $verbose;
>}
>
>
>Thnx,
>Dan
U tell me. If you don't understand "in solution" then you can't post here
robic0
------------------------------
Date: 16 Jul 2006 18:48:25 -0700
From: "Teffy" <WGSGNUAYHTTE@spammotel.com>
Subject: Re: Requirements for Perl on Windows XP?
Message-Id: <1153100905.297284.290580@m79g2000cwm.googlegroups.com>
Success! I uninstalled ActivePerl, 'Visual C++ 2005 Express' and
'Microsoft Platform SDK for Windows Server 2003 R2' then reinstalled
ActivePerl. UTIL now runs like a champ! Thanks so much to both of
you!
Teffy
------------------------------
Date: 6 Apr 2001 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 6 Apr 01)
Message-Id: <null>
Administrivia:
#The Perl-Users Digest is a retransmission of the USENET newsgroup
#comp.lang.perl.misc. For subscription or unsubscription requests, send
#the single line:
#
# subscribe perl-users
#or:
# unsubscribe perl-users
#
#to almanac@ruby.oce.orst.edu.
NOTE: due to the current flood of worm email banging on ruby, the smtp
server on ruby has been shut off until further notice.
To submit articles to comp.lang.perl.announce, send your article to
clpa@perl.com.
#To request back copies (available for a week or so), send your request
#to almanac@ruby.oce.orst.edu with the command "send perl-users x.y",
#where x is the volume number and y is the issue number.
#For other requests pertaining to the digest, send mail to
#perl-users-request@ruby.oce.orst.edu. Do not waste your time or mine
#sending perl questions to the -request address, I don't have time to
#answer them even if I did know the answer.
------------------------------
End of Perl-Users Digest V10 Issue 9485
***************************************
