« back to all changes in this revision
Viewing changes to bin/pt-query-digest
- browse files at revision 589
- compare with another revision
- download diff
- download tarball
- view history from revision 589
- Committer: Daniel Nichter
- Date: 2013-08-03 18:50:15 UTC
- Revision ID: daniel@percona.com-20130803185015-3769c4w60npdorvq
Update modules in pt-query-digest to fix bug 821692 and bug 984053. Replace HTTPMicro with HTTP::Micro.
- files added:
- t/lib/samples/slowlogs/slow058.txt
- files modified:
- bin/pt-query-digest
added
removed
bin/pt-query-digest
48
48
FileIterator
49
49
Runtime
50
50
Pipeline
51
HTTPMicro
51
HTTP::Micro
52
52
VersionCheck
53
53
));
54
54
}
2928
2928
$query =~ m/\A\s*UNLOCK TABLES/i && return "UNLOCK";
2929
2929
$query =~ m/\A\s*xa\s+(\S+)/i && return "XA_$1";
2930
2930
2931
if ( $query =~ m/\A\s*LOAD/i ) {
2932
my ($tbl) = $query =~ m/INTO TABLE\s+(\S+)/i;
2933
$tbl ||= '';
2934
$tbl =~ s/`//g;
2935
return "LOAD DATA $tbl";
2936
}
2937
2931
2938
if ( $query =~ m/\Aadministrator command:/ ) {
2932
2939
$query =~ s/administrator command:/ADMIN/;
2933
2940
$query = uc $query;
3021
3028
map { $verbs =~ s/$_/$alias_for{$_}/ } keys %alias_for;
3022
3029
$query = $verbs;
3023
3030
}
3031
elsif ( $verbs && $verbs =~ m/^LOAD DATA/ ) {
3032
return $verbs;
3033
}
3024
3034
else {
3025
3035
my @tables = $self->__distill_tables($query, $table, %args);
3026
3036
$query = join(q{ }, $verbs, @tables);
8259
8269
return ($tbl);
8260
8270
}
8261
8271
8262
$query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig;
8272
$query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN|DELAYED) / /ig;
8263
8273
8264
8274
if ( $query =~ s/^\s*LOCK TABLES\s+//i ) {
8265
8275
PTDEBUG && _d('Special table type: LOCK TABLES');
8268
8278
$query = "FROM $query";
8269
8279
}
8270
8280
8271
$query =~ s/\\["']//g; # quoted strings
8272
$query =~ s/".*?"/?/sg; # quoted strings
8273
$query =~ s/'.*?'/?/sg; # quoted strings
8281
$query =~ s/\\["']//g; # quoted strings
8282
$query =~ s/".*?"/?/sg; # quoted strings
8283
$query =~ s/'.*?'/?/sg; # quoted strings
8284
8285
if ( $query =~ m/\A\s*(?:INSERT|REPLACE)\s+(?!INTO)/i ) {
8286
$query =~ s/\A\s*((?:INSERT|REPLACE))\s+/$1 INTO /i;
8287
}
8274
8288
8275
8289
my @tables;
8276
8290
foreach my $tbls ( $query =~ m/$tbl_regex/gio ) {
9253
9267
use strict;
9254
9268
use warnings FATAL => 'all';
9255
9269
use English qw(-no_match_vars);
9270
9256
9271
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
9257
9272
9258
9273
use POSIX qw(setsid);
9274
use Fcntl qw(:DEFAULT);
9259
9275
9260
9276
sub new {
9261
my ( $class, %args ) = @_;
9262
foreach my $arg ( qw(o) ) {
9263
die "I need a $arg argument" unless $args{$arg};
9264
}
9265
my $o = $args{o};
9277
my ($class, %args) = @_;
9266
9278
my $self = {
9267
o => $o,
9268
log_file => $o->has('log') ? $o->get('log') : undef,
9269
PID_file => $o->has('pid') ? $o->get('pid') : undef,
9279
log_file => $args{log_file},
9280
pid_file => $args{pid_file},
9281
daemonize => $args{daemonize},
9282
force_log_file => $args{force_log_file},
9283
parent_exit => $args{parent_exit},
9284
pid_file_owner => 0,
9270
9285
};
9271
9272
check_PID_file(undef, $self->{PID_file});
9273
9274
PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
9275
9286
return bless $self, $class;
9276
9287
}
9277
9288
9278
sub daemonize {
9279
my ( $self ) = @_;
9280
9281
PTDEBUG && _d('About to fork and daemonize');
9282
defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
9283
if ( $pid ) {
9284
PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
9285
exit;
9286
}
9287
9288
PTDEBUG && _d('Daemonizing child PID', $PID);
9289
$self->{PID_owner} = $PID;
9290
$self->{child} = 1;
9291
9292
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
9293
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
9294
9295
$self->_make_PID_file();
9296
9297
$OUTPUT_AUTOFLUSH = 1;
9298
9299
PTDEBUG && _d('Redirecting STDIN to /dev/null');
9300
close STDIN;
9301
open STDIN, '/dev/null'
9302
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
9303
9304
if ( $self->{log_file} ) {
9305
PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
9306
close STDOUT;
9307
open STDOUT, '>>', $self->{log_file}
9308
or die "Cannot open log file $self->{log_file}: $OS_ERROR";
9309
9310
close STDERR;
9311
open STDERR, ">&STDOUT"
9312
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
9313
}
9314
else {
9315
if ( -t STDOUT ) {
9316
PTDEBUG && _d('No log file and STDOUT is a terminal;',
9317
'redirecting to /dev/null');
9289
sub run {
9290
my ($self) = @_;
9291
9292
my $daemonize = $self->{daemonize};
9293
my $pid_file = $self->{pid_file};
9294
my $log_file = $self->{log_file};
9295
my $force_log_file = $self->{force_log_file};
9296
my $parent_exit = $self->{parent_exit};
9297
9298
PTDEBUG && _d('Starting daemon');
9299
9300
if ( $pid_file ) {
9301
eval {
9302
$self->_make_pid_file(
9303
pid => $PID, # parent's pid
9304
pid_file => $pid_file,
9305
);
9306
};
9307
die "$EVAL_ERROR\n" if $EVAL_ERROR;
9308
if ( !$daemonize ) {
9309
$self->{pid_file_owner} = $PID; # parent's pid
9310
}
9311
}
9312
9313
if ( $daemonize ) {
9314
defined (my $child_pid = fork()) or die "Cannot fork: $OS_ERROR";
9315
if ( $child_pid ) {
9316
PTDEBUG && _d('Forked child', $child_pid);
9317
$parent_exit->($child_pid) if $parent_exit;
9318
exit 0;
9319
}
9320
9321
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
9322
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
9323
9324
if ( $pid_file ) {
9325
$self->_update_pid_file(
9326
pid => $PID, # child's pid
9327
pid_file => $pid_file,
9328
);
9329
$self->{pid_file_owner} = $PID;
9330
}
9331
}
9332
9333
if ( $daemonize || $force_log_file ) {
9334
PTDEBUG && _d('Redirecting STDIN to /dev/null');
9335
close STDIN;
9336
open STDIN, '/dev/null'
9337
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
9338
if ( $log_file ) {
9339
PTDEBUG && _d('Redirecting STDOUT and STDERR to', $log_file);
9318
9340
close STDOUT;
9319
open STDOUT, '>', '/dev/null'
9320
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
9321
}
9322
if ( -t STDERR ) {
9323
PTDEBUG && _d('No log file and STDERR is a terminal;',
9324
'redirecting to /dev/null');
9341
open STDOUT, '>>', $log_file
9342
or die "Cannot open log file $log_file: $OS_ERROR";
9343
9325
9344
close STDERR;
9326
open STDERR, '>', '/dev/null'
9327
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
9328
}
9329
}
9330
9331
return;
9332
}
9333
9334
sub check_PID_file {
9335
my ( $self, $file ) = @_;
9336
my $PID_file = $self ? $self->{PID_file} : $file;
9337
PTDEBUG && _d('Checking PID file', $PID_file);
9338
if ( $PID_file && -f $PID_file ) {
9339
my $pid;
9340
eval {
9341
chomp($pid = (slurp_file($PID_file) || ''));
9342
};
9343
if ( $EVAL_ERROR ) {
9344
die "The PID file $PID_file already exists but it cannot be read: "
9345
. $EVAL_ERROR;
9346
}
9347
PTDEBUG && _d('PID file exists; it contains PID', $pid);
9348
if ( $pid ) {
9349
my $pid_is_alive = kill 0, $pid;
9345
open STDERR, ">&STDOUT"
9346
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
9347
}
9348
else {
9349
if ( -t STDOUT ) {
9350
PTDEBUG && _d('No log file and STDOUT is a terminal;',
9351
'redirecting to /dev/null');
9352
close STDOUT;
9353
open STDOUT, '>', '/dev/null'
9354
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
9355
}
9356
if ( -t STDERR ) {
9357
PTDEBUG && _d('No log file and STDERR is a terminal;',
9358
'redirecting to /dev/null');
9359
close STDERR;
9360
open STDERR, '>', '/dev/null'
9361
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
9362
}
9363
}
9364
9365
$OUTPUT_AUTOFLUSH = 1;
9366
}
9367
9368
PTDEBUG && _d('Daemon running');
9369
return;
9370
}
9371
9372
sub _make_pid_file {
9373
my ($self, %args) = @_;
9374
my @required_args = qw(pid pid_file);
9375
foreach my $arg ( @required_args ) {
9376
die "I need a $arg argument" unless $args{$arg};
9377
};
9378
my $pid = $args{pid};
9379
my $pid_file = $args{pid_file};
9380
9381
eval {
9382
sysopen(PID_FH, $pid_file, O_RDWR|O_CREAT|O_EXCL) or die $OS_ERROR;
9383
print PID_FH $PID, "\n";
9384
close PID_FH;
9385
};
9386
if ( my $e = $EVAL_ERROR ) {
9387
if ( $e =~ m/file exists/i ) {
9388
my $old_pid = $self->_check_pid_file(
9389
pid_file => $pid_file,
9390
pid => $PID,
9391
);
9392
if ( $old_pid ) {
9393
warn "Overwriting PID file $pid_file because PID $old_pid "
9394
. "is not running.\n";
9395
}
9396
$self->_update_pid_file(
9397
pid => $PID,
9398
pid_file => $pid_file
9399
);
9400
}
9401
else {
9402
die "Error creating PID file $pid_file: $e\n";
9403
}
9404
}
9405
9406
return;
9407
}
9408
9409
sub _check_pid_file {
9410
my ($self, %args) = @_;
9411
my @required_args = qw(pid_file pid);
9412
foreach my $arg ( @required_args ) {
9413
die "I need a $arg argument" unless $args{$arg};
9414
};
9415
my $pid_file = $args{pid_file};
9416
my $pid = $args{pid};
9417
9418
PTDEBUG && _d('Checking if PID in', $pid_file, 'is running');
9419
9420
if ( ! -f $pid_file ) {
9421
PTDEBUG && _d('PID file', $pid_file, 'does not exist');
9422
return;
9423
}
9424
9425
open my $fh, '<', $pid_file
9426
or die "Error opening $pid_file: $OS_ERROR";
9427
my $existing_pid = do { local $/; <$fh> };
9428
chomp($existing_pid) if $existing_pid;
9429
close $fh
9430
or die "Error closing $pid_file: $OS_ERROR";
9431
9432
if ( $existing_pid ) {
9433
if ( $existing_pid == $pid ) {
9434
warn "The current PID $pid already holds the PID file $pid_file\n";
9435
return;
9436
}
9437
else {
9438
PTDEBUG && _d('Checking if PID', $existing_pid, 'is running');
9439
my $pid_is_alive = kill 0, $existing_pid;
9350
9440
if ( $pid_is_alive ) {
9351
die "The PID file $PID_file already exists "
9352
. " and the PID that it contains, $pid, is running";
9353
}
9354
else {
9355
warn "Overwriting PID file $PID_file because the PID that it "
9356
. "contains, $pid, is not running";
9357
}
9358
}
9359
else {
9360
die "The PID file $PID_file already exists but it does not "
9361
. "contain a PID";
9441
die "PID file $pid_file exists and PID $existing_pid is running\n";
9442
}
9362
9443
}
9363
9444
}
9364
9445
else {
9365
PTDEBUG && _d('No PID file');
9366
}
9367
return;
9368
}
9369
9370
sub make_PID_file {
9371
my ( $self ) = @_;
9372
if ( exists $self->{child} ) {
9373
die "Do not call Daemon::make_PID_file() for daemonized scripts";
9374
}
9375
$self->_make_PID_file();
9376
$self->{PID_owner} = $PID;
9377
return;
9378
}
9379
9380
sub _make_PID_file {
9381
my ( $self ) = @_;
9382
9383
my $PID_file = $self->{PID_file};
9384
if ( !$PID_file ) {
9385
PTDEBUG && _d('No PID file to create');
9386
return;
9387
}
9388
9389
$self->check_PID_file();
9390
9391
open my $PID_FH, '>', $PID_file
9392
or die "Cannot open PID file $PID_file: $OS_ERROR";
9393
print $PID_FH $PID
9394
or die "Cannot print to PID file $PID_file: $OS_ERROR";
9395
close $PID_FH
9396
or die "Cannot close PID file $PID_file: $OS_ERROR";
9397
9398
PTDEBUG && _d('Created PID file:', $self->{PID_file});
9399
return;
9400
}
9401
9402
sub _remove_PID_file {
9403
my ( $self ) = @_;
9404
if ( $self->{PID_file} && -f $self->{PID_file} ) {
9405
unlink $self->{PID_file}
9406
or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
9446
die "PID file $pid_file exists but it is empty. Remove the file "
9447
. "if the process is no longer running.\n";
9448
}
9449
9450
return $existing_pid;
9451
}
9452
9453
sub _update_pid_file {
9454
my ($self, %args) = @_;
9455
my @required_args = qw(pid pid_file);
9456
foreach my $arg ( @required_args ) {
9457
die "I need a $arg argument" unless $args{$arg};
9458
};
9459
my $pid = $args{pid};
9460
my $pid_file = $args{pid_file};
9461
9462
open my $fh, '>', $pid_file
9463
or die "Cannot open $pid_file: $OS_ERROR";
9464
print { $fh } $pid, "\n"
9465
or die "Cannot print to $pid_file: $OS_ERROR";
9466
close $fh
9467
or warn "Cannot close $pid_file: $OS_ERROR";
9468
9469
return;
9470
}
9471
9472
sub remove_pid_file {
9473
my ($self, $pid_file) = @_;
9474
$pid_file ||= $self->{pid_file};
9475
if ( $pid_file && -f $pid_file ) {
9476
unlink $self->{pid_file}
9477
or warn "Cannot remove PID file $pid_file: $OS_ERROR";
9407
9478
PTDEBUG && _d('Removed PID file');
9408
9479
}
9409
9480
else {
9413
9484
}
9414
9485
9415
9486
sub DESTROY {
9416
my ( $self ) = @_;
9487
my ($self) = @_;
9417
9488
9418
$self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
9489
if ( $self->{pid_file_owner} == $PID ) {
9490
$self->remove_pid_file();
9491
}
9419
9492
9420
9493
return;
9421
9494
}
9422
9495
9423
sub slurp_file {
9424
my ($file) = @_;
9425
return unless $file;
9426
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
9427
return do { local $/; <$fh> };
9428
}
9429
9430
9496
sub _d {
9431
9497
my ($package, undef, $line) = caller 0;
9432
9498
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
11479
11545
# ###########################################################################
11480
11546
11481
11547
# ###########################################################################
11482
# HTTPMicro package
11548
# HTTP::Micro package
11483
11549
# This package is a copy without comments from the original. The original
11484
11550
# with comments and its test file can be found in the Bazaar repository at,
11485
# lib/HTTPMicro.pm
11486
# t/lib/HTTPMicro.t
11551
# lib/HTTP/Micro.pm
11552
# t/lib/HTTP/Micro.t
11487
11553
# See https://launchpad.net/percona-toolkit for more information.
11488
11554
# ###########################################################################
11489
11555
{
11490
11491
package HTTPMicro;
11492
BEGIN {
11493
$HTTPMicro::VERSION = '0.001';
11494
}
11556
package HTTP::Micro;
11557
11558
our $VERSION = '0.01';
11559
11495
11560
use strict;
11496
use warnings;
11497
11561
use warnings FATAL => 'all';
11562
use English qw(-no_match_vars);
11498
11563
use Carp ();
11499
11564
11500
11501
11565
my @attributes;
11502
11566
BEGIN {
11503
11567
@attributes = qw(agent timeout);
11568
11632
headers => {},
11569
11633
};
11570
11634
11571
my $handle = HTTPMicro::Handle->new(timeout => $self->{timeout});
11635
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
11572
11636
11573
11637
$handle->connect($scheme, $host, $port);
11574
11638
11633
11697
return ($scheme, $host, $port, $path_query);
11634
11698
}
11635
11699
11636
package
11637
HTTPMicro::Handle; # hide from PAUSE/indexers
11638
use strict;
11639
use warnings;
11640
11641
use Carp qw[croak];
11642
use Errno qw[EINTR EPIPE];
11643
use IO::Socket qw[SOCK_STREAM];
11644
11645
sub BUFSIZE () { 32768 }
11646
11647
my $Printable = sub {
11648
local $_ = shift;
11649
s/\r/\\r/g;
11650
s/\n/\\n/g;
11651
s/\t/\\t/g;
11652
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
11653
$_;
11654
};
11655
11656
sub new {
11657
my ($class, %args) = @_;
11658
return bless {
11659
rbuf => '',
11660
timeout => 60,
11661
max_line_size => 16384,
11662
%args
11663
}, $class;
11664
}
11665
11666
my $ssl_verify_args = {
11667
check_cn => "when_only",
11668
wildcards_in_alt => "anywhere",
11669
wildcards_in_cn => "anywhere"
11670
};
11671
11672
sub connect {
11673
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
11674
my ($self, $scheme, $host, $port) = @_;
11675
11676
if ( $scheme eq 'https' ) {
11677
eval "require IO::Socket::SSL"
11678
unless exists $INC{'IO/Socket/SSL.pm'};
11679
croak(qq/IO::Socket::SSL must be installed for https support\n/)
11680
unless $INC{'IO/Socket/SSL.pm'};
11681
}
11682
elsif ( $scheme ne 'http' ) {
11683
croak(qq/Unsupported URL scheme '$scheme'\n/);
11684
}
11685
11686
$self->{fh} = 'IO::Socket::INET'->new(
11687
PeerHost => $host,
11688
PeerPort => $port,
11689
Proto => 'tcp',
11690
Type => SOCK_STREAM,
11691
Timeout => $self->{timeout}
11692
) or croak(qq/Could not connect to '$host:$port': $@/);
11693
11694
binmode($self->{fh})
11695
or croak(qq/Could not binmode() socket: '$!'/);
11696
11697
if ( $scheme eq 'https') {
11698
IO::Socket::SSL->start_SSL($self->{fh});
11699
ref($self->{fh}) eq 'IO::Socket::SSL'
11700
or die(qq/SSL connection failed for $host\n/);
11701
if ( $self->{fh}->can("verify_hostname") ) {
11702
$self->{fh}->verify_hostname( $host, $ssl_verify_args );
11703
}
11704
else {
11705
my $fh = $self->{fh};
11706
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
11707
or die(qq/SSL certificate not valid for $host\n/);
11708
}
11709
}
11710
11711
$self->{host} = $host;
11712
$self->{port} = $port;
11713
11714
return $self;
11715
}
11716
11717
sub close {
11718
@_ == 1 || croak(q/Usage: $handle->close()/);
11719
my ($self) = @_;
11720
CORE::close($self->{fh})
11721
or croak(qq/Could not close socket: '$!'/);
11722
}
11723
11724
sub write {
11725
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
11726
my ($self, $buf) = @_;
11727
11728
my $len = length $buf;
11729
my $off = 0;
11730
11731
local $SIG{PIPE} = 'IGNORE';
11732
11733
while () {
11734
$self->can_write
11735
or croak(q/Timed out while waiting for socket to become ready for writing/);
11736
my $r = syswrite($self->{fh}, $buf, $len, $off);
11737
if (defined $r) {
11738
$len -= $r;
11739
$off += $r;
11740
last unless $len > 0;
11741
}
11742
elsif ($! == EPIPE) {
11743
croak(qq/Socket closed by remote server: $!/);
11744
}
11745
elsif ($! != EINTR) {
11746
croak(qq/Could not write to socket: '$!'/);
11747
}
11748
}
11749
return $off;
11750
}
11751
11752
sub read {
11753
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
11754
my ($self, $len) = @_;
11755
11756
my $buf = '';
11757
my $got = length $self->{rbuf};
11758
11759
if ($got) {
11760
my $take = ($got < $len) ? $got : $len;
11761
$buf = substr($self->{rbuf}, 0, $take, '');
11762
$len -= $take;
11763
}
11764
11765
while ($len > 0) {
11766
$self->can_read
11767
or croak(q/Timed out while waiting for socket to become ready for reading/);
11768
my $r = sysread($self->{fh}, $buf, $len, length $buf);
11769
if (defined $r) {
11770
last unless $r;
11771
$len -= $r;
11772
}
11773
elsif ($! != EINTR) {
11774
croak(qq/Could not read from socket: '$!'/);
11775
}
11776
}
11777
if ($len) {
11778
croak(q/Unexpected end of stream/);
11779
}
11780
return $buf;
11781
}
11782
11783
sub readline {
11784
@_ == 1 || croak(q/Usage: $handle->readline()/);
11785
my ($self) = @_;
11786
11787
while () {
11788
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
11789
return $1;
11790
}
11791
$self->can_read
11792
or croak(q/Timed out while waiting for socket to become ready for reading/);
11793
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
11794
if (defined $r) {
11795
last unless $r;
11796
}
11797
elsif ($! != EINTR) {
11798
croak(qq/Could not read from socket: '$!'/);
11799
}
11800
}
11801
croak(q/Unexpected end of stream while looking for line/);
11802
}
11803
11804
sub read_header_lines {
11805
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
11806
my ($self, $headers) = @_;
11807
$headers ||= {};
11808
my $lines = 0;
11809
my $val;
11810
11811
while () {
11812
my $line = $self->readline;
11813
11814
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
11815
my ($field_name) = lc $1;
11816
$val = \($headers->{$field_name} = $2);
11817
}
11818
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
11819
$val
11820
or croak(q/Unexpected header continuation line/);
11821
next unless length $1;
11822
$$val .= ' ' if length $$val;
11823
$$val .= $1;
11824
}
11825
elsif ($line =~ /\A \x0D?\x0A \z/x) {
11826
last;
11827
}
11828
else {
11829
croak(q/Malformed header line: / . $Printable->($line));
11830
}
11831
}
11832
return $headers;
11833
}
11834
11835
sub write_header_lines {
11836
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
11837
my($self, $headers) = @_;
11838
11839
my $buf = '';
11840
while (my ($k, $v) = each %$headers) {
11841
my $field_name = lc $k;
11842
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
11843
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
11844
$field_name =~ s/\b(\w)/\u$1/g;
11845
$buf .= "$field_name: $v\x0D\x0A";
11846
}
11847
$buf .= "\x0D\x0A";
11848
return $self->write($buf);
11849
}
11850
11851
sub read_content_body {
11852
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
11853
my ($self, $cb, $response, $len) = @_;
11854
$len ||= $response->{headers}{'content-length'};
11855
11856
croak("No content-length in the returned response, and this "
11857
. "UA doesn't implement chunking") unless defined $len;
11858
11859
while ($len > 0) {
11860
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
11861
$cb->($self->read($read), $response);
11862
$len -= $read;
11863
}
11864
11865
return;
11866
}
11867
11868
sub write_content_body {
11869
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
11870
my ($self, $request) = @_;
11871
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
11872
11873
$len += $self->write($request->{content});
11874
11875
$len == $content_length
11876
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
11877
11878
return $len;
11879
}
11880
11881
sub read_response_header {
11882
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
11883
my ($self) = @_;
11884
11885
my $line = $self->readline;
11886
11887
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
11888
or croak(q/Malformed Status-Line: / . $Printable->($line));
11889
11890
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
11891
11892
return {
11893
status => $status,
11894
reason => $reason,
11895
headers => $self->read_header_lines,
11896
protocol => $protocol,
11897
};
11898
}
11899
11900
sub write_request_header {
11901
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
11902
my ($self, $method, $request_uri, $headers) = @_;
11903
11904
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
11905
+ $self->write_header_lines($headers);
11906
}
11907
11908
sub _do_timeout {
11909
my ($self, $type, $timeout) = @_;
11910
$timeout = $self->{timeout}
11911
unless defined $timeout && $timeout >= 0;
11912
11913
my $fd = fileno $self->{fh};
11914
defined $fd && $fd >= 0
11915
or croak(q/select(2): 'Bad file descriptor'/);
11916
11917
my $initial = time;
11918
my $pending = $timeout;
11919
my $nfound;
11920
11921
vec(my $fdset = '', $fd, 1) = 1;
11922
11923
while () {
11924
$nfound = ($type eq 'read')
11925
? select($fdset, undef, undef, $pending)
11926
: select(undef, $fdset, undef, $pending) ;
11927
if ($nfound == -1) {
11928
$! == EINTR
11929
or croak(qq/select(2): '$!'/);
11930
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
11931
$nfound = 0;
11932
}
11933
last;
11934
}
11935
$! = 0;
11936
return $nfound;
11937
}
11938
11939
sub can_read {
11940
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
11941
my $self = shift;
11942
return $self->_do_timeout('read', @_)
11943
}
11944
11945
sub can_write {
11946
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
11947
my $self = shift;
11948
return $self->_do_timeout('write', @_)
11949
}
11700
} # HTTP::Micro
11701
11702
{
11703
package HTTP::Micro::Handle;
11704
11705
use strict;
11706
use warnings FATAL => 'all';
11707
use English qw(-no_match_vars);
11708
11709
use Carp qw(croak);
11710
use Errno qw(EINTR EPIPE);
11711
use IO::Socket qw(SOCK_STREAM);
11712
11713
sub BUFSIZE () { 32768 }
11714
11715
my $Printable = sub {
11716
local $_ = shift;
11717
s/\r/\\r/g;
11718
s/\n/\\n/g;
11719
s/\t/\\t/g;
11720
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
11721
$_;
11722
};
11723
11724
sub new {
11725
my ($class, %args) = @_;
11726
return bless {
11727
rbuf => '',
11728
timeout => 60,
11729
max_line_size => 16384,
11730
%args
11731
}, $class;
11732
}
11733
11734
my $ssl_verify_args = {
11735
check_cn => "when_only",
11736
wildcards_in_alt => "anywhere",
11737
wildcards_in_cn => "anywhere"
11738
};
11739
11740
sub connect {
11741
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
11742
my ($self, $scheme, $host, $port) = @_;
11743
11744
if ( $scheme eq 'https' ) {
11745
eval "require IO::Socket::SSL"
11746
unless exists $INC{'IO/Socket/SSL.pm'};
11747
croak(qq/IO::Socket::SSL must be installed for https support\n/)
11748
unless $INC{'IO/Socket/SSL.pm'};
11749
}
11750
elsif ( $scheme ne 'http' ) {
11751
croak(qq/Unsupported URL scheme '$scheme'\n/);
11752
}
11753
11754
$self->{fh} = IO::Socket::INET->new(
11755
PeerHost => $host,
11756
PeerPort => $port,
11757
Proto => 'tcp',
11758
Type => SOCK_STREAM,
11759
Timeout => $self->{timeout}
11760
) or croak(qq/Could not connect to '$host:$port': $@/);
11761
11762
binmode($self->{fh})
11763
or croak(qq/Could not binmode() socket: '$!'/);
11764
11765
if ( $scheme eq 'https') {
11766
IO::Socket::SSL->start_SSL($self->{fh});
11767
ref($self->{fh}) eq 'IO::Socket::SSL'
11768
or die(qq/SSL connection failed for $host\n/);
11769
if ( $self->{fh}->can("verify_hostname") ) {
11770
$self->{fh}->verify_hostname( $host, $ssl_verify_args );
11771
}
11772
else {
11773
my $fh = $self->{fh};
11774
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
11775
or die(qq/SSL certificate not valid for $host\n/);
11776
}
11777
}
11778
11779
$self->{host} = $host;
11780
$self->{port} = $port;
11781
11782
return $self;
11783
}
11784
11785
sub close {
11786
@_ == 1 || croak(q/Usage: $handle->close()/);
11787
my ($self) = @_;
11788
CORE::close($self->{fh})
11789
or croak(qq/Could not close socket: '$!'/);
11790
}
11791
11792
sub write {
11793
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
11794
my ($self, $buf) = @_;
11795
11796
my $len = length $buf;
11797
my $off = 0;
11798
11799
local $SIG{PIPE} = 'IGNORE';
11800
11801
while () {
11802
$self->can_write
11803
or croak(q/Timed out while waiting for socket to become ready for writing/);
11804
my $r = syswrite($self->{fh}, $buf, $len, $off);
11805
if (defined $r) {
11806
$len -= $r;
11807
$off += $r;
11808
last unless $len > 0;
11809
}
11810
elsif ($! == EPIPE) {
11811
croak(qq/Socket closed by remote server: $!/);
11812
}
11813
elsif ($! != EINTR) {
11814
croak(qq/Could not write to socket: '$!'/);
11815
}
11816
}
11817
return $off;
11818
}
11819
11820
sub read {
11821
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
11822
my ($self, $len) = @_;
11823
11824
my $buf = '';
11825
my $got = length $self->{rbuf};
11826
11827
if ($got) {
11828
my $take = ($got < $len) ? $got : $len;
11829
$buf = substr($self->{rbuf}, 0, $take, '');
11830
$len -= $take;
11831
}
11832
11833
while ($len > 0) {
11834
$self->can_read
11835
or croak(q/Timed out while waiting for socket to become ready for reading/);
11836
my $r = sysread($self->{fh}, $buf, $len, length $buf);
11837
if (defined $r) {
11838
last unless $r;
11839
$len -= $r;
11840
}
11841
elsif ($! != EINTR) {
11842
croak(qq/Could not read from socket: '$!'/);
11843
}
11844
}
11845
if ($len) {
11846
croak(q/Unexpected end of stream/);
11847
}
11848
return $buf;
11849
}
11850
11851
sub readline {
11852
@_ == 1 || croak(q/Usage: $handle->readline()/);
11853
my ($self) = @_;
11854
11855
while () {
11856
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
11857
return $1;
11858
}
11859
$self->can_read
11860
or croak(q/Timed out while waiting for socket to become ready for reading/);
11861
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
11862
if (defined $r) {
11863
last unless $r;
11864
}
11865
elsif ($! != EINTR) {
11866
croak(qq/Could not read from socket: '$!'/);
11867
}
11868
}
11869
croak(q/Unexpected end of stream while looking for line/);
11870
}
11871
11872
sub read_header_lines {
11873
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
11874
my ($self, $headers) = @_;
11875
$headers ||= {};
11876
my $lines = 0;
11877
my $val;
11878
11879
while () {
11880
my $line = $self->readline;
11881
11882
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
11883
my ($field_name) = lc $1;
11884
$val = \($headers->{$field_name} = $2);
11885
}
11886
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
11887
$val
11888
or croak(q/Unexpected header continuation line/);
11889
next unless length $1;
11890
$$val .= ' ' if length $$val;
11891
$$val .= $1;
11892
}
11893
elsif ($line =~ /\A \x0D?\x0A \z/x) {
11894
last;
11895
}
11896
else {
11897
croak(q/Malformed header line: / . $Printable->($line));
11898
}
11899
}
11900
return $headers;
11901
}
11902
11903
sub write_header_lines {
11904
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
11905
my($self, $headers) = @_;
11906
11907
my $buf = '';
11908
while (my ($k, $v) = each %$headers) {
11909
my $field_name = lc $k;
11910
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
11911
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
11912
$field_name =~ s/\b(\w)/\u$1/g;
11913
$buf .= "$field_name: $v\x0D\x0A";
11914
}
11915
$buf .= "\x0D\x0A";
11916
return $self->write($buf);
11917
}
11918
11919
sub read_content_body {
11920
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
11921
my ($self, $cb, $response, $len) = @_;
11922
$len ||= $response->{headers}{'content-length'};
11923
11924
croak("No content-length in the returned response, and this "
11925
. "UA doesn't implement chunking") unless defined $len;
11926
11927
while ($len > 0) {
11928
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
11929
$cb->($self->read($read), $response);
11930
$len -= $read;
11931
}
11932
11933
return;
11934
}
11935
11936
sub write_content_body {
11937
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
11938
my ($self, $request) = @_;
11939
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
11940
11941
$len += $self->write($request->{content});
11942
11943
$len == $content_length
11944
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
11945
11946
return $len;
11947
}
11948
11949
sub read_response_header {
11950
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
11951
my ($self) = @_;
11952
11953
my $line = $self->readline;
11954
11955
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
11956
or croak(q/Malformed Status-Line: / . $Printable->($line));
11957
11958
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
11959
11960
return {
11961
status => $status,
11962
reason => $reason,
11963
headers => $self->read_header_lines,
11964
protocol => $protocol,
11965
};
11966
}
11967
11968
sub write_request_header {
11969
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
11970
my ($self, $method, $request_uri, $headers) = @_;
11971
11972
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
11973
+ $self->write_header_lines($headers);
11974
}
11975
11976
sub _do_timeout {
11977
my ($self, $type, $timeout) = @_;
11978
$timeout = $self->{timeout}
11979
unless defined $timeout && $timeout >= 0;
11980
11981
my $fd = fileno $self->{fh};
11982
defined $fd && $fd >= 0
11983
or croak(q/select(2): 'Bad file descriptor'/);
11984
11985
my $initial = time;
11986
my $pending = $timeout;
11987
my $nfound;
11988
11989
vec(my $fdset = '', $fd, 1) = 1;
11990
11991
while () {
11992
$nfound = ($type eq 'read')
11993
? select($fdset, undef, undef, $pending)
11994
: select(undef, $fdset, undef, $pending) ;
11995
if ($nfound == -1) {
11996
$! == EINTR
11997
or croak(qq/select(2): '$!'/);
11998
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
11999
$nfound = 0;
12000
}
12001
last;
12002
}
12003
$! = 0;
12004
return $nfound;
12005
}
12006
12007
sub can_read {
12008
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
12009
my $self = shift;
12010
return $self->_do_timeout('read', @_)
12011
}
12012
12013
sub can_write {
12014
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
12015
my $self = shift;
12016
return $self->_do_timeout('write', @_)
12017
}
12018
} # HTTP::Micro::Handle
11950
12019
11951
12020
my $prog = <<'EOP';
11952
12021
BEGIN {
11967
12036
}
11968
12037
}
11969
12038
{
12039
use Carp qw(croak);
11970
12040
my %dispatcher = (
11971
12041
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
11972
12042
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
12122
12192
}
12123
12193
12124
12194
1;
12125
}
12126
12195
# ###########################################################################
12127
# End HTTPMicro package
12196
# End HTTP::Micro package
12128
12197
# ###########################################################################
12129
12198
12130
12199
# ###########################################################################
Loggerhead is a web-based interface for Breezy
Version: 2.0.1