Jemand zu Hause?![[twitter]](/battie/theme/default/icons/twitter.gif){kind=icon}
 |
|< 1 2 3 4 5 >| |  |
41 Einträge, 5 Seiten |
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
use strict;
use warnings;
use Time::HiRes qw(time);
use constant TIMEOUT => 1;
my $bigString = pack "C*", 33 .. 126;
$bigString = $bigString x 1_000_000;
my $time_to_die = time + TIMEOUT;
eval {
local $SIG{ALRM} = sub { die "regex timed out at ", time, "\n" };
alarm TIMEOUT;
print "time to die at $time_to_die\n";
print "begin regex at ", time, "\n";
my ( $foo, $bar, $baz ) = $bigString =~ /(?{1})(abc).*(def).*(ghi)/;
print "foo = $foo, bar = $bar, baz = $baz\n";
print "end regex at ", time, "\n";
alarm 0;
};
print "error while regex. $@\n" if $@;
use Benchmark qw(:all);
cmpthese ( 5, {
'mit ' => sub { $bigString =~ /(?{1})(abc).*(def).*(ghi)/ },
'ohne ' => sub { $bigString =~ /(abc).*(def).*(ghi)/ }
} );
![[Homepage]](/battie/theme/default/homepage.gif)
![[default_avatar]](/battie/theme/default/default_avatar.gif){kind=avatar}
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
#!/usr/bin/perl
use strict;
use warnings;
use POSIX ":sys_wait_h";
pipe PREAD, CWRITE; # child -> parent
my $parent_pid = $$;
if (my $pid = fork()) {
parent($pid);
}
else {
child();
}
sub child {
close PREAD; # child - close parent end of pipe
print "child: id $$ dad $parent_pid\n";
print "child: start of proccess\n";
syswrite CWRITE, "0\n";
for (1..9) {print "child zZZZzzz\n";sleep 1;}
print "child is awaking\n";
syswrite CWRITE, "$_\n" for 1 .. 10;
print "child ending\n";
exit;
} # sub child
sub parent {
my ($pid) = @_;
close CWRITE; # parent - close child end of pipes
print "parent id $$ child $pid\n";
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
my @erg;
eval {
alarm 15;
while (waitpid($pid, WNOHANG) == 0) {
print "parent: kind lebt noch\n";
sleep 1;
}
alarm 0;
};
if ($@) {
die "other error : $@"
unless $@ eq "alarm\n"; # propagate unexpected errors
warn "parent : child got time out!\n";
# ... Maßnahmen ergreifen um klarzumachen, dass die Verarbeitung
# unvollständig ist ...
}
else {
alarm 0; # Ist das wirklich notwendig?
chomp(@erg = <PREAD>);
print "parent got ", join(' - ', @erg), "\n";
print "parent : ", (eof(PREAD)?'ENDE':'keine Ende'), "\n";
}
kill TERM => $pid; # Kind abschießen (in beiden Fällen, einmal als Zombie,
# einmal läuft es noch und verbraucht Rechenzeit)
} # sub parent
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
C:\Daten\perl\fork>f5.pl
parent id 1500 child -1520
parent: kind lebt noch
child: id -1520 dad 1500
child: start of proccess
child zZZZzzz
parent: kind lebt noch
child zZZZzzz
parent: kind lebt noch
child zZZZzzz
child zZZZzzz
parent: kind lebt noch
child zZZZzzz
parent: kind lebt noch
child zZZZzzz
parent: kind lebt noch
child zZZZzzz
parent: kind lebt noch
parent: kind lebt noch
child zZZZzzz
parent: kind lebt noch
child zZZZzzz
child is awaking
child ending
parent: kind lebt noch
parent got 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - 10
parent : ENDE
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
C:\Daten\perl\fork>f5.pl
parent id 1340 child -1520
parent: kind lebt noch
child: id -1520 dad 1340
child: start of proccess
child zZZZzzz
parent: kind lebt noch
child zZZZzzz
parent: kind lebt noch
child zZZZzzz
child zZZZzzz
parent: kind lebt noch
child zZZZzzz
parent: kind lebt noch
child zZZZzzz
parent : child got time out!
Terminating on signal SIGTERM(15)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
#!/usr/bin/perl
use strict;
use warnings;
use POSIX ":sys_wait_h";
pipe PREAD, CWRITE; # child -> parent
my $parent_pid = $$;
if (my $pid = fork()) {
parent($pid);
}
else {
child();
}
sub child {
close PREAD; # child - close parent end of pipe
print "child: id $$ dad $parent_pid\n";
print "child: start of proccess\n";
syswrite CWRITE, "0\n";
for (1..9) {print "child zZZZzzz\n";sleep 1;}
print "child is awaking\n";
syswrite CWRITE, "$_\n" for 1 .. 10;
print "child ending\n";
exit;
} # sub child
sub parent {
my ($pid) = @_;
close CWRITE; # parent - close child end of pipes
print "parent id $$ child $pid\n";
my @erg;
eval {
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
alarm 15;
while (waitpid($pid, WNOHANG) == 0) {
print "parent: kind lebt noch\n";
sleep 1;
}
alarm 0;
};
alarm 0; # Ist das wirklich notwendig?
if ($@) {
die "other error : $@"
unless $@ eq "alarm\n"; # propagate unexpected errors
warn "parent : child got time out!\n";
# ... Maßnahmen ergreifen um klarzumachen, dass die Verarbeitung
# unvollständig ist ...
}
else {
chomp(@erg = <PREAD>);
print "parent got ", join(' - ', @erg), "\n";
print "parent : ", (eof(PREAD)?'ENDE':'keine Ende'), "\n";
}
kill TERM => $pid; # Kind abschießen (in beiden Fällen, einmal als Zombie,
# einmal läuft es noch und verbraucht Rechenzeit)
} # sub parent
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
#!/usr/bin/perl
use strict;
use warnings;
use IO::Socket;
use File::Basename;
use POSIX ":sys_wait_h";
use Communication;
my $Debug = 0;
my $server_port = 4714;
my $server = IO::Socket::INET->new(
LocalPort => $server_port,
Type => SOCK_STREAM,
Reuse => 1,
Listen => 10,
) or die "Kann keinen TCP-Server an Port $server_port sein: $@\n";
print "Server ", basename($0), " is starting on port $server_port ...\n";
main();
close($server);
exit;
sub main {
CLIENT: while (my $client = $server->accept()) {
pipe PREAD, CWRITE; # child -> parent
chomp(my $input = <$client>);
print "Client sagt '$input'\n" if $Debug;
unless ($input eq Communication::RE_REQUEST) {
print $client Communication::DECLINE, "\n";
}
else {
print $client Communication::ACCEPT, "\n";
my $timeout = <$client>;
unless (defined $timeout) {
warn "Client schickte falsche Daten, Abbruch!\n";
next CLIENT;
}
my $txt = <$client>;
unless (defined $txt) {
warn "Client schickte falsche Daten, Abbruch!\n";
next CLIENT;
}
my $re = <$client>;
unless (defined $re) {
warn "Client schickte falsche Daten, Abbruch!\n";
next CLIENT;
}
chomp ($timeout, $txt, $re);
unless ($timeout =~ /^\d+$/) {
warn "Timeoutwert '$timeout' ist keine natürliche Zahl\n";
next CLIENT;
}
print "Client sagt timeout = '$timeout'\n",
"Client sagt txt = '$txt'\n",
"Client sagt re = '$re'\n" if $Debug;
print '.';
if (my $pid = fork()) {
parent($pid, $client, $timeout);
}
else {
child($txt, $re);
}
}
}
} # sub main
sub child {
my ($txt, $re) = @_;
$server->shutdown(0); # nur im Kind schließen
close PREAD; # child - close parent end of pipe
#print "child: id $$ dad $parent_pid\n";
print "child: start of proccess\n" if $Debug;
use re 'eval';
if (my @all = $txt =~ /$re/) {
print CWRITE "$_\n" for $`, $&, $', @all;
}
else {
print CWRITE "-1\n";
}
print "child: end of proccess\n" if $Debug;
exit;
} # sub child
sub parent {
my ($pid, $client, $timeout) = @_;
close CWRITE; # parent - close child end of pipes
print "parent id $$ child $pid\n" if $Debug;
my @erg;
eval {
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
alarm $timeout;
while (waitpid($pid, WNOHANG) == 0) {
#print "parent: kind lebt noch\n";
#sleep 1;
}
alarm 0;
};
alarm 0; # Ist das wirklich notwendig?
if ($@) {
die "other error : $@"
unless $@ eq "alarm\n"; # propagate unexpected errors
warn "parent : child got time out!\n" if $Debug;
print $client Communication::TIME_OUT, "\n";
}
else {
chomp(@erg = <PREAD>);
print "parent got ", join(' - ', @erg), "\n" if $Debug;
if (@erg == 1 and $erg[0] eq -1) {
print $client Communication::NO_MATCH, "\n";
}
else {
print $client "$_\n" for @erg;
}
}
#kill TERM => $pid; # Kind abschießen (in beiden Fällen, einmal als Zombie,
# einmal läuft es noch und verbraucht Rechenzeit)
} # sub parent
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
#!/usr/bin/perl
use strict;
use warnings;
use IO::Socket;
use File::Basename;
use Communication;
do_the_re(15, 'a b c d', '\s*(b)\s*(c)\s*');
do_the_re( 5, 'a b c d', '\s*(b)\s*(c)\s*');
do_the_re( 5, 'a b c d', '\s*(e)\s*');
do_the_re( 2, 'a b c d', '(?{sleep 3})');
sub do_the_re {
my ($timeout, $txt, $re) = @_;
my $remote_host = 'localhost';
my $remote_port = 4714;
my $socket = IO::Socket::INET->new(
PeerAddr => $remote_host,
PeerPort => $remote_port,
Proto => 'tcp',
Type => SOCK_STREAM,
) or die "Konnte Verbindung zu $remote_host:$remote_port nicht herstellen: $@\n";
print "Client ", basename($0), " is starting, connected to $remote_host:$remote_port ...\n";
print $socket Communication::RE_REQUEST, "\n";
chomp(my $antwort = <$socket>);
die "no server-accept\n" unless $antwort eq Communication::ACCEPT;
print $socket "$timeout\n$txt\n$re\n";
chomp(my @erg = <$socket>);
if (@erg == 1 and $erg[0] eq Communication::TIME_OUT) {
print "ABBRUCH WEGEN ZEITUEBERSCHREITUNG\n";
}
elsif (@erg == 1 and $erg[0] eq Communication::NO_MATCH) {
print "KEIN MATCH\n";
}
else {
print "Ergbenis: [", join('], [', @erg), "]\n";
}
}
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
use strict;
use warnings;
package Communication;
#------------------------------------------------------------------------------
# Von Exporter erben:
#------------------------------------------------------------------------------
use base qw/Exporter/;
our @EXPORT = qw//;
our @EXPORT_OK = qw/RE_REQUEST ACCEPT DECLINE TIME_OUT NO_MATCH/;
our %EXPORT_TAGS = (all => [qw/RE_REQUEST ACCEPT DECLINE TIME_OUT NO_MATCH/]);
#------------------------------------------------------------------------------
# Konstanten:
#------------------------------------------------------------------------------
use constant RE_REQUEST => 33001;
use constant ACCEPT => 33002;
use constant DECLINE => 33003;
use constant TIME_OUT => 33004;
use constant NO_MATCH => 33005;
1;
1
2
3
4
5
6
7
8
9
C:\Daten\perl\socket>c4.pl
Client c4.pl is starting, connected to localhost:4714 ...
Ergbenis: [a], [ b c ], [d], [b], [c]
Client c4.pl is starting, connected to localhost:4714 ...
Ergbenis: [a], [ b c ], [d], [b], [c]
Client c4.pl is starting, connected to localhost:4714 ...
KEIN MATCH
Client c4.pl is starting, connected to localhost:4714 ...
ABBRUCH WEGEN ZEITUEBERSCHREITUNG
|
|< 1 2 3 4 5 >| | |
41 Einträge, 5 Seiten |
Schrift
Blog
Einstellungen![[feed]](/battie/theme/default/icons/feed.png){kind=icon}
![[Powered by Battie]](/battie/img/powered.png)
