I'm trying to change a thread priority within my script, without success, here are the details.
$thr = threads->new(\&someFunction,
$shared variable 1,
$shared variable 2,
);
I've tried using threads::State;
$thr->priority(2);
Without success
So, I thought the Win32::API must work
my $functionGetLastError= Win32::API->new('Kernel32',
'GetLastError',
'',
'N'
);
my $functionSetThreadPriority= Win32::API->new('Kernel32',
'SetThreadPriority',
'II', # I've tried 'PI' and 'II' as well
'N'
);
my $h = $thr->_handle();
my $success = $functionSetThreadPriority->Call( $h, 2 );
warn "Return Error #".$functionGetLastError->Call() if !$success;
Again, without success: (, but now I have a clue, the script return error number
last Error 6
From MSDN site, System Error Codes (0-499), it seems that the error is
ERROR_INVALID_HANDLE
What am I doing wrong?
$thread->_handle weirdly returns a HANDLE*, while SetThreadPriority expects a HANDLE. You need to dereference the pointer, which you can do as follows:
use constant THREAD_PRIORITY_HIGHEST => 2;
sub SetThreadPriority {
my ($thread, $priority) = #_;
# $thread->_handle() returns a HANDLE*.
my $handle_ptr = $thread->_handle();
my $packed_handle = unpack('P'.HANDLE_SIZE, pack(PTR_FORMAT, $handle_ptr));
my $handle = unpack(HANDLE_FORMAT, $packed_handle);
state $SetThreadPriority = (
Win32::API->new('Kernel32', 'SetThreadPriority', 'Ni', 'i')
or die("Loading SetThreadPriority: $^E\n")
);
return $SetThreadPriority->Call($handle, $priority);
}
Here's the full test program:
use strict;
use warnings;
use feature qw( say state );
use threads;
use threads::shared;
use Carp qw( croak );
use Config qw( %Config );
use Win32::API qw( );
sub uint_format {
$_[0] == 4 ? 'L'
: $_[0] == 8 ? 'Q'
: croak("Unsupported")
}
use constant PTR_SIZE => $Config{ptrsize};
use constant PTR_FORMAT => uint_format(PTR_SIZE);
use constant HANDLE_SIZE => PTR_SIZE;
use constant HANDLE_FORMAT => PTR_FORMAT;
use constant THREAD_PRIORITY_HIGHEST => 2;
sub SetThreadPriority {
my ($thread, $priority) = #_;
# $thread->_handle() returns a HANDLE*.
my $handle_ptr = $thread->_handle();
my $packed_handle = unpack('P'.HANDLE_SIZE, pack(PTR_FORMAT, $handle_ptr));
my $handle = unpack(HANDLE_FORMAT, $packed_handle);
state $SetThreadPriority = (
Win32::API->new('Kernel32', 'SetThreadPriority', 'Ni', 'i')
or die("Loading SetThreadPriority: $^E\n")
);
return $SetThreadPriority->Call($handle, $priority);
}
{
my $done :shared = 0;
my $thread = async {
{ lock($done); cond_wait($done) while !$done; }
};
my $rv = SetThreadPriority($thread, THREAD_PRIORITY_HIGHEST);
say $rv ? "Success" : "Error: $^E";
{ lock($done); $done = 1; cond_broadcast($done); }
$thread->join();
}
Notice that you can use $^E to access GetLastError.
SetThreadPriority($handle, THREAD_PRIORITY_HIGHEST)
or die("SetThreadPriority: $^E\n";
ERROR_INVALID_HANDLE
Which suggests that what _handle returns is not something Win32::API understands. I suspect "P" wants a string buffer not an integer-casted pointer. "I" may be the wrong thing because it's the wrong size on 64-bit, I would try "N" myself.
Also, for future readers running into this issue on Unix: try my POSIX::RT::Scheduler module.
Related
I'm fairly new to Perl and am working on a project to further my learning. It's a little console word game (translated from a python project of mine), and part of the logic requires to draw a random letter from a pool that is 98 characters long.
Running the functions individually, I've never had an issue, but when I try to loop it into a list it occasionally fails. Running with warnings on tells me that some of these are undefined, but I can't for the life of me figure out why. Here's an MRE:
package Random;
sub choice {
shift;
my ($str) = #_;
my $random_index = int(rand(length($str)));
return substr($str,$random_index,1); #fixed variable name
}
package Player;
sub new {
my $class = shift;
my $self = { "name" => shift, "letters" => {fillList()} };
bless $self, $class;
return $self;
}
sub drawCharacter {
my $freq = "aaaaaaaaabbccddddeeeeeeeeeeeeffggghhiiiiiiiiijkllllmmnnnnnnooooooooppqrrrrrrssssttttttuuuuvvwwxyyz";
my $choice = Random -> choice($freq);
return $choice;
}
sub fillList {
my #ls = ();
for (0..6) {
push #ls, drawCharacter();
}
return #ls;
}
sub getLetters {
my ($self) = #_;
my $arr = $self -> {letters};
return %$arr;
}
package Main;
my #players = ();
for (0..12){
my $player = Player -> new("Foo");
print($player->getLetters(),"\n");
}
BIG EDIT: Adding the object I'm using. This is verifiably not working. Warnings:
"Use of uninitialized value in print" and "Odd number of elements in anonymous hash". This is where I think the issue lies.
The list returned by fillList sometimes is missing an item or 2, and in some circumstances even 3 or 4 items are missing. Does anybody know what's going on here? The python one hasn't failed once.
If the python analogue would be helpful, I can include that here too.
The error comes from using a hash ref where you should have an array ref:
my $self = { "name" => shift, "letters" => {fillList()} };
# ^ ^-- wrong brackets
This is what the warning talks about:
Odd number of elements in anonymous hash at foo.pl line 22.
You want to change that to:
my $self = { "name" => shift, "letters" => [fillList()] };
# ^ ^--- creates array ref
And also the line which uses this array
return %$arr;
Where you need to change % to #.
return #$arr;
After those fixes, the code runs without errors for me.
File Directory：
/home/wh/perlstudy/perl2/Person/Student.pm
/home/wh/perlstudy/perl2/Person/person.pl
Student.pm
package Student;
use strict;
use warnings FATAL => 'all';
# use utf8;
# binmode(STDIN,"encoding(gbk)");
sub new
{
my $class = shift;
my $self = {
_name => shift, _rank => shift, };
# Print all the values just for clarification.
print "获取学生名字 $self->{_name}\n";
print "获取学生排名 $self->{_rank}\n";
bless $self, $class;
return $self;
}
sub studentRank {
my ( $self, $name ) = #_;
$self->{_name} = $name if defined($name);
return $self->{_name};
}
sub studentName {
my( $self ) = #_;
return $self->{_name};
}
1;
person.pl
#!/usr/bin/perl
use strict;
use warnings FATAL => 'all';
# use utf8;
# binmode(STDOUT,"encoding(gbk)");
BEGIN(push #INC,"/home/wh/perlstudy/perl2/Person/");
use Student;
my$object = Student->new( "Ana", "9th");
# name which is set using constructor.
my$name = $object->studentName();
print "Name set using constructor is : $name\n";
# name set using helper function.
$object->studentRank( "Anastasia" );
# getting name set by helper function.
$name = $object->studentName();
print "名字 set using helper is : $name\n";
I get:
Prototype after '#' for BEGIN : push #INC,"/home/wh/perlstudy/perl2/Person/" at perlson.pl line 6.
Want to solve the use of perl modules other than #INC.
BEGIN is a code block, so you need curly braces:
#!/usr/bin/perl
use strict;
use warnings FATAL => 'all';
# use utf8;
# binmode(STDOUT,"encoding(gbk)");
BEGIN {
push #INC, "/home/wh/perlstudy/perl2/Person/";
}
# rest of person.pl goes here
Or you use the -I flag when you call Perl:
perl -I/home/wh/perlstudy/perl2/Person/ person.pl
This has the advantage that you don't have to hard-code the path, but you'll have to re-type it each time. (Or make an alias or shell script for it.)
Or use lib:
use lib "/home/wh/perlstudy/perl2/Person/";
Finally you could install your Perl module in a place where Perl looks for modules by default, but during development you'll have to do that each time you make changes to Student.pm.
Use of global arrays in different threads
I'm going to use Dancer2 and File::Tail to use Tail on the web. So when the Websocket is opened, it stores the $conn in an array, and when File::Tail is detected, it tries to send data to the socket stored in the array. But it doesn't work as expected.
The array that is saved when a websocket connection occurs is probably not a global variable.
# it doesn't works.
foreach (#webs) {
$_->send_utf8("test2!!!!!!!!");
}
I tried to use threads::shared and Cache:::Memcached etc, but I failed.
I don't know perl very well. I tried to solve it myself, but I couldn't solve it for too long, so I leave a question.
This is the whole code.
use File::Tail ();
use threads;
use threads::shared;
use Net::WebSocket::Server;
use strict;
use Dancer2;
my #webs = ();
# my %clients :shared = ();
my $conns :shared = 4;
threads->create(sub {
print "start-end:", "$conns", "\n";
my #files = glob( $ARGV[0] . '/*' );
my #fs = ();
foreach my $fileName(#files) {
my $file = File::Tail->new(name=>"$fileName",
tail => 1000,
maxinterval=>1,
interval=>1,
adjustafter=>5,resetafter=>1,
ignore_nonexistant=>1,
maxbuf=>32768);
push(#fs, $file);
}
do {
my $timeout = 1;
(my $nfound,my $timeleft,my #pending)=
File::Tail::select(undef,undef,undef,$timeout,#fs);
unless ($nfound) {
} else {
foreach (#pending) {
my $str = $_->read;
print $_->{"input"} . " ||||||||| ".localtime(time)." ||||||||| ".$str;
# it doesn't works.
foreach (#webs) {
$_->send_utf8("test!!!!!!!!");
}
}
}
} until(0);
})->detach();
threads->create(sub {
Net::WebSocket::Server->new(
listen => 8080,
on_connect => sub {
my ($serv, $conn) = #_;
push(#webs, $conn);
$conn->on(
utf8 => sub {
my ($conn, $msg) = #_;
$conn->send_utf8($msg);
# it works.
foreach (#webs) {
$_->send_utf8("test!!!!!!!!");
}
},
);
},
)->start;
})->detach();
get '/' => sub {
my $ws_url = "ws://127.0.0.1:8080/";
return <<"END";
<html>
<head><script>
var urlMySocket = "$ws_url";
var mySocket = new WebSocket(urlMySocket);
mySocket.onmessage = function (evt) {
console.log( "Got message " + evt.data );
};
mySocket.onopen = function(evt) {
console.log("opening");
setTimeout( function() {
mySocket.send('hello'); }, 2000 );
};
</script></head>
<body><h1>WebSocket client</h1></body>
</html>
END
};
dance;
Threads in perl are not lightweight. They're separate instances of the program.
The only thing that threads have in common, are things that exist prior to the threads instantating.
You can - with declaring shared variables - allow data structures to share between threads, however I'd warn you to be cautious here - without some manner of locking, you potentially create yourself a race condition.
In your case, you could declare #webs as : shared. This will mean values inserted into it will be visible to all your threads. But you still need a degree of caution there, because 'when stuff is added' is still nondeterministic.
But anyway, this basically works:
#!/usr/bin/env perl
use strict;
use warnings;
use threads;
use threads::shared;
use Data::Dumper;
my #shared_struct : shared;
sub reader {
print "Starting reader\n";
for ( 1..10 ) {
print threads -> self() -> tid(), ":", join (",", #shared_struct ), "\n";
sleep 1;
}
}
sub writer {
print "starting writer\n";
for ( 1..10 ) {
push #shared_struct, rand(10);
print Dumper \#shared_struct;
sleep 1;
}
}
## start the threads;
my $reader = threads -> create ( \&reader );
my $writer = threads -> create ( \&writer );
while ( 1 ) {
print #shared_struct;
sleep 1;
}
More generally, I'd suggest you almost never actually want to detach a thread in perl - in doing so, what you're saying is 'I don't care about your execution'. And clearly that's not the case in your code - you're trying to talk to the threads.
Just creating the thread accomplishes what you want - parallel execution and you can have:
for my $thread ( threads -> list ) {
$thread -> join;
}
As and when you're ready for the thread to terminate.
I get the following error when trying to run my test code:
thread failed to start: Invalid value for shared scalar at ./threaded_test.pl line 47.
Line 47 is:
%hoh = hoh(#new_array);
My observations:
If I remove line 47 and other lines referencing %hoh, then the script runs without errors
I can create a new hash %new_hash = (itchy => "Scratchy"); without errors, but when I try to "return" a hash from another sub (line 47), it results in the error above.
Unfortunately, I cannot use a in/out Queue because the version of Thread::Queue that I use is too old (and installed on a system I have no control over) and doesn't support hash and hash-ref types to be returned via a Queue (according to this). Apparently, my version only support strings to be returned via queues.
Is there a way to successfully do this: $hash{$string}{"jc"} = \%hoh;
#!/usr/bin/perl
use strict;
use warnings;
use threads;
use Thread::Queue;
use constant NUM_WORKERS => 10;
my #out_array : shared = ();
main();
sub main
{
my #results = test1();
foreach my $item (#results) {
print "item: $item\n";
}
}
sub test1
{
my $my_queue = Thread::Queue->new();
foreach (1..NUM_WORKERS) {
async {
while (my $job = $my_queue->dequeue()) {
test2($job);
}
};
}
my #sentiments = ("Axe Murderer", "Mauler", "Babyface", "Dragon");
$my_queue->enqueue(#sentiments);
$my_queue->enqueue(undef) for 1..NUM_WORKERS;
$_->join() for threads->list();
my #return_array = #out_array;
return #return_array;
}
sub test2
{
my $string = $_[0];
my %hash : shared;
my #new_array : shared;
my %new_hash : shared;
my %hoh : shared;
#new_array = ("tom", "jerry");
%new_hash = (itchy => "Scratchy");
%hoh = hoh(#new_array);
my %anon : shared;
$hash{$string} = \%anon;
$hash{$string}{"Grenade"} = \#new_array;
$hash{$string}{"Pipe bomb"} = \%new_hash;
$hash{$string}{"jc"} = \%hoh;
push #out_array, \%hash;
return;
}
sub hoh
{
my %hoh;
foreach my $item (#_) {
$hoh{"jeepers"}{"creepers"} = $item;
}
return %hoh;
}
The problem is that your trying to store a reference to something that isn't shared in a shared variable. You need to use share as previously mentioned, or you need to serialise the data structure.
#!/perl/bin/perl
use strict;
use threads;
use threads::shared;
my %hm_n2g:shared = ();
my $row = &share([]);
$hm_n2g{"aa"}=$row;
$row->[0]=1;
$row->[1]=2;
my #arr = #{$hm_n2g{"aa"}};
print #arr[0]." ".#arr[1]."\n";
#If you want to lock the hash in a thread-subroutine
{
lock(%hm_n2g)
}
I have written a Perl script that reads data from the serial port.
use Device::SerialPort;
$PortObj = new Device::SerialPort ($PortName, $quiet, $lockfile);
$PortObj->read_const_time( 500 ); # timeout waiting for data after 500ms
...
The main loop tries to read data from the serial port:
while ( 1 ) {
( $count, $data ) = $PortObj->read( $frameLength );
process_my_data( $data );
do_something_entirely_different_that_needs_being_done;
}
But rather than having a $PortObj->read time out (which consumes a lot of time), I want to be able to test if data is available in the buffer, so I can speed up the loop:
while ( 1 ) {
if ( test_serial_data_available ) { ( $count, $data ) = $PortObj->read( $frameLength ); }
do_something_entirely_different_that_needs_being_done;
}
Can I test the serial buffer for data availability?
EDIT1: I've been spending this morning rewriting the problem to use serial device as a file handle and reading data works, but it is still blocking the loop. This might open up new options to check for data available in the buffer.
In pseudo-Perl:
use Symbol qw( gensym );
my $handle = gensym();
my $PortObj = tie( *$handle, "Device::SerialPort", $PortName );
while ( 1 ) {
my $frameData;
if ( test_serial_data_available ) { my $readLength = read( $handle , $frameData , $frameLength ); }
do_something_entirely_different_that_needs_being_done;
}
So my question is: What should test_serial_data_available look like?
Since you have a filehandle, you can use select.
select will take an arbitrary number of file descriptors and wait until one of them becomes "ready", where ready is defined by which of the 3 sets select gets contains the filehandle. See perldoc -f select for details.
select accepts a timeout, so if you give it a timeout of 0, it becomes a polling function. So this function will do what you need:
sub poll {
my ($fh) = #_;
my $in = '';
vec($in,fileno($fh),1) = 1;
return select($in,undef,undef,0);
}
# ...
if ( poll($handle) ) { my $readLength = read( $handle , $frameData , $frameLength ); }