I'm using perl on a linux box, and I have 2 devices - a pc(the linux box) and a router/dsl-thingy - on my local net at ip addresses 192.168.1.1 & 192.168.1.2 and am trying to list or show the progress of pinging such + a test of 8 other none existing devices, with the below code, but am having troubles with my StatusLabel updating, any help...
for($i=1;$i<=10;++$i) { # --- $i<$VarClients --- 254
my $thr_List = ("ping$i");
$thr_List = threads->create(\&pingingthreads, "$i");
}
sub pingingthreads{
my #pingpong = ping("$localAddress$i", '-c 1', '-i .2'); # -i may not count for much?
print "Pinging: $localAddress$i\n"; # output goes from address1 - address10 ok
$StatusLabel = "Pinging: $localAddress$i"; # only the last responding one(device) seems to be shown in my statuslabel?!
$val = ($val + 10); # 0.392156863
print "$val\% done...\n"; # goes to 100% for me ok
# $indicatorbar->value( $val ); # I have a ProgressBar and it gets stuck on 20% also
if ($val == 100){$val = 0;
} # reset after scanning
# then after the last ping, update the statusLable:
#my #ParamList = ('something', 'testing', 7, 8, 9);
#$thr5 = threads->create(\&updateStatusLable, #ParamList); # starting a thread within a thread ???
# ping response text...
for( #pingpong ) { # need to do something for none responding clients & any time laps/ping latency..., or *** ???
$pong=$_;
chop ($pong); # Get rid of the trailling \n ??
if ($pong =~ m/1 packets transmitted, 1 received, 0% packet loss/) {
push(#boxs, "$localAddress$i");
} else{
# see the other lines from the ping's output
# print "$pong\n";
}
}
}
# For $localAddress$i icmp_seq=1 Destination Host Unreachable ???
--------------------- # StatusBar/progress label & bar ----------------
my $sb = $main->StatusBar();
$sb->addLabel( -textvariable => \$StatusLabel,
-relief => 'flat',
-font => $font,
-foreground => "$statusbartextColour",
);
my $indicatorbar = $sb->ProgressBar( -padx=>2, -pady=>2, -borderwidth=>2,
-troughcolor=>"$Colour2",
-colors=>[ 0, "$indicatorcolour" ],
-length=>106,
-relief => 'flat',
-value => "$val",
)->pack;
# $val = 0;
# $indicatorbar->value( $val );
=====================================
my $StatusLabel :shared = ();
my $val :shared = (0); # var for progress bar value
I have uploaded my full code here (http://cid-99cdb89630050fff.office.live.com/browse.aspx/.Public) if needed, its in the Boxy.zip...
By default data in Perl threads are private; updates to a variable in one thread will not change the value of that variable in other threads (or in the main thread). You will want to declare $val as a shared variable.
See threads::shared.
I see you have declared $val as shared at the bottom of the script, so I didn't see it until it was too late. Not coincidentally, the Perl interpreter is also not going to see that declaration until it is too late. The top 95% of your program is manipulating the global, thread-private variable $var and not the lexical, shared $var you declare at the end of your script. Move this declaration to the top of the script.
Putting use strict at the top of your program would have caught this and saved you minutes, if not hours, of grief.
You don't. GUI frameworks tend to be not threadsafe. You communicate the info to the thread in which the GUI is run instead. Example
First sorry for replying here, but have lost my cookie or the ability to reply and edit etc...
Thanks ikegami, I will have to play with the example for a while to see if I can work things out and mix it into what I'm doing... but on first sight, looks just right... Thanks very much.
I was able to update the $StatusLabel using:
# in 3 seconds maybe do a fade to: Ready...
my #ParamList = ('ping', 'testing', 4, 5, 6);
$thr2 = threads->create(\&updateStatusLable, #ParamList);
sub updateStatusLable {
# should probably check if threads are running already first???
# and if so ***/*** them ???
my #InboundParameters = #_;
my $tid = threads->tid();
# my $thr_object = threads->self(); # Get a thread's object
# print("This is a new thread\($tid\)... and I am counting to 3...\n");
sleep(3);
$StatusLabel = "Ready..."; # print "Am now trying to change the status bar's label to \"Ready...\"\n";
# try updating better/smoother... My main window needs "focus and a mouse move" I think
# for the new text to appear...
# print('Recieved the parameters: ', join(', ', #InboundParameters), ".\n" );
# $returnedvalue = "the thread should return this...";
# return($returnedvalue); # try returning any value just to test/see how...
}
but will try your method... Thanks again.
Related
I am getting a file to be reset after a first read. All googling hasn't helped at all.
How do I reset a file to it's begin after it has been read a first time?
Trial one:
inFile = QFile( self._pathFileName )
inFile.open(QFile.ReadOnly | QFile.Text)
stream = QTextStream(inFile)
# Count first all lines in the file
self._numLinesRead = 0
self._mumLinesTotal = 0
while not stream.atEnd():
self._mumLinesTotal=+1
stream.readLine();
inFile.seek(0)
stream.seek(0)
pos = stream.pos() # pos is equal to 0 after this line verified with debugging
while( not stream.atEnd() ): # but here it still thinks he's at file end and jumps over
....
Trial two:
inFile = QFile( self._pathFileName )
inFile.open(QFile.ReadOnly | QFile.Text)
stream = QTextStream(inFile)
# Count first all lines in the file
self._numLinesRead = 0
self._mumLinesTotal = 0
while not stream.atEnd():
self._mumLinesTotal=+1
stream.readLine();
inFile.close()
del inFile
del stream
inFile = QFile( self._pathFileName )
inFile.open(QFile.ReadOnly | QFile.Text)
stream = QTextStream(inFile)
# everyting has been reset?!
while( not stream.atEnd() ): # Nop it still thinks it is atEnd and jumps over
....
I tried all the solutions found in the net. Nothing helps. What I'm doing wrong?
Not sure what I should say, but after a complete reboot of the system "Trial two" worked.
After a second reboot (two days and a lot of code changes later) also "Trial one" came to life.
After all: both trials are from my point of view valid and working.
If in case you discover strange behaviour during development and debugging try a reboot.
Looking for right way to detect one keyword during board boot up message.
After keyword detected, send Enter key after one second.
Kernel is Linux.
# Serial port inisialisation is finished here.
# Read boot message
($count, $result) = $ob->read(300); # at least 300 chars coming till keyword appear
if ($result =~ m/Booting_up/) {
print "send Enter ...\n";
sleep 1;
$ob->write("\r\n");
}
Thanks for hint
It appears that you are using Win32::SerialPort module, or perhaps Device::SerialPort which
provides an object-based user interface essentially identical to the one provided by the Win32::SerialPort module.
Its method read takes the number of bytes to read and returns the number read and writes them into the given string.
You may be "missing" the phrase because it's past the 300-mark, and your code doesn't read any further. Try to loop, getting a few bytes at a time and adding them up, thus building the string in small reads.
my bytes_in = 10; # length of pattern, but it does NOT ensure anything
my ($read, $result);
while (1)
{
my ($count, $read) = $ob->read( $bytes_in );
$result = $result . $read;
if ($result =~ m/Booting_up/) { # is it "Booting_up" or "Booting up" ?
print "send Enter ...\n";
sleep 1; # is this needed?
$ob->write("\r\n");
# last; # in case this is all you need to do
}
last if $count != $bytes_in; # done reading
}
I don't put the $ob->read statement in the loop condition since the documentation isn't crystal clear on how the method works. You may also be able to simply use
while ( my ($count, $read) = $ob->read( $bytes_in ) ) {
$result = $result . $read;
if ($result =~ m/Booting_up/s) {
# ...
}
last if $count != $bytes_in;
}
We read a small number of bytes at a time to prevent problems with either polling or blocking reads, brought up in comments by BenPen. See Configuration and capability methods.
You can first read those first 300 bytes that precede the pattern in one go and then start reading a few (or one) at a time, which would also lead to the quickest identification of the phrase.
This can be tweaked further but let's first see what it does as it stands (I cannot test).
Documentation also offers a few other methods which may be useful, in particular readline and streamline. As this is all rather low level there are yet other ways but if you got all else working perhaps this will be enough to complete it.
Perhaps rather index the string?
($count, $result) = $ob->read(300); # at least 300 chars coming till keyword appear
$substring = 'Booting_up';
if (index($result, $substring) != -1) {
print "send Enter ..\n";
sleep 1;
$ob->write("\r\n");
}
Im trying to write some basic chat system just to learn perl. Im trying to get the chatlog into a 1 file and print new message if it's appears in the chatlog.dat file, So i've wrote a function that does almost the same thing, but I have got some problems and don't know how to solve them.
So now I have 2 problems!
I could not understand how to keep checkFile function always active (like multiprocession) to continuously check for new messages
This problem occurs when I'm trying to write a new message that will be appended into the chatlog. The Interpreter waits for my input on the line my $newMessage = <STDIN>;, but, what if someone writes a new message? it will not be shown until he press enter... how to void that?
my ($sec,$min,$hour) = localtime();
while(1){
my $userMessage = <STDIN>;
last if $userMessage eq "::quit";
`echo "($hour:$min:$sec): $userMessage" >>chatlog.dat`;
}
sub checkFile{
my $lastMessage = "";
my $newMessage = "";
while (1) {
my $context = `cat chatlog.dat`;
split(/\n/, $context);
$newMessage = $_[$#_];
if ($newMessage ne $lastMessage) {
print $newMessage;
$lastMessage = $newMessage;
}
}
}
First:
don't use echo within a perl script. It's nasty to shell escape when you've got perfectly good IO routines.
using cat to read files is about as nasty as using 'echo'.
reading <STDIN> like that will be a blocking call - which means your script will pause.
but that's not as bad as it sounds, because otherwise you're running a 'busy wait' loop which'll repeatedy cat the file. This is a very bad idea.
You're assuming writing a file like that is an atomic operation, when it's not. You'll hit problems with doing that too.
What I would suggest you do it look at IO::Handle and also consider using flock to ensure you've got the file locked for IO. You may also wish to consider File::Tail instead.
I would actually suggest though, you want to consider a different mode of IPC - as 'file swapping' is quite inefficient. If you really want to use the filesystem for your IO, you might want to consider using a FIFO pipe - have each 'client' open it's own, and have a server reading and coalescing them.
Either way though - you'll either need to use IO::Select or perhaps multithreading, just to swap back and forth between reading and writing. http://perldoc.perl.org/IO/Select.html
Answering my own question
sub checkFile{
my $lastMessage = "";
my $newMessage = "";
my $userName = $_[0];
while (1) {
my $context = `cat chatlog.dat`;
split(/\n/, $context);
$newMessage = $_[$#_];
if ($newMessage ne $lastMessage) {
$newMessage =~ /^\(.+\):\((.+)\) (.+$)/;
if ($1 ne $userName) { print "[$1]: $2";}
$lastMessage = $newMessage;
}
}
}
my $userName = "Rocker";
my ($sec,$min,$hour) = localtime();
my $thr = threads -> create ( \&checkFile, $userName ); #Starting a thread to continuously check for the file update
while (1) {
my $userMessage = <STDIN>; #STDIN will not interfere file checking
last if $userMessage eq "::quit";
`echo "($hour:$min:$sec):($userName) $userMessage" >>chatlog.dat` if $userMessage =~ /\S+/;
}
$thr -> join();
I have a perl tk application where in i create many objects and update the perl tk gui display with information in objects.I need to add large number of jobs(say 30k) in the tree in the gui.If i add all jobs in one go,the gui freezes.
Below is the code snippet:
sub Importjobs
{
#================= start creation of objects=============================
my JobList $self = shift;
my $exportedJobList = shift;
# third parameter whether to clear the list
$self->clear () unless shift;
my $noOfProcsToBeAdded = shift || 3000;
my $cellCollection = Tasks::CellCollection::instance ();
my $calcActionsPathHash = $cellCollection->caPathCAHash ();
my $collectionCellNames = $cellCollection->allCellNames ();
my #importedJobs = ();
# if the given job list is empty, add import job list to it
push #{$self->_importJobList()}, #$exportedJobList;
$exportedJobList = [];
# do not import new jobs if the previous jobs are still being created
foreach my $taskGenJob(#{$self->getTaskGenJobObjs()}) {
goto FINISH if TaskGenJobState::CREATE == $taskGenJob->state();
}
# now get each job and add it into the imported jobs till the noOfJobs exceeds $noOfJobsToBeAdded
while(my $jobDescription = shift #{$self->_importJobList()}) {
my $taskInstantiation = $jobDescription->{'taskInstantiation'};
my $caPath = $taskInstantiation->{'calcActionPath'};
my $errMsgPrefix = 'Error importing ' . join ('-', $task, $command, $method, $caPath);
my #calcActionList;
if(defined $caPath) {
my $calcAction = $calcActionsPathHash->{ $caPath };
unless($calcAction) {
my $errMsg = $errMsgPrefix . ": the calcAction is not defined within the current CellCollection : " . $caPath;
$logger4Perl -> error ($errMsg);
next;
}
push #calcActionList, $calcAction;
} else {
my #mList;
if(not defined $method) {
push #mList, #{$task->getMethods(cellCollection => $cellCollection, command => $command)};
$method = join(' ', #mList);
} elsif($method eq $task_desc::default_method) {
#mList = ($task_desc::default_method);
} else {
#mList = sort (grep { $_ } split(/\s+|__/, $method));
}
foreach my $m (#mList) {
push(#calcActionList, #{$cellCollection->findCalcActions($task, $command, $m)});
}
}
foreach my $calcAction(#calcActionList) {
my TaskGenJob $job = TaskGenJob->new ();
$logger4Perl->info ("Adding $caPath");
push (#importedJobs, $job);
my $noOfProcsBeingAdded = $job->calculateNoOfJobExecObjs();
$noOfProcsToBeAdded -= $noOfProcsBeingAdded;
}
last if 1 > $noOfProcsToBeAdded;
}
#================= End creation of objects=============================
#Below function updates the GUI display
$self->addJobs (\#importedJobs);
#================= Mechanism which am using so that GUI will be active after certain time limit=============================
FINISH:
if(#{$self->_importJobList()}) {
$self->parentDlg()->parentWnd()->after(60000,
sub {
$GuiTasksAppl::mainDlg->Disable();
$self->importJobList([], 'noclear', 200);
$GuiTasksAppl::mainDlg->Enable();
});
}
}
Currently the way am doing it is to add say 3000 jobs using $noOfProcsToBeAdded variable and stay idle for some time and repeat the process after some time.During this idle process,there is different process which processes the jobs in GUI.
can someone propose a better approach than this ???
Expecting ideas on threading ,shared memory.
First, if the GUI freezes (and never unfreezes) during your large 30k update then you might have found a Tk bug since that shouldn't happen. However, if its merely unresponsive for a period of time, then it make sense to mitigate the delay.
In the past, i've used either Tk::repeat() or Tk::after() to drive my UI update routine. The user interface doesn't typically need to be updated at a high rate, so every few hundred milliseconds can be a reasonable delay. The determining factor is largely determined by how responsive of an interface you need. Then during the job import step: append references to a list for the UI update routine and then periodically call $MW->update(). The update routine doesn't necessarily need to process the full list during each call but you don't want the processing to get too far behind.
I'd also recommend some visual indicator to identify that the update is still in-progress.
If ImportJobs is computationally expensive, obviously one could perform multi-process / multi-threading tricks to exploit multiple processors on the system. But that'll add a bit of complexity and testing effort.
Perl threads do not support sharing filehandles. All the elements of a shared data structure must be shared. This presents a problem if one needs to share an object which contains a filehandle.
{
package Foo;
use Mouse;
has fh =>
is => 'rw',
default => sub { \*STDOUT };
}
use threads;
use threads::shared;
my $obj = Foo->new;
$obj = shared_clone($obj); # error: "Unsupported ref type: GLOB"
print {$obj->fh} "Hello, world!\n";
It really doesn't matter if the filehandle is "shared" or not, it's only used for output. Perhaps there is a trick where the filehandle is stored outside the shared object?
This object is actually contained in another shared object which is in another and so on. The grand irony is the objects in question never use threads themselves, but must remain coordinated across the process if the user uses threads.
The real code in question can be seen here: These objects are used to configure where formatted output goes. An object is necessary because output does not always go to a filehandle.
I don't have access to threaded Perl at the moment, so can't guarantee that this will work.
But a somewhat simplistic approach would be to use a level of abstraction and store a key/index into a global filehandle hash/array into the object, something similar to the following:
my #filehandles = (); # Stores all the filehandles ### CHANGED
my $stdout; # Store the index into #filehandles, NOT filehandle.
# Should really be renamed "$stdout_id" instead.
sub stdout {
my $self = shift;
return $stdout if defined $stdout;
$stdout = scalar(#filehandles); ### CHANGED
my $stdout_fh = $self->dup_filehandle(\*STDOUT); ### CHANGED
push #filehandles, $stdout_fh; ### CHANGED
$self->autoflush($stdout_fh); ### CHANGED
$self->autoflush(\*STDOUT);
return $stdout;
}
sub safe_print {
my $self = shift;
my $fh_id = shift; ### CHANGED
my $fh = $filehandles[$fh_id]; ### CHANGED
local( $\, $, ) = ( undef, '' );
print $fh #_;
}
I have a strong feeling that you would need to somehow also thread-safe the list of IDs, so perhaps an shared index counter would be needed instead of $stdout = scalar(#filehandles);
As an alternative to my other answer with global array, here's another approach from Perlmonks:
http://perlmonks.org/?node_id=395513
It works by actually storing fileno (file descriptor) of the filehandle. Here's his sample code based on what BrowserUk posted:
my $stdout; # Store the fileno, NOT filehandle.
# Should really be renamed "$stdout_fileno" instead.
sub stdout {
my $self = shift;
return $stdout if defined $stdout;
my $stdout_fh = $self->dup_filehandle(\*STDOUT); ### CHANGED
$stdout = fileno $stdout_fh; ### CHANGED
$self->autoflush($stdout_fh); ### CHANGED
$self->autoflush(\*STDOUT);
return $stdout;
}
sub safe_print {
my $self = shift;
my $fh_id = shift; ### CHANGED
open(my $fh, ">>&=$fh_id") ### CHANGED
|| die "Error opening filehandle: $fh_id: $!\n"; ### CHANGED
local( $\, $, ) = ( undef, '' );
print $fh #_;
}
CAVEAT - as of 2004, this had a bug where you couldn't read from the shared filehandle from >1 thread. I am guessing that writing is OK. More specifics on how to do synchronised writes on a shared filehandle (from the same Monk): http://www.perlmonks.org/?node_id=807540
It just occurred to me there's two possible solutions:
Put the filehandle outside the Streamer object.
Put the Streamer object outside the Formatter.
#DVK's suggestions are all about doing 1.
But 2 is in some ways simpler than 1. Instead of holding the Streamer object itself, the Formatter can hold an identifier to the Streamer object. If the Streamer is implemented inside-out, that happens naturally!
Unfortunately, reference addresses change between threads, even shared ones. This can be solved with Hash::Util::FieldHash, but that's a 5.10 thing and I have to support 5.8. It's possible something could be put together using CLONE.
Here's what I wound up with...
package ThreadSafeFilehandle;
use Mouse;
use Mouse::Util::TypeConstraints;
my %Filehandle_Storage; # unshared storage of filehandles
my $Storage_Counter = 1; # a counter to use as a key
# This "type" exists to intercept incoming filehandles.
# The filehandle goes into %Filehandle_Storage and the
# object gets the key.
subtype 'FilehandleKey' =>
as 'Int';
coerce 'FilehandleKey' =>
from 'Defined',
via {
my $key = $Storage_Counter++;
$Filehandle_Storage{$key} = $_;
return $key;
};
has thread_safe_fh =>
is => 'rw',
isa => 'FilehandleKey',
coerce => 1,
;
# This converts the stored key back into a filehandle upon getting.
around thread_safe_fh => sub {
my $orig = shift;
my $self = shift;
if( #_ ) { # setting
return $self->$orig(#_);
}
else { # getting
my $key = $self->$orig;
return $Filehandle_Storage{$key};
}
};
1;
Using type coercion ensures that the translation from filehandle to key happens even in the object constructor.
It works, but it has flaws:
Each object stores its filehandle redundantly. If a bunch of objects all store the same filehandle they could probably just store it once. The trick would be how to identify the same filehandle. fileno or the refaddr are options.
The filehandle is not removed from %Filehandle_Storage upon object deletion. I originally put in a DESTROY method to do so, but since the object cloning idiom is $clone = shared_clone($obj) $clone's filehandle is trashed once $obj goes out of scope.
Changes which occur in children are not shared.
These are all acceptable for my purposes which will only create a handful of these objects per process.
Then again, one could use https://metacpan.org/module/Coro if one did not have an allergic reaction to its trolldocs.