I'm trying to centre a getSaveFile dialog on a selected(by xwininfo) window, I have the position, width and height of the selected window, but need help moving the getSaveFile dialog about (when it's up/showing maybe the key), and so to the centre of the selected window...
vars I have for the selected window are $window_width, $window_height, $abs_x, $abs_y
I believe to position the GetSaveFile dialog right, I would need something like:
$sfile ->geometry("originalWidth"."x"."orighnalHeight+($abs_x+($window_width/2 - originalWidth/2))+($abs_y+($window_height/2 -orighnalHeight/2)");
the above is not so much the problem, but some help there too would be nice,
it is what code to use to plug those numbers into that I'm after...
where and how to use the "$sfile ->geometry(widthxheight+x+y);" type bits, as I'm getting errors with the below:
# save dialog
my $types = [
['All Files', '*', ],
['mpg files', '.mpg', ],
['avi files', '.avi', ],
['mov files', '.mov', ],
];
my $sfile = $mw->getSaveFile(
-defaultextension => ".mov",
-initialdir => "/home/frank/Perl/screencaps", # standardise...
-initialfile => "ScreenCast01",
-title => "ScreenCast Capture file",
-filetypes => $types,
# position/geometry
);
# $sfile ->geometry('100x100+100+100'); # can't call method "geometry" without a package or object reference...
&do_saveFileWithType($sfile) if defined $sfile;
sub do_saveFileWithType {
my #InboundParameters = #_;
print "This is what was passed:\t$InboundParameters[0]\n";
# $sfile ->geometry('100x100+100+100'); # can't call method "geometry" without a package or object reference...
}
I now have this:
# to centre the save dialog(for when it's up):
my $title = "ScreenCast Capture file";
my $x = ($abs_x+($window_width/2)-207); # 207 = SaveDialogWidth/2
my $y = ($abs_y+($window_height/2)-134); # 134 = SaveDialogHeight/2
my $checking4win2move;
$checking4win2move = "on";
my $pid = fork(); # ??
if ($pid == 0){ # ??
while ($checking4win2move eq "on"){
my #runwmctrl = wmctrl ("-l");
for( #runwmctrl ) {
my $linesOf_wmctrl=$_;
chomp ($linesOf_wmctrl); # Get rid of the trailling \n ??
if($linesOf_wmctrl =~ m/ScreenCast Capture file/) {
#print "The \"ScreenCast Capture file\" dialog is mentioned and so is up, I can now move it to the centre of the selected window.\n";
my $windowMove = wmctrl ("-r $title", "-e 0,$x,$y,-1,-1");
# and stop checking:
# $checking4win2move = "off"; # unfork?? # X Error of failed request: BadIDChoice (invalid resource ID chosen for this connection)
exit(); #??
}else{ # print "The dialog is not mentioned in this line of wmctrl\'s output\n";
}
}
sleep .02; # then check again or...
}
}
The getSaveFile method returns a file name (or undef, if cancelled), not a widget reference. I don't see anything its documentation about positioning the window.
Related
I want to print all sql result of my perl script, I've connected to the database and I want to show the result of my sql query :
MySQL("SELECT * FROM test");
# define subroutine to submit MySQL command
sub MySQL
{
#Connect to the database.
my $dbh = DBI->connect("DBI:mysql:database=database;host=ip",
"login", 'password',
{'RaiseError' => 1});
my $query = $_[0]; #assign argument to string
my $sth = $prepare($query); #prepare query
$sth->execute(); #execute query
while (my #row = $sth->fetchrow_array)
{
print "#row\n";
}
}
I have this errors :
Global symbol "$prepare" requires explicit package name at test3.pl line 34.
syntax error at test3.pl line 34, near "$prepare("
Global symbol "$sth" requires explicit package name at test3.pl line 36.
Execution of test3.pl aborted due to compilation errors.
Change this line:
my $sth = $prepare($query);
to
my $sth = $dbh->prepare($query);
and don't forget to close the $sth and $dbh handles after the while loop with:
$sth->finish;
$dbh->disconnect;
In your last post there is only one reference to e in the following comment
#INNER JOIN events e ON (e.objectid = t.triggerid)
probably it is better to use syntax INNER JOIN events as e ON (e.objectid = t.triggerid) -- more readable
I do not have a database at hand available right at this moment. The following example should work in theory. I have replaced fetch_array on fetch_hashref the output will provide information about each row
ddddd column=value\tcolumn=value\t...
use strict;
use warnings;
my $query = qq(SELECT * FROM tb_test);
db_query($query);
sub db_query {
my $query = shift;
my $count = 1;
my $dbh = DBI->connect(
"DBI:mysql:database=database;host=ip",
"login", 'password',
{'RaiseError' => 1}
);
my $sth = $dbh->prepare($query);
$sth->execute();
while ( my $row = $sth->fetchrow_hashref() ) {
print "%5d ", $count++; # rows count
while( my($k,$v) = each %$row ) { print "%s=%s\t",$k,$v; }
print "\n"; # we done with current row
}
$sth->finish;
$dbh->disconnect;
}
You need look into DBI documentation to get full understanding how it works.
I have a sort of a problem, and I am still novice with Perl.
I just want to ask how can I format the following results file into an Excel readable format (let's say CSV).
Result file example. llq1_dly.mt0
$MEAS COMMANDS SOURCE='llq1_dly.meas' DB FILE='clk_top_45h_lpe_sim.fsdb'
.TITLE '**-------------'
tdrll10_0 tdfll10_0 tdrll10_1 tdfll10_1 tdrll10_2 tdfll10_2 tdrll10_3
2.106560e-10 1.990381e-10 2.102583e-10 1.986280e-10 2.095036e-10 1.978480e-10 2.083813e-10
into the following file with a result like this one below
llq1_dly,tdr,tdf,
ll10_0,2.106560e-10,1.990381e-10,
ll10_1,2.102583e-10,1.986280e-10,
ll10_2,2.095036e-10,1.978480e-10,
ll10_3,2.083813e-10,1.967019e-10,
...
or more likely this one (to be compatible with engineering scientific notations):
llq1_dly,tdr,tdf,
ll10_0,210.6560e-12,199.0381e-12,
ll10_1,210.2583e-12,198.6280e-12,
ll10_2,209.5036e-12,197.8480e-12,
ll10_3,208.3813e-12,196.7019e-12,
...
Here's a program that produces the output you ask for. I don't generally approve of offering answers to questions where the OP hasn't made any attempt to write a solution themselves, but this question interested me.
It may well be that this could be written more simply, but you don't say what parts of the input are invariant. For instance, I have written it so that there can be any number of different columns with any names, rather than just tdr and tdf every time. As it is I have had to guess that the trailing part of each header ends in ll, so for instance tdrll10_0 is tdr and ll10_0. If that is wrong then you will need a different way of splitting the string.
I have written the program so that it reads from the DATA file handle. I trust you are able to write an open statement to read from the correct input file?
I hope this helps
use strict;
use warnings;
use 5.010;
use Number::FormatEng 'format_eng';
Number::FormatEng::use_e_zero();
my $fh = \*DATA;
my ($source, #headers, #values);
while ( <$fh> ) {
if ( /SOURCE=(?|'([^']+)'|"([^"]+)")/ ) { #' code highlighting fix
($source = $1) =~ s/\.[^.]*\z//;
}
elsif ( /^\.TITLE/ ) {
#headers = split ' ', <$fh>;
#values = split ' ', <$fh>;
last;
}
}
my #title = ( $source );
my (%headers, #table, #line);
for my $i ( 0 .. $#headers) {
my #fields = split /(?=ll)/, $headers[$i];
if ( $headers{$fields[0]} ) {
push #table, [ #line ];
#line = ();
%headers = ();
}
++$headers{$fields[0]};
push #line, $fields[1] if #line == 0;
push #line, format_eng($values[$i]);
push #title, $fields[0] unless #table;
}
print "$_," for #title;
print "\n";
for ( #table ) {
print "$_," for #$_;
print "\n";
}
__DATA__
$MEAS COMMANDS SOURCE='llq1_dly.meas' DB FILE='clk_top_45h_lpe_sim.fsdb'
.TITLE '**-------------'
tdrll10_0 tdfll10_0 tdrll10_1 tdfll10_1 tdrll10_2 tdfll10_2 tdrll10_3
2.106560e-10 1.990381e-10 2.102583e-10 1.986280e-10 2.095036e-10 1.978480e-10 2.083813e-10
output
llq1_dly,tdr,tdf,
ll10_0,210.656e-12,199.0381e-12,
ll10_1,210.2583e-12,198.628e-12,
ll10_2,209.5036e-12,197.848e-12,
SOLVED ALREADY --> See edit 7
At this moment I'm fairly new on Perl, and trying to modify part of an existing page (in Wonderdesk).
The way the page works, is that it gets the information from the GET url and parses it to an SQL query.
Since this is part of a much larger system, I'm not able to modify the coding around it, and have to solve it in this script.
A working test I performed:
$input->{help_id} = ['33450','31976'];
When running this, the query that is being build returns something as
select * from table where help_id in(33450,31976)
The part of my code that does not work as expected:
my $callIDs = '33450,31450';
my #callIDs = split(/,/,$callIDs);
my $callIDsearch = \#callIDs;
$input->{help_id} = $callIDsearch;
When running this, the query that is being build returns something as
select * from table where help_id = '33450,31976'
I've tried to debug it, and used Data::Dumper to get the result of $callIDsearch, which appears as [33450, 31450] in my browser.
Can someone give me a hint on how to transform from '123,456' into ['123', '456']?
With kind regards,
Marcel
--===--
Edit:
As requested, minimal code piece that works:
$input->{help_id} = ['123','456']
Code that does not work:
$str = '123,456';
#ids = split(/,/,$str);
$input->{help_id} = \#ids;
--===--
Edit 2:
Source of the question:
The following part of the code is responsible for getting the correct information from the database:
my $input = $IN->get_hash;
my $db = $DB->table('help_desk');
foreach (keys %$input){
if (/^corr/ and !/-opt$/ and $input->{$_} or $input->{keyword}){
$db = $DB->table('help_desk','correspondence');
$input->{rs} = 'DISTINCT help_id,help_name,help_email,help_datetime,help_subject,help_website,help_category,
help_priority,help_status,help_emergency_flag,help_cus_id_fk,help_tech,help_attach';
$input->{left_join} = 1;
last;
}
}
# Do the search
my $sth = $db->query_sth($input);
my $hits = $db->hits;
Now instead of being able to provide a single parameter help_id, I want to be able to provide multiple parameters.
--===--
Edit 3:
query_sth is either of the following two, have not been able to find it out yet:
$COMPILE{query} = __LINE__ . <<'END_OF_SUB';
sub query {
# -----------------------------------------------------------
# $obj->query($HASH or $CGI);
# ----------------------------
# Performs a query based on the options in the hash.
# $HASH can be a hash ref, hash or CGI object.
#
# Returns the result of a query as fetchall_arrayref.
#
my $self = shift;
my $sth = $self->_query(#_) or return;
return $sth->fetchall_arrayref;
}
END_OF_SUB
$COMPILE{query_sth} = __LINE__ . <<'END_OF_SUB';
sub query_sth {
# -----------------------------------------------------------
# $obj->query_sth($HASH or $CGI);
# --------------------------------
# Same as query but returns the sth object.
#
shift->_query(#_)
}
END_OF_SUB
Or
$COMPILE{query} = __LINE__ . <<'END_OF_SUB';
sub query {
# -------------------------------------------------------------------
# Just performs the query and returns a fetchall.
#
return shift->_query(#_)->fetchall_arrayref;
}
END_OF_SUB
$COMPILE{query_sth} = __LINE__ . <<'END_OF_SUB';
sub query_sth {
# -------------------------------------------------------------------
# Just performs the query and returns an active sth.
#
return shift->_query(#_);
}
END_OF_SUB
--===--
Edit 4: _query
$COMPILE{_query} = __LINE__ . <<'END_OF_SUB';
sub _query {
# -------------------------------------------------------------------
# Parses the input, and runs a select based on input.
#
my $self = shift;
my $opts = $self->common_param(#_) or return $self->fatal(BADARGS => 'Usage: $obj->insert(HASH or HASH_REF or CGI) only.');
$self->name or return $self->fatal('NOTABLE');
# Clear errors.
$self->{_error} = [];
# Strip out values that are empty or blank (as query is generally derived from
# cgi input).
my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} !~ /^\s*$/ } keys %$opts;
$opts = \%input;
# If build_query_cond returns a GT::SQL::Search object, then we are done.
my $cond = $self->build_query_cond($opts, $self->{schema}->{cols});
if ( ( ref $cond ) =~ /(?:DBI::st|::STH)$/i ) {
return $cond;
}
# If we have a callback, then we get all the results as a hash, send them
# to the callback, and then do the regular query on the remaining set.
if (defined $opts->{callback} and (ref $opts->{callback} eq 'CODE')) {
my $pk = $self->{schema}->{pk}->[0];
my $sth = $self->select($pk, $cond) or return;
my %res = map { $_ => 1 } $sth->fetchall_list;
my $new_results = $opts->{callback}->($self, \%res);
$cond = GT::SQL::Condition->new($pk, 'IN', [keys %$new_results]);
}
# Set the limit clause, defaults to 25, set to -1 for none.
my $in = $self->_get_search_opts($opts);
my $offset = ($in->{nh} - 1) * $in->{mh};
$self->select_options("ORDER BY $in->{sb} $in->{so}") if ($in->{sb});
$self->select_options("LIMIT $in->{mh} OFFSET $offset") unless $in->{mh} == -1;
# Now do the select.
my #sel = ();
if ($cond) { push #sel, $cond }
if ($opts->{rs} and $cond) { push #sel, $opts->{rs} }
my $sth = $self->select(#sel) or return;
return $sth;
}
END_OF_SUB
--===--
Edit 5: I've uploaded the SQL module that is used:
https://www.dropbox.com/s/yz0bq8ch8kdgyl6/SQL.zip
--===--
Edit 6:
On request, the dumps (trimmed to only include the sections for help_id):
The result of the modification in Base.pm for the non-working code:
$VAR1 = [
33450,
31450
];
The result of the modification in Condition.pm for the non-working code:
$VAR1 = [
"help_id",
"IN",
[
33450,
31450
]
];
$VAR1 = [
"cus_username",
"=",
"Someone"
];
$VAR1 = [
"help_id",
"=",
"33450,31450"
];
The result for the modification in Base.pm for the working code:
$VAR1 = [
33450,
31976
];
The result for the modification in Condition.pm for the working code:
$VAR1 = [
"help_id",
"IN",
[
33450,
31976
]
];
It looks as if the value gets changed afterwards somehow :S
All I changed for the working/non-working code was to replace:
$input->{help_id} = ['33450','31976'];
With:
$input->{help_id} = [ split(/,/,'33450,31450') ];
--===--
Edit 7:
After reading all the tips, I decided to start over and found that by writing some logs to files, I could break down into the issue with more details.
I'm still not sure why, but it now works, using the same methods as before. I think it's a typo/glitch/bug in my code somewhere..
Sorry to have bothered you all, but I still recommend the points to go to amon due to his tips providing the breakthrough.
I don't have an answer, but I have found a few critical points where we need to know what is going on.
In build_query_cond (Base.pm line 528), an array argument will be transformed into an key in (...) relation:
if (ref($opts->{$field}) eq 'ARRAY' ) {
my $add = [];
for ( #{$opts->{$field}} ) {
next if !defined( $_ ) or !length( $_ ) or !/\S/;
push #$add, $_;
}
if ( #$add ) {
push #ins, [$field, 'IN', $add];
}
}
Interesting bit in sql (Condition.pm line 181). Even if there is an arrayref, an IN test will be simplified to an = test if it contains only a single element.
if (uc $op eq 'IN' || $op eq '=' and ref $val eq 'ARRAY') {
if (#$val > 1) {
$op = 'IN';
$val = '('
. join(',' => map !length || /\D/ ? quote($_) : $_, #$val)
. ')';
}
elsif (#$val == 0) {
($col, $op, $val) = (qw(1 = 0));
}
else {
$op = '=';
$val = quote($val->[0]);
}
push #output, "$col $op $val";
}
Before these two conditions, it would be interesting to insert the following code:
Carp::cluck(Data::Dumper::Dump(...));
where ... is $opts->{$field} in the first snippet or $cond in the second snippet. The resulting stack trace would allow us to find all subroutines which could have modified the value. For this to work, the following code has to be placed in your main script before starting the query:
use Carp ();
use Data::Dumper;
$Data::Dumper::Useqq = 1; # escape special characters
Once the code has been modified like this, run both the working and not-working code, and print out the resulting query with
print Dumper($result);
So for each of your code snippets, we should get two stack traces and one resulting SQL query.
A shot in the dark... there's a temporary array #callIDs created by this code:
my #callIDs = split(/,/,$callIDs);
my $callIDsearch = \#callIDs;
$input->{help_id} = $callIDsearch;
If some other part of your code modifies #callIDs, even after it's been assigned to $input->{help_id}, that could cause problems. Of course the fact that it's a lexical (my) variable means that any such changes to #callIDs are probably "nearby".
You could eliminate the named temporary array by doing the split like this:
$input->{help_id} = [ split(/,/,$callIDs) ];
I'm not sure I understand exactly why this is happening. It seems that your query builder needs an arrayref of strings. You can use map to do that
my $callIDs = '33450,31450';
my #callIDs = map {$_*1} split(/,/,$callIDs);
$input->{help_id} = \#callIDs;
This code should work
my $callIDs = '33450,31450';
$input->{help_id} = [split ",", $callIDs];
If your code somehow detect your data is number you can use
my $callIDs = '33450,31450';
$input->{help_id} = [map 0+$_, split ',', $callIDs];
If it somehow become number and you need string instead which should not in this case but advice for future work:
my $callIDs = '33450,31450';
$input->{help_id} = [map ''.$_, split ',', $callIDs];
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.
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.