File-RsyBak
view release on metacpan or search on metacpan
script/rsybak view on Meta::CPAN
# ? $request->{headers}{'user-agent'} : $self->{agent};
#
# my $connect_request = {
# method => 'CONNECT',
# uri => "$request->{host}:$request->{port}",
# headers => {
# host => "$request->{host}:$request->{port}",
# 'user-agent' => $agent,
# }
# };
#
# if ( $request->{headers}{'proxy-authorization'} ) {
# $connect_request->{headers}{'proxy-authorization'} =
# delete $request->{headers}{'proxy-authorization'};
# }
#
# $handle->write_request($connect_request);
# my $response;
# do { $response = $handle->read_response_header }
# until (substr($response->{status},0,1) ne '1');
#
# unless (substr($response->{status},0,1) eq '2') {
# die $response;
# }
#
# $handle->start_ssl( $request->{host} );
#
# return;
#}
#
#sub _prepare_headers_and_cb {
# my ($self, $request, $args, $url, $auth) = @_;
#
# for ($self->{default_headers}, $args->{headers}) {
# next unless defined;
# while (my ($k, $v) = each %$_) {
# $request->{headers}{lc $k} = $v;
# $request->{header_case}{lc $k} = $k;
# }
# }
#
# if (exists $request->{headers}{'host'}) {
# die(qq/The 'Host' header must not be provided as header option\n/);
# }
#
# $request->{headers}{'host'} = $request->{host_port};
# $request->{headers}{'user-agent'} ||= $self->{agent};
# $request->{headers}{'connection'} = "close"
# unless $self->{keep_alive};
#
# if ( defined $args->{content} ) {
# if (ref $args->{content} eq 'CODE') {
# $request->{headers}{'content-type'} ||= "application/octet-stream";
# $request->{headers}{'transfer-encoding'} = 'chunked'
# unless $request->{headers}{'content-length'}
# || $request->{headers}{'transfer-encoding'};
# $request->{cb} = $args->{content};
# }
# elsif ( length $args->{content} ) {
# my $content = $args->{content};
# if ( $] ge '5.008' ) {
# utf8::downgrade($content, 1)
# or die(qq/Wide character in request message body\n/);
# }
# $request->{headers}{'content-type'} ||= "application/octet-stream";
# $request->{headers}{'content-length'} = length $content
# unless $request->{headers}{'content-length'}
# || $request->{headers}{'transfer-encoding'};
# $request->{cb} = sub { substr $content, 0, length $content, '' };
# }
# $request->{trailer_cb} = $args->{trailer_callback}
# if ref $args->{trailer_callback} eq 'CODE';
# }
#
# if ( $self->{cookie_jar} ) {
# my $cookies = $self->cookie_jar->cookie_header( $url );
# $request->{headers}{cookie} = $cookies if length $cookies;
# }
#
# if ( length $auth && ! defined $request->{headers}{authorization} ) {
# $self->_add_basic_auth_header( $request, 'authorization' => $auth );
# }
#
# return;
#}
#
#sub _add_basic_auth_header {
# my ($self, $request, $header, $auth) = @_;
# require MIME::Base64;
# $request->{headers}{$header} =
# "Basic " . MIME::Base64::encode_base64($auth, "");
# return;
#}
#
#sub _prepare_data_cb {
# my ($self, $response, $args) = @_;
# my $data_cb = $args->{data_callback};
# $response->{content} = '';
#
# if (!$data_cb || $response->{status} !~ /^2/) {
# if (defined $self->{max_size}) {
# $data_cb = sub {
# $_[1]->{content} .= $_[0];
# die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
# if length $_[1]->{content} > $self->{max_size};
# };
# }
# else {
# $data_cb = sub { $_[1]->{content} .= $_[0] };
# }
# }
# return $data_cb;
#}
#
#sub _update_cookie_jar {
# my ($self, $url, $response) = @_;
#
# my $cookies = $response->{headers}->{'set-cookie'};
# return unless defined $cookies;
#
# my @cookies = ref $cookies ? @$cookies : $cookies;
script/rsybak view on Meta::CPAN
#sub _split_url {
# my $url = pop;
#
# my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
# or die(qq/Cannot parse URL: '$url'\n/);
#
# $scheme = lc $scheme;
# $path_query = "/$path_query" unless $path_query =~ m<\A/>;
#
# my $auth = '';
# if ( (my $i = index $host, '@') != -1 ) {
# $auth = substr $host, 0, $i, '';
# substr $host, 0, 1, '';
#
# $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
# }
# my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
# : $scheme eq 'http' ? 80
# : $scheme eq 'https' ? 443
# : undef;
#
# return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
#}
#
#my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
#my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
#sub _http_date {
# my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
# return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
# substr($DoW,$wday*4,3),
# $mday, substr($MoY,$mon*4,3), $year+1900,
# $hour, $min, $sec
# );
#}
#
#sub _parse_http_date {
# my ($self, $str) = @_;
# require Time::Local;
# my @tl_parts;
# if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
# @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
# }
# elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
# @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
# }
# elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
# @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
# }
# return eval {
# my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
# $t < 0 ? undef : $t;
# };
#}
#
#my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
#$escapes{' '}="+";
#my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
#
#sub _uri_escape {
# my ($self, $str) = @_;
# if ( $] ge '5.008' ) {
# utf8::encode($str);
# }
# else {
# $str = pack("U*", unpack("C*", $str))
# if ( length $str == do { use bytes; length $str } );
# $str = pack("C*", unpack("C*", $str));
# }
# $str =~ s/($unsafe_char)/$escapes{$1}/ge;
# return $str;
#}
#
#package
# HTTP::Tiny::Handle;
#use strict;
#use warnings;
#
#use Errno qw[EINTR EPIPE];
#use IO::Socket qw[SOCK_STREAM];
#use Socket qw[SOL_SOCKET SO_KEEPALIVE];
#
#my $SOCKET_CLASS =
# $ENV{PERL_HTTP_TINY_IPV4_ONLY} ? 'IO::Socket::INET' :
# eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.25) } ? 'IO::Socket::IP' :
# 'IO::Socket::INET';
#
#sub BUFSIZE () { 32768 }
#
#my $Printable = sub {
# local $_ = shift;
# s/\r/\\r/g;
# s/\n/\\n/g;
# s/\t/\\t/g;
# s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
# $_;
#};
#
#my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
#my $Field_Content = qr/[[:print:]]+ (?: [\x20\x09]+ [[:print:]]+ )*/x;
#
#sub new {
# my ($class, %args) = @_;
# return bless {
# rbuf => '',
# timeout => 60,
# max_line_size => 16384,
# max_header_lines => 64,
# verify_SSL => 0,
# SSL_options => {},
# %args
# }, $class;
#}
#
#sub timeout {
# my ($self, $timeout) = @_;
# if ( @_ > 1 ) {
# $self->{timeout} = $timeout;
# if ( $self->{fh} && $self->{fh}->can('timeout') ) {
# $self->{fh}->timeout($timeout);
# }
# }
script/rsybak view on Meta::CPAN
#
# binmode($self->{fh})
# or die(qq/Could not binmode() socket: '$!'\n/);
#
# if ( $self->{keep_alive} ) {
# unless ( defined( $self->{fh}->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1 ) ) ) {
# CORE::close($self->{fh});
# die(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/);
# }
# }
#
# $self->start_ssl($host) if $scheme eq 'https';
#
# $self->{scheme} = $scheme;
# $self->{host} = $host;
# $self->{peer} = $peer;
# $self->{port} = $port;
# $self->{pid} = $$;
# $self->{tid} = _get_tid();
#
# return $self;
#}
#
#sub start_ssl {
# my ($self, $host) = @_;
#
# if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
# unless ( $self->{fh}->stop_SSL ) {
# my $ssl_err = IO::Socket::SSL->errstr;
# die(qq/Error halting prior SSL connection: $ssl_err/);
# }
# }
#
# my $ssl_args = $self->_ssl_args($host);
# IO::Socket::SSL->start_SSL(
# $self->{fh},
# %$ssl_args,
# SSL_create_ctx_callback => sub {
# my $ctx = shift;
# Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
# },
# );
#
# unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
# my $ssl_err = IO::Socket::SSL->errstr;
# die(qq/SSL connection failed for $host: $ssl_err\n/);
# }
#}
#
#sub close {
# @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
# my ($self) = @_;
# CORE::close($self->{fh})
# or die(qq/Could not close socket: '$!'\n/);
#}
#
#sub write {
# @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
# my ($self, $buf) = @_;
#
# if ( $] ge '5.008' ) {
# utf8::downgrade($buf, 1)
# or die(qq/Wide character in write()\n/);
# }
#
# my $len = length $buf;
# my $off = 0;
#
# local $SIG{PIPE} = 'IGNORE';
#
# while () {
# $self->can_write
# or die(qq/Timed out while waiting for socket to become ready for writing\n/);
# my $r = syswrite($self->{fh}, $buf, $len, $off);
# if (defined $r) {
# $len -= $r;
# $off += $r;
# last unless $len > 0;
# }
# elsif ($! == EPIPE) {
# die(qq/Socket closed by remote server: $!\n/);
# }
# elsif ($! != EINTR) {
# if ($self->{fh}->can('errstr')){
# my $err = $self->{fh}->errstr();
# die (qq/Could not write to SSL socket: '$err'\n /);
# }
# else {
# die(qq/Could not write to socket: '$!'\n/);
# }
#
# }
# }
# return $off;
#}
#
#sub read {
# @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
# my ($self, $len, $allow_partial) = @_;
#
# my $buf = '';
# my $got = length $self->{rbuf};
#
# if ($got) {
# my $take = ($got < $len) ? $got : $len;
# $buf = substr($self->{rbuf}, 0, $take, '');
# $len -= $take;
# }
#
# while ($len > 0) {
# $self->can_read
# or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
# my $r = sysread($self->{fh}, $buf, $len, length $buf);
# if (defined $r) {
# last unless $r;
# $len -= $r;
# }
# elsif ($! != EINTR) {
# if ($self->{fh}->can('errstr')){
# my $err = $self->{fh}->errstr();
# die (qq/Could not read from SSL socket: '$err'\n /);
script/rsybak view on Meta::CPAN
# $buf .= "$field_name: $_\x0D\x0A";
# }
# }
# $buf .= "\x0D\x0A";
# return $self->write($buf);
#}
#
#sub read_body {
# @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
# my ($self, $cb, $response) = @_;
# my $te = $response->{headers}{'transfer-encoding'} || '';
# my $chunked = grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ;
# return $chunked
# ? $self->read_chunked_body($cb, $response)
# : $self->read_content_body($cb, $response);
#}
#
#sub write_body {
# @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
# my ($self, $request) = @_;
# if ($request->{headers}{'content-length'}) {
# return $self->write_content_body($request);
# }
# else {
# return $self->write_chunked_body($request);
# }
#}
#
#sub read_content_body {
# @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
# my ($self, $cb, $response, $content_length) = @_;
# $content_length ||= $response->{headers}{'content-length'};
#
# if ( defined $content_length ) {
# my $len = $content_length;
# while ($len > 0) {
# my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
# $cb->($self->read($read, 0), $response);
# $len -= $read;
# }
# return length($self->{rbuf}) == 0;
# }
#
# my $chunk;
# $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
#
# return;
#}
#
#sub write_content_body {
# @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
# my ($self, $request) = @_;
#
# my ($len, $content_length) = (0, $request->{headers}{'content-length'});
# while () {
# my $data = $request->{cb}->();
#
# defined $data && length $data
# or last;
#
# if ( $] ge '5.008' ) {
# utf8::downgrade($data, 1)
# or die(qq/Wide character in write_content()\n/);
# }
#
# $len += $self->write($data);
# }
#
# $len == $content_length
# or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);
#
# return $len;
#}
#
#sub read_chunked_body {
# @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
# my ($self, $cb, $response) = @_;
#
# while () {
# my $head = $self->readline;
#
# $head =~ /\A ([A-Fa-f0-9]+)/x
# or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
#
# my $len = hex($1)
# or last;
#
# $self->read_content_body($cb, $response, $len);
#
# $self->read(2) eq "\x0D\x0A"
# or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
# }
# $self->read_header_lines($response->{headers});
# return 1;
#}
#
#sub write_chunked_body {
# @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
# my ($self, $request) = @_;
#
# my $len = 0;
# while () {
# my $data = $request->{cb}->();
#
# defined $data && length $data
# or last;
#
# if ( $] ge '5.008' ) {
# utf8::downgrade($data, 1)
# or die(qq/Wide character in write_chunked_body()\n/);
# }
#
# $len += length $data;
#
# my $chunk = sprintf '%X', length $data;
# $chunk .= "\x0D\x0A";
# $chunk .= $data;
# $chunk .= "\x0D\x0A";
#
# $self->write($chunk);
# }
# $self->write("0\x0D\x0A");
# if ( ref $request->{trailer_cb} eq 'CODE' ) {
# $self->write_header_lines($request->{trailer_cb}->())
# }
# else {
# $self->write("\x0D\x0A");
# }
# return $len;
#}
#
#sub read_response_header {
# @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
# my ($self) = @_;
#
# my $line = $self->readline;
#
# $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
# or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
#
# my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
#
# die (qq/Unsupported HTTP protocol: $protocol\n/)
# unless $version =~ /0*1\.0*[01]/;
#
# return {
# status => $status,
# reason => $reason,
# headers => $self->read_header_lines,
# protocol => $protocol,
# };
#}
#
#sub write_request_header {
# @_ == 5 || die(q/Usage: $handle->write_request_header(method, request_uri, headers, header_case)/ . "\n");
# my ($self, $method, $request_uri, $headers, $header_case) = @_;
#
# return $self->write_header_lines($headers, $header_case, "$method $request_uri HTTP/1.1\x0D\x0A");
#}
#
#sub _do_timeout {
# my ($self, $type, $timeout) = @_;
# $timeout = $self->{timeout}
# unless defined $timeout && $timeout >= 0;
#
# my $fd = fileno $self->{fh};
# defined $fd && $fd >= 0
# or die(qq/select(2): 'Bad file descriptor'\n/);
( run in 0.668 second using v1.01-cache-2.11-cpan-e1769b4cff6 )