在 perl 线程中复制共享哈希的问题

Question

我在 perl 中遇到了我觉得共享哈希的奇怪行为，需要一些帮助来理解它。

实际问题出在更大的代码库中，我已尝试将其缩减为更小的可重现脚本。

所以本质上我面临的问题是我有一个共享变量，看起来像这些行：

 my %headers :shared= map { lc($_) => $custom_headers->{$_} }  keys %{$custom_headers};   
 my %task1_request :shared; 
 $task1_request{count} = $count;
 $task1_request{header} = \%headers if(keys %headers);

也就是说，我最终将对共享变量 headers 的引用传递给两个单独的线程

这些线程中的每一个都对哈希“headers”的引用执行“只读”操作。

但是，在将共享哈希的副本传递给线程中的函数时看起来像，如下面的示例所示：

iterate_header($request->{count},%{$request->{header}});

sub iterate_header
{
    my $count = shift;
    my $current_count = scalar(@_);
    if($count != $current_count) {
      print STDERR "Test failed Expected: $count, Actual : $current_count \n";
    }
    else {
      print STDERR "Test passed\n" ;
    }
}

导致复制的哈希损坏 即 iterate_header 中的 @_ 已损坏。

在我看来，迭代器对于共享哈希来说是全局的，因此副本不是线程安全的。然而，以上只是我的一个鲁莽假设，我希望有人可以帮助澄清为什么复制共享哈希会导致这种看似奇怪的行为，如果这是预期的？

复制器脚本如下：

use strict;
use warnings;
use threads;
use threads::shared;
use Thread::Queue;

#should run test_count * 2 times
sub iterate_header
{
    my $count = shift;
    my $current_count = scalar(@_);
    if($count != $current_count) {
      print STDERR "Test failed Expected: $count, Actual : $current_count \n";
    }
    else {
      print STDERR "Test passed\n" ;
    }
}

sub request_loop {
    my ($request_queue) = @_;

    # wait for the next reuest...
    while (defined(my $request = $request_queue->dequeue())) {
        my %result :shared;
        if(exists($request->{header})) {
            iterate_header($request->{count},%{$request->{header}});
        }
        last if(exists($request->{exit}));
        $result{is_success} = "200";
    }
}

# Main program
# create thread queues
my $task1_request_queue = Thread::Queue->new();   
my $task2_request_queue = Thread::Queue->new();    

# start worker threads
my $task1_worker = threads->create(\&request_loop, $task1_request_queue);
my $task2_worker = threads->create(\&request_loop, $task2_request_queue);

# a high number to ensure tests fail
 my $test_count = 100; 
 my $custom_headers = {
        "key" => "558193F28878E5FE",
        "username" => "Mastodon",
        "real_username" => "Mastodon",
        "type" => "EMPLOYEE",
        "expiration" => "1434556278",
        "env" => "save it",
        "for" => "some ip",
        "long-string" => "This islong string",
        "state" => "internal",
        "account" => "home",
        "original_account" => "home",
        "key" => "MCwCFAPOE74uvXso5alKytqjlfpdqeY4AhRpDeIMLCAk3ciBcyDXLdnyZjC/7Q==",
        "charset" => "iso-8859-1,*,utf-8",
        "agent" => "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/535.19 (KHTML, like Gecko) Chrome/18.0.1025.166 Workstation/2013.9.213.116 Safari/535.19",
        "accept" => "application/json, text/plain, */*",
        "encoding" => "gzip,deflate",
        "language" => "en-us,en",
        "cookie" => "TS01375c99=012e7f4fa1e82941689f22669e2e6403ce1c75f9f8c7cb86de86c19a887f61a1109c6e2aae",
        "created" => "1434555378",

    };


my @data = %{$custom_headers};
my $count = scalar(@data);
print STDERR  "Expected Count for all tests:$count\n";
for(my $i = 0;$i < 2; $i++) {
  my %headers :shared= map { lc($_) => $custom_headers->{$_} }  keys %{$custom_headers};   
  #add to task1 q
    {    

        my %task1_request :shared; 
        $task1_request{count} = $count;

        $task1_request{header} = \%headers if(keys %headers);

        $task1_request_queue->enqueue(\%task1_request);
    }

    # add to task2 q
    {
        my %task2_request :shared; 
        $task2_request{count} = $count;

        $task2_request{header} = \%headers if(keys %headers);
        $task2_request_queue->enqueue(\%task2_request);
    }
}

my %end_request :shared = (exit => 1);
$task1_request_queue->enqueue(\%end_request);
$task2_request_queue->enqueue(\%end_request);

$task1_worker->join();
$task2_worker->join();
print "testing done\n";

测试运行的示例输出：

[]$ perl thread_shared_issue.pl
Expected Count for all tests:36
Test passed
Test passed
Test passed
Test passed
testing done
[]$ perl thread_shared_issue.pl
Expected Count for all tests:36
Test failed Expected: 36, Actual : 16
Test failed Expected: 36, Actual : 60
Test failed Expected: 36, Actual : 18
Test failed Expected: 36, Actual : 56
testing done

经测试的 Perl 版本

perl -version

This is perl 5, version 12, subversion 5 (v5.12.5) built for x86_64-linux-thread-multi

Answer 1

两个线程同时迭代同一个哈希，所以它们都在改变它的迭代器。您需要确保一次不超过一个线程使用哈希的迭代器。

我会删除所有这些 :shared 并使用 Thread::Queue::Any。