Файловый менеджер - Редактировать - /var/www/html/back/storage/app/public/17/f8lo32/perl5.zip
Назад
PK ! A�g? g? HTTP/Request/Common.pmnu �[��� package HTTP::Request::Common; use strict; use warnings; our $VERSION = '6.36'; our $DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why) use Exporter 5.57 'import'; our @EXPORT =qw(GET HEAD PUT PATCH POST OPTIONS); our @EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE); require HTTP::Request; use Carp(); use File::Spec; my $CRLF = "\015\012"; # "\r\n" is not portable sub GET { _simple_req('GET', @_); } sub HEAD { _simple_req('HEAD', @_); } sub DELETE { _simple_req('DELETE', @_); } sub PATCH { request_type_with_data('PATCH', @_); } sub POST { request_type_with_data('POST', @_); } sub PUT { request_type_with_data('PUT', @_); } sub OPTIONS { request_type_with_data('OPTIONS', @_); } sub request_type_with_data { my $type = shift; my $url = shift; my $req = HTTP::Request->new($type => $url); my $content; $content = shift if @_ and ref $_[0]; my($k, $v); while (($k,$v) = splice(@_, 0, 2)) { if (lc($k) eq 'content') { $content = $v; } else { $req->push_header($k, $v); } } my $ct = $req->header('Content-Type'); unless ($ct) { $ct = 'application/x-www-form-urlencoded'; } elsif ($ct eq 'form-data') { $ct = 'multipart/form-data'; } if (ref $content) { if ($ct =~ m,^multipart/form-data\s*(;|$),i) { require HTTP::Headers::Util; my @v = HTTP::Headers::Util::split_header_words($ct); Carp::carp("Multiple Content-Type headers") if @v > 1; @v = @{$v[0]}; my $boundary; my $boundary_index; for (my @tmp = @v; @tmp;) { my($k, $v) = splice(@tmp, 0, 2); if ($k eq "boundary") { $boundary = $v; $boundary_index = @v - @tmp - 1; last; } } ($content, $boundary) = form_data($content, $boundary, $req); if ($boundary_index) { $v[$boundary_index] = $boundary; } else { push(@v, boundary => $boundary); } $ct = HTTP::Headers::Util::join_header_words(@v); } else { # We use a temporary URI object to format # the application/x-www-form-urlencoded content. require URI; my $url = URI->new('http:'); $url->query_form(ref($content) eq "HASH" ? %$content : @$content); $content = $url->query; # HTML/4.01 says that line breaks are represented as "CR LF" pairs (i.e., `%0D%0A') $content =~ s/(?<!%0D)%0A/%0D%0A/g if defined($content); } } $req->header('Content-Type' => $ct); # might be redundant if (defined($content)) { $req->header('Content-Length' => length($content)) unless ref($content); $req->content($content); } else { $req->header('Content-Length' => 0); } $req; } sub _simple_req { my($method, $url) = splice(@_, 0, 2); my $req = HTTP::Request->new($method => $url); my($k, $v); my $content; while (($k,$v) = splice(@_, 0, 2)) { if (lc($k) eq 'content') { $req->add_content($v); $content++; } else { $req->push_header($k, $v); } } if ($content && !defined($req->header("Content-Length"))) { $req->header("Content-Length", length(${$req->content_ref})); } $req; } sub form_data # RFC1867 { my($data, $boundary, $req) = @_; my @data = ref($data) eq "HASH" ? %$data : @$data; # copy my $fhparts; my @parts; while (my ($k,$v) = splice(@data, 0, 2)) { if (!ref($v)) { $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes no warnings 'uninitialized'; push(@parts, qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v)); } else { my($file, $usename, @headers) = @$v; unless (defined $usename) { $usename = $file; $usename = (File::Spec->splitpath($usename))[-1] if defined($usename); } $k =~ s/([\\\"])/\\$1/g; my $disp = qq(form-data; name="$k"); if (defined($usename) and length($usename)) { $usename =~ s/([\\\"])/\\$1/g; $disp .= qq(; filename="$usename"); } my $content = ""; my $h = HTTP::Headers->new(@headers); if ($file) { open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!"); binmode($fh); if ($DYNAMIC_FILE_UPLOAD) { # will read file later, close it now in order to # not accumulate to many open file handles close($fh); $content = \$file; } else { local($/) = undef; # slurp files $content = <$fh>; close($fh); } unless ($h->header("Content-Type")) { require LWP::MediaTypes; LWP::MediaTypes::guess_media_type($file, $h); } } if ($h->header("Content-Disposition")) { # just to get it sorted first $disp = $h->header("Content-Disposition"); $h->remove_header("Content-Disposition"); } if ($h->header("Content")) { $content = $h->header("Content"); $h->remove_header("Content"); } my $head = join($CRLF, "Content-Disposition: $disp", $h->as_string($CRLF), ""); if (ref $content) { push(@parts, [$head, $$content]); $fhparts++; } else { push(@parts, $head . $content); } } } return ("", "none") unless @parts; my $content; if ($fhparts) { $boundary = boundary(10) # hopefully enough randomness unless $boundary; # add the boundaries to the @parts array for (1..@parts-1) { splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF"); } unshift(@parts, "--$boundary$CRLF"); push(@parts, "$CRLF--$boundary--$CRLF"); # See if we can generate Content-Length header my $length = 0; for (@parts) { if (ref $_) { my ($head, $f) = @$_; my $file_size; unless ( -f $f && ($file_size = -s _) ) { # The file is either a dynamic file like /dev/audio # or perhaps a file in the /proc file system where # stat may return a 0 size even though reading it # will produce data. So we cannot make # a Content-Length header. undef $length; last; } $length += $file_size + length $head; } else { $length += length; } } $length && $req->header('Content-Length' => $length); # set up a closure that will return content piecemeal $content = sub { for (;;) { unless (@parts) { defined $length && $length != 0 && Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer."; return; } my $p = shift @parts; unless (ref $p) { $p .= shift @parts while @parts && !ref($parts[0]); defined $length && ($length -= length $p); return $p; } my($buf, $fh) = @$p; unless (ref($fh)) { my $file = $fh; undef($fh); open($fh, "<", $file) || Carp::croak("Can't open file $file: $!"); binmode($fh); } my $buflength = length $buf; my $n = read($fh, $buf, 2048, $buflength); if ($n) { $buflength += $n; unshift(@parts, ["", $fh]); } else { close($fh); } if ($buflength) { defined $length && ($length -= $buflength); return $buf } } }; } else { $boundary = boundary() unless $boundary; my $bno = 0; CHECK_BOUNDARY: { for (@parts) { if (index($_, $boundary) >= 0) { # must have a better boundary $boundary = boundary(++$bno); redo CHECK_BOUNDARY; } } last; } $content = "--$boundary$CRLF" . join("$CRLF--$boundary$CRLF", @parts) . "$CRLF--$boundary--$CRLF"; } wantarray ? ($content, $boundary) : $content; } sub boundary { my $size = shift || return "xYzZY"; require MIME::Base64; my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), ""); $b =~ s/[\W]/X/g; # ensure alnum only $b; } 1; =pod =encoding UTF-8 =head1 NAME HTTP::Request::Common - Construct common HTTP::Request objects =head1 VERSION version 6.36 =head1 SYNOPSIS use HTTP::Request::Common; $ua = LWP::UserAgent->new; $ua->request(GET 'http://www.sn.no/'); $ua->request(POST 'http://somewhere/foo', foo => bar, bar => foo); $ua->request(PATCH 'http://somewhere/foo', foo => bar, bar => foo); $ua->request(PUT 'http://somewhere/foo', foo => bar, bar => foo); $ua->request(OPTIONS 'http://somewhere/foo', foo => bar, bar => foo); =head1 DESCRIPTION This module provides functions that return newly created C<HTTP::Request> objects. These functions are usually more convenient to use than the standard C<HTTP::Request> constructor for the most common requests. Note that L<LWP::UserAgent> has several convenience methods, including C<get>, C<head>, C<delete>, C<post> and C<put>. The following functions are provided: =over 4 =item GET $url =item GET $url, Header => Value,... The C<GET> function returns an L<HTTP::Request> object initialized with the "GET" method and the specified URL. It is roughly equivalent to the following call HTTP::Request->new( GET => $url, HTTP::Headers->new(Header => Value,...), ) but is less cluttered. What is different is that a header named C<Content> will initialize the content part of the request instead of setting a header field. Note that GET requests should normally not have a content, so this hack makes more sense for the C<PUT>, C<PATCH> and C<POST> functions described below. The C<get(...)> method of L<LWP::UserAgent> exists as a shortcut for C<< $ua->request(GET ...) >>. =item HEAD $url =item HEAD $url, Header => Value,... Like GET() but the method in the request is "HEAD". The C<head(...)> method of L<LWP::UserAgent> exists as a shortcut for C<< $ua->request(HEAD ...) >>. =item DELETE $url =item DELETE $url, Header => Value,... Like C<GET> but the method in the request is C<DELETE>. This function is not exported by default. =item PATCH $url =item PATCH $url, Header => Value,... =item PATCH $url, $form_ref, Header => Value,... =item PATCH $url, Header => Value,..., Content => $form_ref =item PATCH $url, Header => Value,..., Content => $content The same as C<POST> below, but the method in the request is C<PATCH>. =item PUT $url =item PUT $url, Header => Value,... =item PUT $url, $form_ref, Header => Value,... =item PUT $url, Header => Value,..., Content => $form_ref =item PUT $url, Header => Value,..., Content => $content The same as C<POST> below, but the method in the request is C<PUT> =item OPTIONS $url =item OPTIONS $url, Header => Value,... =item OPTIONS $url, $form_ref, Header => Value,... =item OPTIONS $url, Header => Value,..., Content => $form_ref =item OPTIONS $url, Header => Value,..., Content => $content The same as C<POST> below, but the method in the request is C<OPTIONS> =item POST $url =item POST $url, Header => Value,... =item POST $url, $form_ref, Header => Value,... =item POST $url, Header => Value,..., Content => $form_ref =item POST $url, Header => Value,..., Content => $content C<POST>, C<PATCH> and C<PUT> all work with the same parameters. %data = ( title => 'something', body => something else' ); $ua = LWP::UserAgent->new(); $request = HTTP::Request::Common::POST( $url, [ %data ] ); $response = $ua->request($request); They take a second optional array or hash reference parameter C<$form_ref>. The content can also be specified directly using the C<Content> pseudo-header, and you may also provide the C<$form_ref> this way. The C<Content> pseudo-header steals a bit of the header field namespace as there is no way to directly specify a header that is actually called "Content". If you really need this you must update the request returned in a separate statement. The C<$form_ref> argument can be used to pass key/value pairs for the form content. By default we will initialize a request using the C<application/x-www-form-urlencoded> content type. This means that you can emulate an HTML E<lt>form> POSTing like this: POST 'http://www.perl.org/survey.cgi', [ name => 'Gisle Aas', email => 'gisle@aas.no', gender => 'M', born => '1964', perc => '3%', ]; This will create an L<HTTP::Request> object that looks like this: POST http://www.perl.org/survey.cgi Content-Length: 66 Content-Type: application/x-www-form-urlencoded name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25 Multivalued form fields can be specified by either repeating the field name or by passing the value as an array reference. The POST method also supports the C<multipart/form-data> content used for I<Form-based File Upload> as specified in RFC 1867. You trigger this content format by specifying a content type of C<'form-data'> as one of the request headers. If one of the values in the C<$form_ref> is an array reference, then it is treated as a file part specification with the following interpretation: [ $file, $filename, Header => Value... ] [ undef, $filename, Header => Value,..., Content => $content ] The first value in the array ($file) is the name of a file to open. This file will be read and its content placed in the request. The routine will croak if the file can't be opened. Use an C<undef> as $file value if you want to specify the content directly with a C<Content> header. The $filename is the filename to report in the request. If this value is undefined, then the basename of the $file will be used. You can specify an empty string as $filename if you want to suppress sending the filename when you provide a $file value. If a $file is provided by no C<Content-Type> header, then C<Content-Type> and C<Content-Encoding> will be filled in automatically with the values returned by C<LWP::MediaTypes::guess_media_type()> Sending my F<~/.profile> to the survey used as example above can be achieved by this: POST 'http://www.perl.org/survey.cgi', Content_Type => 'form-data', Content => [ name => 'Gisle Aas', email => 'gisle@aas.no', gender => 'M', born => '1964', init => ["$ENV{HOME}/.profile"], ] This will create an L<HTTP::Request> object that almost looks this (the boundary and the content of your F<~/.profile> is likely to be different): POST http://www.perl.org/survey.cgi Content-Length: 388 Content-Type: multipart/form-data; boundary="6G+f" --6G+f Content-Disposition: form-data; name="name" Gisle Aas --6G+f Content-Disposition: form-data; name="email" gisle@aas.no --6G+f Content-Disposition: form-data; name="gender" M --6G+f Content-Disposition: form-data; name="born" 1964 --6G+f Content-Disposition: form-data; name="init"; filename=".profile" Content-Type: text/plain PATH=/local/perl/bin:$PATH export PATH --6G+f-- If you set the C<$DYNAMIC_FILE_UPLOAD> variable (exportable) to some TRUE value, then you get back a request object with a subroutine closure as the content attribute. This subroutine will read the content of any files on demand and return it in suitable chunks. This allow you to upload arbitrary big files without using lots of memory. You can even upload infinite files like F</dev/audio> if you wish; however, if the file is not a plain file, there will be no C<Content-Length> header defined for the request. Not all servers (or server applications) like this. Also, if the file(s) change in size between the time the C<Content-Length> is calculated and the time that the last chunk is delivered, the subroutine will C<Croak>. The C<post(...)> method of L<LWP::UserAgent> exists as a shortcut for C<< $ua->request(POST ...) >>. =back =head1 SEE ALSO L<HTTP::Request>, L<LWP::UserAgent> Also, there are some examples in L<HTTP::Request/"EXAMPLES"> that you might find useful. For example, batch requests are explained there. =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ #ABSTRACT: Construct common HTTP::Request objects PK ! �69( B B HTTP/Response.pmnu �[��� package HTTP::Response; use strict; use warnings; our $VERSION = '6.36'; use base 'HTTP::Message'; use HTTP::Status (); sub new { my($class, $rc, $msg, $header, $content) = @_; my $self = $class->SUPER::new($header, $content); $self->code($rc); $self->message($msg); $self; } sub parse { my($class, $str) = @_; Carp::carp('Undefined argument to parse()') if $^W && ! defined $str; my $status_line; if (defined $str && $str =~ s/^(.*)\n//) { $status_line = $1; } else { $status_line = $str; $str = ""; } $status_line =~ s/\r\z// if defined $status_line; my $self = $class->SUPER::parse($str); if (defined $status_line) { my($protocol, $code, $message); if ($status_line =~ /^\d{3} /) { # Looks like a response created by HTTP::Response->new ($code, $message) = split(' ', $status_line, 2); } else { ($protocol, $code, $message) = split(' ', $status_line, 3); } $self->protocol($protocol) if $protocol; $self->code($code) if defined($code); $self->message($message) if defined($message); } $self; } sub clone { my $self = shift; my $clone = bless $self->SUPER::clone, ref($self); $clone->code($self->code); $clone->message($self->message); $clone->request($self->request->clone) if $self->request; # we don't clone previous $clone; } sub code { shift->_elem('_rc', @_); } sub message { shift->_elem('_msg', @_); } sub previous { shift->_elem('_previous',@_); } sub request { shift->_elem('_request', @_); } sub status_line { my $self = shift; my $code = $self->{'_rc'} || "000"; my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code"; return "$code $mess"; } sub base { my $self = shift; my $base = ( $self->header('Content-Base'), # used to be HTTP/1.1 $self->header('Content-Location'), # HTTP/1.1 $self->header('Base'), # HTTP/1.0 )[0]; if ($base && $base =~ /^$URI::scheme_re:/o) { # already absolute return $HTTP::URI_CLASS->new($base); } my $req = $self->request; if ($req) { # if $base is undef here, the return value is effectively # just a copy of $self->request->uri. return $HTTP::URI_CLASS->new_abs($base, $req->uri); } # can't find an absolute base return undef; } sub redirects { my $self = shift; my @r; my $r = $self; while (my $p = $r->previous) { push(@r, $p); $r = $p; } return @r unless wantarray; return reverse @r; } sub filename { my $self = shift; my $file; my $cd = $self->header('Content-Disposition'); if ($cd) { require HTTP::Headers::Util; if (my @cd = HTTP::Headers::Util::split_header_words($cd)) { my ($disposition, undef, %cd_param) = @{$cd[-1]}; $file = $cd_param{filename}; # RFC 2047 encoded? if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) { my $charset = $1; my $encoding = uc($2); my $encfile = $3; if ($encoding eq 'Q' || $encoding eq 'B') { local($SIG{__DIE__}); eval { if ($encoding eq 'Q') { $encfile =~ s/_/ /g; require MIME::QuotedPrint; $encfile = MIME::QuotedPrint::decode($encfile); } else { # $encoding eq 'B' require MIME::Base64; $encfile = MIME::Base64::decode($encfile); } require Encode; require Encode::Locale; Encode::from_to($encfile, $charset, "locale_fs"); }; $file = $encfile unless $@; } } } } unless (defined($file) && length($file)) { my $uri; if (my $cl = $self->header('Content-Location')) { $uri = URI->new($cl); } elsif (my $request = $self->request) { $uri = $request->uri; } if ($uri) { $file = ($uri->path_segments)[-1]; } } if ($file) { $file =~ s,.*[\\/],,; # basename } if ($file && !length($file)) { $file = undef; } $file; } sub as_string { my $self = shift; my($eol) = @_; $eol = "\n" unless defined $eol; my $status_line = $self->status_line; my $proto = $self->protocol; $status_line = "$proto $status_line" if $proto; return join($eol, $status_line, $self->SUPER::as_string(@_)); } sub dump { my $self = shift; my $status_line = $self->status_line; my $proto = $self->protocol; $status_line = "$proto $status_line" if $proto; return $self->SUPER::dump( preheader => $status_line, @_, ); } sub is_info { HTTP::Status::is_info (shift->{'_rc'}); } sub is_success { HTTP::Status::is_success (shift->{'_rc'}); } sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); } sub is_error { HTTP::Status::is_error (shift->{'_rc'}); } sub is_client_error { HTTP::Status::is_client_error (shift->{'_rc'}); } sub is_server_error { HTTP::Status::is_server_error (shift->{'_rc'}); } sub error_as_HTML { my $self = shift; my $title = 'An Error Occurred'; my $body = $self->status_line; $body =~ s/&/&/g; $body =~ s/</</g; return <<EOM; <html> <head><title>$title</title></head> <body> <h1>$title</h1> <p>$body</p> </body> </html> EOM } sub current_age { my $self = shift; my $time = shift; # Implementation of RFC 2616 section 13.2.3 # (age calculations) my $response_time = $self->client_date; my $date = $self->date; my $age = 0; if ($response_time && $date) { $age = $response_time - $date; # apparent_age $age = 0 if $age < 0; } my $age_v = $self->header('Age'); if ($age_v && $age_v > $age) { $age = $age_v; # corrected_received_age } if ($response_time) { my $request = $self->request; if ($request) { my $request_time = $request->date; if ($request_time && $request_time < $response_time) { # Add response_delay to age to get 'corrected_initial_age' $age += $response_time - $request_time; } } $age += ($time || time) - $response_time; } return $age; } sub freshness_lifetime { my($self, %opt) = @_; # First look for the Cache-Control: max-age=n header for my $cc ($self->header('Cache-Control')) { for my $cc_dir (split(/\s*,\s*/, $cc)) { return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i; } } # Next possibility is to look at the "Expires" header my $date = $self->date || $self->client_date || $opt{time} || time; if (my $expires = $self->expires) { return $expires - $date; } # Must apply heuristic expiration return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry}; # Default heuristic expiration parameters $opt{h_min} ||= 60; $opt{h_max} ||= 24 * 3600; $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616 $opt{h_default} ||= 3600; # Should give a warning if more than 24 hours according to # RFC 2616 section 13.2.4. Here we just make this the default # maximum value. if (my $last_modified = $self->last_modified) { my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction}; return $opt{h_min} if $h_exp < $opt{h_min}; return $opt{h_max} if $h_exp > $opt{h_max}; return $h_exp; } # default when all else fails return $opt{h_min} if $opt{h_min} > $opt{h_default}; return $opt{h_default}; } sub is_fresh { my($self, %opt) = @_; $opt{time} ||= time; my $f = $self->freshness_lifetime(%opt); return undef unless defined($f); return $f > $self->current_age($opt{time}); } sub fresh_until { my($self, %opt) = @_; $opt{time} ||= time; my $f = $self->freshness_lifetime(%opt); return undef unless defined($f); return $f - $self->current_age($opt{time}) + $opt{time}; } 1; =pod =encoding UTF-8 =head1 NAME HTTP::Response - HTTP style response message =head1 VERSION version 6.36 =head1 SYNOPSIS Response objects are returned by the request() method of the C<LWP::UserAgent>: # ... $response = $ua->request($request); if ($response->is_success) { print $response->decoded_content; } else { print STDERR $response->status_line, "\n"; } =head1 DESCRIPTION The C<HTTP::Response> class encapsulates HTTP style responses. A response consists of a response line, some headers, and a content body. Note that the LWP library uses HTTP style responses even for non-HTTP protocol schemes. Instances of this class are usually created and returned by the request() method of an C<LWP::UserAgent> object. C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore inherits its methods. The following additional methods are available: =over 4 =item $r = HTTP::Response->new( $code ) =item $r = HTTP::Response->new( $code, $msg ) =item $r = HTTP::Response->new( $code, $msg, $header ) =item $r = HTTP::Response->new( $code, $msg, $header, $content ) Constructs a new C<HTTP::Response> object describing a response with response code $code and optional message $msg. The optional $header argument should be a reference to an C<HTTP::Headers> object or a plain array reference of key/value pairs. The optional $content argument should be a string of bytes. The meanings of these arguments are described below. =item $r = HTTP::Response->parse( $str ) This constructs a new response object by parsing the given string. =item $r->code =item $r->code( $code ) This is used to get/set the code attribute. The code is a 3 digit number that encode the overall outcome of an HTTP response. The C<HTTP::Status> module provide constants that provide mnemonic names for the code attribute. =item $r->message =item $r->message( $message ) This is used to get/set the message attribute. The message is a short human readable single line string that explains the response code. =item $r->header( $field ) =item $r->header( $field => $value ) This is used to get/set header values and it is inherited from C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for details and other similar methods that can be used to access the headers. =item $r->content =item $r->content( $bytes ) This is used to get/set the raw content and it is inherited from the C<HTTP::Message> base class. See L<HTTP::Message> for details and other methods that can be used to access the content. =item $r->decoded_content( %options ) This will return the content after any C<Content-Encoding> and charsets have been decoded. See L<HTTP::Message> for details. =item $r->request =item $r->request( $request ) This is used to get/set the request attribute. The request attribute is a reference to the request that caused this response. It does not have to be the same request passed to the $ua->request() method, because there might have been redirects and authorization retries in between. =item $r->previous =item $r->previous( $response ) This is used to get/set the previous attribute. The previous attribute is used to link together chains of responses. You get chains of responses if the first response is redirect or unauthorized. The value is C<undef> if this is the first response in a chain. Note that the method $r->redirects is provided as a more convenient way to access the response chain. =item $r->status_line Returns the string "E<lt>code> E<lt>message>". If the message attribute is not set then the official name of E<lt>code> (see L<HTTP::Status>) is substituted. =item $r->base Returns the base URI for this response. The return value will be a reference to a URI object. The base URI is obtained from one the following sources (in priority order): =over 4 =item 1. Embedded in the document content, for instance <BASE HREF="..."> in HTML documents. =item 2. A "Content-Base:" or a "Content-Location:" header in the response. For backwards compatibility with older HTTP implementations we will also look for the "Base:" header. =item 3. The URI used to request this response. This might not be the original URI that was passed to $ua->request() method, because we might have received some redirect responses first. =back If none of these sources provide an absolute URI, undef is returned. When the LWP protocol modules produce the HTTP::Response object, then any base URI embedded in the document (step 1) will already have initialized the "Content-Base:" header. (See L<LWP::UserAgent/parse_head>). This means that this method only performs the last 2 steps (the content is not always available either). =item $r->filename Returns a filename for this response. Note that doing sanity checks on the returned filename (eg. removing characters that cannot be used on the target filesystem where the filename would be used, and laundering it for security purposes) are the caller's responsibility; the only related thing done by this method is that it makes a simple attempt to return a plain filename with no preceding path segments. The filename is obtained from one the following sources (in priority order): =over 4 =item 1. A "Content-Disposition:" header in the response. Proper decoding of RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q" encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules. =item 2. A "Content-Location:" header in the response. =item 3. The URI used to request this response. This might not be the original URI that was passed to $ua->request() method, because we might have received some redirect responses first. =back If a filename cannot be derived from any of these sources, undef is returned. =item $r->as_string =item $r->as_string( $eol ) Returns a textual representation of the response. =item $r->is_info =item $r->is_success =item $r->is_redirect =item $r->is_error =item $r->is_client_error =item $r->is_server_error These methods indicate if the response was informational, successful, a redirection, or an error. See L<HTTP::Status> for the meaning of these. =item $r->error_as_HTML Returns a string containing a complete HTML document indicating what error occurred. This method should only be called when $r->is_error is TRUE. =item $r->redirects Returns the list of redirect responses that lead up to this response by following the $r->previous chain. The list order is oldest first. In scalar context return the number of redirect responses leading up to this one. =item $r->current_age Calculates the "current age" of the response as specified by RFC 2616 section 13.2.3. The age of a response is the time since it was sent by the origin server. The returned value is a number representing the age in seconds. =item $r->freshness_lifetime( %opt ) Calculates the "freshness lifetime" of the response as specified by RFC 2616 section 13.2.4. The "freshness lifetime" is the length of time between the generation of a response and its expiration time. The returned value is the number of seconds until expiry. If the response does not contain an "Expires" or a "Cache-Control" header, then this function will apply some simple heuristic based on the "Last-Modified" header to determine a suitable lifetime. The following options might be passed to control the heuristics: =over =item heuristic_expiry => $bool If passed as a FALSE value, don't apply heuristics and just return C<undef> when "Expires" or "Cache-Control" is lacking. =item h_lastmod_fraction => $num This number represent the fraction of the difference since the "Last-Modified" timestamp to make the expiry time. The default is C<0.10>, the suggested typical setting of 10% in RFC 2616. =item h_min => $sec This is the lower limit of the heuristic expiry age to use. The default is C<60> (1 minute). =item h_max => $sec This is the upper limit of the heuristic expiry age to use. The default is C<86400> (24 hours). =item h_default => $sec This is the expiry age to use when nothing else applies. The default is C<3600> (1 hour) or "h_min" if greater. =back =item $r->is_fresh( %opt ) Returns TRUE if the response is fresh, based on the values of freshness_lifetime() and current_age(). If the response is no longer fresh, then it has to be re-fetched or re-validated by the origin server. Options might be passed to control expiry heuristics, see the description of freshness_lifetime(). =item $r->fresh_until( %opt ) Returns the time (seconds since epoch) when this entity is no longer fresh. Options might be passed to control expiry heuristics, see the description of freshness_lifetime(). =back =head1 SEE ALSO L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request> =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ #ABSTRACT: HTTP style response message PK ! �-�Bb Bb HTTP/Headers.pmnu �[��� package HTTP::Headers; use strict; use warnings; our $VERSION = '6.36'; use Carp (); # The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used # as a replacement for '-' in header field names. our $TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE; # "Good Practice" order of HTTP message headers: # - General-Headers # - Request-Headers # - Response-Headers # - Entity-Headers my @general_headers = qw( Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade Via Warning ); my @request_headers = qw( Accept Accept-Charset Accept-Encoding Accept-Language Authorization Expect From Host If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since Max-Forwards Proxy-Authorization Range Referer TE User-Agent ); my @response_headers = qw( Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server Vary WWW-Authenticate ); my @entity_headers = qw( Allow Content-Encoding Content-Language Content-Length Content-Location Content-MD5 Content-Range Content-Type Expires Last-Modified ); my %entity_header = map { lc($_) => 1 } @entity_headers; my @header_order = ( @general_headers, @request_headers, @response_headers, @entity_headers, ); # Make alternative representations of @header_order. This is used # for sorting and case matching. my %header_order; my %standard_case; { my $i = 0; for (@header_order) { my $lc = lc $_; $header_order{$lc} = ++$i; $standard_case{$lc} = $_; } } sub new { my($class) = shift; my $self = bless {}, $class; $self->header(@_) if @_; # set up initial headers $self; } sub header { my $self = shift; Carp::croak('Usage: $h->header($field, ...)') unless @_; my(@old); my %seen; while (@_) { my $field = shift; my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET'; @old = $self->_header($field, shift, $op); } return @old if wantarray; return $old[0] if @old <= 1; join(", ", @old); } sub clear { my $self = shift; %$self = (); } sub push_header { my $self = shift; return $self->_header(@_, 'PUSH_H') if @_ == 2; while (@_) { $self->_header(splice(@_, 0, 2), 'PUSH_H'); } } sub init_header { Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3; shift->_header(@_, 'INIT'); } sub remove_header { my($self, @fields) = @_; my $field; my @values; foreach $field (@fields) { $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE; my $v = delete $self->{lc $field}; push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v; } return @values; } sub remove_content_headers { my $self = shift; unless (defined(wantarray)) { # fast branch that does not create return object delete @$self{grep $entity_header{$_} || /^content-/, keys %$self}; return; } my $c = ref($self)->new; for my $f (grep $entity_header{$_} || /^content-/, keys %$self) { $c->{$f} = delete $self->{$f}; } if (exists $self->{'::std_case'}) { $c->{'::std_case'} = $self->{'::std_case'}; } $c; } sub _header { my($self, $field, $val, $op) = @_; Carp::croak("Illegal field name '$field'") if rindex($field, ':') > 1 || !length($field); unless ($field =~ /^:/) { $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE; my $old = $field; $field = lc $field; unless($standard_case{$field} || $self->{'::std_case'}{$field}) { # generate a %std_case entry for this field $old =~ s/\b(\w)/\u$1/g; $self->{'::std_case'}{$field} = $old; } } $op ||= defined($val) ? 'SET' : 'GET'; if ($op eq 'PUSH_H') { # Like PUSH but where we don't care about the return value if (exists $self->{$field}) { my $h = $self->{$field}; if (ref($h) eq 'ARRAY') { push(@$h, ref($val) eq "ARRAY" ? @$val : $val); } else { $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val] } return; } $self->{$field} = $val; return; } my $h = $self->{$field}; my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ()); unless ($op eq 'GET' || ($op eq 'INIT' && @old)) { if (defined($val)) { my @new = ($op eq 'PUSH') ? @old : (); if (ref($val) ne 'ARRAY') { push(@new, $val); } else { push(@new, @$val); } $self->{$field} = @new > 1 ? \@new : $new[0]; } elsif ($op ne 'PUSH') { delete $self->{$field}; } } @old; } sub _sorted_field_names { my $self = shift; return [ sort { ($header_order{$a} || 999) <=> ($header_order{$b} || 999) || $a cmp $b } grep !/^::/, keys %$self ]; } sub header_field_names { my $self = shift; return map $standard_case{$_} || $self->{'::std_case'}{$_} || $_, @{ $self->_sorted_field_names }, if wantarray; return grep !/^::/, keys %$self; } sub scan { my($self, $sub) = @_; my $key; for $key (@{ $self->_sorted_field_names }) { my $vals = $self->{$key}; if (ref($vals) eq 'ARRAY') { my $val; for $val (@$vals) { $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $val); } } else { $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $vals); } } } sub flatten { my($self)=@_; ( map { my $k = $_; map { ( $k => $_ ) } $self->header($_); } $self->header_field_names ); } sub as_string { my($self, $endl) = @_; $endl = "\n" unless defined $endl; my @result = (); for my $key (@{ $self->_sorted_field_names }) { next if index($key, '_') == 0; my $vals = $self->{$key}; if ( ref($vals) eq 'ARRAY' ) { for my $val (@$vals) { $val = '' if not defined $val; my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key; $field =~ s/^://; if ( index($val, "\n") >= 0 ) { $val = _process_newline($val, $endl); } push @result, $field . ': ' . $val; } } else { $vals = '' if not defined $vals; my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key; $field =~ s/^://; if ( index($vals, "\n") >= 0 ) { $vals = _process_newline($vals, $endl); } push @result, $field . ': ' . $vals; } } join($endl, @result, ''); } sub _process_newline { local $_ = shift; my $endl = shift; # must handle header values with embedded newlines with care s/\s+$//; # trailing newlines and space must go s/\n(\x0d?\n)+/\n/g; # no empty lines s/\n([^\040\t])/\n $1/g; # initial space for continuation s/\n/$endl/g; # substitute with requested line ending $_; } if (eval { require Clone; 1 }) { *clone = \&Clone::clone; } else { *clone = sub { my $self = shift; my $clone = HTTP::Headers->new; $self->scan(sub { $clone->push_header(@_);} ); $clone; }; } sub _date_header { require HTTP::Date; my($self, $header, $time) = @_; my($old) = $self->_header($header); if (defined $time) { $self->_header($header, HTTP::Date::time2str($time)); } $old =~ s/;.*// if defined($old); HTTP::Date::str2time($old); } sub date { shift->_date_header('Date', @_); } sub expires { shift->_date_header('Expires', @_); } sub if_modified_since { shift->_date_header('If-Modified-Since', @_); } sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); } sub last_modified { shift->_date_header('Last-Modified', @_); } # This is used as a private LWP extension. The Client-Date header is # added as a timestamp to a response when it has been received. sub client_date { shift->_date_header('Client-Date', @_); } # The retry_after field is dual format (can also be a expressed as # number of seconds from now), so we don't provide an easy way to # access it until we have know how both these interfaces can be # addressed. One possibility is to return a negative value for # relative seconds and a positive value for epoch based time values. #sub retry_after { shift->_date_header('Retry-After', @_); } sub content_type { my $self = shift; my $ct = $self->{'content-type'}; $self->{'content-type'} = shift if @_; $ct = $ct->[0] if ref($ct) eq 'ARRAY'; return '' unless defined($ct) && length($ct); my @ct = split(/;\s*/, $ct, 2); for ($ct[0]) { s/\s+//g; $_ = lc($_); } wantarray ? @ct : $ct[0]; } sub content_type_charset { my $self = shift; require HTTP::Headers::Util; my $h = $self->{'content-type'}; $h = $h->[0] if ref($h); $h = "" unless defined $h; my @v = HTTP::Headers::Util::split_header_words($h); if (@v) { my($ct, undef, %ct_param) = @{$v[0]}; my $charset = $ct_param{charset}; if ($ct) { $ct = lc($ct); $ct =~ s/\s+//; } if ($charset) { $charset = uc($charset); $charset =~ s/^\s+//; $charset =~ s/\s+\z//; undef($charset) if $charset eq ""; } return $ct, $charset if wantarray; return $charset; } return undef, undef if wantarray; return undef; } sub content_is_text { my $self = shift; return $self->content_type =~ m,^text/,; } sub content_is_html { my $self = shift; return $self->content_type eq 'text/html' || $self->content_is_xhtml; } sub content_is_xhtml { my $ct = shift->content_type; return $ct eq "application/xhtml+xml" || $ct eq "application/vnd.wap.xhtml+xml"; } sub content_is_xml { my $ct = shift->content_type; return 1 if $ct eq "text/xml"; return 1 if $ct eq "application/xml"; return 1 if $ct =~ /\+xml$/; return 0; } sub referer { my $self = shift; if (@_ && $_[0] =~ /#/) { # Strip fragment per RFC 2616, section 14.36. my $uri = shift; if (ref($uri)) { $uri = $uri->clone; $uri->fragment(undef); } else { $uri =~ s/\#.*//; } unshift @_, $uri; } ($self->_header('Referer', @_))[0]; } *referrer = \&referer; # on tchrist's request sub title { (shift->_header('Title', @_))[0] } sub content_encoding { (shift->_header('Content-Encoding', @_))[0] } sub content_language { (shift->_header('Content-Language', @_))[0] } sub content_length { (shift->_header('Content-Length', @_))[0] } sub user_agent { (shift->_header('User-Agent', @_))[0] } sub server { (shift->_header('Server', @_))[0] } sub from { (shift->_header('From', @_))[0] } sub warning { (shift->_header('Warning', @_))[0] } sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] } sub authorization { (shift->_header('Authorization', @_))[0] } sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] } sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] } sub authorization_basic { shift->_basic_auth("Authorization", @_) } sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) } sub _basic_auth { require MIME::Base64; my($self, $h, $user, $passwd) = @_; my($old) = $self->_header($h); if (defined $user) { Carp::croak("Basic authorization user name can't contain ':'") if $user =~ /:/; $passwd = '' unless defined $passwd; $self->_header($h => 'Basic ' . MIME::Base64::encode("$user:$passwd", '')); } if (defined $old && $old =~ s/^\s*Basic\s+//) { my $val = MIME::Base64::decode($old); return $val unless wantarray; return split(/:/, $val, 2); } return; } 1; =pod =encoding UTF-8 =head1 NAME HTTP::Headers - Class encapsulating HTTP Message headers =head1 VERSION version 6.36 =head1 SYNOPSIS require HTTP::Headers; $h = HTTP::Headers->new; $h->header('Content-Type' => 'text/plain'); # set $ct = $h->header('Content-Type'); # get $h->remove_header('Content-Type'); # delete =head1 DESCRIPTION The C<HTTP::Headers> class encapsulates HTTP-style message headers. The headers consist of attribute-value pairs also called fields, which may be repeated, and which are printed in a particular order. The field names are cases insensitive. Instances of this class are usually created as member variables of the C<HTTP::Request> and C<HTTP::Response> classes, internal to the library. The following methods are available: =over 4 =item $h = HTTP::Headers->new Constructs a new C<HTTP::Headers> object. You might pass some initial attribute-value pairs as parameters to the constructor. I<E.g.>: $h = HTTP::Headers->new( Date => 'Thu, 03 Feb 1994 00:00:00 GMT', Content_Type => 'text/html; version=3.2', Content_Base => 'http://www.perl.org/'); The constructor arguments are passed to the C<header> method which is described below. =item $h->clone Returns a copy of this C<HTTP::Headers> object. =item $h->header( $field ) =item $h->header( $field => $value ) =item $h->header( $f1 => $v1, $f2 => $v2, ... ) Get or set the value of one or more header fields. The header field name ($field) is not case sensitive. To make the life easier for perl users who wants to avoid quoting before the => operator, you can use '_' as a replacement for '-' in header names. The header() method accepts multiple ($field => $value) pairs, which means that you can update several fields with a single invocation. The $value argument may be a plain string or a reference to an array of strings for a multi-valued field. If the $value is provided as C<undef> then the field is removed. If the $value is not given, then that header field will remain unchanged. In addition to being a string, $value may be something that stringifies. The old value (or values) of the last of the header fields is returned. If no such field exists C<undef> will be returned. A multi-valued field will be returned as separate values in list context and will be concatenated with ", " as separator in scalar context. The HTTP spec (RFC 2616) promises that joining multiple values in this way will not change the semantic of a header field, but in practice there are cases like old-style Netscape cookies (see L<HTTP::Cookies>) where "," is used as part of the syntax of a single field value. Examples: $header->header(MIME_Version => '1.0', User_Agent => 'My-Web-Client/0.01'); $header->header(Accept => "text/html, text/plain, image/*"); $header->header(Accept => [qw(text/html text/plain image/*)]); @accepts = $header->header('Accept'); # get multiple values $accepts = $header->header('Accept'); # get values as a single string =item $h->push_header( $field => $value ) =item $h->push_header( $f1 => $v1, $f2 => $v2, ... ) Add a new field value for the specified header field. Previous values for the same field are retained. As for the header() method, the field name ($field) is not case sensitive and '_' can be used as a replacement for '-'. The $value argument may be a scalar or a reference to a list of scalars. $header->push_header(Accept => 'image/jpeg'); $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]); =item $h->init_header( $field => $value ) Set the specified header to the given value, but only if no previous value for that field is set. The header field name ($field) is not case sensitive and '_' can be used as a replacement for '-'. The $value argument may be a scalar or a reference to a list of scalars. =item $h->remove_header( $field, ... ) This function removes the header fields with the specified names. The header field names ($field) are not case sensitive and '_' can be used as a replacement for '-'. The return value is the values of the fields removed. In scalar context the number of fields removed is returned. Note that if you pass in multiple field names then it is generally not possible to tell which of the returned values belonged to which field. =item $h->remove_content_headers This will remove all the header fields used to describe the content of a message. All header field names prefixed with C<Content-> fall into this category, as well as C<Allow>, C<Expires> and C<Last-Modified>. RFC 2616 denotes these fields as I<Entity Header Fields>. The return value is a new C<HTTP::Headers> object that contains the removed headers only. =item $h->clear This will remove all header fields. =item $h->header_field_names Returns the list of distinct names for the fields present in the header. The field names have case as suggested by HTTP spec, and the names are returned in the recommended "Good Practice" order. In scalar context return the number of distinct field names. =item $h->scan( \&process_header_field ) Apply a subroutine to each header field in turn. The callback routine is called with two parameters; the name of the field and a single value (a string). If a header field is multi-valued, then the routine is called once for each value. The field name passed to the callback routine has case as suggested by HTTP spec, and the headers will be visited in the recommended "Good Practice" order. Any return values of the callback routine are ignored. The loop can be broken by raising an exception (C<die>), but the caller of scan() would have to trap the exception itself. =item $h->flatten() Returns the list of pairs of keys and values. =item $h->as_string =item $h->as_string( $eol ) Return the header fields as a formatted MIME header. Since it internally uses the C<scan> method to build the string, the result will use case as suggested by HTTP spec, and it will follow recommended "Good Practice" of ordering the header fields. Long header values are not folded. The optional $eol parameter specifies the line ending sequence to use. The default is "\n". Embedded "\n" characters in header field values will be substituted with this line ending sequence. =back =head1 CONVENIENCE METHODS The most frequently used headers can also be accessed through the following convenience methods. Most of these methods can both be used to read and to set the value of a header. The header value is set if you pass an argument to the method. The old header value is always returned. If the given header did not exist then C<undef> is returned. Methods that deal with dates/times always convert their value to system time (seconds since Jan 1, 1970) and they also expect this kind of value when the header value is set. =over 4 =item $h->date This header represents the date and time at which the message was originated. I<E.g.>: $h->date(time); # set current date =item $h->expires This header gives the date and time after which the entity should be considered stale. =item $h->if_modified_since =item $h->if_unmodified_since These header fields are used to make a request conditional. If the requested resource has (or has not) been modified since the time specified in this field, then the server will return a C<304 Not Modified> response instead of the document itself. =item $h->last_modified This header indicates the date and time at which the resource was last modified. I<E.g.>: # check if document is more than 1 hour old if (my $last_mod = $h->last_modified) { if ($last_mod < time - 60*60) { ... } } =item $h->content_type The Content-Type header field indicates the media type of the message content. I<E.g.>: $h->content_type('text/html'); The value returned will be converted to lower case, and potential parameters will be chopped off and returned as a separate value if in an array context. If there is no such header field, then the empty string is returned. This makes it safe to do the following: if ($h->content_type eq 'text/html') { # we enter this place even if the real header value happens to # be 'TEXT/HTML; version=3.0' ... } =item $h->content_type_charset Returns the upper-cased charset specified in the Content-Type header. In list context return the lower-cased bare content type followed by the upper-cased charset. Both values will be C<undef> if not specified in the header. =item $h->content_is_text Returns TRUE if the Content-Type header field indicate that the content is textual. =item $h->content_is_html Returns TRUE if the Content-Type header field indicate that the content is some kind of HTML (including XHTML). This method can't be used to set Content-Type. =item $h->content_is_xhtml Returns TRUE if the Content-Type header field indicate that the content is XHTML. This method can't be used to set Content-Type. =item $h->content_is_xml Returns TRUE if the Content-Type header field indicate that the content is XML. This method can't be used to set Content-Type. =item $h->content_encoding The Content-Encoding header field is used as a modifier to the media type. When present, its value indicates what additional encoding mechanism has been applied to the resource. =item $h->content_length A decimal number indicating the size in bytes of the message content. =item $h->content_language The natural language(s) of the intended audience for the message content. The value is one or more language tags as defined by RFC 1766. Eg. "no" for some kind of Norwegian and "en-US" for English the way it is written in the US. =item $h->title The title of the document. In libwww-perl this header will be initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element of HTML documents. I<This header is no longer part of the HTTP standard.> =item $h->user_agent This header field is used in request messages and contains information about the user agent originating the request. I<E.g.>: $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)'); =item $h->server The server header field contains information about the software being used by the originating server program handling the request. =item $h->from This header should contain an Internet e-mail address for the human user who controls the requesting user agent. The address should be machine-usable, as defined by RFC822. E.g.: $h->from('King Kong <king@kong.com>'); I<This header is no longer part of the HTTP standard.> =item $h->referer Used to specify the address (URI) of the document from which the requested resource address was obtained. The "Free On-line Dictionary of Computing" as this to say about the word I<referer>: <World-Wide Web> A misspelling of "referrer" which somehow made it into the {HTTP} standard. A given {web page}'s referer (sic) is the {URL} of whatever web page contains the link that the user followed to the current page. Most browsers pass this information as part of a request. (1998-10-19) By popular demand C<referrer> exists as an alias for this method so you can avoid this misspelling in your programs and still send the right thing on the wire. When setting the referrer, this method removes the fragment from the given URI if it is present, as mandated by RFC2616. Note that the removal does I<not> happen automatically if using the header(), push_header() or init_header() methods to set the referrer. =item $h->www_authenticate This header must be included as part of a C<401 Unauthorized> response. The field value consist of a challenge that indicates the authentication scheme and parameters applicable to the requested URI. =item $h->proxy_authenticate This header must be included in a C<407 Proxy Authentication Required> response. =item $h->authorization =item $h->proxy_authorization A user agent that wishes to authenticate itself with a server or a proxy, may do so by including these headers. =item $h->authorization_basic This method is used to get or set an authorization header that use the "Basic Authentication Scheme". In array context it will return two values; the user name and the password. In scalar context it will return I<"uname:password"> as a single string value. When used to set the header value, it expects two arguments. I<E.g.>: $h->authorization_basic($uname, $password); The method will croak if the $uname contains a colon ':'. =item $h->proxy_authorization_basic Same as authorization_basic() but will set the "Proxy-Authorization" header instead. =back =head1 NON-CANONICALIZED FIELD NAMES The header field name spelling is normally canonicalized including the '_' to '-' translation. There are some application where this is not appropriate. Prefixing field names with ':' allow you to force a specific spelling. For example if you really want a header field name to show up as C<foo_bar> instead of "Foo-Bar", you might set it like this: $h->header(":foo_bar" => 1); These field names are returned with the ':' intact for $h->header_field_names and the $h->scan callback, but the colons do not show in $h->as_string. =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ #ABSTRACT: Class encapsulating HTTP Message headers PK ! ����" �" HTTP/Request.pmnu �[��� package HTTP::Request; use strict; use warnings; our $VERSION = '6.36'; use base 'HTTP::Message'; sub new { my($class, $method, $uri, $header, $content) = @_; my $self = $class->SUPER::new($header, $content); $self->method($method); $self->uri($uri); $self; } sub parse { my($class, $str) = @_; Carp::carp('Undefined argument to parse()') if $^W && ! defined $str; my $request_line; if (defined $str && $str =~ s/^(.*)\n//) { $request_line = $1; } else { $request_line = $str; $str = ""; } my $self = $class->SUPER::parse($str); if (defined $request_line) { my($method, $uri, $protocol) = split(' ', $request_line); $self->method($method); $self->uri($uri) if defined($uri); $self->protocol($protocol) if $protocol; } $self; } sub clone { my $self = shift; my $clone = bless $self->SUPER::clone, ref($self); $clone->method($self->method); $clone->uri($self->uri); $clone; } sub method { shift->_elem('_method', @_); } sub uri { my $self = shift; my $old = $self->{'_uri'}; if (@_) { my $uri = shift; if (!defined $uri) { # that's ok } elsif (ref $uri) { Carp::croak("A URI can't be a " . ref($uri) . " reference") if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY'; Carp::croak("Can't use a " . ref($uri) . " object as a URI") unless $uri->can('scheme') && $uri->can('canonical'); $uri = $uri->clone; unless ($HTTP::URI_CLASS eq "URI") { # Argh!! Hate this... old LWP legacy! eval { local $SIG{__DIE__}; $uri = $uri->abs; }; die $@ if $@ && $@ !~ /Missing base argument/; } } else { $uri = $HTTP::URI_CLASS->new($uri); } $self->{'_uri'} = $uri; delete $self->{'_uri_canonical'}; } $old; } *url = \&uri; # legacy sub uri_canonical { my $self = shift; my $uri = $self->{_uri}; if (defined (my $canon = $self->{_uri_canonical})) { # early bailout if these are the exact same string; # rely on stringification of the URI objects return $canon if $canon eq $uri; } # otherwise we need to refresh the memoized value $self->{_uri_canonical} = $uri->canonical; } sub accept_decodable { my $self = shift; $self->header("Accept-Encoding", scalar($self->decodable)); } sub as_string { my $self = shift; my($eol) = @_; $eol = "\n" unless defined $eol; my $req_line = $self->method || "-"; my $uri = $self->uri; $uri = (defined $uri) ? $uri->as_string : "-"; $req_line .= " $uri"; my $proto = $self->protocol; $req_line .= " $proto" if $proto; return join($eol, $req_line, $self->SUPER::as_string(@_)); } sub dump { my $self = shift; my @pre = ($self->method || "-", $self->uri || "-"); if (my $prot = $self->protocol) { push(@pre, $prot); } return $self->SUPER::dump( preheader => join(" ", @pre), @_, ); } 1; =pod =encoding UTF-8 =head1 NAME HTTP::Request - HTTP style request message =head1 VERSION version 6.36 =head1 SYNOPSIS require HTTP::Request; $request = HTTP::Request->new(GET => 'http://www.example.com/'); and usually used like this: $ua = LWP::UserAgent->new; $response = $ua->request($request); =head1 DESCRIPTION C<HTTP::Request> is a class encapsulating HTTP style requests, consisting of a request line, some headers, and a content body. Note that the LWP library uses HTTP style requests even for non-HTTP protocols. Instances of this class are usually passed to the request() method of an C<LWP::UserAgent> object. C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore inherits its methods. The following additional methods are available: =over 4 =item $r = HTTP::Request->new( $method, $uri ) =item $r = HTTP::Request->new( $method, $uri, $header ) =item $r = HTTP::Request->new( $method, $uri, $header, $content ) Constructs a new C<HTTP::Request> object describing a request on the object $uri using method $method. The $method argument must be a string. The $uri argument can be either a string, or a reference to a C<URI> object. The optional $header argument should be a reference to an C<HTTP::Headers> object or a plain array reference of key/value pairs. The optional $content argument should be a string of bytes. =item $r = HTTP::Request->parse( $str ) This constructs a new request object by parsing the given string. =item $r->method =item $r->method( $val ) This is used to get/set the method attribute. The method should be a short string like "GET", "HEAD", "PUT", "PATCH" or "POST". =item $r->uri =item $r->uri( $val ) This is used to get/set the uri attribute. The $val can be a reference to a URI object or a plain string. If a string is given, then it should be parsable as an absolute URI. =item $r->header( $field ) =item $r->header( $field => $value ) This is used to get/set header values and it is inherited from C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for details and other similar methods that can be used to access the headers. =item $r->accept_decodable This will set the C<Accept-Encoding> header to the list of encodings that decoded_content() can decode. =item $r->content =item $r->content( $bytes ) This is used to get/set the content and it is inherited from the C<HTTP::Message> base class. See L<HTTP::Message> for details and other methods that can be used to access the content. Note that the content should be a string of bytes. Strings in perl can contain characters outside the range of a byte. The C<Encode> module can be used to turn such strings into a string of bytes. =item $r->as_string =item $r->as_string( $eol ) Method returning a textual representation of the request. =back =head1 EXAMPLES Creating requests to be sent with L<LWP::UserAgent> or others can be easy. Here are a few examples. =head2 Simple POST Here, we'll create a simple POST request that could be used to send JSON data to an endpoint. #!/usr/bin/env perl use strict; use warnings; use HTTP::Request (); use JSON::MaybeXS qw(encode_json); my $url = 'https://www.example.com/api/user/123'; my $header = ['Content-Type' => 'application/json; charset=UTF-8']; my $data = {foo => 'bar', baz => 'quux'}; my $encoded_data = encode_json($data); my $r = HTTP::Request->new('POST', $url, $header, $encoded_data); # at this point, we could send it via LWP::UserAgent # my $ua = LWP::UserAgent->new(); # my $res = $ua->request($r); =head2 Batch POST Request Some services, like Google, allow multiple requests to be sent in one batch. L<https://developers.google.com/drive/v3/web/batch> for example. Using the C<add_part> method from L<HTTP::Message> makes this simple. #!/usr/bin/env perl use strict; use warnings; use HTTP::Request (); use JSON::MaybeXS qw(encode_json); my $auth_token = 'auth_token'; my $batch_url = 'https://www.googleapis.com/batch'; my $url = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id'; my $url_no_email = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id&sendNotificationEmail=false'; # generate a JSON post request for one of the batch entries my $req1 = build_json_request($url, { emailAddress => 'example@appsrocks.com', role => "writer", type => "user", }); # generate a JSON post request for one of the batch entries my $req2 = build_json_request($url_no_email, { domain => "appsrocks.com", role => "reader", type => "domain", }); # generate a multipart request to send all of the other requests my $r = HTTP::Request->new('POST', $batch_url, [ 'Accept-Encoding' => 'gzip', # if we don't provide a boundary here, HTTP::Message will generate # one for us. We could use UUID::uuid() here if we wanted. 'Content-Type' => 'multipart/mixed; boundary=END_OF_PART' ]); # add the two POST requests to the main request $r->add_part($req1, $req2); # at this point, we could send it via LWP::UserAgent # my $ua = LWP::UserAgent->new(); # my $res = $ua->request($r); exit(); sub build_json_request { my ($url, $href) = @_; my $header = ['Authorization' => "Bearer $auth_token", 'Content-Type' => 'application/json; charset=UTF-8']; return HTTP::Request->new('POST', $url, $header, encode_json($href)); } =head1 SEE ALSO L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>, L<HTTP::Response> =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ #ABSTRACT: HTTP style request message PK ! U�S�l. l. HTTP/Date.pmnu �[��� package HTTP::Date; use strict; our $VERSION = '6.05'; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(time2str str2time); our @EXPORT_OK = qw(parse_date time2iso time2isoz); require Time::Local; our ( @DoW, @MoY, %MoY ); @DoW = qw(Sun Mon Tue Wed Thu Fri Sat); @MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); @MoY{@MoY} = ( 1 .. 12 ); my %GMT_ZONE = ( GMT => 1, UTC => 1, UT => 1, Z => 1 ); sub time2str (;$) { my $time = shift; $time = time unless defined $time; my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = gmtime($time); sprintf( "%s, %02d %s %04d %02d:%02d:%02d GMT", $DoW[$wday], $mday, $MoY[$mon], $year + 1900, $hour, $min, $sec ); } sub str2time ($;$) { my $str = shift; return undef unless defined $str; # fast exit for strictly conforming string if ( $str =~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/ ) { return eval { my $t = Time::Local::timegm( $6, $5, $4, $1, $MoY{$2} - 1, $3 ); $t < 0 ? undef : $t; }; } my @d = parse_date($str); return undef unless @d; $d[1]--; # month my $tz = pop(@d); unless ( defined $tz ) { unless ( defined( $tz = shift ) ) { return eval { my $frac = $d[-1]; $frac -= ( $d[-1] = int($frac) ); my $t = Time::Local::timelocal( reverse @d ) + $frac; $t < 0 ? undef : $t; }; } } my $offset = 0; if ( $GMT_ZONE{ uc $tz } ) { # offset already zero } elsif ( $tz =~ /^([-+])?(\d\d?):?(\d\d)?$/ ) { $offset = 3600 * $2; $offset += 60 * $3 if $3; $offset *= -1 if $1 && $1 eq '-'; } else { eval { require Time::Zone } || return undef; $offset = Time::Zone::tz_offset($tz); return undef unless defined $offset; } return eval { my $frac = $d[-1]; $frac -= ( $d[-1] = int($frac) ); my $t = Time::Local::timegm( reverse @d ) + $frac; $t < 0 ? undef : $t - $offset; }; } sub parse_date ($) { local ($_) = shift; return unless defined; # More lax parsing below s/^\s+//; # kill leading space s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday my ( $day, $mon, $yr, $hr, $min, $sec, $tz, $ampm ); # Then we are able to check for most of the formats with this regexp ( ( $day, $mon, $yr, $hr, $min, $sec, $tz ) = /^ (\d\d?) # day (?:\s+|[-\/]) (\w+) # month (?:\s+|[-\/]) (\d+) # year (?: (?:\s+|:) # separator before clock (\d\d?):(\d\d) # hour:min (?::(\d\d))? # optional seconds )? # optional clock \s* ([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone \s* (?:\(\w+\)|\w{3,})? # ASCII representation of timezone. \s*$ /x ) || # Try the ctime and asctime format ( ( $mon, $day, $hr, $min, $sec, $tz, $yr ) = /^ (\w{1,3}) # month \s+ (\d\d?) # day \s+ (\d\d?):(\d\d) # hour:min (?::(\d\d))? # optional seconds \s+ (?:([A-Za-z]+)\s+)? # optional timezone (\d+) # year \s*$ # allow trailing whitespace /x ) || # Then the Unix 'ls -l' date format ( ( $mon, $day, $yr, $hr, $min, $sec ) = /^ (\w{3}) # month \s+ (\d\d?) # day \s+ (?: (\d\d\d\d) | # year (\d{1,2}):(\d{2}) # hour:min (?::(\d\d))? # optional seconds ) \s*$ /x ) || # ISO 8601 format '1996-02-29 12:00:00 -0100' and variants ( ( $yr, $mon, $day, $hr, $min, $sec, $tz ) = /^ (\d{4}) # year [-\/]? (\d\d?) # numerical month [-\/]? (\d\d?) # day (?: (?:\s+|[-:Tt]) # separator before clock (\d\d?):?(\d\d) # hour:min (?::?(\d\d(?:\.\d*)?))? # optional seconds (and fractional) )? # optional clock \s* ([-+]?\d\d?:?(:?\d\d)? |Z|z)? # timezone (Z is "zero meridian", i.e. GMT) \s*$ /x ) || # Windows 'dir' 11-12-96 03:52PM ( ( $mon, $day, $yr, $hr, $min, $ampm ) = /^ (\d{2}) # numerical month - (\d{2}) # day - (\d{2}) # year \s+ (\d\d?):(\d\d)([APap][Mm]) # hour:min AM or PM \s*$ /x ) || return; # unrecognized format # Translate month name to number $mon = $MoY{$mon} || $MoY{"\u\L$mon"} || ( $mon =~ /^\d\d?$/ && $mon >= 1 && $mon <= 12 && int($mon) ) || return; # If the year is missing, we assume first date before the current, # because of the formats we support such dates are mostly present # on "ls -l" listings. unless ( defined $yr ) { my $cur_mon; ( $cur_mon, $yr ) = (localtime)[ 4, 5 ]; $yr += 1900; $cur_mon++; $yr-- if $mon > $cur_mon; } elsif ( length($yr) < 3 ) { # Find "obvious" year my $cur_yr = (localtime)[5] + 1900; my $m = $cur_yr % 100; my $tmp = $yr; $yr += $cur_yr - $m; $m -= $tmp; $yr += ( $m > 0 ) ? 100 : -100 if abs($m) > 50; } # Make sure clock elements are defined $hr = 0 unless defined($hr); $min = 0 unless defined($min); $sec = 0 unless defined($sec); # Compensate for AM/PM if ($ampm) { $ampm = uc $ampm; $hr = 0 if $hr == 12 && $ampm eq 'AM'; $hr += 12 if $ampm eq 'PM' && $hr != 12; } return ( $yr, $mon, $day, $hr, $min, $sec, $tz ) if wantarray; if ( defined $tz ) { $tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/; } else { $tz = ""; } return sprintf( "%04d-%02d-%02d %02d:%02d:%02d%s", $yr, $mon, $day, $hr, $min, $sec, $tz ); } sub time2iso (;$) { my $time = shift; $time = time unless defined $time; my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time); sprintf( "%04d-%02d-%02d %02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec ); } sub time2isoz (;$) { my $time = shift; $time = time unless defined $time; my ( $sec, $min, $hour, $mday, $mon, $year ) = gmtime($time); sprintf( "%04d-%02d-%02d %02d:%02d:%02dZ", $year + 1900, $mon + 1, $mday, $hour, $min, $sec ); } 1; # ABSTRACT: HTTP::Date - date conversion routines # __END__ =pod =encoding UTF-8 =head1 NAME HTTP::Date - HTTP::Date - date conversion routines =head1 VERSION version 6.05 =head1 SYNOPSIS use HTTP::Date; $string = time2str($time); # Format as GMT ASCII time $time = str2time($string); # convert ASCII date to machine time =head1 DESCRIPTION This module provides functions that deal the date formats used by the HTTP protocol (and then some more). Only the first two functions, time2str() and str2time(), are exported by default. =over 4 =item time2str( [$time] ) The time2str() function converts a machine time (seconds since epoch) to a string. If the function is called without an argument or with an undefined argument, it will use the current time. The string returned is in the format preferred for the HTTP protocol. This is a fixed length subset of the format defined by RFC 1123, represented in Universal Time (GMT). An example of a time stamp in this format is: Sun, 06 Nov 1994 08:49:37 GMT =item str2time( $str [, $zone] ) The str2time() function converts a string to machine time. It returns C<undef> if the format of $str is unrecognized, otherwise whatever the C<Time::Local> functions can make out of the parsed time. Dates before the system's epoch may not work on all operating systems. The time formats recognized are the same as for parse_date(). The function also takes an optional second argument that specifies the default time zone to use when converting the date. This parameter is ignored if the zone is found in the date string itself. If this parameter is missing, and the date string format does not contain any zone specification, then the local time zone is assumed. If the zone is not "C<GMT>" or numerical (like "C<-0800>" or "C<+0100>"), then the C<Time::Zone> module must be installed in order to get the date recognized. =item parse_date( $str ) This function will try to parse a date string, and then return it as a list of numerical values followed by a (possible undefined) time zone specifier; ($year, $month, $day, $hour, $min, $sec, $tz). The $year will be the full 4-digit year, and $month numbers start with 1 (for January). In scalar context the numbers are interpolated in a string of the "YYYY-MM-DD hh:mm:ss TZ"-format and returned. If the date is unrecognized, then the empty list is returned (C<undef> in scalar context). The function is able to parse the following formats: "Wed, 09 Feb 1994 22:23:32 GMT" -- HTTP format "Thu Feb 3 17:03:55 GMT 1994" -- ctime(3) format "Thu Feb 3 00:00:00 1994", -- ANSI C asctime() format "Tuesday, 08-Feb-94 14:15:29 GMT" -- old rfc850 HTTP format "Tuesday, 08-Feb-1994 14:15:29 GMT" -- broken rfc850 HTTP format "03/Feb/1994:17:03:55 -0700" -- common logfile format "09 Feb 1994 22:23:32 GMT" -- HTTP format (no weekday) "08-Feb-94 14:15:29 GMT" -- rfc850 format (no weekday) "08-Feb-1994 14:15:29 GMT" -- broken rfc850 format (no weekday) "1994-02-03 14:15:29 -0100" -- ISO 8601 format "1994-02-03 14:15:29" -- zone is optional "1994-02-03" -- only date "1994-02-03T14:15:29" -- Use T as separator "19940203T141529Z" -- ISO 8601 compact format "19940203" -- only date "08-Feb-94" -- old rfc850 HTTP format (no weekday, no time) "08-Feb-1994" -- broken rfc850 HTTP format (no weekday, no time) "09 Feb 1994" -- proposed new HTTP format (no weekday, no time) "03/Feb/1994" -- common logfile format (no time, no offset) "Feb 3 1994" -- Unix 'ls -l' format "Feb 3 17:03" -- Unix 'ls -l' format "11-15-96 03:52PM" -- Windows 'dir' format The parser ignores leading and trailing whitespace. It also allow the seconds to be missing and the month to be numerical in most formats. If the year is missing, then we assume that the date is the first matching date I<before> current month. If the year is given with only 2 digits, then parse_date() will select the century that makes the year closest to the current date. =item time2iso( [$time] ) Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ss"-formatted string representing time in the local time zone. =item time2isoz( [$time] ) Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ssZ"-formatted string representing Universal Time. =back =head1 SEE ALSO L<perlfunc/time>, L<Time::Zone> =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1995-2019 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut PK ! (o۔�2 �2 HTTP/Status.pmnu �[��� package HTTP::Status; use strict; use warnings; our $VERSION = '6.36'; use Exporter 5.57 'import'; our @EXPORT = qw(is_info is_success is_redirect is_error status_message); our @EXPORT_OK = qw(is_client_error is_server_error is_cacheable_by_default); # Note also addition of mnemonics to @EXPORT below # Unmarked codes are from RFC 7231 (2017-12-20) # See also: # https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml my %StatusCode = ( 100 => 'Continue', 101 => 'Switching Protocols', 102 => 'Processing', # RFC 2518: WebDAV 103 => 'Early Hints', # RFC 8297: Indicating Hints # 104 .. 199 200 => 'OK', 201 => 'Created', 202 => 'Accepted', 203 => 'Non-Authoritative Information', 204 => 'No Content', 205 => 'Reset Content', 206 => 'Partial Content', # RFC 7233: Range Requests 207 => 'Multi-Status', # RFC 4918: WebDAV 208 => 'Already Reported', # RFC 5842: WebDAV bindings # 209 .. 225 226 => 'IM Used', # RFC 3229: Delta encoding # 227 .. 299 300 => 'Multiple Choices', 301 => 'Moved Permanently', 302 => 'Found', 303 => 'See Other', 304 => 'Not Modified', # RFC 7232: Conditional Request 305 => 'Use Proxy', 307 => 'Temporary Redirect', 308 => 'Permanent Redirect', # RFC 7528: Permanent Redirect # 309 .. 399 400 => 'Bad Request', 401 => 'Unauthorized', # RFC 7235: Authentication 402 => 'Payment Required', 403 => 'Forbidden', 404 => 'Not Found', 405 => 'Method Not Allowed', 406 => 'Not Acceptable', 407 => 'Proxy Authentication Required', # RFC 7235: Authentication 408 => 'Request Timeout', 409 => 'Conflict', 410 => 'Gone', 411 => 'Length Required', 412 => 'Precondition Failed', # RFC 7232: Conditional Request 413 => 'Payload Too Large', 414 => 'URI Too Long', 415 => 'Unsupported Media Type', 416 => 'Range Not Satisfiable', # RFC 7233: Range Requests 417 => 'Expectation Failed', # 418 .. 420 421 => 'Misdirected Request', # RFC 7540: HTTP/2 422 => 'Unprocessable Entity', # RFC 4918: WebDAV 423 => 'Locked', # RFC 4918: WebDAV 424 => 'Failed Dependency', # RFC 4918: WebDAV 425 => 'Too Early', # RFC 8470: Using Early Data in HTTP 426 => 'Upgrade Required', # 427 428 => 'Precondition Required', # RFC 6585: Additional Codes 429 => 'Too Many Requests', # RFC 6585: Additional Codes # 430 431 => 'Request Header Fields Too Large', # RFC 6585: Additional Codes # 432 .. 450 451 => 'Unavailable For Legal Reasons', # RFC 7725: Legal Obstacles # 452 .. 499 500 => 'Internal Server Error', 501 => 'Not Implemented', 502 => 'Bad Gateway', 503 => 'Service Unavailable', 504 => 'Gateway Timeout', 505 => 'HTTP Version Not Supported', 506 => 'Variant Also Negotiates', # RFC 2295: Transparant Ngttn 507 => 'Insufficient Storage', # RFC 4918: WebDAV 508 => 'Loop Detected', # RFC 5842: WebDAV bindings # 509 510 => 'Not Extended', # RFC 2774: Extension Framework 511 => 'Network Authentication Required', # RFC 6585: Additional Codes ); # keep some unofficial codes that used to be in this distribution %StatusCode = ( %StatusCode, 418 => 'I\'m a teapot', # RFC 2324: HTCPC/1.0 1-april 449 => 'Retry with', # microsoft 509 => 'Bandwidth Limit Exceeded', # Apache / cPanel ); my $mnemonicCode = ''; my ($code, $message); while (($code, $message) = each %StatusCode) { # create mnemonic subroutines $message =~ s/I'm/I am/; $message =~ tr/a-z \-/A-Z__/; $mnemonicCode .= "sub HTTP_$message () { $code }\n"; $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n"; $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n"; } eval $mnemonicCode; # only one eval for speed die if $@; # backwards compatibility *RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard push(@EXPORT, "RC_MOVED_TEMPORARILY"); my %compat = ( REQUEST_ENTITY_TOO_LARGE => \&HTTP_PAYLOAD_TOO_LARGE, REQUEST_URI_TOO_LARGE => \&HTTP_URI_TOO_LONG, REQUEST_RANGE_NOT_SATISFIABLE => \&HTTP_RANGE_NOT_SATISFIABLE, NO_CODE => \&HTTP_TOO_EARLY, UNORDERED_COLLECTION => \&HTTP_TOO_EARLY, ); foreach my $name (keys %compat) { push(@EXPORT, "RC_$name"); push(@EXPORT_OK, "HTTP_$name"); no strict 'refs'; *{"RC_$name"} = $compat{$name}; *{"HTTP_$name"} = $compat{$name}; } our %EXPORT_TAGS = ( constants => [grep /^HTTP_/, @EXPORT_OK], is => [grep /^is_/, @EXPORT, @EXPORT_OK], ); sub status_message ($) { $StatusCode{$_[0]}; } sub is_info ($) { $_[0] && $_[0] >= 100 && $_[0] < 200; } sub is_success ($) { $_[0] && $_[0] >= 200 && $_[0] < 300; } sub is_redirect ($) { $_[0] && $_[0] >= 300 && $_[0] < 400; } sub is_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 600; } sub is_client_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 500; } sub is_server_error ($) { $_[0] && $_[0] >= 500 && $_[0] < 600; } sub is_cacheable_by_default ($) { $_[0] && ( $_[0] == 200 # OK || $_[0] == 203 # Non-Authoritative Information || $_[0] == 204 # No Content || $_[0] == 206 # Not Acceptable || $_[0] == 300 # Multiple Choices || $_[0] == 301 # Moved Permanently || $_[0] == 308 # Permanent Redirect || $_[0] == 404 # Not Found || $_[0] == 405 # Method Not Allowed || $_[0] == 410 # Gone || $_[0] == 414 # Request-URI Too Large || $_[0] == 451 # Unavailable For Legal Reasons || $_[0] == 501 # Not Implemented ); } 1; =pod =encoding UTF-8 =head1 NAME HTTP::Status - HTTP Status code processing =head1 VERSION version 6.36 =head1 SYNOPSIS use HTTP::Status qw(:constants :is status_message); if ($rc != HTTP_OK) { print status_message($rc), "\n"; } if (is_success($rc)) { ... } if (is_error($rc)) { ... } if (is_redirect($rc)) { ... } =head1 DESCRIPTION I<HTTP::Status> is a library of routines for defining and classifying HTTP status codes for libwww-perl. Status codes are used to encode the overall outcome of an HTTP response message. Codes correspond to those defined in RFC 2616 and RFC 2518. =head1 CONSTANTS The following constant functions can be used as mnemonic status code names. None of these are exported by default. Use the C<:constants> tag to import them all. HTTP_CONTINUE (100) HTTP_SWITCHING_PROTOCOLS (101) HTTP_PROCESSING (102) HTTP_EARLY_HINTS (103) HTTP_OK (200) HTTP_CREATED (201) HTTP_ACCEPTED (202) HTTP_NON_AUTHORITATIVE_INFORMATION (203) HTTP_NO_CONTENT (204) HTTP_RESET_CONTENT (205) HTTP_PARTIAL_CONTENT (206) HTTP_MULTI_STATUS (207) HTTP_ALREADY_REPORTED (208) HTTP_IM_USED (226) HTTP_MULTIPLE_CHOICES (300) HTTP_MOVED_PERMANENTLY (301) HTTP_FOUND (302) HTTP_SEE_OTHER (303) HTTP_NOT_MODIFIED (304) HTTP_USE_PROXY (305) HTTP_TEMPORARY_REDIRECT (307) HTTP_PERMANENT_REDIRECT (308) HTTP_BAD_REQUEST (400) HTTP_UNAUTHORIZED (401) HTTP_PAYMENT_REQUIRED (402) HTTP_FORBIDDEN (403) HTTP_NOT_FOUND (404) HTTP_METHOD_NOT_ALLOWED (405) HTTP_NOT_ACCEPTABLE (406) HTTP_PROXY_AUTHENTICATION_REQUIRED (407) HTTP_REQUEST_TIMEOUT (408) HTTP_CONFLICT (409) HTTP_GONE (410) HTTP_LENGTH_REQUIRED (411) HTTP_PRECONDITION_FAILED (412) HTTP_PAYLOAD_TOO_LARGE (413) HTTP_URI_TOO_LONG (414) HTTP_UNSUPPORTED_MEDIA_TYPE (415) HTTP_RANGE_NOT_SATISFIABLE (416) HTTP_EXPECTATION_FAILED (417) HTTP_MISDIRECTED REQUEST (421) HTTP_UNPROCESSABLE_ENTITY (422) HTTP_LOCKED (423) HTTP_FAILED_DEPENDENCY (424) HTTP_TOO_EARLY (425) HTTP_UPGRADE_REQUIRED (426) HTTP_PRECONDITION_REQUIRED (428) HTTP_TOO_MANY_REQUESTS (429) HTTP_REQUEST_HEADER_FIELDS_TOO_LARGE (431) HTTP_UNAVAILABLE_FOR_LEGAL_REASONS (451) HTTP_INTERNAL_SERVER_ERROR (500) HTTP_NOT_IMPLEMENTED (501) HTTP_BAD_GATEWAY (502) HTTP_SERVICE_UNAVAILABLE (503) HTTP_GATEWAY_TIMEOUT (504) HTTP_HTTP_VERSION_NOT_SUPPORTED (505) HTTP_VARIANT_ALSO_NEGOTIATES (506) HTTP_INSUFFICIENT_STORAGE (507) HTTP_LOOP_DETECTED (508) HTTP_NOT_EXTENDED (510) HTTP_NETWORK_AUTHENTICATION_REQUIRED (511) =head1 FUNCTIONS The following additional functions are provided. Most of them are exported by default. The C<:is> import tag can be used to import all the classification functions. =over 4 =item status_message( $code ) The status_message() function will translate status codes to human readable strings. The string is the same as found in the constant names above. If the $code is not registered in the L<list of IANA HTTP Status Codes|https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml> then C<undef> is returned. =item is_info( $code ) Return TRUE if C<$code> is an I<Informational> status code (1xx). This class of status code indicates a provisional response which can't have any content. =item is_success( $code ) Return TRUE if C<$code> is a I<Successful> status code (2xx). =item is_redirect( $code ) Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of status code indicates that further action needs to be taken by the user agent in order to fulfill the request. =item is_error( $code ) Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx). The function returns TRUE for both client and server error status codes. =item is_client_error( $code ) Return TRUE if C<$code> is a I<Client Error> status code (4xx). This class of status code is intended for cases in which the client seems to have erred. This function is B<not> exported by default. =item is_server_error( $code ) Return TRUE if C<$code> is a I<Server Error> status code (5xx). This class of status codes is intended for cases in which the server is aware that it has erred or is incapable of performing the request. This function is B<not> exported by default. =item is_cacheable_by_default( $code ) Return TRUE if C<$code> indicates that a response is cacheable by default, and it can be reused by a cache with heuristic expiration. All other status codes are not cacheable by default. See L<RFC 7231 - HTTP/1.1 Semantics and Content, Section 6.1. Overview of Status Codes|https://tools.ietf.org/html/rfc7231#section-6.1>. This function is B<not> exported by default. =back =head1 SEE ALSO L<IANA HTTP Status Codes|https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml> =head1 BUGS For legacy reasons all the C<HTTP_> constants are exported by default with the prefix C<RC_>. It's recommended to use explicit imports and the C<:constants> tag instead of relying on this. =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ #ABSTRACT: HTTP Status code processing PK ! �[��j{ j{ HTTP/Message.pmnu �[��� package HTTP::Message; use strict; use warnings; our $VERSION = '6.36'; require HTTP::Headers; require Carp; my $CRLF = "\015\012"; # "\r\n" is not portable unless ($HTTP::URI_CLASS) { if ($ENV{PERL_HTTP_URI_CLASS} && $ENV{PERL_HTTP_URI_CLASS} =~ /^([\w:]+)$/) { $HTTP::URI_CLASS = $1; } else { $HTTP::URI_CLASS = "URI"; } } eval "require $HTTP::URI_CLASS"; die $@ if $@; *_utf8_downgrade = defined(&utf8::downgrade) ? sub { utf8::downgrade($_[0], 1) or Carp::croak("HTTP::Message content must be bytes") } : sub { }; sub new { my($class, $header, $content) = @_; if (defined $header) { Carp::croak("Bad header argument") unless ref $header; if (ref($header) eq "ARRAY") { $header = HTTP::Headers->new(@$header); } else { $header = $header->clone; } } else { $header = HTTP::Headers->new; } if (defined $content) { _utf8_downgrade($content); } else { $content = ''; } bless { '_headers' => $header, '_content' => $content, }, $class; } sub parse { my($class, $str) = @_; my @hdr; while (1) { if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) { push(@hdr, $1, $2); $hdr[-1] =~ s/\r\z//; } elsif (@hdr && $str =~ s/^([ \t].*)\n?//) { $hdr[-1] .= "\n$1"; $hdr[-1] =~ s/\r\z//; } else { $str =~ s/^\r?\n//; last; } } local $HTTP::Headers::TRANSLATE_UNDERSCORE; new($class, \@hdr, $str); } sub clone { my $self = shift; my $clone = HTTP::Message->new($self->headers, $self->content); $clone->protocol($self->protocol); $clone; } sub clear { my $self = shift; $self->{_headers}->clear; $self->content(""); delete $self->{_parts}; return; } sub protocol { shift->_elem('_protocol', @_); } sub headers { my $self = shift; # recalculation of _content might change headers, so we # need to force it now $self->_content unless exists $self->{_content}; $self->{_headers}; } sub headers_as_string { shift->headers->as_string(@_); } sub content { my $self = $_[0]; if (defined(wantarray)) { $self->_content unless exists $self->{_content}; my $old = $self->{_content}; $old = $$old if ref($old) eq "SCALAR"; &_set_content if @_ > 1; return $old; } if (@_ > 1) { &_set_content; } else { Carp::carp("Useless content call in void context") if $^W; } } sub _set_content { my $self = $_[0]; _utf8_downgrade($_[1]); if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") { ${$self->{_content}} = defined( $_[1] ) ? $_[1] : ''; } else { die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR"; $self->{_content} = defined( $_[1] ) ? $_[1] : ''; delete $self->{_content_ref}; } delete $self->{_parts} unless $_[2]; } sub add_content { my $self = shift; $self->_content unless exists $self->{_content}; my $chunkref = \$_[0]; $chunkref = $$chunkref if ref($$chunkref); # legacy _utf8_downgrade($$chunkref); my $ref = ref($self->{_content}); if (!$ref) { $self->{_content} .= $$chunkref; } elsif ($ref eq "SCALAR") { ${$self->{_content}} .= $$chunkref; } else { Carp::croak("Can't append to $ref content"); } delete $self->{_parts}; } sub add_content_utf8 { my($self, $buf) = @_; utf8::upgrade($buf); utf8::encode($buf); $self->add_content($buf); } sub content_ref { my $self = shift; $self->_content unless exists $self->{_content}; delete $self->{_parts}; my $old = \$self->{_content}; my $old_cref = $self->{_content_ref}; if (@_) { my $new = shift; Carp::croak("Setting content_ref to a non-ref") unless ref($new); delete $self->{_content}; # avoid modifying $$old $self->{_content} = $new; $self->{_content_ref}++; } $old = $$old if $old_cref; return $old; } sub content_charset { my $self = shift; if (my $charset = $self->content_type_charset) { return $charset; } # time to start guessing my $cref = $self->decoded_content(ref => 1, charset => "none"); # Unicode BOM for ($$cref) { return "UTF-8" if /^\xEF\xBB\xBF/; return "UTF-32LE" if /^\xFF\xFE\x00\x00/; return "UTF-32BE" if /^\x00\x00\xFE\xFF/; return "UTF-16LE" if /^\xFF\xFE/; return "UTF-16BE" if /^\xFE\xFF/; } if ($self->content_is_xml) { # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing # XML entity not accompanied by external encoding information and not # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration, # in which the first characters must be '<?xml' for ($$cref) { return "UTF-32BE" if /^\x00\x00\x00</; return "UTF-32LE" if /^<\x00\x00\x00/; return "UTF-16BE" if /^(?:\x00\s)*\x00</; return "UTF-16LE" if /^(?:\s\x00)*<\x00/; if (/^\s*(<\?xml[^\x00]*?\?>)/) { if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) { my $enc = $2; $enc =~ s/^\s+//; $enc =~ s/\s+\z//; return $enc if $enc; } } } return "UTF-8"; } elsif ($self->content_is_html) { # look for <META charset="..."> or <META content="..."> # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding require IO::HTML; # Use relaxed search to match previous versions of HTTP::Message: my $encoding = IO::HTML::find_charset_in($$cref, { encoding => 1, need_pragma => 0 }); return $encoding->mime_name if $encoding; } elsif ($self->content_type eq "application/json") { for ($$cref) { # RFC 4627, ch 3 return "UTF-32BE" if /^\x00\x00\x00./s; return "UTF-32LE" if /^.\x00\x00\x00/s; return "UTF-16BE" if /^\x00.\x00./s; return "UTF-16LE" if /^.\x00.\x00/s; return "UTF-8"; } } if ($self->content_type =~ /^text\//) { for ($$cref) { if (length) { return "US-ASCII" unless /[\x80-\xFF]/; require Encode; eval { Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC()); }; return "UTF-8" unless $@; return "ISO-8859-1"; } } } return undef; } sub decoded_content { my($self, %opt) = @_; my $content_ref; my $content_ref_iscopy; eval { $content_ref = $self->content_ref; die "Can't decode ref content" if ref($content_ref) ne "SCALAR"; if (my $h = $self->header("Content-Encoding")) { $h =~ s/^\s+//; $h =~ s/\s+$//; for my $ce (reverse split(/\s*,\s*/, lc($h))) { next unless $ce; next if $ce eq "identity" || $ce eq "none"; if ($ce eq "gzip" || $ce eq "x-gzip") { require IO::Uncompress::Gunzip; my $output; IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0) or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError"; $content_ref = \$output; $content_ref_iscopy++; } elsif ($ce eq "x-bzip2" or $ce eq "bzip2") { require IO::Uncompress::Bunzip2; my $output; IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0) or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error"; $content_ref = \$output; $content_ref_iscopy++; } elsif ($ce eq "deflate") { require IO::Uncompress::Inflate; my $output; my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0); my $error = $IO::Uncompress::Inflate::InflateError; unless ($status) { # "Content-Encoding: deflate" is supposed to mean the # "zlib" format of RFC 1950, but Microsoft got that # wrong, so some servers sends the raw compressed # "deflate" data. This tries to inflate this format. $output = undef; require IO::Uncompress::RawInflate; unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) { $self->push_header("Client-Warning" => "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError"); $output = undef; } } die "Can't inflate content: $error" unless defined $output; $content_ref = \$output; $content_ref_iscopy++; } elsif ($ce eq "compress" || $ce eq "x-compress") { die "Can't uncompress content"; } elsif ($ce eq "base64") { # not really C-T-E, but should be harmless require MIME::Base64; $content_ref = \MIME::Base64::decode($$content_ref); $content_ref_iscopy++; } elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless require MIME::QuotedPrint; $content_ref = \MIME::QuotedPrint::decode($$content_ref); $content_ref_iscopy++; } else { die "Don't know how to decode Content-Encoding '$ce'"; } } } if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) { my $charset = lc( $opt{charset} || $self->content_type_charset || $opt{default_charset} || $self->content_charset || "ISO-8859-1" ); if ($charset eq "none") { # leave it as is } elsif ($charset eq "us-ascii" || $charset eq "iso-8859-1") { if ($$content_ref =~ /[^\x00-\x7F]/ && defined &utf8::upgrade) { unless ($content_ref_iscopy) { my $copy = $$content_ref; $content_ref = \$copy; $content_ref_iscopy++; } utf8::upgrade($$content_ref); } } else { require Encode; eval { $content_ref = \Encode::decode($charset, $$content_ref, ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC()); }; if ($@) { my $retried; if ($@ =~ /^Unknown encoding/) { my $alt_charset = lc($opt{alt_charset} || ""); if ($alt_charset && $charset ne $alt_charset) { # Retry decoding with the alternative charset $content_ref = \Encode::decode($alt_charset, $$content_ref, ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC()) unless $alt_charset eq "none"; $retried++; } } die unless $retried; } die "Encode::decode() returned undef improperly" unless defined $$content_ref; if ($is_xml) { # Get rid of the XML encoding declaration if present $$content_ref =~ s/^\x{FEFF}//; if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) { substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//; } } } } }; if ($@) { Carp::croak($@) if $opt{raise_error}; return undef; } return $opt{ref} ? $content_ref : $$content_ref; } sub decodable { # should match the Content-Encoding values that decoded_content can deal with my $self = shift; my @enc; local $@; # XXX preferably we should determine if the modules are available without loading # them here eval { require IO::Uncompress::Gunzip; push(@enc, "gzip", "x-gzip"); }; eval { require IO::Uncompress::Inflate; require IO::Uncompress::RawInflate; push(@enc, "deflate"); }; eval { require IO::Uncompress::Bunzip2; push(@enc, "x-bzip2", "bzip2"); }; # we don't care about announcing the 'identity', 'base64' and # 'quoted-printable' stuff return wantarray ? @enc : join(", ", @enc); } sub decode { my $self = shift; return 1 unless $self->header("Content-Encoding"); if (defined(my $content = $self->decoded_content(charset => "none"))) { $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5"); $self->content($content); return 1; } return 0; } sub encode { my($self, @enc) = @_; Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,; Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,; return 1 unless @enc; # nothing to do my $content = $self->content; for my $encoding (@enc) { if ($encoding eq "identity" || $encoding eq "none") { # nothing to do } elsif ($encoding eq "base64") { require MIME::Base64; $content = MIME::Base64::encode($content); } elsif ($encoding eq "gzip" || $encoding eq "x-gzip") { require IO::Compress::Gzip; my $output; IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1) or die "Can't gzip content: $IO::Compress::Gzip::GzipError"; $content = $output; } elsif ($encoding eq "deflate") { require IO::Compress::Deflate; my $output; IO::Compress::Deflate::deflate(\$content, \$output) or die "Can't deflate content: $IO::Compress::Deflate::DeflateError"; $content = $output; } elsif ($encoding eq "x-bzip2" || $encoding eq "bzip2") { require IO::Compress::Bzip2; my $output; IO::Compress::Bzip2::bzip2(\$content, \$output) or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error"; $content = $output; } elsif ($encoding eq "rot13") { # for the fun of it $content =~ tr/A-Za-z/N-ZA-Mn-za-m/; } else { return 0; } } my $h = $self->header("Content-Encoding"); unshift(@enc, $h) if $h; $self->header("Content-Encoding", join(", ", @enc)); $self->remove_header("Content-Length", "Content-MD5"); $self->content($content); return 1; } sub as_string { my($self, $eol) = @_; $eol = "\n" unless defined $eol; # The calculation of content might update the headers # so we need to do that first. my $content = $self->content; return join("", $self->{'_headers'}->as_string($eol), $eol, $content, (@_ == 1 && length($content) && $content !~ /\n\z/) ? "\n" : "", ); } sub dump { my($self, %opt) = @_; my $content = $self->content; my $chopped = 0; if (!ref($content)) { my $maxlen = $opt{maxlength}; $maxlen = 512 unless defined($maxlen); if ($maxlen && length($content) > $maxlen * 1.1 + 3) { $chopped = length($content) - $maxlen; $content = substr($content, 0, $maxlen) . "..."; } $content =~ s/\\/\\\\/g; $content =~ s/\t/\\t/g; $content =~ s/\r/\\r/g; # no need for 3 digits in escape for these $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg; # remaining whitespace $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg; $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg; $content =~ s/\n\z/\\n/; my $no_content = $opt{no_content}; $no_content = "(no content)" unless defined $no_content; if ($content eq $no_content) { # escape our $no_content marker $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg; } elsif ($content eq "") { $content = $no_content; } } my @dump; push(@dump, $opt{preheader}) if $opt{preheader}; push(@dump, $self->{_headers}->as_string, $content); push(@dump, "(+ $chopped more bytes not shown)") if $chopped; my $dump = join("\n", @dump, ""); $dump =~ s/^/$opt{prefix}/gm if $opt{prefix}; print $dump unless defined wantarray; return $dump; } # allow subclasses to override what will handle individual parts sub _part_class { return __PACKAGE__; } sub parts { my $self = shift; if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) { $self->_parts; } my $old = $self->{_parts}; if (@_) { my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_; my $ct = $self->content_type || ""; if ($ct =~ m,^message/,) { Carp::croak("Only one part allowed for $ct content") if @parts > 1; } elsif ($ct !~ m,^multipart/,) { $self->remove_content_headers; $self->content_type("multipart/mixed"); } $self->{_parts} = \@parts; _stale_content($self); } return @$old if wantarray; return $old->[0]; } sub add_part { my $self = shift; if (($self->content_type || "") !~ m,^multipart/,) { my $p = $self->_part_class->new( $self->remove_content_headers, $self->content(""), ); $self->content_type("multipart/mixed"); $self->{_parts} = []; if ($p->headers->header_field_names || $p->content ne "") { push(@{$self->{_parts}}, $p); } } elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") { $self->_parts; } push(@{$self->{_parts}}, @_); _stale_content($self); return; } sub _stale_content { my $self = shift; if (ref($self->{_content}) eq "SCALAR") { # must recalculate now $self->_content; } else { # just invalidate cache delete $self->{_content}; delete $self->{_content_ref}; } } # delegate all other method calls to the headers object. our $AUTOLOAD; sub AUTOLOAD { my ( $package, $method ) = $AUTOLOAD =~ m/\A(.+)::([^:]*)\z/; my $code = $_[0]->can($method); Carp::croak( qq(Can't locate object method "$method" via package "$package")) unless $code; goto &$code; } sub can { my ( $self, $method ) = @_; if ( my $own_method = $self->SUPER::can($method) ) { return $own_method; } my $headers = ref($self) ? $self->headers : 'HTTP::Headers'; if ( $headers->can($method) ) { # We create the function here so that it will not need to be # autoloaded or recreated the next time. no strict 'refs'; *$method = sub { local $Carp::Internal{ +__PACKAGE__ } = 1; shift->headers->$method(@_); }; return \&$method; } return undef; } sub DESTROY { } # avoid AUTOLOADing it # Private method to access members in %$self sub _elem { my $self = shift; my $elem = shift; my $old = $self->{$elem}; $self->{$elem} = $_[0] if @_; return $old; } # Create private _parts attribute from current _content sub _parts { my $self = shift; my $ct = $self->content_type; if ($ct =~ m,^multipart/,) { require HTTP::Headers::Util; my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type")); die "Assert" unless @h; my %h = @{$h[0]}; if (defined(my $b = $h{boundary})) { my $str = $self->content; $str =~ s/\r?\n--\Q$b\E--.*//s; if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) { $self->{_parts} = [map $self->_part_class->parse($_), split(/\r?\n--\Q$b\E\r?\n/, $str)] } } } elsif ($ct eq "message/http") { require HTTP::Request; require HTTP::Response; my $content = $self->content; my $class = ($content =~ m,^(HTTP/.*)\n,) ? "HTTP::Response" : "HTTP::Request"; $self->{_parts} = [$class->parse($content)]; } elsif ($ct =~ m,^message/,) { $self->{_parts} = [ $self->_part_class->parse($self->content) ]; } $self->{_parts} ||= []; } # Create private _content attribute from current _parts sub _content { my $self = shift; my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed"; if ($ct =~ m,^\s*message/,i) { _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1); return; } require HTTP::Headers::Util; my @v = HTTP::Headers::Util::split_header_words($ct); Carp::carp("Multiple Content-Type headers") if @v > 1; @v = @{$v[0]}; my $boundary; my $boundary_index; for (my @tmp = @v; @tmp;) { my($k, $v) = splice(@tmp, 0, 2); if ($k eq "boundary") { $boundary = $v; $boundary_index = @v - @tmp - 1; last; } } my @parts = map $_->as_string($CRLF), @{$self->{_parts}}; my $bno = 0; $boundary = _boundary() unless defined $boundary; CHECK_BOUNDARY: { for (@parts) { if (index($_, $boundary) >= 0) { # must have a better boundary $boundary = _boundary(++$bno); redo CHECK_BOUNDARY; } } } if ($boundary_index) { $v[$boundary_index] = $boundary; } else { push(@v, boundary => $boundary); } $ct = HTTP::Headers::Util::join_header_words(@v); $self->{_headers}->header("Content-Type", $ct); _set_content($self, "--$boundary$CRLF" . join("$CRLF--$boundary$CRLF", @parts) . "$CRLF--$boundary--$CRLF", 1); } sub _boundary { my $size = shift || return "xYzZY"; require MIME::Base64; my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), ""); $b =~ s/[\W]/X/g; # ensure alnum only $b; } 1; =pod =encoding UTF-8 =head1 NAME HTTP::Message - HTTP style message (base class) =head1 VERSION version 6.36 =head1 SYNOPSIS use base 'HTTP::Message'; =head1 DESCRIPTION An C<HTTP::Message> object contains some headers and a content body. The following methods are available: =over 4 =item $mess = HTTP::Message->new =item $mess = HTTP::Message->new( $headers ) =item $mess = HTTP::Message->new( $headers, $content ) This constructs a new message object. Normally you would want construct C<HTTP::Request> or C<HTTP::Response> objects instead. The optional $header argument should be a reference to an C<HTTP::Headers> object or a plain array reference of key/value pairs. If an C<HTTP::Headers> object is provided then a copy of it will be embedded into the constructed message, i.e. it will not be owned and can be modified afterwards without affecting the message. The optional $content argument should be a string of bytes. =item $mess = HTTP::Message->parse( $str ) This constructs a new message object by parsing the given string. =item $mess->headers Returns the embedded C<HTTP::Headers> object. =item $mess->headers_as_string =item $mess->headers_as_string( $eol ) Call the as_string() method for the headers in the message. This will be the same as $mess->headers->as_string but it will make your program a whole character shorter :-) =item $mess->content =item $mess->content( $bytes ) The content() method sets the raw content if an argument is given. If no argument is given the content is not touched. In either case the original raw content is returned. If the C<undef> argument is given, the content is reset to its default value, which is an empty string. Note that the content should be a string of bytes. Strings in perl can contain characters outside the range of a byte. The C<Encode> module can be used to turn such strings into a string of bytes. =item $mess->add_content( $bytes ) The add_content() methods appends more data bytes to the end of the current content buffer. =item $mess->add_content_utf8( $string ) The add_content_utf8() method appends the UTF-8 bytes representing the string to the end of the current content buffer. =item $mess->content_ref =item $mess->content_ref( \$bytes ) The content_ref() method will return a reference to content buffer string. It can be more efficient to access the content this way if the content is huge, and it can even be used for direct manipulation of the content, for instance: ${$res->content_ref} =~ s/\bfoo\b/bar/g; This example would modify the content buffer in-place. If an argument is passed it will setup the content to reference some external source. The content() and add_content() methods will automatically dereference scalar references passed this way. For other references content() will return the reference itself and add_content() will refuse to do anything. =item $mess->content_charset This returns the charset used by the content in the message. The charset is either found as the charset attribute of the C<Content-Type> header or by guessing. See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding> for details about how charset is determined. =item $mess->decoded_content( %options ) Returns the content with any C<Content-Encoding> undone and, for textual content (C<Content-Type> values starting with C<text/>, exactly matching C<application/xml>, or ending with C<+xml>), the raw content's character set decoded into Perl's Unicode string format. Note that this L<does not currently|https://github.com/libwww-perl/HTTP-Message/pull/99> attempt to decode declared character sets for any other content types like C<application/json> or C<application/javascript>. If the C<Content-Encoding> or C<charset> of the message is unknown, this method will fail by returning C<undef>. The following options can be specified. =over =item C<charset> This override the charset parameter for text content. The value C<none> can used to suppress decoding of the charset. =item C<default_charset> This override the default charset guessed by content_charset() or if that fails "ISO-8859-1". =item C<alt_charset> If decoding fails because the charset specified in the Content-Type header isn't recognized by Perl's Encode module, then try decoding using this charset instead of failing. The C<alt_charset> might be specified as C<none> to simply return the string without any decoding of charset as alternative. =item C<charset_strict> Abort decoding if malformed characters is found in the content. By default you get the substitution character ("\x{FFFD}") in place of malformed characters. =item C<raise_error> If TRUE then raise an exception if not able to decode content. Reason might be that the specified C<Content-Encoding> or C<charset> is not supported. If this option is FALSE, then decoded_content() will return C<undef> on errors, but will still set $@. =item C<ref> If TRUE then a reference to decoded content is returned. This might be more efficient in cases where the decoded content is identical to the raw content as no data copying is required in this case. =back =item $mess->decodable =item HTTP::Message::decodable() This returns the encoding identifiers that decoded_content() can process. In scalar context returns a comma separated string of identifiers. This value is suitable for initializing the C<Accept-Encoding> request header field. =item $mess->decode This method tries to replace the content of the message with the decoded version and removes the C<Content-Encoding> header. Returns TRUE if successful and FALSE if not. If the message does not have a C<Content-Encoding> header this method does nothing and returns TRUE. Note that the content of the message is still bytes after this method has been called and you still need to call decoded_content() if you want to process its content as a string. =item $mess->encode( $encoding, ... ) Apply the given encodings to the content of the message. Returns TRUE if successful. The "identity" (non-)encoding is always supported; other currently supported encodings, subject to availability of required additional modules, are "gzip", "deflate", "x-bzip2" and "base64". A successful call to this function will set the C<Content-Encoding> header. Note that C<multipart/*> or C<message/*> messages can't be encoded and this method will croak if you try. =item $mess->parts =item $mess->parts( @parts ) =item $mess->parts( \@parts ) Messages can be composite, i.e. contain other messages. The composite messages have a content type of C<multipart/*> or C<message/*>. This method give access to the contained messages. The argumentless form will return a list of C<HTTP::Message> objects. If the content type of $msg is not C<multipart/*> or C<message/*> then this will return the empty list. In scalar context only the first object is returned. The returned message parts should be regarded as read-only (future versions of this library might make it possible to modify the parent by modifying the parts). If the content type of $msg is C<message/*> then there will only be one part returned. If the content type is C<message/http>, then the return value will be either an C<HTTP::Request> or an C<HTTP::Response> object. If a @parts argument is given, then the content of the message will be modified. The array reference form is provided so that an empty list can be provided. The @parts array should contain C<HTTP::Message> objects. The @parts objects are owned by $mess after this call and should not be modified or made part of other messages. When updating the message with this method and the old content type of $mess is not C<multipart/*> or C<message/*>, then the content type is set to C<multipart/mixed> and all other content headers are cleared. This method will croak if the content type is C<message/*> and more than one part is provided. =item $mess->add_part( $part ) This will add a part to a message. The $part argument should be another C<HTTP::Message> object. If the previous content type of $mess is not C<multipart/*> then the old content (together with all content headers) will be made part #1 and the content type made C<multipart/mixed> before the new part is added. The $part object is owned by $mess after this call and should not be modified or made part of other messages. There is no return value. =item $mess->clear Will clear the headers and set the content to the empty string. There is no return value =item $mess->protocol =item $mess->protocol( $proto ) Sets the HTTP protocol used for the message. The protocol() is a string like C<HTTP/1.0> or C<HTTP/1.1>. =item $mess->clone Returns a copy of the message object. =item $mess->as_string =item $mess->as_string( $eol ) Returns the message formatted as a single string. The optional $eol parameter specifies the line ending sequence to use. The default is "\n". If no $eol is given then as_string will ensure that the returned string is newline terminated (even when the message content is not). No extra newline is appended if an explicit $eol is passed. =item $mess->dump( %opt ) Returns the message formatted as a string. In void context print the string. This differs from C<< $mess->as_string >> in that it escapes the bytes of the content so that it's safe to print them and it limits how much content to print. The escapes syntax used is the same as for Perl's double quoted strings. If there is no content the string "(no content)" is shown in its place. Options to influence the output can be passed as key/value pairs. The following options are recognized: =over =item maxlength => $num How much of the content to show. The default is 512. Set this to 0 for unlimited. If the content is longer then the string is chopped at the limit and the string "...\n(### more bytes not shown)" appended. =item no_content => $str Replaces the "(no content)" marker. =item prefix => $str A string that will be prefixed to each line of the dump. =back =back All methods unknown to C<HTTP::Message> itself are delegated to the C<HTTP::Headers> object that is part of every message. This allows convenient access to these methods. Refer to L<HTTP::Headers> for details of these methods: $mess->header( $field => $val ) $mess->push_header( $field => $val ) $mess->init_header( $field => $val ) $mess->remove_header( $field ) $mess->remove_content_headers $mess->header_field_names $mess->scan( \&doit ) $mess->date $mess->expires $mess->if_modified_since $mess->if_unmodified_since $mess->last_modified $mess->content_type $mess->content_encoding $mess->content_length $mess->content_language $mess->title $mess->user_agent $mess->server $mess->from $mess->referer $mess->www_authenticate $mess->authorization $mess->proxy_authorization $mess->authorization_basic $mess->proxy_authorization_basic =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ #ABSTRACT: HTTP style message (base class) PK ! K=�� � HTTP/Headers/Util.pmnu �[��� package HTTP::Headers::Util; use strict; use warnings; our $VERSION = '6.36'; use Exporter 5.57 'import'; our @EXPORT_OK=qw(split_header_words _split_header_words join_header_words); sub split_header_words { my @res = &_split_header_words; for my $arr (@res) { for (my $i = @$arr - 2; $i >= 0; $i -= 2) { $arr->[$i] = lc($arr->[$i]); } } return @res; } sub _split_header_words { my(@val) = @_; my @res; for (@val) { my @cur; while (length) { if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute' push(@cur, $1); # a quoted value if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) { my $val = $1; $val =~ s/\\(.)/$1/g; push(@cur, $val); # some unquoted value } elsif (s/^\s*=\s*([^;,\s]*)//) { my $val = $1; $val =~ s/\s+$//; push(@cur, $val); # no value, a lone token } else { push(@cur, undef); } } elsif (s/^\s*,//) { push(@res, [@cur]) if @cur; @cur = (); } elsif (s/^\s*;// || s/^\s+// || s/^=//) { # continue } else { die "This should not happen: '$_'"; } } push(@res, \@cur) if @cur; } @res; } sub join_header_words { @_ = ([@_]) if @_ && !ref($_[0]); my @res; for (@_) { my @cur = @$_; my @attr; while (@cur) { my $k = shift @cur; my $v = shift @cur; if (defined $v) { if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) { $v =~ s/([\"\\])/\\$1/g; # escape " and \ $k .= qq(="$v"); } else { # token $k .= "=$v"; } } push(@attr, $k); } push(@res, join("; ", @attr)) if @attr; } join(", ", @res); } 1; =pod =encoding UTF-8 =head1 NAME HTTP::Headers::Util - Header value parsing utility functions =head1 VERSION version 6.36 =head1 SYNOPSIS use HTTP::Headers::Util qw(split_header_words); @values = split_header_words($h->header("Content-Type")); =head1 DESCRIPTION This module provides a few functions that helps parsing and construction of valid HTTP header values. None of the functions are exported by default. The following functions are available: =over 4 =item split_header_words( @header_values ) This function will parse the header values given as argument into a list of anonymous arrays containing key/value pairs. The function knows how to deal with ",", ";" and "=" as well as quoted values after "=". A list of space separated tokens are parsed as if they were separated by ";". If the @header_values passed as argument contains multiple values, then they are treated as if they were a single value separated by comma ",". This means that this function is useful for parsing header fields that follow this syntax (BNF as from the HTTP/1.1 specification, but we relax the requirement for tokens). headers = #header header = (token | parameter) *( [";"] (token | parameter)) token = 1*<any CHAR except CTLs or separators> separators = "(" | ")" | "<" | ">" | "@" | "," | ";" | ":" | "\" | <"> | "/" | "[" | "]" | "?" | "=" | "{" | "}" | SP | HT quoted-string = ( <"> *(qdtext | quoted-pair ) <"> ) qdtext = <any TEXT except <">> quoted-pair = "\" CHAR parameter = attribute "=" value attribute = token value = token | quoted-string Each I<header> is represented by an anonymous array of key/value pairs. The keys will be all be forced to lower case. The value for a simple token (not part of a parameter) is C<undef>. Syntactically incorrect headers will not necessarily be parsed as you would want. This is easier to describe with some examples: split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz'); split_header_words('text/html; charset="iso-8859-1"'); split_header_words('Basic realm="\\"foo\\\\bar\\""'); will return [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ] ['text/html' => undef, charset => 'iso-8859-1'] [basic => undef, realm => "\"foo\\bar\""] If you don't want the function to convert tokens and attribute keys to lower case you can call it as C<_split_header_words> instead (with a leading underscore). =item join_header_words( @arrays ) This will do the opposite of the conversion done by split_header_words(). It takes a list of anonymous arrays as arguments (or a list of key/value pairs) and produces a single header value. Attribute values are quoted if needed. Example: join_header_words(["text/plain" => undef, charset => "iso-8859/1"]); join_header_words("text/plain" => undef, charset => "iso-8859/1"); will both return the string: text/plain; charset="iso-8859/1" =back =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ #ABSTRACT: Header value parsing utility functions PK ! �-�y. . HTTP/Headers/Auth.pmnu �[��� package HTTP::Headers::Auth; use strict; use warnings; our $VERSION = '6.36'; use HTTP::Headers; package HTTP::Headers; BEGIN { # we provide a new (and better) implementations below undef(&www_authenticate); undef(&proxy_authenticate); } require HTTP::Headers::Util; sub _parse_authenticate { my @ret; for (HTTP::Headers::Util::split_header_words(@_)) { if (!defined($_->[1])) { # this is a new auth scheme push(@ret, shift(@$_) => {}); shift @$_; } if (@ret) { # this a new parameter pair for the last auth scheme while (@$_) { my $k = shift @$_; my $v = shift @$_; $ret[-1]{$k} = $v; } } else { # something wrong, parameter pair without any scheme seen # IGNORE } } @ret; } sub _authenticate { my $self = shift; my $header = shift; my @old = $self->_header($header); if (@_) { $self->remove_header($header); my @new = @_; while (@new) { my $a_scheme = shift(@new); if ($a_scheme =~ /\s/) { # assume complete valid value, pass it through $self->push_header($header, $a_scheme); } else { my @param; if (@new) { my $p = $new[0]; if (ref($p) eq "ARRAY") { @param = @$p; shift(@new); } elsif (ref($p) eq "HASH") { @param = %$p; shift(@new); } } my $val = ucfirst(lc($a_scheme)); if (@param) { my $sep = " "; while (@param) { my $k = shift @param; my $v = shift @param; if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") { # must quote the value $v =~ s,([\\\"]),\\$1,g; $v = qq("$v"); } $val .= "$sep$k=$v"; $sep = ", "; } } $self->push_header($header, $val); } } } return unless defined wantarray; wantarray ? _parse_authenticate(@old) : join(", ", @old); } sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) } sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) } 1; __END__ =pod =encoding UTF-8 =head1 NAME HTTP::Headers::Auth =head1 VERSION version 6.36 =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut PK ! ����� � HTTP/Headers/ETag.pmnu �[��� package HTTP::Headers::ETag; use strict; use warnings; our $VERSION = '6.36'; require HTTP::Date; require HTTP::Headers; package HTTP::Headers; sub _etags { my $self = shift; my $header = shift; my @old = _split_etag_list($self->_header($header)); if (@_) { $self->_header($header => join(", ", _split_etag_list(@_))); } wantarray ? @old : join(", ", @old); } sub etag { shift->_etags("ETag", @_); } sub if_match { shift->_etags("If-Match", @_); } sub if_none_match { shift->_etags("If-None-Match", @_); } sub if_range { # Either a date or an entity-tag my $self = shift; my @old = $self->_header("If-Range"); if (@_) { my $new = shift; if (!defined $new) { $self->remove_header("If-Range"); } elsif ($new =~ /^\d+$/) { $self->_date_header("If-Range", $new); } else { $self->_etags("If-Range", $new); } } return unless defined(wantarray); for (@old) { my $t = HTTP::Date::str2time($_); $_ = $t if $t; } wantarray ? @old : join(", ", @old); } # Split a list of entity tag values. The return value is a list # consisting of one element per entity tag. Suitable for parsing # headers like C<If-Match>, C<If-None-Match>. You might even want to # use it on C<ETag> and C<If-Range> entity tag values, because it will # normalize them to the common form. # # entity-tag = [ weak ] opaque-tag # weak = "W/" # opaque-tag = quoted-string sub _split_etag_list { my(@val) = @_; my @res; for (@val) { while (length) { my $weak = ""; $weak = "W/" if s,^\s*[wW]/,,; my $etag = ""; if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) { push(@res, "$weak$1"); } elsif (s/^\s*,//) { push(@res, qq(W/"")) if $weak; } elsif (s/^\s*([^,\s]+)//) { $etag = $1; $etag =~ s/([\"\\])/\\$1/g; push(@res, qq($weak"$etag")); } elsif (s/^\s+// || !length) { push(@res, qq(W/"")) if $weak; } else { die "This should not happen: '$_'"; } } } @res; } 1; __END__ =pod =encoding UTF-8 =head1 NAME HTTP::Headers::ETag =head1 VERSION version 6.36 =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut PK ! h�{�%. %. HTTP/Config.pmnu �[��� package HTTP::Config; use strict; use warnings; our $VERSION = '6.36'; use URI; sub new { my $class = shift; return bless [], $class; } sub entries { my $self = shift; @$self; } sub empty { my $self = shift; not @$self; } sub add { if (@_ == 2) { my $self = shift; push(@$self, shift); return; } my($self, %spec) = @_; push(@$self, \%spec); return; } sub find2 { my($self, %spec) = @_; my @found; my @rest; ITEM: for my $item (@$self) { for my $k (keys %spec) { no warnings 'uninitialized'; if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) { push(@rest, $item); next ITEM; } } push(@found, $item); } return \@found unless wantarray; return \@found, \@rest; } sub find { my $self = shift; my $f = $self->find2(@_); return @$f if wantarray; return $f->[0]; } sub remove { my($self, %spec) = @_; my($removed, $rest) = $self->find2(%spec); @$self = @$rest if @$removed; return @$removed; } my %MATCH = ( m_scheme => sub { my($v, $uri) = @_; return $uri->_scheme eq $v; # URI known to be canonical }, m_secure => sub { my($v, $uri) = @_; my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https"; return $secure == !!$v; }, m_host_port => sub { my($v, $uri) = @_; return unless $uri->can("host_port"); return $uri->host_port eq $v, 7; }, m_host => sub { my($v, $uri) = @_; return unless $uri->can("host"); return $uri->host eq $v, 6; }, m_port => sub { my($v, $uri) = @_; return unless $uri->can("port"); return $uri->port eq $v; }, m_domain => sub { my($v, $uri) = @_; return unless $uri->can("host"); my $h = $uri->host; $h = "$h.local" unless $h =~ /\./; $v = ".$v" unless $v =~ /^\./; return length($v), 5 if substr($h, -length($v)) eq $v; return 0; }, m_path => sub { my($v, $uri) = @_; return unless $uri->can("path"); return $uri->path eq $v, 4; }, m_path_prefix => sub { my($v, $uri) = @_; return unless $uri->can("path"); my $path = $uri->path; my $len = length($v); return $len, 3 if $path eq $v; return 0 if length($path) <= $len; $v .= "/" unless $v =~ m,/\z,,; return $len, 3 if substr($path, 0, length($v)) eq $v; return 0; }, m_path_match => sub { my($v, $uri) = @_; return unless $uri->can("path"); return $uri->path =~ $v; }, m_uri__ => sub { my($v, $k, $uri) = @_; return unless $uri->can($k); return 1 unless defined $v; return $uri->$k eq $v; }, m_method => sub { my($v, $uri, $request) = @_; return $request && $request->method eq $v; }, m_proxy => sub { my($v, $uri, $request) = @_; return $request && ($request->{proxy} || "") eq $v; }, m_code => sub { my($v, $uri, $request, $response) = @_; $v =~ s/xx\z//; return unless $response; return length($v), 2 if substr($response->code, 0, length($v)) eq $v; }, m_media_type => sub { # for request too?? my($v, $uri, $request, $response) = @_; return unless $response; return 1, 1 if $v eq "*/*"; my $ct = $response->content_type; return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,; return 3, 1 if $v eq "html" && $response->content_is_html; return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml; return 10, 1 if $v eq $ct; return 0; }, m_header__ => sub { my($v, $k, $uri, $request, $response) = @_; return unless $request; my $req_header = $request->header($k); return 1 if defined($req_header) && $req_header eq $v; if ($response) { my $res_header = $response->header($k); return 1 if defined($res_header) && $res_header eq $v; } return 0; }, m_response_attr__ => sub { my($v, $k, $uri, $request, $response) = @_; return unless $response; return 1 if !defined($v) && exists $response->{$k}; return 0 unless exists $response->{$k}; return 1 if $response->{$k} eq $v; return 0; }, ); sub matching { my $self = shift; if (@_ == 1) { if ($_[0]->can("request")) { unshift(@_, $_[0]->request); unshift(@_, undef) unless defined $_[0]; } unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical"); } my($uri, $request, $response) = @_; $uri = URI->new($uri) unless ref($uri); my @m; ITEM: for my $item (@$self) { my $order; for my $ikey (keys %$item) { my $mkey = $ikey; my $k; $k = $1 if $mkey =~ s/__(.*)/__/; if (my $m = $MATCH{$mkey}) { #print "$ikey $mkey\n"; my($c, $o); my @arg = ( defined($k) ? $k : (), $uri, $request, $response ); my $v = $item->{$ikey}; $v = [$v] unless ref($v) eq "ARRAY"; for (@$v) { ($c, $o) = $m->($_, @arg); #print " - $_ ==> $c $o\n"; last if $c; } next ITEM unless $c; $order->[$o || 0] += $c; } } $order->[7] ||= 0; $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order); push(@m, $item); } @m = sort { $b->{_order} cmp $a->{_order} } @m; delete $_->{_order} for @m; return @m if wantarray; return $m[0]; } sub add_item { my $self = shift; my $item = shift; return $self->add(item => $item, @_); } sub remove_items { my $self = shift; return map $_->{item}, $self->remove(@_); } sub matching_items { my $self = shift; return map $_->{item}, $self->matching(@_); } 1; =pod =encoding UTF-8 =head1 NAME HTTP::Config - Configuration for request and response objects =head1 VERSION version 6.36 =head1 SYNOPSIS use HTTP::Config; my $c = HTTP::Config->new; $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1); use HTTP::Request; my $request = HTTP::Request->new(GET => "http://www.example.com"); if (my @m = $c->matching($request)) { print "Yadayada\n" if $m[0]->{verbose}; } =head1 DESCRIPTION An C<HTTP::Config> object is a list of entries that can be matched against request or request/response pairs. Its purpose is to hold configuration data that can be looked up given a request or response object. Each configuration entry is a hash. Some keys specify matching to occur against attributes of request/response objects. Other keys can be used to hold user data. The following methods are provided: =over 4 =item $conf = HTTP::Config->new Constructs a new empty C<HTTP::Config> object and returns it. =item $conf->entries Returns the list of entries in the configuration object. In scalar context returns the number of entries. =item $conf->empty Return true if there are no entries in the configuration object. This is just a shorthand for C<< not $conf->entries >>. =item $conf->add( %matchspec, %other ) =item $conf->add( \%entry ) Adds a new entry to the configuration. You can either pass separate key/value pairs or a hash reference. =item $conf->remove( %spec ) Removes (and returns) the entries that have matches for all the key/value pairs in %spec. If %spec is empty this will match all entries; so it will empty the configuration object. =item $conf->matching( $uri, $request, $response ) =item $conf->matching( $uri ) =item $conf->matching( $request ) =item $conf->matching( $response ) Returns the entries that match the given $uri, $request and $response triplet. If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method. If called with a single $response object, then the request object is obtained by calling its 'request' method; and then the $uri is obtained as if a single $request was provided. The entries are returned with the most specific matches first. In scalar context returns the most specific match or C<undef> in none match. =item $conf->add_item( $item, %matchspec ) =item $conf->remove_items( %spec ) =item $conf->matching_items( $uri, $request, $response ) Wrappers that hides the entries themselves. =back =head2 Matching The following keys on a configuration entry specify matching. For all of these you can provide an array of values instead of a single value. The entry matches if at least one of the values in the array matches. Entries that require match against a response object attribute will never match unless a response object was provided. =over =item m_scheme => $scheme Matches if the URI uses the specified scheme; e.g. "http". =item m_secure => $bool If $bool is TRUE; matches if the URI uses a secure scheme. If $bool is FALSE; matches if the URI does not use a secure scheme. An example of a secure scheme is "https". =item m_host_port => "$hostname:$port" Matches if the URI's host_port method return the specified value. =item m_host => $hostname Matches if the URI's host method returns the specified value. =item m_port => $port Matches if the URI's port method returns the specified value. =item m_domain => ".$domain" Matches if the URI's host method return a value that within the given domain. The hostname "www.example.com" will for instance match the domain ".com". =item m_path => $path Matches if the URI's path method returns the specified value. =item m_path_prefix => $path Matches if the URI's path is the specified path or has the specified path as prefix. =item m_path_match => $Regexp Matches if the regular expression matches the URI's path. Eg. qr/\.html$/. =item m_method => $method Matches if the request method matches the specified value. Eg. "GET" or "POST". =item m_code => $digit =item m_code => $status_code Matches if the response status code matches. If a single digit is specified; matches for all response status codes beginning with that digit. =item m_proxy => $url Matches if the request is to be sent to the given Proxy server. =item m_media_type => "*/*" =item m_media_type => "text/*" =item m_media_type => "html" =item m_media_type => "xhtml" =item m_media_type => "text/html" Matches if the response media type matches. With a value of "html" matches if $response->content_is_html returns TRUE. With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE. =item m_uri__I<$method> => undef Matches if the URI object provides the method. =item m_uri__I<$method> => $string Matches if the URI's $method method returns the given value. =item m_header__I<$field> => $string Matches if either the request or the response have a header $field with the given value. =item m_response_attr__I<$key> => undef =item m_response_attr__I<$key> => $string Matches if the response object has that key, or the entry has the given value. =back =head1 SEE ALSO L<URI>, L<HTTP::Request>, L<HTTP::Response> =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ #ABSTRACT: Configuration for request and response objects PK ! +z DebianLinux.pmnu �[��� # Copyright 2011 Ben Hutchings # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA package DebianLinux; use strict; use warnings; use POSIX qw(uname); use FileHandle; BEGIN { use Exporter (); our @ISA = qw(Exporter); our @EXPORT_OK = qw(version_cmp image_stem image_list read_kernelimg_conf); } sub version_split { # Split into numbers and non-numeric strings, but break the non- # numeric strings at hyphens my $version = shift; return $version =~ /(?:\d+|-?[^-\d]*)/g; } sub version_cmp { my ($left_ver, $right_ver) = @_; my @left_comp = version_split($left_ver); my @right_comp = version_split($right_ver); for (my $i = 0; ; $i++) { my $left = $left_comp[$i]; my $right = $right_comp[$i]; # Do the components indicate pre-releases? my $left_pre = defined($left) && $left =~ /^-(?:rc|trunk)$/; my $right_pre = defined($right) && $right =~ /^-(?:rc|trunk)$/; # Are the components numeric? my $left_num = defined($left) && $left =~ /^\d+/; my $right_num = defined($right) && $right =~ /^\d+/; # Pre-releases sort before anything, even end-of-string if ($left_pre or $right_pre) { return -1 if !$right_pre; return 1 if !$left_pre; } # End-of-string sorts before anything else. # End-of-string on both sides means equality. if (!defined($left) or !defined($right)) { return -1 if defined($right); return defined($left) || 0; } # Use numeric comparison if both sides numeric. # Otherwise use ASCII comparison. if ($left_num && $right_num) { return -1 if $left < $right; return 1 if $left > $right; } else { # Note that '.' > '-' thus 2.6.x.y > 2.6.x-z for any y, z. return -1 if $left lt $right; return 1 if $left gt $right; } } } # Find kernel image name stem for this architecture my $image_stem; if ((uname())[4] =~ /^(?:mips|parisc|powerpc|ppc)/) { $image_stem = 'vmlinux'; } else { $image_stem = 'vmlinuz'; } sub image_stem { return $image_stem; } sub image_list { my @results; my $prefix = "/boot/$image_stem-"; for (glob("$prefix*")) { push @results, [substr($_, length($prefix)), $_]; } return @results; } sub read_kernelimg_conf { my $conf_loc = shift || '/etc/kernel-img.conf'; my @bool_param = qw(do_symlinks link_in_boot no_symlinks); my @path_param = qw(image_dest); # These are still set in the jessie installer even though they # have no effect. Ignore them quietly. my @quiet_param = qw(do_bootloader do_initrd); # These are used only by kernel-package, and are not relevant to # anything that linux-base does. Ignore them quietly. push @quiet_param, qw(clobber_modules force_build_link relink_build_link relink_src_link silent_modules warn_reboot); # Initialise configuration to defaults my $conf = { do_symlinks => 1, image_dest => '/', link_in_boot => 1, no_symlinks => 0, }; if (my $fh = new FileHandle($conf_loc, 'r')) { while (<$fh>) { # Delete line endings, comments and blank lines chomp; s/\#.*$//g; next if /^\s*$/; # Historically this was done by matching against one # (path) or two (bool) regexps per parameter, with no # attempt to ensure that each line matched one. We now # warn about syntax errors, but for backward compatibility # we never treat them as fatal. # Parse into name = value if (!/^\s*(\w+)\s*=\s*(.*)/) { print STDERR "$conf_loc:$.: W: ignoring line with syntax error\n"; next; } my ($name, $value) = (lc($1), $2); # Parse value according to expected type if (grep({$_ eq $name} @bool_param)) { if ($value =~ /^(?:no|false|0)\s*$/i) { $conf->{$name} = 0; } elsif ($value =~ /^(?:yes|true|1)\s*$/i) { $conf->{$name} = 1; } else { print STDERR "$conf_loc:$.: W: ignoring invalid value for $name\n"; } } elsif (grep({$_ eq $name} @path_param)) { # Only one space-separated word is supported $value =~ /^(\S*)(.*)/; ($conf->{$name}, my $excess) = ($1, $2); if ($excess =~ /\S/) { print STDERR "$conf_loc:$.: W: ignoring excess values for $name\n"; } } elsif (grep({$_ eq $name} @quiet_param)) { ; } else { print STDERR "$conf_loc:$.: W: ignoring unknown parameter $name\n"; } } $fh->close(); } # This is still set (to 0) by default in jessie so we should only # warn if the default is changed if ($conf->{no_symlinks}) { print STDERR "$conf_loc: W: ignoring no_symlinks; only symlinks are supported\n"; } delete $conf->{no_symlinks}; if ($conf->{link_in_boot}) { $conf->{image_dest} = '/boot'; } delete $conf->{link_in_boot}; return $conf; } 1; PK ! Ӭ�ӯ � & Debconf/Element/Noninteractive/Note.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Noninteractive::Note; use strict; use base qw(Debconf::Element::Noninteractive); 1 PK ! !���� � * Debconf/Element/Noninteractive/Password.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Noninteractive::Password; use strict; use base qw(Debconf::Element::Noninteractive); 1 PK ! }V�� * Debconf/Element/Noninteractive/Progress.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Noninteractive::Progress; use strict; use base qw(Debconf::Element::Noninteractive); sub start { } sub set { return 1; } sub info { return 1; } sub stop { } 1; PK ! �� Z Z ( Debconf/Element/Noninteractive/Select.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Noninteractive::Select; use strict; use base qw(Debconf::Element::Noninteractive); sub show { my $this=shift; $this->question->template->i18n(''); my @choices=$this->question->choices_split; $this->question->template->i18n(1); my $value=$this->question->value; $value='' unless defined $value; my $inlist=0; map { $inlist=1 if $_ eq $value } @choices; if (! $inlist) { if (@choices) { $this->value($choices[0]); } else { $this->value(''); } } else { $this->value($value); } } 1 PK ! y6 � � & Debconf/Element/Noninteractive/Text.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Noninteractive::Text; use strict; use base qw(Debconf::Element::Noninteractive); sub show { my $this=shift; $this->value(''); } 1 PK ! cb�� � ) Debconf/Element/Noninteractive/Boolean.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Noninteractive::Boolean; use strict; use base qw(Debconf::Element::Noninteractive); 1 PK ! 0� � � - Debconf/Element/Noninteractive/Multiselect.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Noninteractive::Multiselect; use strict; use base qw(Debconf::Element::Noninteractive); 1 PK ! �w� � ( Debconf/Element/Noninteractive/String.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Noninteractive::String; use strict; use base qw(Debconf::Element::Noninteractive); 1 PK ! ��Ҝ� � ' Debconf/Element/Noninteractive/Error.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Noninteractive::Error; use strict; use Text::Wrap; use Debconf::Gettext; use Debconf::Config; use Debconf::Log ':all'; use Debconf::Path; use base qw(Debconf::Element::Noninteractive); sub show { my $this=shift; if ($this->question->flag('seen') ne 'true') { $this->sendmail(gettext("Debconf is not confident this error message was displayed, so it mailed it to you.")); $this->frontend->display($this->question->description."\n\n". $this->question->extended_description."\n"); } $this->value(''); } sub sendmail { my $this=shift; my $footer=shift; return unless length Debconf::Config->admin_email; if (Debconf::Path::find("mail")) { debug user => "mailing a note"; my $title=gettext("Debconf").": ". $this->frontend->title." -- ". $this->question->description; unless (open(MAIL, "|-")) { # child exec("mail", "-s", $title, Debconf::Config->admin_email) or return ''; } my $old_columns=$Text::Wrap::columns; $Text::Wrap::columns=75; if ($this->question->extended_description ne '') { print MAIL wrap('', '', $this->question->extended_description); } else { print MAIL wrap('', '', $this->question->description); } print MAIL "\n\n"; my $hostname=`hostname -f 2>/dev/null`; if (! defined $hostname) { $hostname="unknown system"; } print MAIL "-- \n", sprintf(gettext("Debconf, running at %s"), $hostname, "\n"); print MAIL "[ ", wrap('', '', $footer), " ]\n" if $footer; close MAIL or return ''; $Text::Wrap::columns=$old_columns; $this->question->flag('seen', 'true'); return 1; } } 1 PK ! qzIw� � Debconf/Element/Web/Note.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Web::Note; use strict; use base qw(Debconf::Element::Web::Text); 1 PK ! M�G�� � Debconf/Element/Web/Password.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Web::Password; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $_=$this->question->extended_description; s/\n/\n<br>\n/g; $_.="\n<p>\n"; my $default=''; $default=$this->question->value if defined $this->question->value; my $id=$this->id; $_.="<b>".$this->question->description."</b><input type=password name=\"$id\" value=\"$default\">\n"; return $_; } 1 PK ! ]�p� � Debconf/Element/Web/Progress.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Web::Progress; use strict; use base qw(Debconf::Element); sub start { } sub set { return 1; } sub info { return 1; } sub stop { } 1; PK ! 6"��m m Debconf/Element/Web/Select.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Web::Select; use strict; use base qw(Debconf::Element::Select); sub show { my $this=shift; $_=$this->question->extended_description; s/\n/\n<br>\n/g; $_.="\n<p>\n"; my $default=$this->translate_default; my $id=$this->id; $_.="<b>".$this->question->description."</b>\n<select name=\"$id\">\n"; my $c=0; foreach my $x ($this->question->choices_split) { if ($x ne $default) { $_.="<option value=".$c++.">$x\n"; } else { $_.="<option value=".$c++." selected>$x\n"; } } $_.="</select>\n"; return $_; } sub value { my $this=shift; return $this->SUPER::value() unless @_; my $value=shift; $this->question->template->i18n(''); my @choices=$this->question->choices_split; $this->question->template->i18n(1); $this->SUPER::value($choices[$value]); } 1 PK ! Q��@; ; Debconf/Element/Web/Text.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Web::Text; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $_=$this->question->extended_description; s/\n/\n<br>\n/g; $_.="\n<p>\n"; return "<b>".$this->question->description."</b>$_<p>"; } 1 PK ! ��]� � Debconf/Element/Web/Boolean.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Web::Boolean; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $_=$this->question->extended_description; s/\n/\n<br>\n/g; $_.="\n<p>\n"; my $default=''; $default=$this->question->value if defined $this->question->value; my $id=$this->id; $_.="<input type=checkbox name=\"$id\"". ($default eq 'true' ? ' checked' : ''). ">\n<b>". $this->question->description."</b>"; return $_; } sub value { my $this=shift; return $this->SUPER::value() unless @_; my $value=shift; $this->SUPER::value($value eq 'on' ? 'true' : 'false'); } 1 PK ! ��W� � " Debconf/Element/Web/Multiselect.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Web::Multiselect; use strict; use base qw(Debconf::Element::Multiselect); sub show { my $this=shift; $_=$this->question->extended_description; s/\n/\n<br>\n/g; $_.="\n<p>\n"; my %value = map { $_ => 1 } $this->translate_default; my $id=$this->id; $_.="<b>".$this->question->description."</b>\n<select multiple name=\"$id\">\n"; my $c=0; foreach my $x ($this->question->choices_split) { if (! $value{$x}) { $_.="<option value=".$c++.">$x\n"; } else { $_.="<option value=".$c++." selected>$x\n"; } } $_.="</select>\n"; return $_; } sub value { my $this=shift; return $this->SUPER::value() unless @_; my @values=@_; $this->question->template->i18n(''); my @choices=$this->question->choices_split; $this->question->template->i18n(1); $this->SUPER::value(join(', ', $this->order_values(map { $choices[$_] } @values))); } 1 PK ! �� � Debconf/Element/Web/String.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Web::String; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $_=$this->question->extended_description; s/\n/\n<br>\n/g; $_.="\n<p>\n"; my $default=''; $default=$this->question->value if defined $this->question->value; my $id=$this->id; $_.="<b>".$this->question->description."</b><input name=\"$id\" value=\"$default\">\n"; return $_; } 1 PK ! <f� � Debconf/Element/Web/Error.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Web::Error; use strict; use base qw(Debconf::Element::Web::Text); 1 PK ! ��߾ � Debconf/Element/Select.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Select; use strict; use Debconf::Log ':all'; use Debconf::Gettext; use base qw(Debconf::Element); use Debconf::Encoding qw(to_Unicode); sub visible { my $this=shift; my @choices=$this->question->choices_split; if (@choices > 1) { return 1; } else { debug 'developer' => 'Not displaying select list '. $this->question->name.' with '. (@choices+0).' choice'.((@choices == 0) ? 's' : ''); return 0; } } sub translate_default { my $this=shift; my @choices=$this->question->choices_split; $this->question->template->i18n(''); my @choices_c=$this->question->choices_split; $this->question->template->i18n(1); my $c_default=''; $c_default=$this->question->value if defined $this->question->value; foreach (my $x=0; $x <= $#choices; $x++) { return $choices[$x] if $choices_c[$x] eq $c_default; } return ''; } sub translate_to_C { my $this=shift; my $value=shift; my @choices=$this->question->choices_split; $this->question->template->i18n(''); my @choices_c=$this->question->choices_split; $this->question->template->i18n(1); for (my $x=0; $x <= $#choices; $x++) { return $choices_c[$x] if $choices[$x] eq $value; } debug developer => sprintf(gettext("Input value, \"%s\" not found in C choices! This should never happen. Perhaps the templates were incorrectly localized."), $value); return ''; } sub translate_to_C_uni { my $this=shift; my $value=shift; my @choices=$this->question->choices_split; $this->question->template->i18n(''); my @choices_c=$this->question->choices_split; $this->question->template->i18n(1); for (my $x=0; $x <= $#choices; $x++) { return $choices_c[$x] if to_Unicode($choices[$x]) eq $value; } debug developer => sprintf(gettext("Input value, \"%s\" not found in C choices! This should never happen. Perhaps the templates were incorrectly localized."), $value); return ''; } 1 PK ! l�5�� � Debconf/Element/Editor/Note.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Editor::Note; use strict; use base qw(Debconf::Element::Editor::Text); 1 PK ! ���ë � " Debconf/Element/Editor/Password.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Editor::Password; use strict; use base qw(Debconf::Element::Editor::String); 1 PK ! �m�� � " Debconf/Element/Editor/Progress.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Editor::Progress; use strict; use base qw(Debconf::Element); sub start { } sub set { return 1; } sub info { return 1; } sub stop { } 1; PK ! �6�B B Debconf/Element/Editor/Select.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Editor::Select; use strict; use Debconf::Gettext; use base qw(Debconf::Element::Select); sub show { my $this=shift; my $default=$this->translate_default; my @choices=$this->question->choices_split; $this->frontend->comment($this->question->extended_description."\n\n". "(".gettext("Choices").": ".join(", ", @choices).")\n". $this->question->description."\n"); $this->frontend->item($this->question->name, $default); } sub value { my $this=shift; return $this->SUPER::value() unless @_; my $value=shift; my %valid=map { $_ => 1 } $this->question->choices_split; if ($valid{$value}) { return $this->SUPER::value($this->translate_to_C($value)); } else { return $this->SUPER::value($this->question->value); } } 1 PK ! �t�C< < Debconf/Element/Editor/Text.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Editor::Text; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $this->frontend->comment($this->question->extended_description."\n\n". $this->question->description."\n\n"); $this->value(''); } 1 PK ! � ��� � ! Debconf/Element/Editor/Boolean.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Editor::Boolean; use strict; use Debconf::Gettext; use base qw(Debconf::Element); sub show { my $this=shift; $this->frontend->comment($this->question->extended_description."\n\n". "(".gettext("Choices").": ".join(", ", gettext("yes"), gettext("no")).")\n". $this->question->description."\n"); my $default=''; $default=$this->question->value if defined $this->question->value; if ($default eq 'true') { $default=gettext("yes"); } elsif ($default eq 'false') { $default=gettext("no"); } $this->frontend->item($this->question->name, $default); } sub value { my $this=shift; return $this->SUPER::value() unless @_; my $value=shift; if ($value eq 'yes' || $value eq gettext("yes")) { return $this->SUPER::value('true'); } elsif ($value eq 'no' || $value eq gettext("no")) { return $this->SUPER::value('false'); } else { return $this->SUPER::value($this->question->value); } } 1 PK ! � � � % Debconf/Element/Editor/Multiselect.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Editor::Multiselect; use strict; use Debconf::Gettext; use base qw(Debconf::Element::Multiselect); sub show { my $this=shift; my @choices=$this->question->choices_split; $this->frontend->comment($this->question->extended_description."\n\n". "(".gettext("Choices").": ".join(", ", @choices).")\n". gettext("(Enter zero or more items separated by a comma followed by a space (', ').)")."\n". $this->question->description."\n"); $this->frontend->item($this->question->name, join ", ", $this->translate_default); } sub value { my $this=shift; return $this->SUPER::value() unless @_; my @values=split(',\s+', shift); my %valid=map { $_ => 1 } $this->question->choices_split; $this->SUPER::value(join(', ', $this->order_values( map { $this->translate_to_C($_) } grep { $valid{$_} } @values))); } 1 PK ! F%�s� � Debconf/Element/Editor/String.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Editor::String; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $this->frontend->comment($this->question->extended_description."\n\n". $this->question->description."\n"); my $default=''; $default=$this->question->value if defined $this->question->value; $this->frontend->item($this->question->name, $default); } 1 PK ! �� � Debconf/Element/Editor/Error.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Editor::Error; use strict; use base qw(Debconf::Element::Editor::Text); 1 PK ! UJ d4 4 Debconf/Element/Gnome/Note.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Gnome::Note; use strict; use Debconf::Gettext; use Gtk3; use utf8; use Debconf::Encoding qw(to_Unicode); use Debconf::Element::Noninteractive::Note; use base qw(Debconf::Element::Gnome); sub init { my $this=shift; my $extended_description = to_Unicode($this->question->extended_description); $this->SUPER::init(@_); $this->multiline(1); $this->fill(1); $this->expand(1); $this->widget(Gtk3::HBox->new(0, 0)); my $text = Gtk3::TextView->new(); my $textbuffer = $text->get_buffer; $text->show; $text->set_wrap_mode ("word"); $text->set_editable (0); my $scrolled_window = Gtk3::ScrolledWindow->new(); $scrolled_window->show; $scrolled_window->set_policy('automatic', 'automatic'); $scrolled_window->set_shadow_type('in'); $scrolled_window->add ($text); $this->widget->show; $this->widget->pack_start($scrolled_window, 1, 1, 0); $textbuffer->set_text($extended_description); $this->widget->show; $this->adddescription; $this->addwidget($this->widget); } 1 PK ! X��D D ! Debconf/Element/Gnome/Password.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Gnome::Password; use strict; use Gtk3; use utf8; use base qw(Debconf::Element::Gnome); sub init { my $this=shift; $this->SUPER::init(@_); $this->adddescription; $this->widget(Gtk3::Entry->new); $this->widget->show; $this->widget->set_visibility(0); $this->addwidget($this->widget); $this->tip( $this->widget ); $this->addhelp; } sub value { my $this=shift; my $text = $this->widget->get_chars(0, -1); $text = $this->question->value if $text eq ''; return $text; } 1 PK ! ihE Y Y ! Debconf/Element/Gnome/Progress.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Gnome::Progress; use strict; use Gtk3; use utf8; use Debconf::Encoding qw(to_Unicode); use base qw(Debconf::Element::Gnome); sub _fraction { my $this=shift; return (($this->progress_cur() - $this->progress_min()) / ($this->progress_max() - $this->progress_min())); } sub start { my $this=shift; my $description=to_Unicode($this->question->description); my $frontend=$this->frontend; $this->SUPER::init(@_); $this->multiline(1); $this->expand(1); $frontend->title($description); $this->widget(Gtk3::ProgressBar->new()); $this->widget->show; $this->widget->set_text(' '); $this->addwidget($this->widget); $this->addhelp; } sub set { my $this=shift; my $value=shift; $this->progress_cur($value); $this->widget->set_fraction($this->_fraction); return 1; } sub info { my $this=shift; my $question=shift; $this->widget->set_text(to_Unicode($question->description)); return 1; } sub stop { my $this=shift; my $frontend=$this->frontend; $frontend->title($frontend->requested_title); } 1; PK ! �]�� � Debconf/Element/Gnome/Select.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Gnome::Select; use strict; use Gtk3; use utf8; use Debconf::Encoding qw(to_Unicode); use base qw(Debconf::Element::Gnome Debconf::Element::Select); sub init { my $this=shift; my $default=$this->translate_default; my @choices=$this->question->choices_split; $this->SUPER::init(@_); $this->widget(Gtk3::ComboBoxText->new); $this->widget->show; foreach my $choice (@choices) { $this->widget->append_text(to_Unicode($choice)); } $this->widget->set_active(0); for (my $choice=0; $choice <= $#choices; $choice++) { if ($choices[$choice] eq $default) { $this->widget->set_active($choice); last; } } $this->adddescription; $this->addwidget($this->widget); $this->tip( $this->widget ); $this->addhelp; } sub value { my $this=shift; return $this->translate_to_C_uni($this->widget->get_active_text); } *visible = \&Debconf::Element::Select::visible; 1 PK ! � " " Debconf/Element/Gnome/Text.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Gnome::Text; use strict; use Debconf::Gettext; use utf8; use base qw(Debconf::Element::Gnome); sub init { my $this=shift; $this->SUPER::init(@_); $this->adddescription; # yeah, that's all } 1 PK ! xP�֬ � Debconf/Element/Gnome/Boolean.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Gnome::Boolean; use strict; use Gtk3; use utf8; use Debconf::Encoding qw(to_Unicode); use base qw(Debconf::Element::Gnome); sub init { my $this=shift; my $description=to_Unicode($this->question->description); $this->SUPER::init(@_); $this->widget(Gtk3::CheckButton->new($description)); $this->widget->show; $this->widget->set_active(($this->question->value eq 'true') ? 1 : 0); $this->addwidget($this->widget); $this->tip( $this->widget ); $this->addhelp; } sub value { my $this=shift; if ($this->widget->get_active) { return "true"; } else { return "false"; } } 1 PK ! �t�� � $ Debconf/Element/Gnome/Multiselect.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Gnome::Multiselect; use strict; use Gtk3; use utf8; use Debconf::Encoding qw(to_Unicode); use base qw(Debconf::Element::Gnome Debconf::Element::Multiselect); use constant SELECTED_COLUMN => 0; use constant CHOICES_COLUMN => 1; sub init { my $this=shift; my @choices = map { to_Unicode($_) } $this->question->choices_split; my %default=map { to_Unicode($_) => 1 } $this->translate_default; $this->SUPER::init(@_); $this->multiline(1); $this->adddescription; $this->widget(Gtk3::ScrolledWindow->new); $this->widget->show; $this->widget->set_policy('automatic', 'automatic'); my $list_store = Gtk3::ListStore->new('Glib::Boolean', 'Glib::String'); $this->list_view(Gtk3::TreeView->new($list_store)); $this->list_view->set_headers_visible(0); my $renderer_toggle = Gtk3::CellRendererToggle->new; $renderer_toggle->signal_connect(toggled => sub { my $path_string = $_[1]; my $model = $_[2]; my $iter = $model->get_iter_from_string($path_string); $model->set($iter, SELECTED_COLUMN, not $model->get($iter, SELECTED_COLUMN)); }, $list_store); $this->list_view->append_column( Gtk3::TreeViewColumn->new_with_attributes('Selected', $renderer_toggle, 'active', SELECTED_COLUMN)); $this->list_view->append_column( Gtk3::TreeViewColumn->new_with_attributes('Choices', Gtk3::CellRendererText->new, 'text', CHOICES_COLUMN)); $this->list_view->show; $this->widget->add($this->list_view); for (my $i=0; $i <= $#choices; $i++) { my $iter = $list_store->append(); $list_store->set($iter, CHOICES_COLUMN, $choices[$i]); if ($default{$choices[$i]}) { $list_store->set($iter, SELECTED_COLUMN, 1); } } $this->addwidget($this->widget); $this->tip($this->list_view); $this->addhelp; $this->fill(1); $this->expand(1); } sub value { my $this=shift; my $list_view = $this->list_view; my $list_store = $list_view->get_model(); my ($ret, $val); my @vals; $this->question->template->i18n(''); my @choices=$this->question->choices_split; $this->question->template->i18n(1); my $iter = $list_store->get_iter_first(); for (my $i=0; $i <= $#choices; $i++) { if ($list_store->get($iter, SELECTED_COLUMN)) { push @vals, $choices[$i]; } $list_store->iter_next($iter) or last; } return join(', ', $this->order_values(@vals)); } *visible = \&Debconf::Element::Multiselect::visible; 1 PK ! Y�KO� � Debconf/Element/Gnome/String.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Gnome::String; use strict; use Gtk3; use utf8; use Debconf::Encoding qw(to_Unicode); use base qw(Debconf::Element::Gnome); sub init { my $this=shift; $this->SUPER::init(@_); $this->widget(Gtk3::Entry->new); $this->widget->show; my $default=''; $default=$this->question->value if defined $this->question->value; $this->widget->set_text(to_Unicode($default)); $this->adddescription; $this->addwidget($this->widget); $this->tip( $this->widget ); $this->addhelp; } sub value { my $this=shift; return $this->widget->get_chars(0, -1); } 1 PK ! ��J� � Debconf/Element/Gnome/Error.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Gnome::Error; use strict; use Debconf::Gettext; use Gtk3; use utf8; use Debconf::Encoding qw(to_Unicode); use base qw(Debconf::Element::Gnome); sub init { my $this=shift; my $extended_description = to_Unicode($this->question->extended_description); $this->SUPER::init(@_); $this->multiline(1); $this->fill(1); $this->expand(1); $this->widget(Gtk3::HBox->new(0, 0)); my $image = Gtk3::Image->new_from_stock("gtk-dialog-error", "dialog"); $image->show; my $text = Gtk3::TextView->new(); my $textbuffer = $text->get_buffer; $text->show; $text->set_wrap_mode ("word"); $text->set_editable (0); my $scrolled_window = Gtk3::ScrolledWindow->new(); $scrolled_window->show; $scrolled_window->set_policy('automatic', 'automatic'); $scrolled_window->set_shadow_type('in'); $scrolled_window->add ($text); $this->widget->show; $this->widget->pack_start($image, 0, 0, 6); $this->widget->pack_start($scrolled_window, 1, 1, 0); $textbuffer->set_text($extended_description); $this->widget->show; $this->adddescription; $this->addwidget($this->widget); } 1 PK ! � 7 7 Debconf/Element/Gnome.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Gnome; use strict; use utf8; use Gtk3; use Debconf::Gettext; use Debconf::Encoding qw(to_Unicode); use base qw(Debconf::Element); sub init { my $this=shift; $this->hbox(Gtk3::VBox->new(0, 10)); $this->hline1(Gtk3::HBox->new(0, 10)); $this->hline1->show; $this->line1(Gtk3::VBox->new(0, 10)); $this->line1->show; $this->line1->pack_end ($this->hline1, 1, 1, 0); $this->hline2(Gtk3::HBox->new(0, 10)); $this->hline2->show; $this->line2(Gtk3::VBox->new(0, 10)); $this->line2->show; $this->line2->pack_end ($this->hline2, 1, 1, 0); $this->vbox(Gtk3::VBox->new(0, 5)); $this->vbox->pack_start($this->line1, 0, 0, 0); $this->vbox->pack_start($this->line2, 1, 1, 0); $this->vbox->show; $this->hbox->pack_start($this->vbox, 1, 1, 0); $this->hbox->show; $this->fill(0); $this->expand(0); $this->multiline(0); } sub addwidget { my $this=shift; my $widget=shift; if ($this->multiline == 0) { $this->hline1->pack_start($widget, 1, 1, 0); } else { $this->hline2->pack_start($widget, 1, 1, 0); } } sub adddescription { my $this=shift; my $description=to_Unicode($this->question->description); my $label=Gtk3::Label->new($description); $label->show; $this->line1->pack_start($label, 0, 0, 0); } sub addbutton { my $this=shift; my $text = shift; my $callback = shift; my $button = Gtk3::Button->new_with_mnemonic(to_Unicode($text)); $button->show; $button->signal_connect("clicked", $callback); my $vbox = Gtk3::VBox->new(0, 0); $vbox->show; $vbox->pack_start($button, 1, 0, 0); $this->hline1->pack_end($vbox, 0, 0, 0); } sub create_message_dialog { my $this = shift; my $type = shift; my $title = shift; my $text = shift; my $dialog = Gtk3::Dialog->new_with_buttons(to_Unicode($title), undef, "modal", "gtk-close", "close"); $dialog->set_border_width(3); my $hbox = Gtk3::HBox->new(0); $dialog->get_content_area->pack_start($hbox, 1, 1, 5); $hbox->show; my $alignment = Gtk3::Alignment->new(0.5, 0.0, 1.0, 0.0); $hbox->pack_start($alignment, 1, 1, 3); $alignment->show; my $image = Gtk3::Image->new_from_stock($type, "dialog"); $alignment->add($image); $image->show; my $label = Gtk3::Label->new(to_Unicode($text)); $label->set_line_wrap(1); $hbox->pack_start($label, 1, 1, 2); $label->show; $dialog->run; $dialog->destroy; } sub addhelp { my $this=shift; my $help=$this->question->extended_description; return unless length $help; $this->addbutton(gettext("_Help"), sub { $this->create_message_dialog("gtk-dialog-info", gettext("Help"), to_Unicode($help)); }); if (defined $this->tip ){ $this->tip->set_tooltip_text(to_Unicode($help)); } } sub value { my $this=shift; return ''; } 1 PK ! ��U�� � Debconf/Element/Multiselect.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Multiselect; use strict; use base qw(Debconf::Element::Select); sub order_values { my $this=shift; my %vals=map { $_ => 1 } @_; $this->question->template->i18n(''); my @ret=grep { $vals{$_} } $this->question->choices_split; $this->question->template->i18n(1); return @ret; } sub visible { my $this=shift; my @choices=$this->question->choices_split; return ($#choices >= 0); } sub translate_default { my $this=shift; my @choices=$this->question->choices_split; $this->question->template->i18n(''); my @choices_c=$this->question->choices_split; $this->question->template->i18n(1); my @ret; foreach my $c_default ($this->question->value_split) { foreach (my $x=0; $x <= $#choices; $x++) { push @ret, $choices[$x] if $choices_c[$x] eq $c_default; } } return @ret; } 1 PK ! �ۯJ J Debconf/Element/Dialog/Note.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Dialog::Note; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $this->frontend->showtext($this->question, $this->question->description."\n\n". $this->question->extended_description ); $this->value(''); } 1 PK ! H�Ce� � " Debconf/Element/Dialog/Password.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Dialog::Password; use strict; use base qw(Debconf::Element); sub show { my $this=shift; my ($text, $lines, $columns)= $this->frontend->makeprompt($this->question); my @params=('--passwordbox'); push @params, $this->frontend->dashsep if $this->frontend->dashsep; push @params, ($text, $lines + $this->frontend->spacer, $columns); my $ret=$this->frontend->showdialog($this->question, @params); if (! defined $ret || $ret eq '') { my $default=''; $default=$this->question->value if defined $this->question->value; $this->value($default); } else { $this->value($ret); } } 1 PK ! !���6 6 " Debconf/Element/Dialog/Progress.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Dialog::Progress; use strict; use base qw(Debconf::Element); sub _communicate { my $this=shift; my $data=shift; my $dialoginput = $this->frontend->dialog_input_wtr; print $dialoginput $data; } sub _percent { my $this=shift; use integer; return (($this->progress_cur() - $this->progress_min()) * 100 / ($this->progress_max() - $this->progress_min())); } sub start { my $this=shift; $this->frontend->title($this->question->description); my ($text, $lines, $columns); if (defined $this->_info) { ($text, $lines, $columns)=$this->frontend->sizetext($this->_info->description); } else { ($text, $lines, $columns)=$this->frontend->sizetext(' '); } if ($this->frontend->screenwidth - $this->frontend->columnspacer > $columns) { $columns = $this->frontend->screenwidth - $this->frontend->columnspacer; } my @params=('--gauge'); push @params, $this->frontend->dashsep if $this->frontend->dashsep; push @params, ($text, $lines + $this->frontend->spacer, $columns, $this->_percent); $this->frontend->startdialog($this->question, 1, @params); $this->_lines($lines); $this->_columns($columns); } sub set { my $this=shift; my $value=shift; $this->progress_cur($value); $this->_communicate($this->_percent . "\n"); return 1; } sub info { my $this=shift; my $question=shift; $this->_info($question); my ($text, $lines, $columns)=$this->frontend->sizetext($question->description); if ($lines > $this->_lines or $columns > $this->_columns) { $this->stop; $this->start; } $this->_communicate( sprintf("XXX\n%d\n%s\nXXX\n%d\n", $this->_percent, $text, $this->_percent)); return 1; } sub stop { my $this=shift; $this->frontend->waitdialog; $this->frontend->title($this->frontend->requested_title); } 1 PK ! ��/B� � Debconf/Element/Dialog/Select.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Dialog::Select; use strict; use base qw(Debconf::Element::Select); use Debconf::Encoding qw(width); use Debconf::Log qw(debug); sub show { my $this=shift; my ($text, $lines, $columns)= $this->frontend->makeprompt($this->question, -2); my $screen_lines=$this->frontend->screenheight - $this->frontend->spacer; my $default=$this->translate_default; my @params=(); my @choices=$this->question->choices_split; my $menu_height=$#choices + 1; if ($lines + $#choices + 2 >= $screen_lines) { $menu_height = $screen_lines - $lines - 4; } $lines=$lines + $menu_height + $this->frontend->spacer; my $c=1; my $selectspacer = $this->frontend->selectspacer; my %unellipsized; foreach (@choices) { my $choice = $this->frontend->ellipsize($_); if (exists $unellipsized{$choice}) { debug 'developer' => sprintf 'Ambiguous ellipsized choice "%s": "%s" or "%s". Overflow.', $choice, $unellipsized{$choice}, $_; $choice = $_; } $unellipsized{$choice} = $_; push @params, $choice, ''; if ($columns < width($choice) + $selectspacer) { $columns = width($choice) + $selectspacer; } } if ($this->frontend->dashsep) { unshift @params, $this->frontend->dashsep; } @params=('--default-item', $default, '--menu', $text, $lines, $columns, $menu_height, @params); my $value=$this->frontend->showdialog($this->question, @params); if (defined $value) { $this->value($this->translate_to_C($unellipsized{$value})); } else { my $default=''; $default=$this->question->value if defined $this->question->value; $this->value($default); } } 1 PK ! � 7�J J Debconf/Element/Dialog/Text.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Dialog::Text; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $this->frontend->showtext($this->question, $this->question->description."\n\n". $this->question->extended_description ); $this->value(''); } 1 PK ! ��h�� � ! Debconf/Element/Dialog/Boolean.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Dialog::Boolean; use strict; use base qw(Debconf::Element); sub show { my $this=shift; my @params=('--yesno'); push @params, $this->frontend->dashsep if $this->frontend->dashsep; push @params, $this->frontend->makeprompt($this->question, 1); if (defined $this->question->value && $this->question->value eq 'false') { unshift @params, '--defaultno'; } my ($ret, $value)=$this->frontend->showdialog($this->question, @params); if (defined $ret) { $this->value($ret eq 0 ? 'true' : 'false'); } else { my $default=''; $default=$this->question->value if defined $this->question->value; $this->value($default); } } 1 PK ! �XcA� � % Debconf/Element/Dialog/Multiselect.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Dialog::Multiselect; use strict; use base qw(Debconf::Element::Multiselect); use Debconf::Encoding qw(width); use Debconf::Log qw(debug); sub show { my $this=shift; my ($text, $lines, $columns)= $this->frontend->makeprompt($this->question, -2); my $screen_lines=$this->frontend->screenheight - $this->frontend->spacer; my @params=(); my @choices=$this->question->choices_split; my %value = map { $_ => 1 } $this->translate_default; my $menu_height=$#choices + 1; if ($lines + $#choices + 2 >= $screen_lines) { $menu_height = $screen_lines - $lines - 4; if ($menu_height < 3 && $#choices + 1 > 2) { $this->frontend->showtext($this->question, $this->question->extended_description); ($text, $lines, $columns)=$this->frontend->sizetext($this->question->description); $menu_height=$#choices + 1; if ($lines + $#choices + 2 >= $screen_lines) { $menu_height = $screen_lines - $lines - 4; } } } $lines=$lines + $menu_height + $this->frontend->spacer; my $selectspacer = $this->frontend->selectspacer; my $c=1; my %unellipsized; foreach (@choices) { my $choice = $this->frontend->ellipsize($_); if (exists $unellipsized{$choice}) { debug 'developer' => sprintf 'Ambiguous ellipsized choice "%s": "%s" or "%s". Overflow.', $choice, $unellipsized{$choice}, $_; $choice = $_; } $unellipsized{$choice} = $_; push @params, ($choice, ""); push @params, ($value{$_} ? 'on' : 'off'); if ($columns < width($choice) + $selectspacer) { $columns = width($choice) + $selectspacer; } } if ($this->frontend->dashsep) { unshift @params, $this->frontend->dashsep; } @params=('--separate-output', '--checklist', $text, $lines, $columns, $menu_height, @params); my $value=$this->frontend->showdialog($this->question, @params); if (defined $value) { $this->value(join(", ", $this->order_values( map { $this->translate_to_C($unellipsized{$_}) } split(/\n/, $value)))); } else { my $default=''; $default=$this->question->value if defined $this->question->value; $this->value($default); } } 1 PK ! ��5 Debconf/Element/Dialog/String.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Dialog::String; use strict; use base qw(Debconf::Element); sub show { my $this=shift; my ($text, $lines, $columns)= $this->frontend->makeprompt($this->question); my $default=''; $default=$this->question->value if defined $this->question->value; my @params=('--inputbox'); push @params, $this->frontend->dashsep if $this->frontend->dashsep; push @params, ($text, $lines + $this->frontend->spacer, $columns, $default); my $value=$this->frontend->showdialog($this->question, @params); if (defined $value) { $this->value($value); } else { my $default=''; $default=$this->question->value if defined $this->question->value; $this->value($default); } } 1 PK ! <_��K K Debconf/Element/Dialog/Error.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Dialog::Error; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $this->frontend->showtext($this->question, $this->question->description."\n\n". $this->question->extended_description ); $this->value(''); } 1 PK ! ���� � Debconf/Element/Teletype/Note.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Teletype::Note; use strict; use base qw(Debconf::Element); sub visible { my $this=shift; return (Debconf::Config->terse eq 'false'); } sub show { my $this=shift; $this->frontend->display($this->question->description."\n\n". $this->question->extended_description."\n"); $this->value(''); } 1 PK ! �Otu u $ Debconf/Element/Teletype/Password.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Teletype::Password; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $this->frontend->display( $this->question->extended_description."\n"); my $default=''; $default=$this->question->value if defined $this->question->value; my $value=$this->frontend->prompt_password( prompt => $this->question->description, default => $default, question => $this->question, ); return unless defined $value; if ($value eq '') { $value=$default; } $this->frontend->display("\n"); $this->value($value); } 1 PK ! ��% % $ Debconf/Element/Teletype/Progress.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Teletype::Progress; use strict; use base qw(Debconf::Element); sub start { my $this=shift; $this->frontend->title($this->question->description); $this->frontend->display(''); $this->last(0); } sub set { my $this=shift; my $value=shift; $this->progress_cur($value); use integer; my $new = ($this->progress_cur() - $this->progress_min()) * 100 / ($this->progress_max() - $this->progress_min()); $this->last(0) if $new < $this->last; return if $new / 10 == $this->last / 10; $this->last($new); $this->frontend->display("..$new%"); return 1; } sub info { return 1; } sub stop { my $this=shift; $this->frontend->display("\n"); $this->frontend->title($this->frontend->requested_title); } 1; PK ! �zs� � " Debconf/Element/Teletype/Select.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Teletype::Select; use strict; use Debconf::Config; use POSIX qw(ceil); use base qw(Debconf::Element::Select); sub expandabbrev { my $this=shift; my $input=shift; my @choices=@_; if (Debconf::Config->terse eq 'false' and $input=~m/^[0-9]+$/ and $input ne '0' and $input <= @choices) { return $choices[$input - 1]; } my @matches=(); foreach (@choices) { return $_ if /^\Q$input\E$/; push @matches, $_ if /^\Q$input\E/; } return $matches[0] if @matches == 1; if (! @matches) { foreach (@choices) { return $_ if /^\Q$input\E$/i; push @matches, $_ if /^\Q$input\E/i; } return $matches[0] if @matches == 1; } return ''; } sub printlist { my $this=shift; my @choices=@_; my $width=$this->frontend->screenwidth; my $choice_min=length $choices[0]; map { $choice_min = length $_ if length $_ < $choice_min } @choices; my $max_cols=int($width / (2 + length(scalar(@choices)) + 2 + $choice_min)) - 1; $max_cols = $#choices if $max_cols > $#choices; my $max_lines; my $num_cols; COLUMN: for ($num_cols = $max_cols; $num_cols >= 0; $num_cols--) { my @col_width; my $total_width; $max_lines=ceil(($#choices + 1) / ($num_cols + 1)); next if ceil(($#choices + 1) / $max_lines) - 1 < $num_cols; foreach (my $choice=1; $choice <= $#choices + 1; $choice++) { my $choice_length=2 + length(scalar(@choices)) + 2 + length($choices[$choice - 1]); my $current_col=ceil($choice / $max_lines) - 1; if (! defined $col_width[$current_col] || $choice_length > $col_width[$current_col]) { $col_width[$current_col]=$choice_length; $total_width=0; map { $total_width += $_ } @col_width; next COLUMN if $total_width > $width; } } last; } my $line=0; my $max_len=0; my $col=0; my @output=(); for (my $choice=0; $choice <= $#choices; $choice++) { $output[$line] .= " ".($choice+1).". " . $choices[$choice]; if (length $output[$line] > $max_len) { $max_len = length $output[$line]; } if (++$line >= $max_lines) { if ($col++ != $num_cols) { for (my $l=0; $l <= $#output; $l++) { $output[$l] .= ' ' x ($max_len - length $output[$l]); } } $line=0; $max_len=0; } } @output = map { s/\s+$//; $_ } @output; map { $this->frontend->display_nowrap($_) } @output; } sub show { my $this=shift; my $default=$this->translate_default; my @choices=$this->question->choices_split; my @completions=@choices; $this->frontend->display($this->question->extended_description."\n"); if (Debconf::Config->terse eq 'false') { for (my $choice=0; $choice <= $#choices; $choice++) { if ($choices[$choice] eq $default) { $default=$choice + 1; last; } } $this->printlist(@choices); $this->frontend->display("\n"); push @completions, 1..@choices; } my $value; while (1) { $value=$this->frontend->prompt( prompt => $this->question->description, default => $default ? $default : '', completions => [@completions], question => $this->question, ); return unless defined $value; $value=$this->expandabbrev($value, @choices); last if $value ne ''; } $this->frontend->display("\n"); $this->value($this->translate_to_C($value)); } 1 PK ! ]zL; ; Debconf/Element/Teletype/Text.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Teletype::Text; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $this->frontend->display($this->question->description."\n\n". $this->question->extended_description."\n"); $this->value(''); } 1 PK ! �ޫ� � # Debconf/Element/Teletype/Boolean.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Teletype::Boolean; use strict; use Debconf::Gettext; use base qw(Debconf::Element); sub show { my $this=shift; my $y=gettext("yes"); my $n=gettext("no"); $this->frontend->display($this->question->extended_description."\n"); my $default=''; $default=$this->question->value if defined $this->question->value; if ($default eq 'true') { $default=$y; } elsif ($default eq 'false') { $default=$n; } my $description=$this->question->description; if (Debconf::Config->terse eq 'false') { $description.=" [$y/$n]"; } my $value=''; while (1) { $_=$this->frontend->prompt( default => $default, completions => [$y, $n], prompt => $description, question => $this->question, ); return unless defined $_; if (substr($y, 0, 1) ne substr($n, 0, 1)) { $y=substr($y, 0, 1); $n=substr($n, 0, 1); } if (/^\Q$y\E/i) { $value='true'; last; } elsif (/^\Q$n\E/i) { $value='false'; last; } if (/^y/i) { $value='true'; last; } elsif (/^n/i) { $value='false'; last; } } $this->frontend->display("\n"); $this->value($value); } 1 PK ! a?�� � ' Debconf/Element/Teletype/Multiselect.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Teletype::Multiselect; use strict; use Debconf::Gettext; use Debconf::Config; use base qw(Debconf::Element::Multiselect Debconf::Element::Teletype::Select); sub expand_ranges { my @ranges = @_; my @accumulator; for my $item (@ranges) { if ($item =~ /\A(\d+)-(\d+)\Z/) { my ($begin, $end) = ($1, $2); for (my $i = $begin; $i <= $end; $i++) { push @accumulator, $i; } } else { push @accumulator, $item; } } return @accumulator; } sub show { my $this=shift; my @selected; my $none_of_the_above=gettext("none of the above"); my @choices=$this->question->choices_split; my %value = map { $_ => 1 } $this->translate_default; if ($this->frontend->promptdefault && $this->question->value ne '') { push @choices, $none_of_the_above; } my @completions=@choices; my $i=1; my %choicenum=map { $_ => $i++ } @choices; $this->frontend->display($this->question->extended_description."\n"); my $default; if (Debconf::Config->terse eq 'false') { $this->printlist(@choices); $this->frontend->display("\n(".gettext("Enter the items or ranges you want to select, separated by spaces.").")\n"); push @completions, 1..@choices; $default=join(" ", map { $choicenum{$_} } grep { $value{$_} } @choices); } else { $default=join(" ", grep { $value{$_} } @choices); } while (1) { $_=$this->frontend->prompt( prompt => $this->question->description, default => $default, completions => [@completions], completion_append_character => " ", question => $this->question, ); return unless defined $_; @selected=split(/[ ,]+/, $_); @selected=expand_ranges(@selected); @selected=map { $this->expandabbrev($_, @choices) } @selected; next if grep { $_ eq '' } @selected; if ($#selected > 0) { map { next if $_ eq $none_of_the_above } @selected; } last; } $this->frontend->display("\n"); if (defined $selected[0] && $selected[0] eq $none_of_the_above) { $this->value(''); } else { my %selected=map { $_ => 1 } @selected; $this->value(join(', ', $this->order_values( map { $this->translate_to_C($_) } keys %selected))); } } 1 PK ! i �= = " Debconf/Element/Teletype/String.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Teletype::String; use strict; use base qw(Debconf::Element); sub show { my $this=shift; $this->frontend->display( $this->question->extended_description."\n"); my $default=''; $default=$this->question->value if defined $this->question->value; my $value=$this->frontend->prompt( prompt => $this->question->description, default => $default, question => $this->question, ); return unless defined $value; $this->frontend->display("\n"); $this->value($value); } 1 PK ! ��� � ! Debconf/Element/Teletype/Error.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Teletype::Error; use strict; use base qw(Debconf::Element::Teletype::Text); 1 PK ! �/X\V V ! Debconf/Element/Noninteractive.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element::Noninteractive; use strict; use base qw(Debconf::Element); sub visible { my $this=shift; return; } sub show { my $this=shift; my $default=''; $default=$this->question->value if defined $this->question->value; $this->value($default); } 1 PK ! n u u Debconf/FrontEnd/Editor.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd::Editor; use strict; use Debconf::Encoding q(wrap); use Debconf::TmpFile; use Debconf::Gettext; use base qw(Debconf::FrontEnd::ScreenSize); my $fh; sub init { my $this=shift; $this->SUPER::init(@_); $this->interactive(1); } sub comment { my $this=shift; my $comment=shift; print $fh wrap('# ','# ',$comment); $this->filecontents(1); } sub divider { my $this=shift; print $fh ("\n".('#' x ($this->screenwidth - 1))."\n"); } sub item { my $this=shift; my $name=shift; my $value=shift; print $fh "$name=\"$value\"\n\n"; $this->filecontents(1); } sub go { my $this=shift; my @elements=@{$this->elements}; return 1 unless @elements; $fh = Debconf::TmpFile::open('.sh'); $this->comment(gettext("You are using the editor-based debconf frontend to configure your system. See the end of this document for detailed instructions.")); $this->divider; print $fh ("\n"); $this->filecontents(''); foreach my $element (@elements) { $element->show; } if (! $this->filecontents) { Debconf::TmpFile::cleanup(); return 1; } $this->divider; $this->comment(gettext("The editor-based debconf frontend presents you with one or more text files to edit. This is one such text file. If you are familiar with standard unix configuration files, this file will look familiar to you -- it contains comments interspersed with configuration items. Edit the file, changing any items as necessary, and then save it and exit. At that point, debconf will read the edited file, and use the values you entered to configure the system.")); print $fh ("\n"); close $fh; my $editor=$ENV{EDITOR} || $ENV{VISUAL} || '/usr/bin/editor'; system "$editor ".Debconf::TmpFile->filename; my %eltname=map { $_->question->name => $_ } @elements; open (IN, "<".Debconf::TmpFile::filename()); while (<IN>) { next if /^\s*#/; if (/(.*?)="(.*)"/ && $eltname{$1}) { $eltname{$1}->value($2); } } close IN; Debconf::TmpFile::cleanup(); return 1; } sub screenwidth { my $this=shift; $Debconf::Encoding::columns=$this->SUPER::screenwidth(@_); } 1 PK ! ��Yq q Debconf/FrontEnd/ScreenSize.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd::ScreenSize; use strict; use Debconf::Gettext; use base qw(Debconf::FrontEnd); sub init { my $this=shift; $this->SUPER::init(@_); $this->resize; # Get current screen size. $SIG{WINCH}=sub { if (defined $this) { $this->resize; } }; } sub resize { my $this=shift; if (exists $ENV{LINES}) { $this->screenheight($ENV{'LINES'}); $this->screenheight_guessed(0); } else { my ($rows)=`stty -a 2>/dev/null` =~ m/rows (\d+)/s; if ($rows) { $this->screenheight($rows); $this->screenheight_guessed(0); } else { $this->screenheight(25); $this->screenheight_guessed(1); } } if (exists $ENV{COLUMNS}) { $this->screenwidth($ENV{'COLUMNS'}); } else { my ($cols)=`stty -a 2>/dev/null` =~ m/columns (\d+)/s; $this->screenwidth($cols || 80); } } 1 PK ! ;-*�% % Debconf/FrontEnd/Teletype.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd::Teletype; use strict; use Debconf::Encoding qw(width wrap); use Debconf::Gettext; use Debconf::Config; use base qw(Debconf::FrontEnd::ScreenSize); sub init { my $this=shift; $this->SUPER::init(@_); $this->interactive(1); $this->linecount(0); } sub display { my $this=shift; my $text=shift; $Debconf::Encoding::columns=$this->screenwidth; $this->display_nowrap(wrap('','',$text)); } sub display_nowrap { my $this=shift; my $text=shift; return if Debconf::Config->terse eq 'true'; my @lines=split(/\n/, $text); push @lines, "" if $text=~/\n$/; my $title=$this->title; if (length $title) { unshift @lines, $title, ('-' x width $title), ''; $this->title(''); } foreach (@lines) { if (! $this->screenheight_guessed && $this->screenheight > 2 && $this->linecount($this->linecount+1) > $this->screenheight - 2) { my $resp=$this->prompt( prompt => '['.gettext("More").']', default => '', completions => [], ); if (defined $resp && $resp eq 'q') { last; } } print "$_\n"; } } sub prompt { my $this=shift; my %params=@_; $this->linecount(0); local $|=1; print "$params{prompt} "; my $ret=<STDIN>; chomp $ret if defined $ret; $this->display_nowrap("\n"); return $ret; } sub prompt_password { my $this=shift; my %params=@_; delete $params{default}; system('stty -echo 2>/dev/null'); my $ret=$this->Debconf::FrontEnd::Teletype::prompt(%params); system('stty sane 2>/dev/null'); return $ret; } 1 PK ! ~#��� � Debconf/FrontEnd/Dialog.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd::Dialog; use strict; use Debconf::Gettext; use Debconf::Priority; use Debconf::TmpFile; use Debconf::Log qw(:all); use Debconf::Encoding qw(wrap $columns width); use Debconf::Path; use IPC::Open3; use POSIX; use Fcntl; use base qw(Debconf::FrontEnd::ScreenSize); sub init { my $this=shift; $this->SUPER::init(@_); delete $ENV{POSIXLY_CORRECT} if exists $ENV{POSIXLY_CORRECT}; delete $ENV{POSIX_ME_HARDER} if exists $ENV{POSIX_ME_HARDER}; if (! exists $ENV{TERM} || ! defined $ENV{TERM} || $ENV{TERM} eq '') { die gettext("TERM is not set, so the dialog frontend is not usable.")."\n"; } elsif ($ENV{TERM} =~ /emacs/i) { die gettext("Dialog frontend is incompatible with emacs shell buffers")."\n"; } elsif ($ENV{TERM} eq 'dumb' || $ENV{TERM} eq 'unknown') { die gettext("Dialog frontend will not work on a dumb terminal, an emacs shell buffer, or without a controlling terminal.")."\n"; } $this->interactive(1); $this->capb('backup'); if (Debconf::Path::find("whiptail") && (! defined $ENV{DEBCONF_FORCE_DIALOG} || ! Debconf::Path::find("dialog")) && (! defined $ENV{DEBCONF_FORCE_XDIALOG} || ! Debconf::Path::find("Xdialog")) && system('whiptail --version >/dev/null 2>&1') == 0) { $this->program('whiptail'); $this->dashsep('--'); $this->borderwidth(5); $this->borderheight(6); $this->spacer(1); $this->titlespacer(10); $this->columnspacer(3); $this->selectspacer(13); $this->hasoutputfd(1); } elsif (Debconf::Path::find("dialog") && (! defined $ENV{DEBCONF_FORCE_XDIALOG} || ! Debconf::Path::find("Xdialog")) && system('dialog --version >/dev/null 2>&1') == 0) { $this->program('dialog'); $this->dashsep(''); # dialog does not need (or support) $this->borderwidth(7); $this->borderheight(6); $this->spacer(0); $this->titlespacer(4); $this->columnspacer(2); $this->selectspacer(0); $this->hasoutputfd(1); } elsif (Debconf::Path::find("Xdialog") && defined $ENV{DISPLAY}) { $this->program("Xdialog"); $this->borderwidth(7); $this->borderheight(20); $this->spacer(0); $this->titlespacer(10); $this->selectspacer(0); $this->columnspacer(2); $this->screenheight(200); } else { die gettext("No usable dialog-like program is installed, so the dialog based frontend cannot be used."); } if ($this->screenheight < 13 || $this->screenwidth < 31) { die gettext("Dialog frontend requires a screen at least 13 lines tall and 31 columns wide.")."\n"; } } sub sizetext { my $this=shift; my $text=shift; $columns = $this->screenwidth - $this->borderwidth - $this->columnspacer; $text=wrap('', '', $text); my @lines=split(/\n/, $text); my $window_columns=width($this->title) + $this->titlespacer; map { my $w=width($_); $window_columns = $w if $w > $window_columns; } @lines; return $text, $#lines + 1 + $this->borderheight, $window_columns + $this->borderwidth; } sub ellipsize { my $this=shift; my $text=shift; return $text if $this->program ne 'whiptail'; $columns = $this->screenwidth - $this->borderwidth - $this->columnspacer - $this->selectspacer; if (width($text) > $columns) { $columns -= 3; $text = (split(/\n/, wrap('', '', $text), 2))[0] . '...'; } return $text; } sub hide_escape { my $line = $_; $line =~ s/\\n/\\\xe2\x81\xa0n/g; return $line; } sub showtext { my $this=shift; my $question=shift; my $intext=shift; my $lines = $this->screenheight; my ($text, $height, $width)=$this->sizetext($intext); my @lines = split(/\n/, $text); my $num; my @args=('--msgbox', join("\n", @lines)); if ($lines - 4 - $this->borderheight <= $#lines) { $num=$lines - 4 - $this->borderheight; if ($this->program eq 'whiptail') { push @args, '--scrolltext'; } else { my $fh=Debconf::TmpFile::open(); print $fh join("\n", map &hide_escape, @lines); close $fh; @args=("--textbox", Debconf::TmpFile::filename()); } } else { $num=$#lines + 1; } $this->showdialog($question, @args, $num + $this->borderheight, $width); if ($args[0] eq '--textbox') { Debconf::TmpFile::cleanup(); } } sub makeprompt { my $this=shift; my $question=shift; my $freelines=$this->screenheight - $this->borderheight + 1; $freelines += shift if @_; my ($text, $lines, $columns)=$this->sizetext( $question->extended_description."\n\n". $question->description ); if ($lines > $freelines) { $this->showtext($question, $question->extended_description); ($text, $lines, $columns)=$this->sizetext($question->description); } return ($text, $lines, $columns); } sub startdialog { my $this=shift; my $question=shift; my $wantinputfd=shift; debug debug => "preparing to run dialog. Params are:" , join(",", $this->program, @_); use vars qw{*SAVEOUT *SAVEIN}; open(SAVEOUT, ">&STDOUT") || die $!; $this->dialog_saveout(\*SAVEOUT); if ($wantinputfd) { $this->dialog_savein(undef); } else { open(SAVEIN, "<&STDIN") || die $!; $this->dialog_savein(\*SAVEIN); } $this->dialog_savew($^W); $^W=0; unless ($this->capb_backup || grep { $_ eq '--defaultno' } @_) { if ($this->program ne 'Xdialog') { unshift @_, '--nocancel'; } else { unshift @_, '--no-cancel'; } } if ($this->program eq 'Xdialog' && $_[0] eq '--passwordbox') { $_[0]='--password --inputbox' } use vars qw{*OUTPUT_RDR *OUTPUT_WTR}; if ($this->hasoutputfd) { pipe(OUTPUT_RDR, OUTPUT_WTR) || die "pipe: $!"; my $flags=fcntl(\*OUTPUT_WTR, F_GETFD, 0); fcntl(\*OUTPUT_WTR, F_SETFD, $flags & ~FD_CLOEXEC); $this->dialog_output_rdr(\*OUTPUT_RDR); unshift @_, "--output-fd", fileno(\*OUTPUT_WTR); } my $backtitle=''; if (defined $this->info) { $backtitle = $this->info->description; } else { $backtitle = gettext("Package configuration"); } use vars qw{*INPUT_RDR *INPUT_WTR}; if ($wantinputfd) { pipe(INPUT_RDR, INPUT_WTR) || die "pipe: $!"; autoflush INPUT_WTR 1; my $flags=fcntl(\*INPUT_RDR, F_GETFD, 0); fcntl(\*INPUT_RDR, F_SETFD, $flags & ~FD_CLOEXEC); $this->dialog_input_wtr(\*INPUT_WTR); } else { $this->dialog_input_wtr(undef); } use vars qw{*ERRFH}; my $pid = open3($wantinputfd ? '<&INPUT_RDR' : '<&STDIN', '>&STDOUT', \*ERRFH, $this->program, '--backtitle', $backtitle, '--title', $this->title, @_); $this->dialog_errfh(\*ERRFH); $this->dialog_pid($pid); close OUTPUT_WTR if $this->hasoutputfd; } sub waitdialog { my $this=shift; my $input_wtr=$this->dialog_input_wtr; if ($input_wtr) { close $input_wtr; } my $output_rdr=$this->dialog_output_rdr; my $errfh=$this->dialog_errfh; my $output=''; if ($this->hasoutputfd) { while (<$output_rdr>) { $output.=$_; } my $error=0; while (<$errfh>) { print STDERR $_; $error++; } if ($error) { die sprintf("debconf: %s output the above errors, giving up!", $this->program)."\n"; } } else { while (<$errfh>) { # ugh $output.=$_; } } chomp $output; waitpid($this->dialog_pid, 0); $^W=$this->dialog_savew; if (defined $this->dialog_savein) { open(STDIN, '<&', $this->dialog_savein) || die $!; } open(STDOUT, '>&', $this->dialog_saveout) || die $!; my $ret=$? >> 8; if ($ret == 255 || ($ret == 1 && join(' ', @_) !~ m/--yesno\s/)) { $this->backup(1); return undef; } if (wantarray) { return $ret, $output; } else { return $output; } } sub showdialog { my $this=shift; my $question=shift; @_=map &hide_escape, @_; if (defined $this->progress_bar) { $this->progress_bar->stop; } $this->startdialog($question, 0, @_); my (@ret, $ret); if (wantarray) { @ret=$this->waitdialog(@_); } else { $ret=$this->waitdialog(@_); } if (defined $this->progress_bar) { $this->progress_bar->start; } if (wantarray) { return @ret; } else { return $ret; } } 1 PK ! ��� Debconf/FrontEnd/Readline.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd::Readline; use strict; use Term::ReadLine; use Debconf::Gettext; use base qw(Debconf::FrontEnd::Teletype); sub init { my $this=shift; $this->SUPER::init(@_); open(TESTTY, "/dev/tty") || die gettext("This frontend requires a controlling tty.")."\n"; close TESTTY; $Term::ReadLine::termcap_nowarn = 1; # Turn off stupid termcap warning. $this->readline(Term::ReadLine->new('debconf')); $this->readline->ornaments(1); if (-p STDOUT && -p STDERR) { # make readline play nice with buffered stdout $this->readline->newTTY(*STDIN, *STDOUT); } if (Term::ReadLine->ReadLine =~ /::Gnu$/) { if (exists $ENV{TERM} && $ENV{TERM} =~ /emacs/i) { die gettext("Term::ReadLine::GNU is incompatable with emacs shell buffers.")."\n"; } $this->readline->add_defun('previous-question', sub { if ($this->capb_backup) { $this->_skip(1); $this->_direction(-1); $this->readline->stuff_char(ord "\n"); } else { $this->readline->ding; } }, ord "\cu"); $this->readline->add_defun('next-question', sub { if ($this->capb_backup) { $this->readline->stuff_char(ord "\n"); } }, ord "\cv"); $this->readline->parse_and_bind('"\e[5~": previous-question'); $this->readline->parse_and_bind('"\e[6~": next-question'); $this->capb('backup'); } if (Term::ReadLine->ReadLine =~ /::Stub$/) { $this->promptdefault(1); } } sub elementtype { return 'Teletype'; } sub go { my $this=shift; foreach my $element (grep ! $_->visible, @{$this->elements}) { my $value=$element->show; return if $this->backup && $this->capb_backup; $element->question->value($value); } my @elements=grep $_->visible, @{$this->elements}; unless (@elements) { $this->_didbackup(''); return 1; } my $current=$this->_didbackup ? $#elements : 0; $this->_direction(1); for (; $current > -1 && $current < @elements; $current += $this->_direction) { my $value=$elements[$current]->show; } if ($current < 0) { $this->_didbackup(1); return; } else { $this->_didbackup(''); return 1; } } sub prompt { my $this=shift; my %params=@_; my $prompt=$params{prompt}." "; my $default=$params{default}; my $noshowdefault=$params{noshowdefault}; my $completions=$params{completions}; if ($completions) { my @matches; $this->readline->Attribs->{completion_entry_function} = sub { my $text=shift; my $state=shift; if ($state == 0) { @matches=(); foreach (@{$completions}) { push @matches, $_ if /^\Q$text\E/i; } } return pop @matches; }; } else { $this->readline->Attribs->{completion_entry_function} = undef; } if (exists $params{completion_append_character}) { $this->readline->Attribs->{completion_append_character}=$params{completion_append_character}; } else { $this->readline->Attribs->{completion_append_character}=''; } $this->linecount(0); my $ret; $this->_skip(0); if (! $noshowdefault) { $ret=$this->readline->readline($prompt, $default); } else { $ret=$this->readline->readline($prompt); } $this->display_nowrap("\n"); return if $this->_skip; $this->_direction(1); $this->readline->addhistory($ret); return $ret; } sub prompt_password { my $this=shift; my %params=@_; if (Term::ReadLine->ReadLine =~ /::Perl$/) { return $this->SUPER::prompt_password(%params); } delete $params{default}; system('stty -echo 2>/dev/null'); my $ret=$this->prompt(@_, noshowdefault => 1, completions => []); system('stty sane 2>/dev/null'); print "\n"; return $ret; } 1 PK ! ,U`�\ \ Debconf/FrontEnd/Gnome.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd::Gnome; use strict; use utf8; use Debconf::Gettext; use Debconf::Config; use Debconf::Encoding qw(to_Unicode); use base qw{Debconf::FrontEnd}; our @ARGV_for_gnome=('--sm-disable'); sub create_assistant_page { my $this=shift; $this->assistant_page(Gtk3::VBox->new); $this->assistant->append_page($this->assistant_page); if ($this->logo) { $this->assistant->set_page_header_image($this->assistant_page, $this->logo); } $this->configure_assistant_page; $this->assistant_page->show_all; } sub configure_assistant_page { my $this=shift; $this->assistant->set_page_title($this->assistant_page, to_Unicode($this->title)); $this->assistant->set_page_type($this->assistant_page, 'custom'); $this->forward_button->grab_default; $this->forward_button->show; if ($this->capb_backup) { $this->back_button->show; } else { $this->back_button->hide; } $this->assistant->set_page_complete($this->assistant_page, 1); } sub reset_assistant_page { my $this=shift; $this->assistant_page($this->assistant->get_nth_page($this->assistant->get_current_page)); foreach my $element ($this->assistant_page->get_children) { $this->assistant_page->remove($element); } } my $prev_page = 0; sub prepare_callback { my ($assistant, $page, $this) = @_; my $current_page = $assistant->get_current_page; if ($prev_page < $current_page) { $this->goback(0); if (Gtk3::main_level()) { Gtk3::main_quit(); } } elsif ($prev_page > $current_page) { $this->goback(1); if (Gtk3::main_level()) { Gtk3::main_quit(); } } $prev_page = $current_page; } sub close_callback { my ($assistant) = @_; my $title = gettext("Really quit configuration?"); my $text = gettext("If you quit this configuration dialog, then the package being configured will probably fail to install, and you may have to fix it manually. This may be especially difficult if you are in the middle of a large upgrade.")."\n\n".gettext("You may need to quit anyway if you are stuck in a configuration loop due to a buggy package.")."\n"; my $quit = gettext("_Quit"); my $continue = gettext("Continue"); my $dialog = Gtk3::Dialog->new_with_buttons(to_Unicode($title), $assistant, "modal", to_Unicode($quit), "yes", to_Unicode($continue), "no"); $dialog->set_default_response("no"); $dialog->set_border_width(3); my $grid = Gtk3::Grid->new(); $grid->set_orientation("horizontal"); $grid->set_column_homogeneous(0); $dialog->get_content_area->pack_start($grid, 1, 1, 5); $grid->show; my $alignment = Gtk3::Alignment->new(0.5, 0.0, 1.0, 0.0); $grid->add($alignment); $alignment->show; my $image = Gtk3::Image->new_from_icon_name("dialog-information", "dialog"); $alignment->add($image); $image->show; my $label = Gtk3::Label->new(to_Unicode($text)); $label->set_line_wrap(1); $grid->add($label); $label->show; my $response = $dialog->run; $dialog->destroy; exit 1 if $response eq "yes"; } sub delete_event_callback { my ($assistant, $event) = @_; close_callback($assistant); } sub forward_page_func { my ($current_page, $assistant) = @_; return $current_page + 1; } sub on_forward { my ($button) = @_; my $assistant = $button->get_ancestor("Gtk3::Assistant"); $assistant->next_page; } sub on_back { my ($button) = @_; my $assistant = $button->get_ancestor("Gtk3::Assistant"); $assistant->previous_page; } sub init { my $this=shift; if (fork) { wait(); # for child if ($? != 0) { die "DISPLAY problem?\n"; } } else { use Gtk3; @ARGV=@ARGV_for_gnome; # temporary change at first Gtk3->init; my $window = Gtk3::Window->new('toplevel'); exit(0); # success } eval q{use Gtk3;}; die "Unable to load Gtk -- is libgtk3-perl installed?\n" if $@; my @gnome_sucks=@ARGV; @ARGV=@ARGV_for_gnome; Gtk3->init; @ARGV=@gnome_sucks; $this->SUPER::init(@_); $this->interactive(1); $this->capb('backup'); $this->need_tty(0); $this->assistant(Gtk3::Assistant->new); $this->assistant->set_position("center"); $this->assistant->set_default_size(600, 400); my $hostname = `hostname`; chomp $hostname; $this->assistant->set_title(to_Unicode(sprintf(gettext("Debconf on %s"), $hostname))); $this->assistant->signal_connect("delete_event", \&delete_event_callback); my $distribution=''; if (system('type lsb_release >/dev/null 2>&1') == 0) { $distribution=lc(`lsb_release -is`); chomp $distribution; } elsif (-e '/etc/debian_version') { $distribution='debian'; } my $logo="/usr/share/pixmaps/$distribution-logo.png"; if (-e $logo) { $this->logo(Gtk3::Gdk::Pixbuf->new_from_file($logo)); } $this->assistant->signal_connect("close", \&close_callback); $this->assistant->signal_connect("prepare", \&prepare_callback, $this); $this->assistant->set_forward_page_func(\&forward_page_func, $this->assistant); $this->forward_button(Gtk3::Button->new_with_mnemonic(to_Unicode(gettext("_Next")))); $this->forward_button->set_can_focus(1); $this->forward_button->set_can_default(1); $this->forward_button->set_receives_default(1); $this->forward_button->signal_connect("clicked", \&on_forward); $this->assistant->add_action_widget($this->forward_button); $this->back_button(Gtk3::Button->new_with_mnemonic(to_Unicode(gettext("_Back")))); $this->back_button->set_can_focus(1); $this->back_button->set_receives_default(1); $this->back_button->signal_connect("clicked", \&on_back); $this->assistant->add_action_widget($this->back_button); $this->create_assistant_page(); $this->assistant->show; } sub go { my $this=shift; my @elements=@{$this->elements}; $this->reset_assistant_page; my $interactive=''; foreach my $element (@elements) { next unless $element->hbox; $interactive=1; $this->assistant_page->pack_start($element->hbox, $element->fill, $element->expand, 0); } if ($interactive) { $this->configure_assistant_page; if ($this->assistant->get_current_page == $this->assistant->get_n_pages - 1) { $this->create_assistant_page(); } Gtk3::main(); } foreach my $element (@elements) { $element->show; } return '' if $this->goback; return 1; } sub progress_start { my $this=shift; $this->SUPER::progress_start(@_); $this->reset_assistant_page; my $element=$this->progress_bar; $this->assistant_page->pack_start($element->hbox, $element->fill, $element->expand, 0); $this->configure_assistant_page; if ($this->assistant->get_current_page == $this->assistant->get_n_pages - 1) { $this->create_assistant_page(); } $this->assistant->set_page_complete($this->assistant_page, 0); $this->assistant->show_all; while (Gtk3::events_pending()) { Gtk3::main_iteration(); } } sub progress_set { my $this=shift; my $ret=$this->SUPER::progress_set(@_); while (Gtk3::events_pending()) { Gtk3::main_iteration(); } return $ret; } sub progress_info { my $this=shift; my $ret=$this->SUPER::progress_info(@_); while (Gtk3::events_pending()) { Gtk3::main_iteration(); } return $ret; } sub progress_stop { my $this=shift; $this->SUPER::progress_stop(@_); while (Gtk3::events_pending) { Gtk3::main_iteration; } if ($this->assistant->get_current_page == $this->assistant->get_n_pages - 1) { $this->create_assistant_page(); } $this->assistant->set_current_page($prev_page + 1); } 1 PK ! (� �� � Debconf/FrontEnd/Text.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd::Text; use strict; use base qw(Debconf::FrontEnd::Readline); 1 PK ! �]\�% % Debconf/FrontEnd/Kde.pmnu �[��� package Debconf::FrontEnd::Kde; use strict; use warnings; use IO::Handle; use Fcntl; use POSIX ":sys_wait_h"; use Debconf::Config; use base "Debconf::FrontEnd::Passthrough"; sub clear_fd_cloexec { my $fh = shift; my $flags; $flags = $fh->fcntl(F_GETFD, 0); $flags &= ~FD_CLOEXEC; $fh->fcntl(F_SETFD, $flags); } sub init { my $this = shift; $this->need_tty(0); pipe my $dc2hp_readfh, my $dc2hp_writefh; pipe my $hp2dc_readfh, my $hp2dc_writefh; my $helper_pid = fork(); if (!defined $helper_pid) { die "Unable to fork for execution of debconf-kde-helper: $!\n"; } elsif ($helper_pid == 0) { close $hp2dc_readfh; close $dc2hp_writefh; clear_fd_cloexec($dc2hp_readfh); clear_fd_cloexec($hp2dc_writefh); my $debug = Debconf::Config->debug; local $ENV{QT_LOGGING_RULES} = 'org.kde.debconf.debug=false' unless $debug && 'kde' =~ /$debug/; my $fds = sprintf("%d,%d", $dc2hp_readfh->fileno(), $hp2dc_writefh->fileno()); if (!exec("debconf-kde-helper", "--fifo-fds=$fds")) { print STDERR "Unable to execute debconf-kde-helper - is debconf-kde-helper installed?"; exit(10); } } close $dc2hp_readfh; close $hp2dc_writefh; $this->{kde_helper_pid} = $helper_pid; $this->{readfh} = $hp2dc_readfh; $this->{writefh} = $dc2hp_writefh; $this->SUPER::init(); my $timeout = 15; my $tag = $this->talk_with_timeout($timeout, "X_PING"); unless (defined $tag && $tag == 0) { close $hp2dc_readfh; close $dc2hp_writefh; if (waitpid($helper_pid, WNOHANG) == $helper_pid) { die "debconf-kde-helper terminated abnormally (exit status: " . WEXITSTATUS($?) . ")\n"; } elsif (kill(0, $helper_pid) == 1) { kill 9, $helper_pid; waitpid($helper_pid, 0); } if (defined $tag) { die "debconf-kde-helper failed to respond to ping. Response was $tag\n"; } else { die "debconf-kde-helper did not respond to ping in $timeout seconds\n"; } } } sub shutdown { my $this = shift; $this->SUPER::shutdown(); if (defined $this->{kde_helper_pid}) { waitpid $this->{kde_helper_pid}, 0; delete $this->{kde_helper_pid}; } } 1; PK ! I44y� � Debconf/FrontEnd/Passthrough.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd::Passthrough; use strict; use Carp; use IO::Socket; use IO::Handle; use IO::Select; use Debconf::FrontEnd; use Debconf::Element; use Debconf::Element::Select; use Debconf::Element::Multiselect; use Debconf::Log qw(:all); use Debconf::Encoding; use base qw(Debconf::FrontEnd); sub init { my $this=shift; if (not defined $this->{readfh} or not defined $this->{writefh}) { if (not defined $this->init_fh_from_env()) { die "Neither DEBCONF_PIPE nor DEBCONF_READFD and DEBCONF_WRITEFD were set\n"; } } binmode $this->{readfh}, ":utf8"; binmode $this->{writefh}, ":utf8"; $this->{readfh}->autoflush(1); $this->{writefh}->autoflush(1); $this->elements([]); $this->interactive(1); $this->need_tty(0); } sub init_fh_from_env { my $this = shift; my ($socket_path, $readfd, $writefd); if (defined $ENV{DEBCONF_PIPE}) { my $socket_path = $ENV{DEBCONF_PIPE}; $this->{readfh} = $this->{writefh} = IO::Socket::UNIX->new( Type => SOCK_STREAM, Peer => $socket_path ) || croak "Cannot connect to $socket_path: $!"; return "socket"; } elsif (defined $ENV{DEBCONF_READFD} and defined $ENV{DEBCONF_WRITEFD}) { $readfd = $ENV{DEBCONF_READFD}; $writefd = $ENV{DEBCONF_WRITEFD}; $this->{readfh} = IO::Handle->new_from_fd(int($readfd), "r") or croak "Failed to open fd $readfd: $!"; $this->{writefh} = IO::Handle->new_from_fd(int($writefd), "w") or croak "Failed to open fd $writefd: $!"; return "fifo"; } return undef; } sub talk_with_timeout { my $this=shift; my $timeout=shift; my $command=join(' ', map { Debconf::Encoding::to_Unicode($_) } @_); my $reply; my $readfh = $this->{readfh} || croak "Broken pipe"; my $writefh = $this->{writefh} || croak "Broken pipe"; debug developer => "----> (passthrough) $command"; print $writefh $command."\n"; $writefh->flush; if (defined $timeout) { my $select = IO::Select->new($readfh); return undef if !$select->can_read($timeout); } return undef if ($readfh->eof()); $reply = <$readfh>; chomp($reply); debug developer => "<---- (passthrough) $reply"; my ($tag, $val) = split(' ', $reply, 2); $val = '' unless defined $val; $val = Debconf::Encoding::convert("UTF-8", $val); return ($tag, $val) if wantarray; return $tag; } sub talk { my $this=shift; return $this->talk_with_timeout(undef, @_); } sub makeelement { my $this=shift; my $question=shift; my $type=$question->type; if ($type eq "select" || $type eq "multiselect") { $type=ucfirst($type); return "Debconf::Element::$type"->new(question => $question); } else { return Debconf::Element->new(question => $question); } } sub capb_backup { my $this=shift; my $val = shift; $this->{capb_backup} = $val; $this->talk('CAPB', 'backup') if $val; } sub capb { my $this=shift; my $ret; return $this->{capb} if exists $this->{capb}; ($ret, $this->{capb}) = $this->talk('CAPB'); return $this->{capb} if $ret eq '0'; } sub title { my $this = shift; return $this->{title} unless @_; my $title = shift; $this->{title} = $title; $this->talk('TITLE', $title); } sub settitle { my $this = shift; my $question = shift; $this->{title} = $question->description; my $tag = $question->template->template; my $type = $question->template->type; my $desc = $question->description; my $extdesc = $question->extended_description; $this->talk('DATA', $tag, 'type', $type); if ($desc) { $desc =~ s/\n/\\n/g; $this->talk('DATA', $tag, 'description', $desc); } if ($extdesc) { $extdesc =~ s/\n/\\n/g; $this->talk('DATA', $tag, 'extended_description', $extdesc); } $this->talk('SETTITLE', $tag); } sub go { my $this = shift; my @elements=grep $_->visible, @{$this->elements}; foreach my $element (@elements) { my $question = $element->question; my $tag = $question->template->template; my $type = $question->template->type; my $desc = $question->description; my $extdesc = $question->extended_description; my $default; if ($type eq 'select') { $default = $element->translate_default; } elsif ($type eq 'multiselect') { $default = join ', ', $element->translate_default; } else { $default = $question->value; } $this->talk('DATA', $tag, 'type', $type); if ($desc) { $desc =~ s/\n/\\n/g; $this->talk('DATA', $tag, 'description', $desc); } if ($extdesc) { $extdesc =~ s/\n/\\n/g; $this->talk('DATA', $tag, 'extended_description', $extdesc); } if ($type eq "select" || $type eq "multiselect") { my $choices = $question->choices; $choices =~ s/\n/\\n/g if ($choices); $this->talk('DATA', $tag, 'choices', $choices); } $this->talk('SET', $tag, $default) if $default ne ''; my @vars=$Debconf::Db::config->variables($question->{name}); for my $var (@vars) { my $val=$Debconf::Db::config->getvariable($question->{name}, $var); $val='' unless defined $val; $this->talk('SUBST', $tag, $var, $val); } $this->talk('INPUT', $question->priority, $tag); } if (@elements && (scalar($this->talk('GO')) eq "30") && $this->{capb_backup}) { return; } foreach my $element (@{$this->elements}) { if ($element->visible) { my $tag = $element->question->template->template; my $type = $element->question->template->type; my ($ret, $val)=$this->talk('GET', $tag); if ($ret eq "0") { if ($type eq 'select') { $element->value($element->translate_to_C($val)); } elsif ($type eq 'multiselect') { $element->value(join(', ', map { $element->translate_to_C($_) } split(', ', $val))); } else { $element->value($val); } debug developer => "Got \"$val\" for $tag"; } } else { $element->show; } } return 1; } sub progress_data { my $this=shift; my $question=shift; my $tag=$question->template->template; my $type=$question->template->type; my $desc=$question->description; my $extdesc=$question->extended_description; $this->talk('DATA', $tag, 'type', $type); if ($desc) { $desc =~ s/\n/\\n/g; $this->talk('DATA', $tag, 'description', $desc); } if ($extdesc) { $extdesc =~ s/\n/\\n/g; $this->talk('DATA', $tag, 'extended_description', $extdesc); } } sub progress_start { my $this=shift; $this->progress_data($_[2]); return $this->talk('PROGRESS', 'START', $_[0], $_[1], $_[2]->template->template); } sub progress_set { my $this=shift; return (scalar($this->talk('PROGRESS', 'SET', $_[0])) ne "30"); } sub progress_step { my $this=shift; return (scalar($this->talk('PROGRESS', 'STEP', $_[0])) ne "30"); } sub progress_info { my $this=shift; $this->progress_data($_[0]); return (scalar($this->talk('PROGRESS', 'INFO', $_[0]->template->template)) ne "30"); } sub progress_stop { my $this=shift; return $this->talk('PROGRESS', 'STOP'); } sub shutdown { my $this=shift; $this->SUPER::shutdown(); if (defined $this->{readfh} && (not defined $this->{writefh} or $this->{readfh} != $this->{writefh})) { close $this->{readfh}; delete $this->{readfh}; } if (defined $this->{writefh}) { close $this->{writefh}; delete $this->{writefh}; } } 1 PK ! Yh� � � " Debconf/FrontEnd/Noninteractive.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd::Noninteractive; use strict; use Debconf::Encoding qw(width wrap); use Debconf::Gettext; use base qw(Debconf::FrontEnd); sub init { my $this=shift; $this->SUPER::init(@_); $this->need_tty(0); } sub display { my $this=shift; my $text=shift; $Debconf::Encoding::columns=76; $this->display_nowrap(wrap('','',$text)); } sub display_nowrap { my $this=shift; my $text=shift; my @lines=split(/\n/, $text); push @lines, "" if $text=~/\n$/; my $title=$this->title; if (length $title) { unshift @lines, $title, ('-' x width $title), ''; $this->title(''); } foreach (@lines) { print "$_\n"; } } 1 PK ! ����i i Debconf/FrontEnd/Web.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd::Web; use IO::Socket; use IO::Select; use CGI; use strict; use Debconf::Gettext; use base qw(Debconf::FrontEnd); sub init { my $this=shift; $this->SUPER::init(@_); $this->port(8001) unless defined $this->port; $this->formid(0); $this->interactive(1); $this->capb('backup'); $this->need_tty(0); $this->server(IO::Socket::INET->new( LocalPort => $this->port, Proto => 'tcp', Listen => 1, Reuse => 1, LocalAddr => '127.0.0.1', )) || die "Can't bind to ".$this->port.": $!"; print STDERR sprintf(gettext("Note: Debconf is running in web mode. Go to http://localhost:%i/"),$this->port)."\n"; } sub client { my $this=shift; $this->{client}=shift if @_; return $this->{client} if $this->{client}; my $select=IO::Select->new($this->server); 1 while ! $select->can_read(1); my $client=$this->server->accept; my $commands=''; while (<$client>) { last if $_ eq "\r\n"; $commands.=$_; } $this->commands($commands); $this->{client}=$client; } sub closeclient { my $this=shift; close $this->client; $this->client(''); } sub showclient { my $this=shift; my $page=shift; my $client=$this->client; print $client $page; } sub go { my $this=shift; $this->backup(''); my $httpheader="HTTP/1.0 200 Ok\nContent-type: text/html\n\n"; my $form=''; my $id=0; my %idtoelt; foreach my $elt (@{$this->elements}) { $idtoelt{$id}=$elt; $elt->id($id++); my $html=$elt->show; if ($html ne '') { $form.=$html."<hr>\n"; } } return 1 if $form eq ''; my $formid=$this->formid(1 + $this->formid); $form="<html>\n<title>".$this->title."</title>\n<body>\n". "<form><input type=hidden name=formid value=$formid>\n". $form."<p>\n"; if ($this->capb_backup) { $form.="<input type=submit value=".gettext("Back")." name=back>\n"; } $form.="<input type=submit value=".gettext("Next").">\n"; $form.="</form>\n</body>\n</html>\n"; my $query; do { $this->showclient($httpheader . $form); $this->closeclient; $this->client; my @get=grep { /^GET / } split(/\r\n/, $this->commands); my $get=shift @get; my ($qs)=$get=~m/^GET\s+.*?\?(.*?)(?:\s+.*)?$/; $query=CGI->new($qs); } until (defined $query->param('formid') && $query->param('formid') eq $formid); if ($this->capb_backup && defined $query->param('back') && $query->param('back') ne '') { return ''; } foreach my $id ($query->param) { next unless $idtoelt{$id}; $idtoelt{$id}->value($query->param($id)); delete $idtoelt{$id}; } foreach my $elt (values %idtoelt) { $elt->value(''); } return 1; } 1 PK ! ϵ� Debconf/Template.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Template; use strict; use POSIX; use FileHandle; use Debconf::Gettext; use Text::Wrap; use Text::Tabs; use Debconf::Db; use Debconf::Iterator; use Debconf::Question; use fields qw(template); use Debconf::Log q{:all}; use Debconf::Encoding; use Debconf::Config; our %template; $Debconf::Template::i18n=1; our %known_field = map { $_ => 1 } qw{template description choices default type}; binmode(STDOUT); binmode(STDERR); sub new { my Debconf::Template $this=shift; my $template=shift || die "no template name specified"; my $owner=shift || 'unknown'; my $type=shift || die "no template type specified"; if ($Debconf::Db::templates->exists($template) and $Debconf::Db::templates->owners($template)) { if ($Debconf::Db::config->exists($template)) { my $q=Debconf::Question->get($template); $q->addowner($owner, $type) if $q; } else { my $q=Debconf::Question->new($template, $owner, $type); $q->template($template); } my @owners=$Debconf::Db::templates->owners($template); foreach my $question (@owners) { my $q=Debconf::Question->get($question); if (! $q) { warn sprintf(gettext("warning: possible database corruption. Will attempt to repair by adding back missing question %s."), $question); my $newq=Debconf::Question->new($question, $owner, $type); $newq->template($template); } } $this = fields::new($this); $this->{template}=$template; return $template{$template}=$this; } unless (ref $this) { $this = fields::new($this); } $this->{template}=$template; if ($Debconf::Db::config->exists($template)) { my $q=Debconf::Question->get($template); $q->addowner($owner, $type) if $q; } else { my $q=Debconf::Question->new($template, $owner, $type); $q->template($template); } return unless $Debconf::Db::templates->addowner($template, $template, $type); $Debconf::Db::templates->setfield($template, 'type', $type); return $template{$template}=$this; } sub get { my Debconf::Template $this=shift; my $template=shift; return $template{$template} if exists $template{$template}; if ($Debconf::Db::templates->exists($template)) { $this = fields::new($this); $this->{template}=$template; return $template{$template}=$this; } return undef; } sub i18n { my $class=shift; $Debconf::Template::i18n=shift; } sub load { my $this=shift; my $file=shift; my @ret; my $fh; if (ref $file) { $fh=$file; } else { $fh=FileHandle->new($file) || die "$file: $!"; } local $/="\n\n"; # read a template at a time. while (<$fh>) { my %data; my $save = sub { my $field=shift; my $value=shift; my $extended=shift; my $file=shift; $extended=~s/\n+$//; if ($field ne '') { if (exists $data{$field}) { die sprintf(gettext("Template #%s in %s has a duplicate field \"%s\" with new value \"%s\". Probably two templates are not properly separated by a lone newline.\n"), $., $file, $field, $value); } $data{$field}=$value; $data{"extended_$field"}=$extended if length $extended; } }; s/^\n+//; s/\n+$//; my ($field, $value, $extended)=('', '', ''); foreach my $line (split "\n", $_) { chomp $line; if ($line=~/^([-_@.A-Za-z0-9]*):\s?(.*)/) { $save->($field, $value, $extended, $file); $field=lc $1; $value=$2; $value=~s/\s*$//; $extended=''; my $basefield=$field; $basefield=~s/-.+$//; if (! $known_field{$basefield}) { warn sprintf(gettext("Unknown template field '%s', in stanza #%s of %s\n"), $field, $., $file); } } elsif ($line=~/^\s\.$/) { $extended.="\n\n"; } elsif ($line=~/^\s(\s+.*)/) { my $bit=$1; $bit=~s/\s*$//; $extended.="\n" if length $extended && $extended !~ /[\n ]$/; $extended.=$bit."\n"; } elsif ($line=~/^\s(.*)/) { my $bit=$1; $bit=~s/\s*$//; $extended.=' ' if length $extended && $extended !~ /[\n ]$/; $extended.=$bit; } else { die sprintf(gettext("Template parse error near `%s', in stanza #%s of %s\n"), $line, $., $file); } } $save->($field, $value, $extended, $file); die sprintf(gettext("Template #%s in %s does not contain a 'Template:' line\n"), $., $file) unless $data{template}; my $template=$this->new($data{template}, @_, $data{type}); $template->clearall; foreach my $key (keys %data) { next if $key eq 'template'; $template->$key($data{$key}); } push @ret, $template; } return @ret; } sub template { my $this=shift; return $this->{template}; } sub fields { my $this=shift; return $Debconf::Db::templates->fields($this->{template}); } sub clearall { my $this=shift; foreach my $field ($this->fields) { $Debconf::Db::templates->removefield($this->{template}, $field); } } sub stringify { my $this=shift; my @templatestrings; foreach (ref $this ? $this : @_) { my $data=''; foreach my $key ('template', 'type', (grep { $_ ne 'template' && $_ ne 'type'} sort $_->fields)) { next if $key=~/^extended_/; if ($key =~ m/-[a-z]{2}_[a-z]{2}(@[^_@.])?(-fuzzy)?$/) { my $casekey=$key; $casekey=~s/([a-z]{2})(@[^_@.]|)(-fuzzy|)$/uc($1).$2.$3/eg; $data.=ucfirst($casekey).": ".$_->$key."\n"; } else { $data.=ucfirst($key).": ".$_->$key."\n"; } my $e="extended_$key"; my $ext=$_->$e; if (defined $ext) { $Text::Wrap::break = qr/\n|\s(?=\S)/; my $extended=expand(wrap(' ', ' ', $ext)); $extended=~s/(\n )+\n/\n .\n/g; $data.=$extended."\n" if length $extended; } } push @templatestrings, $data; } return join("\n", @templatestrings); } sub _addterritory { my $locale=shift; my $territory=shift; $locale=~s/^([^_@.]+)/$1$territory/; return $locale; } sub _addcharset { my $locale=shift; my $charset=shift; $locale=~s/^([^@.]+)/$1$charset/; return $locale; } sub _getlocalelist { my $locale=shift; $locale=~s/(@[^.]+)//; my $modifier=$1; my ($lang, $territory, $charset)=($locale=~m/^ ([^_@.]+) # Language (_[^_@.]+)? # Territory (\..+)? # Charset /x); my (@ret) = ($lang); @ret = map { $_.$modifier, $_} @ret if defined $modifier; @ret = map { _addterritory($_,$territory), $_} @ret if defined $territory; @ret = map { _addcharset($_,$charset), $_} @ret if defined $charset; return @ret; } sub _getlangs { my $language=setlocale(LC_MESSAGES); my @langs = (); if (exists $ENV{LANGUAGE} && $ENV{LANGUAGE} ne '') { foreach (split(/:/, $ENV{LANGUAGE})) { push (@langs, _getlocalelist($_)); } } return @langs, _getlocalelist($language); } my @langs=map { lc $_ } _getlangs(); sub AUTOLOAD { (my $field = our $AUTOLOAD) =~ s/.*://; no strict 'refs'; *$AUTOLOAD = sub { my $this=shift; if (@_) { return $Debconf::Db::templates->setfield($this->{template}, $field, shift); } my $ret; my $want_i18n = $Debconf::Template::i18n && Debconf::Config->c_values ne 'true'; if ($want_i18n && @langs) { foreach my $lang (@langs) { $lang = 'en' if $lang eq 'c'; $ret=$Debconf::Db::templates->getfield($this->{template}, $field.'-'.$lang); return $ret if defined $ret; if ($Debconf::Encoding::charmap) { foreach my $f ($Debconf::Db::templates->fields($this->{template})) { if ($f =~ /^\Q$field-$lang\E\.(.+)/) { my $encoding = $1; $ret = Debconf::Encoding::convert($encoding, $Debconf::Db::templates->getfield($this->{template}, lc($f))); return $ret if defined $ret; } } } last if $lang eq 'en'; } } elsif (not $want_i18n && $field !~ /-c$/i) { $ret=$Debconf::Db::templates->getfield($this->{template}, $field.'-c'); return $ret if defined $ret; } $ret=$Debconf::Db::templates->getfield($this->{template}, $field); return $ret if defined $ret; if ($field =~ /-/) { (my $plainfield = $field) =~ s/-.*//; $ret=$Debconf::Db::templates->getfield($this->{template}, $plainfield); return $ret if defined $ret; return ''; } return ''; }; goto &$AUTOLOAD; } sub DESTROY {} use overload '""' => sub { my $template=shift; $template->template; }; 1 PK ! ��PF[ [ Debconf/Format/822.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Format::822; use strict; use base 'Debconf::Format'; sub beginfile {} sub endfile {} sub read { my $this=shift; my $fh=shift; local $/="\n"; my $name; my %ret=( owners => {}, fields => {}, variables => {}, flags => {}, ); my $invars=0; my $line; while ($line = <$fh>) { chomp $line; last if $line eq ''; # blank line is our record delimiter if ($invars) { if ($line =~ /^\s/) { $line =~ s/^\s+//; my ($var, $value)=split(/\s*=\s?/, $line, 2); $value=~s/\\n/\n/g; $ret{variables}->{$var}=$value; next; } else { $invars=0; } } my ($key, $value)=split(/:\s?/, $line, 2); $key=lc($key); if ($key eq 'owners') { foreach my $owner (split(/,\s+/, $value)) { $ret{owners}->{$owner}=1; } } elsif ($key eq 'flags') { foreach my $flag (split(/,\s+/, $value)) { $ret{flags}->{$flag}='true'; } } elsif ($key eq 'variables') { $invars=1; } elsif ($key eq 'name') { $name=$value; } elsif (length $key) { $value=~s/\\n/\n/g; $ret{fields}->{$key}=$value; } } return unless defined $name; return $name, \%ret; } sub write { my $this=shift; my $fh=shift; my %data=%{shift()}; my $name=shift; print $fh "Name: $name\n" or return undef; foreach my $field (sort keys %{$data{fields}}) { my $val=$data{fields}->{$field}; $val=~s/\n/\\n/g; print $fh ucfirst($field).": $val\n" or return undef; } if (keys %{$data{owners}}) { print $fh "Owners: ".join(", ", sort keys(%{$data{owners}}))."\n" or return undef; } if (grep { $data{flags}->{$_} eq 'true' } keys %{$data{flags}}) { print $fh "Flags: ".join(", ", grep { $data{flags}->{$_} eq 'true' } sort keys(%{$data{flags}}))."\n" or return undef; } if (keys %{$data{variables}}) { print $fh "Variables:\n" or return undef; foreach my $var (sort keys %{$data{variables}}) { my $val=$data{variables}->{$var}; $val=~s/\n/\\n/g; print $fh " $var = $val\n" or return undef; } } print $fh "\n" or return undef; # end of record delimiter return 1; } 1 PK ! �gS� � Debconf/Iterator.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Iterator; use strict; use base qw(Debconf::Base); sub iterate { my $this=shift; $this->callback->($this); } 1 PK ! ɗ|�� � Debconf/Element.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Element; use strict; use base qw(Debconf::Base); sub visible { my $this=shift; return 1; } sub show {} 1 PK ! �0t�f f Debconf/DbDriver/Backup.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::Backup; use strict; use Debconf::Log qw{:all}; use base 'Debconf::DbDriver::Copy'; use fields qw(db backupdb); sub init { my $this=shift; foreach my $f (qw(db backupdb)) { if (! ref $this->{$f}) { my $db=$this->driver($this->{$f}); unless (defined $f) { $this->error("could not find a db named \"$this->{$f}\""); } $this->{$f}=$db; } } } sub copy { my $this=shift; my $item=shift; $this->SUPER::copy($item, $this->{db}, $this->{backupdb}); } sub shutdown { my $this=shift; $this->{backupdb}->shutdown(@_); $this->{db}->shutdown(@_); } sub _query { my $this=shift; my $command=shift; shift; # this again return $this->{db}->$command(@_); } sub _change { my $this=shift; my $command=shift; shift; # this again my $ret=$this->{db}->$command(@_); if (defined $ret) { $this->{backupdb}->$command(@_); } return $ret; } sub iterator { $_[0]->_query('iterator', @_) } sub exists { $_[0]->_query('exists', @_) } sub addowner { $_[0]->_change('addowner', @_) } sub removeowner { $_[0]->_change('removeowner', @_) } sub owners { $_[0]->_query('owners', @_) } sub getfield { $_[0]->_query('getfield', @_) } sub setfield { $_[0]->_change('setfield', @_) } sub fields { $_[0]->_query('fields', @_) } sub getflag { $_[0]->_query('getflag', @_) } sub setflag { $_[0]->_change('setflag', @_) } sub flags { $_[0]->_query('flags', @_) } sub getvariable { $_[0]->_query('getvariable', @_) } sub setvariable { $_[0]->_change('setvariable', @_) } sub variables { $_[0]->_query('variables', @_) } 1 PK ! ���s� � Debconf/DbDriver/DirTree.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::DirTree; use strict; use Debconf::Log qw(:all); use base 'Debconf::DbDriver::Directory'; sub init { my $this=shift; if (! defined $this->{extension} or ! length $this->{extension}) { $this->{extension}=".dat"; } $this->SUPER::init(@_); } sub save { my $this=shift; my $item=shift; return unless $this->accept($item); return if $this->{readonly}; my @dirs=split(m:/:, $this->filename($item)); pop @dirs; # the base filename my $base=$this->{directory}; foreach (@dirs) { $base.="/$_"; next if -d $base; mkdir $base or $this->error("mkdir $base: $!"); } $this->SUPER::save($item, @_); } sub filename { my $this=shift; my $item=shift; $item =~ s/\.\.//g; return $item.$this->{extension}; } sub iterator { my $this=shift; my @stack=(); my $currentdir=""; my $handle; opendir($handle, $this->{directory}) or $this->error("opendir: $this->{directory}: $!"); my $iterator=Debconf::Iterator->new(callback => sub { my $i; while ($handle or @stack) { while (@stack and not $handle) { $currentdir=pop @stack; opendir($handle, "$this->{directory}/$currentdir") or $this->error("opendir: $this->{directory}/$currentdir: $!"); } $i=readdir($handle); if (not defined $i) { closedir $handle; $handle=undef; next; } next if $i eq '.lock' || $i =~ /-old$/; if (-d "$this->{directory}/$currentdir$i") { if ($i ne '..' and $i ne '.') { push @stack, "$currentdir$i/"; } next; } next unless $i=~s/$this->{extension}$//; return $currentdir.$i; } return undef; }); $this->SUPER::iterator($iterator); } sub remove { my $this=shift; my $item=shift; my $ret=$this->SUPER::remove($item); return $ret unless $ret; my $dir=$this->filename($item); while ($dir=~s:(.*)/[^/]*:$1: and length $dir) { rmdir "$this->{directory}/$dir" or last; # not empty, I presume } return $ret; } 1 PK ! �߶ � Debconf/DbDriver/Debug.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::Debug; use strict; use Debconf::Log qw{:all}; use base 'Debconf::DbDriver'; use fields qw(db); sub init { my $this=shift; if (! ref $this->{db}) { $this->{db}=$this->driver($this->{db}); unless (defined $this->{db}) { $this->error("could not find db"); } } } sub DESTROY {} sub AUTOLOAD { my $this=shift; (my $command = our $AUTOLOAD) =~ s/.*://; debug "db $this->{name}" => "running $command(".join(",", map { "'$_'" } @_).") .."; if (wantarray) { my @ret=$this->{db}->$command(@_); debug "db $this->{name}" => "$command returned (".join(", ", @ret).")"; return @ret if @ret; } else { my $ret=$this->{db}->$command(@_); if (defined $ret) { debug "db $this->{name}" => "$command returned \'$ret\'"; return $ret; } else { debug "db $this->{name}" => "$command returned undef"; } } return; # failure } 1 PK ! ���t t Debconf/DbDriver/Directory.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::Directory; use strict; use Debconf::Log qw(:all); use IO::File; use POSIX (); use Fcntl qw(:DEFAULT :flock); use Debconf::Iterator; use base 'Debconf::DbDriver::Cache'; use fields qw(directory extension lock format); sub init { my $this=shift; $this->{extension} = "" unless exists $this->{extension}; $this->{format} = "822" unless exists $this->{format}; $this->{backup} = 1 unless exists $this->{backup}; $this->error("No format specified") unless $this->{format}; eval "use Debconf::Format::$this->{format}"; if ($@) { $this->error("Error setting up format object $this->{format}: $@"); } $this->{format}="Debconf::Format::$this->{format}"->new; if (not ref $this->{format}) { $this->error("Unable to make format object"); } $this->error("No directory specified") unless $this->{directory}; if (exists $this->{root}) { $this->{directory} = $this->{root} . $this->{directory}; } if (not -d $this->{directory} and not $this->{readonly}) { mkdir $this->{directory} || $this->error("mkdir $this->{directory}:$!"); } if (not -d $this->{directory}) { $this->error($this->{directory}." does not exist"); } debug "db $this->{name}" => "started; directory is $this->{directory}"; if (! $this->{readonly}) { open ($this->{lock}, ">".$this->{directory}."/.lock") or $this->error("could not lock $this->{directory}: $!"); while (! flock($this->{lock}, LOCK_EX | LOCK_NB)) { next if $! == &POSIX::EINTR; $this->error("$this->{directory} is locked by another process: $!"); last; } } } sub load { my $this=shift; my $item=shift; debug "db $this->{name}" => "loading $item"; my $file=$this->{directory}.'/'.$this->filename($item); return unless -e $file; my $fh=IO::File->new; open($fh, $file) or $this->error("$file: $!"); $this->cacheadd($this->{format}->read($fh)); close $fh; } sub save { my $this=shift; my $item=shift; my $data=shift; return unless $this->accept($item); return if $this->{readonly}; debug "db $this->{name}" => "saving $item"; my $file=$this->{directory}.'/'.$this->filename($item); my $fh=IO::File->new; if ($this->ispassword($item)) { sysopen($fh, $file."-new", O_WRONLY|O_TRUNC|O_CREAT, 0600) or $this->error("$file-new: $!"); } else { open($fh, ">$file-new") or $this->error("$file-new: $!"); } $this->{format}->beginfile; $this->{format}->write($fh, $data, $item) or $this->error("could not write $file-new: $!"); $this->{format}->endfile; $fh->flush or $this->error("could not flush $file-new: $!"); $fh->sync or $this->error("could not sync $file-new: $!"); close $fh or $this->error("could not close $file-new: $!"); if (-e $file && $this->{backup}) { rename($file, $file."-old") or debug "db $this->{name}" => "rename failed: $!"; } rename("$file-new", $file) or $this->error("rename failed: $!"); } sub shutdown { my $this=shift; $this->SUPER::shutdown(@_); delete $this->{lock}; return 1; } sub exists { my $this=shift; my $name=shift; my $incache=$this->SUPER::exists($name); return $incache if (!defined $incache or $incache); return -e $this->{directory}.'/'.$this->filename($name); } sub remove { my $this=shift; my $name=shift; return if $this->{readonly} or not $this->accept($name); debug "db $this->{name}" => "removing $name"; my $file=$this->{directory}.'/'.$this->filename($name); unlink $file or return undef; if (-e $file."-old") { unlink $file."-old" or return undef; } return 1; } sub accept { my $this=shift; my $name=shift; return if $name=~m#\.\./# or $name=~m#/\.\.#; $this->SUPER::accept($name, @_); } 1 PK ! )��&� � Debconf/DbDriver/File.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::File; use strict; use Debconf::Log qw(:all); use Cwd 'abs_path'; use POSIX (); use Fcntl qw(:DEFAULT :flock); use IO::Handle; use base 'Debconf::DbDriver::Cache'; use fields qw(filename mode format _fh); sub init { my $this=shift; if (exists $this->{mode}) { $this->{mode} = oct($this->{mode}); } else { $this->{mode} = 0600; } $this->{format} = "822" unless exists $this->{format}; $this->{backup} = 1 unless exists $this->{backup}; $this->error("No format specified") unless $this->{format}; eval "use Debconf::Format::$this->{format}"; if ($@) { $this->error("Error setting up format object $this->{format}: $@"); } $this->{format}="Debconf::Format::$this->{format}"->new; if (not ref $this->{format}) { $this->error("Unable to make format object"); } $this->error("No filename specified") unless $this->{filename}; my ($directory)=$this->{filename}=~m!^(.*)/[^/]+!; if (length $directory and ! -d $directory) { mkdir $directory || $this->error("mkdir $directory:$!"); } if (exists $this->{root}) { $this->{filename} = $this->{root} . $this->{filename}; } $this->{filename} = abs_path($this->{filename}); debug "db $this->{name}" => "started; filename is $this->{filename}"; if (! -e $this->{filename}) { $this->{backup}=0; sysopen(my $fh, $this->{filename}, O_WRONLY|O_TRUNC|O_CREAT,$this->{mode}) or $this->error("could not open $this->{filename}"); close $fh; } my $implicit_readonly=0; if (! $this->{readonly}) { if (open ($this->{_fh}, "+<", $this->{filename})) { while (! flock($this->{_fh}, LOCK_EX | LOCK_NB)) { next if $! == &POSIX::EINTR; $this->error("$this->{filename} is locked by another process: $!"); last; } } else { $implicit_readonly=1; } } if ($this->{readonly} || $implicit_readonly) { if (! open ($this->{_fh}, "<", $this->{filename})) { $this->error("could not open $this->{filename}: $!"); return; # always abort, even if not throwing fatal error } } $this->SUPER::init(@_); debug "db $this->{name}" => "loading database"; while (! eof $this->{_fh}) { my ($item, $cache)=$this->{format}->read($this->{_fh}); $this->{cache}->{$item}=$cache; } if ($this->{readonly} || $implicit_readonly) { close $this->{_fh}; } } sub shutdown { my $this=shift; return if $this->{readonly}; if (grep $this->{dirty}->{$_}, keys %{$this->{cache}}) { debug "db $this->{name}" => "saving database"; } else { debug "db $this->{name}" => "no database changes, not saving"; delete $this->{_fh}; return 1; } sysopen(my $fh, $this->{filename}."-new", O_WRONLY|O_TRUNC|O_CREAT,$this->{mode}) or $this->error("could not write $this->{filename}-new: $!"); while (! flock($fh, LOCK_EX | LOCK_NB)) { next if $! == &POSIX::EINTR; $this->error("$this->{filename}-new is locked by another process: $!"); last; } $this->{format}->beginfile; foreach my $item (sort keys %{$this->{cache}}) { next unless defined $this->{cache}->{$item}; # skip deleted $this->{format}->write($fh, $this->{cache}->{$item}, $item) or $this->error("could not write $this->{filename}-new: $!"); } $this->{format}->endfile; $fh->flush or $this->error("could not flush $this->{filename}-new: $!"); $fh->sync or $this->error("could not sync $this->{filename}-new: $!"); if (-e $this->{filename} && $this->{backup}) { rename($this->{filename}, $this->{filename}."-old") or debug "db $this->{name}" => "rename failed: $!"; } rename($this->{filename}."-new", $this->{filename}) or $this->error("rename failed: $!"); delete $this->{_fh}; return 1; } sub load { return undef; } 1 PK ! ��/zW W Debconf/DbDriver/PackageDir.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::PackageDir; use strict; use Debconf::Log qw(:all); use IO::File; use Fcntl qw(:DEFAULT :flock); use Debconf::Iterator; use base 'Debconf::DbDriver::Directory'; use fields qw(mode _loaded); sub init { my $this=shift; if (exists $this->{mode}) { $this->{mode} = oct($this->{mode}); } else { $this->{mode} = 0600; } $this->SUPER::init(@_); } sub loadfile { my $this=shift; my $file=$this->{directory}."/".shift; return if $this->{_loaded}->{$file}; $this->{_loaded}->{$file}=1; debug "db $this->{name}" => "loading $file"; return unless -e $file; my $fh=IO::File->new; open($fh, $file) or $this->error("$file: $!"); my @item = $this->{format}->read($fh); while (@item) { $this->cacheadd(@item); @item = $this->{format}->read($fh); } close $fh; } sub load { my $this=shift; my $item=shift; $this->loadfile($this->filename($item)); } sub filename { my $this=shift; my $item=shift; if ($item =~ m!^([^/]+)(?:/|$)!) { return $1.$this->{extension}; } else { $this->error("failed parsing item name \"$item\"\n"); } } sub iterator { my $this=shift; my $handle; opendir($handle, $this->{directory}) || $this->error("opendir: $!"); while (my $file=readdir($handle)) { next if length $this->{extension} and not $file=~m/$this->{extension}/; next unless -f $this->{directory}."/".$file; next if $file eq '.lock' || $file =~ /-old$/; $this->loadfile($file); } $this->SUPER::iterator; } sub exists { my $this=shift; my $name=shift; my $incache=$this->Debconf::DbDriver::Cache::exists($name); return $incache if (!defined $incache or $incache); my $file=$this->{directory}.'/'.$this->filename($name); return unless -e $file; $this->load($name); return $this->Debconf::DbDriver::Cache::exists($name); } sub shutdown { my $this=shift; return if $this->{readonly}; my (%files, %filecontents, %killfiles, %dirtyfiles); foreach my $item (keys %{$this->{cache}}) { my $file=$this->filename($item); $files{$file}++; if (! defined $this->{cache}->{$item}) { $killfiles{$file}++; delete $this->{cache}->{$item}; } else { push @{$filecontents{$file}}, $item; } if ($this->{dirty}->{$item}) { $dirtyfiles{$file}++; $this->{dirty}->{$item}=0; } } foreach my $file (keys %files) { if (! $filecontents{$file} && $killfiles{$file}) { debug "db $this->{name}" => "removing $file"; my $filename=$this->{directory}."/".$file; unlink $filename or $this->error("unable to remove $filename: $!"); if (-e $filename."-old") { unlink $filename."-old" or $this->error("unable to remove $filename-old: $!"); } } elsif ($dirtyfiles{$file}) { debug "db $this->{name}" => "saving $file"; my $filename=$this->{directory}."/".$file; sysopen(my $fh, $filename."-new", O_WRONLY|O_TRUNC|O_CREAT,$this->{mode}) or $this->error("could not write $filename-new: $!"); $this->{format}->beginfile; foreach my $item (@{$filecontents{$file}}) { $this->{format}->write($fh, $this->{cache}->{$item}, $item) or $this->error("could not write $filename-new: $!"); } $this->{format}->endfile; $fh->flush or $this->error("could not flush $filename-new: $!"); $fh->sync or $this->error("could not sync $filename-new: $!"); if (-e $filename && $this->{backup}) { rename($filename, $filename."-old") or debug "db $this->{name}" => "rename failed: $!"; } rename($filename."-new", $filename) or $this->error("rename failed: $!"); } } $this->SUPER::shutdown(@_); return 1; } 1 PK ! ��R R Debconf/DbDriver/LDAP.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::LDAP; use strict; use Debconf::Log qw(:all); use Net::LDAP; use base 'Debconf::DbDriver::Cache'; use fields qw(server port basedn binddn bindpasswd exists keybykey ds accept_attribute reject_attribute); sub binddb { my $this=shift; $this->error("No server specified") unless exists $this->{server}; $this->error("No Base DN specified") unless exists $this->{basedn}; $this->{binddn} = "" unless exists $this->{binddn}; $this->{port} = 389 unless exists $this->{port}; debug "db $this->{name}" => "talking to $this->{server}, data under $this->{basedn}"; $this->{ds} = Net::LDAP->new($this->{server}, port => $this->{port}, version => 3); if (! $this->{ds}) { $this->error("Unable to connect to LDAP server"); return; # if not fatal, give up anyway } my $rv = ""; if (!($this->{binddn} && $this->{bindpasswd})) { debug "db $this->{name}" => "binding anonymously; hope that's OK"; $rv = $this->{ds}->bind; } else { debug "db $this->{name}" => "binding as $this->{binddn}"; $rv = $this->{ds}->bind($this->{binddn}, password => $this->{bindpasswd}); } if ($rv->code) { $this->error("Bind Failed: ".$rv->error); } return $this->{ds}; } sub init { my $this = shift; $this->SUPER::init(@_); $this->binddb; return unless $this->{ds}; $this->{exists} = {}; if ($this->{keybykey}) { debug "db $this->{name}" => "will get database data key by key"; } else { debug "db $this->{name}" => "getting database data"; my $data = $this->{ds}->search(base => $this->{basedn}, sizelimit => 0, timelimit => 0, filter => "(objectclass=debconfDbEntry)"); if ($data->code) { $this->error("Search failed: ".$data->error); } my $records = $data->as_struct(); debug "db $this->{name}" => "Read ".$data->count()." entries"; $this->parse_records($records); $this->{ds}->unbind; } } sub shutdown { my $this = shift; return if $this->{readonly}; if (grep $this->{dirty}->{$_}, keys %{$this->{cache}}) { debug "db $this->{name}" => "saving changes"; } else { debug "db $this->{name}" => "no database changes, not saving"; return 1; } unless ($this->{keybykey}) { $this->binddb; return unless $this->{ds}; } foreach my $item (keys %{$this->{cache}}) { next unless defined $this->{cache}->{$item}; # skip deleted next unless $this->{dirty}->{$item}; # skip unchanged (my $entry_cn = $item) =~ s/([,+="<>#;])/\\$1/g; my $entry_dn = "cn=$entry_cn,$this->{basedn}"; debug "db $this->{name}" => "writing out to $entry_dn"; my %data = %{$this->{cache}->{$item}}; my %modify_data; my $add_data = [ 'objectclass' => 'top', 'objectclass' => 'debconfdbentry', 'cn' => $item ]; my @fields = keys %{$data{fields}}; foreach my $field (@fields) { my $ldapname = $field; if ( $ldapname =~ s/_(\w)/uc($1)/ge ) { $data{fields}->{$ldapname} = $data{fields}->{$field}; delete $data{fields}->{$field}; } } foreach my $field (keys %{$data{fields}}) { next if ($data{fields}->{$field} eq '' && !($field eq 'value')); if ((exists $this->{accept_attribute} && $field !~ /$this->{accept_attribute}/) or (exists $this->{reject_attribute} && $field =~ /$this->{reject_attribute}/)) { debug "db $item" => "reject $field"; next; } $modify_data{$field}=$data{fields}->{$field}; push(@{$add_data}, $field); push(@{$add_data}, $data{fields}->{$field}); } my @owners = keys %{$data{owners}}; debug "db $this->{name}" => "owners is ".join(" ", @owners); $modify_data{owners} = \@owners; push(@{$add_data}, 'owners'); push(@{$add_data}, \@owners); my @flags = grep { $data{flags}->{$_} eq 'true' } keys %{$data{flags}}; if (@flags) { $modify_data{flags} = \@flags; push(@{$add_data}, 'flags'); push(@{$add_data}, \@flags); } $modify_data{variables} = []; foreach my $var (keys %{$data{variables}}) { my $variable = "$var=$data{variables}->{$var}"; push (@{$modify_data{variables}}, $variable); push(@{$add_data}, 'variables'); push(@{$add_data}, $variable); } my $rv=""; if ($this->{exists}->{$item}) { $rv = $this->{ds}->modify($entry_dn, replace => \%modify_data); } else { $rv = $this->{ds}->add($entry_dn, attrs => $add_data); } if ($rv->code) { $this->error("Modify failed: ".$rv->error); } } $this->{ds}->unbind(); $this->SUPER::shutdown(@_); } sub load { my $this = shift; return unless $this->{keybykey}; my $entry_cn = shift; my $records = $this->get_key($entry_cn); return unless $records; debug "db $this->{name}" => "Read entry for $entry_cn"; $this->parse_records($records); } sub remove { return 1; } sub save { return 1; } sub get_key { my $this = shift; return unless $this->{keybykey}; my $entry_cn = shift; my $data = $this->{ds}->search( base => 'cn=' . $entry_cn . ',' . $this->{basedn}, sizelimit => 0, timelimit => 0, filter => "(objectclass=debconfDbEntry)"); if ($data->code) { $this->error("Search failed: ".$data->error); } return unless $data->entries; $data->as_struct(); } sub parse_records { my $this = shift; my $records = shift; foreach my $dn (keys %{$records}) { my $entry = $records->{$dn}; debug "db $this->{name}" => "Reading data from $dn"; my %ret = (owners => {}, fields => {}, variables => {}, flags => {}, ); my $name = ""; foreach my $attr (keys %{$entry}) { if ($attr eq 'objectclass') { next; } my $values = $entry->{$attr}; $attr =~ s/([a-z])([A-Z])/$1.'_'.lc($2)/ge; debug "db $this->{name}" => "Setting data for $attr"; foreach my $val (@{$values}) { debug "db $this->{name}" => "$attr = $val"; if ($attr eq 'owners') { $ret{owners}->{$val}=1; } elsif ($attr eq 'flags') { $ret{flags}->{$val}='true'; } elsif ($attr eq 'cn') { $name = $val; } elsif ($attr eq 'variables') { my ($var, $value)=split(/\s*=\s*/, $val, 2); $ret{variables}->{$var}=$value; } else { $val=~s/\\n/\n/g; $ret{fields}->{$attr}=$val; } } } $this->{cache}->{$name} = \%ret; $this->{exists}->{$name} = 1; } } 1 PK ! Tu� � � Debconf/DbDriver/Pipe.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::Pipe; use strict; use Debconf::Log qw(:all); use base 'Debconf::DbDriver::Cache'; use fields qw(infd outfd format); sub init { my $this=shift; $this->{format} = "822" unless exists $this->{format}; $this->error("No format specified") unless $this->{format}; eval "use Debconf::Format::$this->{format}"; if ($@) { $this->error("Error setting up format object $this->{format}: $@"); } $this->{format}="Debconf::Format::$this->{format}"->new; if (not ref $this->{format}) { $this->error("Unable to make format object"); } my $fh; if (defined $this->{infd}) { if ($this->{infd} ne 'none') { open ($fh, "<&=$this->{infd}") or $this->error("could not open file descriptor #$this->{infd}: $!"); } } else { open ($fh, '-'); } $this->SUPER::init(@_); debug "db $this->{name}" => "loading database"; if (defined $fh) { while (! eof $fh) { my ($item, $cache)=$this->{format}->read($fh); $this->{cache}->{$item}=$cache; } close $fh; } } sub shutdown { my $this=shift; return if $this->{readonly}; my $fh; if (defined $this->{outfd}) { if ($this->{outfd} ne 'none') { open ($fh, ">&=$this->{outfd}") or $this->error("could not open file descriptor #$this->{outfd}: $!"); } } else { open ($fh, '>-'); } if (defined $fh) { $this->{format}->beginfile; foreach my $item (sort keys %{$this->{cache}}) { next unless defined $this->{cache}->{$item}; # skip deleted $this->{format}->write($fh, $this->{cache}->{$item}, $item) or $this->error("could not write to pipe: $!"); } $this->{format}->endfile; close $fh or $this->error("could not close pipe: $!"); } return 1; } sub load { return undef; } 1 PK ! ��ۙ� � Debconf/DbDriver/Copy.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::Copy; use strict; use Debconf::Log qw{:all}; use base 'Debconf::DbDriver'; sub copy { my $this=shift; my $item=shift; my $src=shift; my $dest=shift; debug "db $this->{name}" => "copying $item from $src->{name} to $dest->{name}"; my @owners=$src->owners($item); if (! @owners) { @owners=("unknown"); } foreach my $owner (@owners) { my $template = Debconf::Template->get($src->getfield($item, 'template')); my $type=""; $type = $template->type if $template; $dest->addowner($item, $owner, $type); } foreach my $field ($src->fields($item)) { $dest->setfield($item, $field, $src->getfield($item, $field)); } foreach my $flag ($src->flags($item)) { $dest->setflag($item, $flag, $src->getflag($item, $flag)); } foreach my $var ($src->variables($item)) { $dest->setvariable($item, $var, $src->getvariable($item, $var)); } } 1 PK ! ųb�� � Debconf/DbDriver/Cache.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::Cache; use strict; use Debconf::Log qw{:all}; use base 'Debconf::DbDriver'; use fields qw(cache dirty); sub iterator { my $this=shift; my $subiterator=shift; my @items=keys %{$this->{cache}}; my $iterator=Debconf::Iterator->new(callback => sub { while (my $item = pop @items) { next unless defined $this->{cache}->{$item}; return $item; } return unless $subiterator; my $ret; do { $ret=$subiterator->iterate; } while defined $ret and exists $this->{cache}->{$ret}; return $ret; }); return $iterator; } sub exists { my $this=shift; my $item=shift; return $this->{cache}->{$item} if exists $this->{cache}->{$item}; return 0; } sub init { my $this=shift; $this->{cache} = {} unless exists $this->{cache}; } sub cacheadd { my $this=shift; my $item=shift; my $entry=shift; return if exists $this->{cache}->{$item}; $this->{cache}->{$item}=$entry; $this->{dirty}->{$item}=0; } sub cachedata { my $this=shift; my $item=shift; return $this->{cache}->{$item}; } sub cached { my $this=shift; my $item=shift; unless (exists $this->{cache}->{$item}) { debug "db $this->{name}" => "cache miss on $item"; $this->load($item); } return $this->{cache}->{$item}; } sub shutdown { my $this=shift; return if $this->{readonly}; my $ret=1; foreach my $item (keys %{$this->{cache}}) { if (not defined $this->{cache}->{$item}) { $ret=undef unless defined $this->remove($item); delete $this->{cache}->{$item}; } elsif ($this->{dirty}->{$item}) { $ret=undef unless defined $this->save($item, $this->{cache}->{$item}); $this->{dirty}->{$item}=0; } } return $ret; } sub addowner { my $this=shift; my $item=shift; my $owner=shift; my $type=shift; return if $this->{readonly}; $this->cached($item); if (! defined $this->{cache}->{$item}) { return if ! $this->accept($item, $type); debug "db $this->{name}" => "creating in-cache $item"; $this->{cache}->{$item}={ owners => {}, fields => {}, variables => {}, flags => {}, } } if (! exists $this->{cache}->{$item}->{owners}->{$owner}) { $this->{cache}->{$item}->{owners}->{$owner}=1; $this->{dirty}->{$item}=1; } return $owner; } sub removeowner { my $this=shift; my $item=shift; my $owner=shift; return if $this->{readonly}; return unless $this->cached($item); if (exists $this->{cache}->{$item}->{owners}->{$owner}) { delete $this->{cache}->{$item}->{owners}->{$owner}; $this->{dirty}->{$item}=1; } unless (keys %{$this->{cache}->{$item}->{owners}}) { $this->{cache}->{$item}=undef; $this->{dirty}->{$item}=1; } return $owner; } sub owners { my $this=shift; my $item=shift; return unless $this->cached($item); return keys %{$this->{cache}->{$item}->{owners}}; } sub getfield { my $this=shift; my $item=shift; my $field=shift; return unless $this->cached($item); return $this->{cache}->{$item}->{fields}->{$field}; } sub setfield { my $this=shift; my $item=shift; my $field=shift; my $value=shift; return if $this->{readonly}; return unless $this->cached($item); $this->{dirty}->{$item}=1; return $this->{cache}->{$item}->{fields}->{$field} = $value; } sub removefield { my $this=shift; my $item=shift; my $field=shift; return if $this->{readonly}; return unless $this->cached($item); $this->{dirty}->{$item}=1; return delete $this->{cache}->{$item}->{fields}->{$field}; } sub fields { my $this=shift; my $item=shift; return unless $this->cached($item); return keys %{$this->{cache}->{$item}->{fields}}; } sub getflag { my $this=shift; my $item=shift; my $flag=shift; return unless $this->cached($item); return $this->{cache}->{$item}->{flags}->{$flag} if exists $this->{cache}->{$item}->{flags}->{$flag}; return 'false'; } sub setflag { my $this=shift; my $item=shift; my $flag=shift; my $value=shift; return if $this->{readonly}; return unless $this->cached($item); $this->{dirty}->{$item}=1; return $this->{cache}->{$item}->{flags}->{$flag} = $value; } sub flags { my $this=shift; my $item=shift; return unless $this->cached($item); return keys %{$this->{cache}->{$item}->{flags}}; } sub getvariable { my $this=shift; my $item=shift; my $variable=shift; return unless $this->cached($item); return $this->{cache}->{$item}->{variables}->{$variable}; } sub setvariable { my $this=shift; my $item=shift; my $variable=shift; my $value=shift; return if $this->{readonly}; return unless $this->cached($item); $this->{dirty}->{$item}=1; return $this->{cache}->{$item}->{variables}->{$variable} = $value; } sub variables { my $this=shift; my $item=shift; return unless $this->cached($item); return keys %{$this->{cache}->{$item}->{variables}}; } 1 PK ! �A�_� � Debconf/DbDriver/Stack.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver::Stack; use strict; use Debconf::Log qw{:all}; use Debconf::Iterator; use base 'Debconf::DbDriver::Copy'; use fields qw(stack stack_change_errors); sub init { my $this=shift; if (! ref $this->{stack}) { my @stack; foreach my $name (split(/\s*,\s/, $this->{stack})) { my $driver=$this->driver($name); unless (defined $driver) { $this->error("could not find a db named \"$name\" to use in the stack (it should be defined before the stack in the config file)"); next; } push @stack, $driver; } $this->{stack}=[@stack]; } $this->error("no stack set") if ! ref $this->{stack}; $this->error("stack is empty") if ! @{$this->{stack}}; } sub iterator { my $this=shift; my %seen; my @iterators = map { $_->iterator } @{$this->{stack}}; my $i = pop @iterators; my $iterator=Debconf::Iterator->new(callback => sub { for (;;) { while (my $ret = $i->iterate) { next if $seen{$ret}; $seen{$ret}=1; return $ret; } $i = pop @iterators; return undef unless defined $i; } }); } sub shutdown { my $this=shift; my $ret=1; foreach my $driver (@{$this->{stack}}) { $ret=undef if not defined $driver->shutdown(@_); } if ($this->{stack_change_errors}) { $this->error("unable to save changes to: ". join(" ", @{$this->{stack_change_errors}})); $ret=undef; } return $ret; } sub exists { my $this=shift; foreach my $driver (@{$this->{stack}}) { return 1 if $driver->exists(@_); } return 0; } sub _query { my $this=shift; my $command=shift; shift; # this again debug "db $this->{name}" => "trying to $command(@_) .."; foreach my $driver (@{$this->{stack}}) { if (wantarray) { my @ret=$driver->$command(@_); debug "db $this->{name}" => "$command done by $driver->{name}" if @ret; return @ret if @ret; } else { my $ret=$driver->$command(@_); debug "db $this->{name}" => "$command done by $driver->{name}" if defined $ret; return $ret if defined $ret; } } return; # failure } sub _change { my $this=shift; my $command=shift; shift; # this again my $item=shift; debug "db $this->{name}" => "trying to $command($item @_) .."; foreach my $driver (@{$this->{stack}}) { if ($driver->exists($item)) { last if $driver->{readonly}; # nope, hit a readonly one debug "db $this->{name}" => "passing to $driver->{name} .."; return $driver->$command($item, @_); } } my $src=0; foreach my $driver (@{$this->{stack}}) { if ($driver->exists($item)) { my $ret=$this->_nochange($driver, $command, $item, @_); if (defined $ret) { debug "db $this->{name}" => "skipped $command($item) as it would have no effect"; return $ret; } $src=$driver; last } } my $writer; foreach my $driver (@{$this->{stack}}) { if ($driver == $src) { push @{$this->{stack_change_errors}}, $item; return; } if (! $driver->{readonly}) { if ($command eq 'addowner') { if ($driver->accept($item, $_[1])) { $writer=$driver; last; } } elsif ($driver->accept($item)) { $writer=$driver; last; } } } unless ($writer) { debug "db $this->{name}" => "FAILED $command"; return; } if ($src) { $this->copy($item, $src, $writer); } debug "db $this->{name}" => "passing to $writer->{name} .."; return $writer->$command($item, @_); } sub _nochange { my $this=shift; my $driver=shift; my $command=shift; my $item=shift; if ($command eq 'addowner') { my $value=shift; foreach my $owner ($driver->owners($item)) { return $value if $owner eq $value; } return; } elsif ($command eq 'removeowner') { my $value=shift; foreach my $owner ($driver->owners($item)) { return if $owner eq $value; } return $value; # no change } elsif ($command eq 'removefield') { my $value=shift; foreach my $field ($driver->fields($item)) { return if $field eq $value; } return $value; # no change } my @list; my $get; if ($command eq 'setfield') { @list=$driver->fields($item); $get='getfield'; } elsif ($command eq 'setflag') { @list=$driver->flags($item); $get='getflag'; } elsif ($command eq 'setvariable') { @list=$driver->variables($item); $get='getvariable'; } else { $this->error("internal error; bad command: $command"); } my $thing=shift; my $value=shift; my $currentvalue=$driver->$get($item, $thing); my $exists=0; foreach my $i (@list) { $exists=1, last if $thing eq $i; } return $currentvalue unless $exists; return $currentvalue if $currentvalue eq $value; return undef; } sub addowner { $_[0]->_change('addowner', @_) } sub removeowner { $_[0]->_change('removeowner', @_) } sub owners { $_[0]->_query('owners', @_) } sub getfield { $_[0]->_query('getfield', @_) } sub setfield { $_[0]->_change('setfield', @_) } sub removefield { $_[0]->_change('removefield', @_) } sub fields { $_[0]->_query('fields', @_) } sub getflag { $_[0]->_query('getflag', @_) } sub setflag { $_[0]->_change('setflag', @_) } sub flags { $_[0]->_query('flags', @_) } sub getvariable { $_[0]->_query('getvariable', @_) } sub setvariable { $_[0]->_change('setvariable', @_) } sub variables { $_[0]->_query('variables', @_) } 1 PK ! a�^= = Debconf/ConfModule.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::ConfModule; use strict; use IPC::Open2; use FileHandle; use Debconf::Gettext; use Debconf::Config; use Debconf::Question; use Debconf::Priority qw(priority_valid high_enough); use Debconf::FrontEnd::Noninteractive; use Debconf::Log ':all'; use Debconf::Encoding; use base qw(Debconf::Base); my %codes = ( success => 0, escaped_data => 1, badparams => 10, syntaxerror => 20, input_invisible => 30, version_bad => 30, go_back => 30, progresscancel => 30, internalerror => 100, ); sub init { my $this=shift; $this->version("2.0"); $this->owner('unknown') if ! defined $this->owner; $this->frontend->capb_backup(''); $this->seen([]); $this->busy([]); $ENV{DEBIAN_HAS_FRONTEND}=1; } sub startup { my $this=shift; my $confmodule=shift; $this->frontend->clear; $this->busy([]); my @args=$this->confmodule($confmodule); push @args, @_ if @_; debug developer => "starting ".join(' ',@args); $this->pid(open2($this->read_handle(FileHandle->new), $this->write_handle(FileHandle->new), @args)) || die $!; $this->caught_sigpipe(''); $SIG{PIPE}=sub { $this->caught_sigpipe(128) }; } sub communicate { my $this=shift; my $r=$this->read_handle; $_=<$r> || return $this->finish; chomp; my $ret=$this->process_command($_); my $w=$this->write_handle; print $w $ret."\n"; return '' unless length $ret; return 1; } sub escape { my $text=shift; $text=~s/\\/\\\\/g; $text=~s/\n/\\n/g; return $text; } sub unescape_split { my $text=shift; my @words; my $word=''; for my $chunk (split /(\\.|\s+)/, $text) { if ($chunk eq '\n') { $word.="\n"; } elsif ($chunk=~/^\\(.)$/) { $word.=$1; } elsif ($chunk=~/^\s+$/) { push @words, $word; $word=''; } else { $word.=$chunk; } } push @words, $word if $word ne ''; return @words; } sub process_command { my $this=shift; debug developer => "<-- $_"; chomp; my ($command, @params); if (defined $this->client_capb and grep { $_ eq 'escape' } @{$this->client_capb}) { ($command, @params)=unescape_split($_); } else { ($command, @params)=split(' ', $_); } if (! defined $command) { return $codes{syntaxerror}.' '. "Bad line \"$_\" received from confmodule."; } $command=lc($command); if (lc($command) eq "stop") { return $this->finish; } if (! $this->can("command_$command")) { return $codes{syntaxerror}.' '. "Unsupported command \"$command\" (full line was \"$_\") received from confmodule."; } $command="command_$command"; my $ret=join(' ', $this->$command(@params)); debug developer => "--> $ret"; if ($ret=~/\n/) { debug developer => 'Warning: return value is multiline, and would break the debconf protocol. Truncating to first line.'; $ret=~s/\n.*//s; debug developer => "--> $ret"; } return $ret; } sub finish { my $this=shift; waitpid $this->pid, 0 if defined $this->pid; $this->exitcode($this->caught_sigpipe || ($? >> 8)); $SIG{PIPE} = sub {}; foreach (@{$this->seen}) { my $q=Debconf::Question->get($_->name); $_->flag('seen', 'true') if $q; } $this->seen([]); return ''; } sub command_input { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 2; my $priority=shift; my $question_name=shift; my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "\"$question_name\" doesn't exist"; if (! priority_valid($priority)) { return $codes{syntaxerror}, "\"$priority\" is not a valid priority"; } $question->priority($priority); my $visible=1; if ($question->type ne 'error') { $visible='' unless high_enough($priority); $visible='' if ! Debconf::Config->reshow && $question->flag('seen') eq 'true'; } my $markseen=$visible; if ($visible && ! $this->frontend->interactive) { $visible=''; $markseen='' unless Debconf::Config->noninteractive_seen eq 'true'; } my $element; if ($visible) { $element=$this->frontend->makeelement($question); unless ($element) { return $codes{internalerror}, "unable to make an input element"; } $visible=$element->visible; } if (! $visible) { $element=Debconf::FrontEnd::Noninteractive->makeelement($question, 1); return $codes{input_invisible}, "question skipped" unless $element; } $element->markseen($markseen); push @{$this->busy}, $question_name; $this->frontend->add($element); if ($element->visible) { return $codes{success}, "question will be asked"; } else { return $codes{input_invisible}, "question skipped"; } } sub command_clear { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 0; $this->frontend->clear; $this->busy([]); return $codes{success}; } sub command_version { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ > 1; my $version=shift; if (defined $version) { return $codes{version_bad}, "Version too low ($version)" if int($version) < int($this->version); return $codes{version_bad}, "Version too high ($version)" if int($version) > int($this->version); } return $codes{success}, $this->version; } sub command_capb { my $this=shift; $this->client_capb([@_]); if (grep { $_ eq 'backup' } @_) { $this->frontend->capb_backup(1); } else { $this->frontend->capb_backup(''); } my @capb=('multiselect', 'escape'); push @capb, $this->frontend->capb; return $codes{success}, @capb; } sub command_title { my $this=shift; $this->frontend->title(join ' ', @_); $this->frontend->requested_title($this->frontend->title); return $codes{success}; } sub command_settitle { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 1; my $question_name=shift; my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "\"$question_name\" doesn't exist"; if ($this->frontend->can('settitle')) { $this->frontend->settitle($question); } else { $this->frontend->title($question->description); } $this->frontend->requested_title($this->frontend->title); return $codes{success}; } sub command_beginblock { return $codes{success}; } sub command_endblock { return $codes{success}; } sub command_go { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ > 0; my $ret=$this->frontend->go; if ($ret && (! $this->backed_up || grep { $_->visible } @{$this->frontend->elements})) { foreach (@{$this->frontend->elements}) { $_->question->value($_->value); push @{$this->seen}, $_->question if $_->markseen && $_->question; } $this->frontend->clear; $this->busy([]); $this->backed_up(''); return $codes{success}, "ok" } else { $this->frontend->clear; $this->busy([]); $this->backed_up(1); return $codes{go_back}, "backup"; } } sub command_get { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 1; my $question_name=shift; my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "$question_name doesn't exist"; my $value=$question->value; if (defined $value) { if (defined $this->client_capb and grep { $_ eq 'escape' } @{$this->client_capb}) { return $codes{escaped_data}, escape($value); } else { return $codes{success}, $value; } } else { return $codes{success}, ''; } } sub command_set { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ < 1; my $question_name=shift; my $value=join(" ", @_); my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "$question_name doesn't exist"; $question->value($value); return $codes{success}, "value set"; } sub command_reset { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 1; my $question_name=shift; my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "$question_name doesn't exist"; $question->value($question->default); $question->flag('seen', 'false'); return $codes{success}; } sub command_subst { my $this = shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ < 2; my $question_name = shift; my $variable = shift; my $value = (join ' ', @_); my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "$question_name doesn't exist"; my $result=$question->variable($variable,$value); return $codes{internalerror}, "Substitution failed" unless defined $result; return $codes{success}; } sub command_register { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 2; my $template=shift; my $name=shift; my $tempobj = Debconf::Question->get($template); if (! $tempobj) { return $codes{badparams}, "No such template, \"$template\""; } my $question=Debconf::Question->get($name) || Debconf::Question->new($name, $this->owner, $tempobj->type); if (! $question) { return $codes{internalerror}, "Internal error making question"; } if (! defined $question->addowner($this->owner, $tempobj->type)) { return $codes{internalerror}, "Internal error adding owner"; } if (! $question->template($template)) { return $codes{internalerror}, "Internal error setting template"; } return $codes{success}; } sub command_unregister { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 1; my $name=shift; my $question=Debconf::Question->get($name) || return $codes{badparams}, "$name doesn't exist"; if (grep { $_ eq $name } @{$this->busy}) { return $codes{badparams}, "$name is busy, cannot unregister right now"; } $question->removeowner($this->owner); return $codes{success}; } sub command_purge { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ > 0; my $iterator=Debconf::Question->iterator; while (my $q=$iterator->iterate) { $q->removeowner($this->owner); } return $codes{success}; } sub command_metaget { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 2; my $question_name=shift; my $field=shift; my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "$question_name doesn't exist"; my $lcfield=lc $field; my $fieldval=$question->$lcfield(); unless (defined $fieldval) { return $codes{badparams}, "$field does not exist"; } if (defined $this->client_capb and grep { $_ eq 'escape' } @{$this->client_capb}) { return $codes{escaped_data}, escape($fieldval); } else { return $codes{success}, $fieldval; } } sub command_fget { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 2; my $question_name=shift; my $flag=shift; my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "$question_name doesn't exist"; return $codes{success}, $question->flag($flag); } sub command_fset { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ < 3; my $question_name=shift; my $flag=shift; my $value=(join ' ', @_); my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "$question_name doesn't exist"; if ($flag eq 'seen') { $this->seen([grep {$_ ne $question} @{$this->seen}]); } return $codes{success}, $question->flag($flag, $value); } sub command_info { my $this=shift; if (@_ == 0) { $this->frontend->info(undef); } elsif (@_ == 1) { my $question_name=shift; my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "\"$question_name\" doesn't exist"; $this->frontend->info($question); } else { return $codes{syntaxerror}, "Incorrect number of arguments"; } return $codes{success}; } sub command_progress { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ < 1; my $subcommand=shift; $subcommand=lc($subcommand); my $ret; if ($subcommand eq 'start') { return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 3; my $min=shift; my $max=shift; my $question_name=shift; return $codes{syntaxerror}, "min ($min) > max ($max)" if $min > $max; my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "$question_name doesn't exist"; $this->frontend->progress_start($min, $max, $question); $ret=1; } elsif ($subcommand eq 'set') { return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 1; my $value=shift; $ret = $this->frontend->progress_set($value); } elsif ($subcommand eq 'step') { return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 1; my $inc=shift; $ret = $this->frontend->progress_step($inc); } elsif ($subcommand eq 'info') { return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 1; my $question_name=shift; my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "$question_name doesn't exist"; $ret = $this->frontend->progress_info($question); } elsif ($subcommand eq 'stop') { return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 0; $this->frontend->progress_stop(); $ret=1; } else { return $codes{syntaxerror}, "Unknown subcommand"; } if ($ret) { return $codes{success}, "OK"; } else { return $codes{progresscancel}, "CANCELED"; } } sub command_data { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ < 3; my $template=shift; my $item=shift; my $value=join(' ', @_); $value=~s/\\([n"\\])/($1 eq 'n') ? "\n" : $1/eg; my $tempobj=Debconf::Template->get($template); if (! $tempobj) { if ($item ne 'type') { return $codes{badparams}, "Template data field '$item' received before type field"; } $tempobj=Debconf::Template->new($template, $this->owner, $value); if (! $tempobj) { return $codes{internalerror}, "Internal error making template"; } } else { if ($item eq 'type') { return $codes{badparams}, "Template type already set"; } $tempobj->$item(Debconf::Encoding::convert("UTF-8", $value)); } return $codes{success}; } sub command_visible { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 2; my $priority=shift; my $question_name=shift; my $question=Debconf::Question->get($question_name) || return $codes{badparams}, "$question_name doesn't exist"; return $codes{success}, $this->frontend->visible($question, $priority) ? "true" : "false"; } sub command_exist { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ != 1; my $question_name=shift; return $codes{success}, Debconf::Question->get($question_name) ? "true" : "false"; } sub command_x_loadtemplatefile { my $this=shift; return $codes{syntaxerror}, "Incorrect number of arguments" if @_ < 1 || @_ > 2; my $file=shift; my $fh=FileHandle->new($file); if (! $fh) { return $codes{badparams}, "failed to open $file: $!"; } my $owner=$this->owner; if (@_) { $owner=shift; } eval { Debconf::Template->load($fh, $owner); }; if ($@) { $@=~s/\n/\\n/g; return $codes{internalerror}, $@; } return $codes{success}; } sub AUTOLOAD { (my $field = our $AUTOLOAD) =~ s/.*://; no strict 'refs'; *$AUTOLOAD = sub { my $this=shift; return $this->{$field} unless @_; return $this->{$field}=shift; }; goto &$AUTOLOAD; } sub DESTROY { my $this=shift; $this->read_handle->close if $this->read_handle; $this->write_handle->close if $this->write_handle; if (defined $this->pid && $this->pid > 1) { kill 'TERM', $this->pid; } } 1 PK ! �5G� � Debconf/Format.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Format; use strict; use base qw(Debconf::Base); 1 PK ! h�z� � Debconf/Question.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Question; use strict; use Debconf::Db; use Debconf::Template; use Debconf::Iterator; use Debconf::Log qw(:all); use fields qw(name priority); our %question; sub new { my Debconf::Question $this=shift; my $name=shift; my $owner=shift; my $type=shift || die "no type given for question"; die "A question called \"$name\" already exists" if exists $question{$name}; unless (ref $this) { $this = fields::new($this); } $this->{name}=$name; return unless defined $this->addowner($owner, $type); $this->flag('seen', 'false'); return $question{$name}=$this; } sub get { my Debconf::Question $this=shift; my $name=shift; return $question{$name} if exists $question{$name}; if ($Debconf::Db::config->exists($name)) { $this = fields::new($this); $this->{name}=$name; return $question{$name}=$this; } return undef; } sub iterator { my $this=shift; my $real_iterator=$Debconf::Db::config->iterator; return Debconf::Iterator->new(callback => sub { return unless my $name=$real_iterator->iterate; return $this->get($name); }); } sub _expand_vars { my $this=shift; my $text=shift; return '' unless defined $text; my @vars=$Debconf::Db::config->variables($this->{name}); my $rest=$text; my $result=''; my $variable; my $varval; my $escape; while ($rest =~ m/^(.*?)(\\)?\$\{([^{}]+)\}(.*)$/sg) { $result.=$1; # copy anything before the variable $escape=$2; $variable=$3; $rest=$4; # continue trying to expand rest of text if (defined $escape && length $escape) { $result.="\${$variable}"; } else { $varval=$Debconf::Db::config->getvariable($this->{name}, $variable); $result.=$varval if defined($varval); # expand the variable } } $result.=$rest; # add on anything that's left. return $result; } sub description { my $this=shift; return $this->_expand_vars($this->template->description); } sub extended_description { my $this=shift; return $this->_expand_vars($this->template->extended_description); } sub choices { my $this=shift; return $this->_expand_vars($this->template->choices); } sub choices_split { my $this=shift; my @items; my $item=''; for my $chunk (split /(\\[, ]|,\s+)/, $this->choices) { if ($chunk=~/^\\([, ])$/) { $item.=$1; } elsif ($chunk=~/^,\s+$/) { push @items, $item; $item=''; } else { $item.=$chunk; } } push @items, $item if $item ne ''; return @items; } sub variable { my $this=shift; my $var=shift; if (@_) { return $Debconf::Db::config->setvariable($this->{name}, $var, shift); } else { return $Debconf::Db::config->getvariable($this->{name}, $var); } } sub flag { my $this=shift; my $flag=shift; if ($flag eq 'isdefault') { debug developer => "The isdefault flag is deprecated, use the seen flag instead"; if (@_) { my $value=(shift eq 'true') ? 'false' : 'true'; $Debconf::Db::config->setflag($this->{name}, 'seen', $value); } return ($Debconf::Db::config->getflag($this->{name}, 'seen') eq 'true') ? 'false' : 'true'; } if (@_) { return $Debconf::Db::config->setflag($this->{name}, $flag, shift); } else { return $Debconf::Db::config->getflag($this->{name}, $flag); } } sub value { my $this = shift; unless (@_) { my $ret=$Debconf::Db::config->getfield($this->{name}, 'value'); return $ret if defined $ret; return $this->template->default if ref $this->template; } else { return $Debconf::Db::config->setfield($this->{name}, 'value', shift); } } sub value_split { my $this=shift; my $value=$this->value; $value='' if ! defined $value; my @items; my $item=''; for my $chunk (split /(\\[, ]|,\s+)/, $value) { if ($chunk=~/^\\([, ])$/) { $item.=$1; } elsif ($chunk=~/^,\s+$/) { push @items, $item; $item=''; } else { $item.=$chunk; } } push @items, $item if $item ne ''; return @items; } sub addowner { my $this=shift; return $Debconf::Db::config->addowner($this->{name}, shift, shift); } sub removeowner { my $this=shift; my $template=$Debconf::Db::config->getfield($this->{name}, 'template'); return unless $Debconf::Db::config->removeowner($this->{name}, shift); if (length $template and not $Debconf::Db::config->exists($this->{name})) { $Debconf::Db::templates->removeowner($template, $this->{name}); delete $question{$this->{name}}; } } sub owners { my $this=shift; return join(", ", sort($Debconf::Db::config->owners($this->{name}))); } sub template { my $this=shift; if (@_) { my $oldtemplate=$Debconf::Db::config->getfield($this->{name}, 'template'); my $newtemplate=shift; if (not defined $oldtemplate or $oldtemplate ne $newtemplate) { $Debconf::Db::templates->removeowner($oldtemplate, $this->{name}) if defined $oldtemplate and length $oldtemplate; $Debconf::Db::config->setfield($this->{name}, 'template', $newtemplate); $Debconf::Db::templates->addowner($newtemplate, $this->{name}, $Debconf::Db::templates->getfield($newtemplate, "type")); } } return Debconf::Template->get( $Debconf::Db::config->getfield($this->{name}, 'template')); } sub name { my $this=shift; return $this->{name}; } sub priority { my $this=shift; $this->{priority}=shift if @_; return $this->{priority}; } sub AUTOLOAD { (my $field = our $AUTOLOAD) =~ s/.*://; no strict 'refs'; *$AUTOLOAD = sub { my $this=shift; if (@_) { return $Debconf::Db::config->setfield($this->{name}, $field, shift); } my $ret=$Debconf::Db::config->getfield($this->{name}, $field); unless (defined $ret) { $ret = $this->template->$field() if ref $this->template; } if (defined $ret) { if ($field =~ /^(?:description|extended_description|choices)-/i) { return $this->_expand_vars($ret); } else { return $ret; } } }; goto &$AUTOLOAD; } sub DESTROY { } 1 PK ! 5 H�v v Debconf/TmpFile.pmnu �[��� #!/usr/bin/perl # This file was preprocessed, do not edit! package Debconf::TmpFile; use strict; use IO::File; use Fcntl; use File::Temp; my $filename; sub open { my $fh; # will be autovivified my $ext=shift || ''; ($fh, $filename) = File::Temp::tempfile(SUFFIX => $ext); return $fh; } sub filename { return $filename; } sub cleanup { unlink $filename; } 1 PK ! ���� � Debconf/Log.pmnu �[��� #!/usr/bin/perl # This file was preprocessed, do not edit! package Debconf::Log; use strict; use base qw(Exporter); our @EXPORT_OK=qw(debug warn); our %EXPORT_TAGS = (all => [@EXPORT_OK]); # Import :all to get everything. require Debconf::Config; # not use; there are recursive use loops my $log_open=0; sub debug { my $type=shift; my $debug=Debconf::Config->debug; if ($debug && $type =~ /$debug/) { print STDERR "debconf ($type): ".join(" ", @_)."\n"; } my $log=Debconf::Config->log; if ($log && $type =~ /$log/) { require Sys::Syslog; unless ($log_open) { Sys::Syslog::setlogsock('unix'); Sys::Syslog::openlog('debconf', '', 'user'); $log_open=1; } eval { # ignore all exceptions this throws Sys::Syslog::syslog('debug', "($type): ". join(" ", @_)); }; } } sub warn { print STDERR "debconf: ".join(" ", @_)."\n" unless Debconf::Config->nowarnings eq 'yes'; } 1 PK ! e�Jb� � Debconf/Base.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Base; use Debconf::Log ':all'; use strict; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $this=bless ({@_}, $class); $this->init; return $this; } sub init {} sub AUTOLOAD { (my $field = our $AUTOLOAD) =~ s/.*://; no strict 'refs'; *$AUTOLOAD = sub { my $this=shift; return $this->{$field} unless @_; return $this->{$field}=shift; }; goto &$AUTOLOAD; } sub DESTROY { } 1 PK ! ���- - Debconf/Gettext.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Gettext; use strict; BEGIN { eval 'use Locale::gettext'; if ($@) { eval q{ sub gettext { return shift; } }; } else { textdomain('debconf'); } } use base qw(Exporter); our @EXPORT=qw(gettext); 1 PK ! �l��< < Debconf/Client/ConfModule.pmnu �[��� #!/usr/bin/perl -w =head1 NAME Debconf::Client::ConfModule - client module for ConfModules =head1 SYNOPSIS use Debconf::Client::ConfModule ':all'; version('2.0'); my $capb=capb('backup'); input("medium", "foo/bar"); my @ret=go(); if ($ret[0] == 30) { # Back button pressed. ... } ... =head1 DESCRIPTION This is a module to ease writing ConfModules for Debian's configuration management system. It can communicate with a FrontEnd via the debconf protocol (which is documented in full in the debconf_specification in Debian policy). The design is that each command in the protocol is represented by one function in this module (with the name lower-cased). Call the function and pass in any parameters you want to follow the command. If the function is called in scalar context, it will return any textual return code. If it is called in list context, an array consisting of the numeric return code and the textual return code will be returned. This module uses Exporter to export all functions it defines. To import everything, simply import ":all". =over 4 =cut package Debconf::Client::ConfModule; use strict; use base qw(Exporter); # List all valid commands here. our @EXPORT_OK=qw(version capb stop reset title input beginblock endblock go unset set get register unregister clear previous_module start_frontend fset fget subst purge metaget visible exist settitle info progress data x_loadtemplatefile); # Import :all to get everything. our %EXPORT_TAGS = (all => [@EXPORT_OK]); # Set up valid command lookup hash. my %commands; map { $commands{uc $_}=1; } @EXPORT_OK; # Unbuffered output is required. $|=1; =item import Ensure that a FrontEnd is running. It's a little hackish. If DEBIAN_HAS_FRONTEND is set, a FrontEnd is assumed to be running. If not, one is started up automatically and stdin and out are connected to it. Note that this function is always run when the module is loaded in the usual way. =cut sub import { if (! $ENV{DEBIAN_HAS_FRONTEND}) { $ENV{PERL_DL_NONLAZY}=1; if (exists $ENV{DEBCONF_USE_CDEBCONF} and $ENV{DEBCONF_USE_CDEBCONF} ne '') { exec "/usr/lib/cdebconf/debconf", $0, @ARGV; } else { exec "/usr/share/debconf/frontend", $0, @ARGV; } } # Make the Exporter still work. Debconf::Client::ConfModule->export_to_level(1, @_); # A truly gross hack. This is only needed if # /usr/share/debconf/confmodule is loaded, and then this # perl module is used. In that case, this module needs to write # to fd #3, rather than stdout. See changelog 0.3.74. if (exists $ENV{DEBCONF_REDIR} && $ENV{DEBCONF_REDIR}) { open(STDOUT,">&3"); } } =item stop The frontend doesn't send a return code here, so we cannot try to read it or we'll block. =cut sub stop { print "STOP\n"; return; } =item AUTOLOAD Creates handler functions for commands on the fly. =cut sub AUTOLOAD { my $command = uc our $AUTOLOAD; $command =~ s|.*:||; # strip fully-qualified portion die "Unsupported command `$command'." unless $commands{$command}; no strict 'refs'; *$AUTOLOAD = sub { my $c=join (' ', $command, @_); # Newlines in input can really badly confuse the protocol, so # detect and warn. if ($c=~m/\n/) { warn "Warning: Newline present in parameters passed to debconf.\n"; warn "This will probably cause strange things to happen!\n"; } print "$c\n"; my $ret=<STDIN>; chomp $ret; my @ret=split(/\s/, $ret, 2); if ($ret[0] eq '1') { # escaped data local $_; my $unescaped=''; for (split /(\\.)/, $ret[1]) { s/\\(.)/$1 eq "n" ? "\n" : $1/eg; $unescaped.=$_; } $ret[0]='0'; $ret[1]=$unescaped; } return @ret if wantarray; return $ret[1]; }; goto &$AUTOLOAD; } =back =head1 SEE ALSO The debconf specification (/usr/share/doc/debian-policy/debconf_specification.txt.gz). =head1 AUTHOR Joey Hess <joeyh@debian.org> =cut 1 PK ! ��A=< < Debconf/DbDriver.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::DbDriver; use Debconf::Log qw{:all}; use strict; use base 1.01; # ensure that they don't have a broken perl installation use fields qw(name readonly required backup failed accept_type reject_type accept_name reject_name root); our %drivers; sub new { my Debconf::DbDriver $this=shift; unless (ref $this) { $this = fields::new($this); } $this->{required}=1; $this->{readonly}=0; $this->{failed}=0; my %params=@_; foreach my $field (keys %params) { if ($field eq 'readonly' || $field eq 'required' || $field eq 'backup') { $this->{$field}=1,next if lc($params{$field}) eq "true"; $this->{$field}=0,next if lc($params{$field}) eq "false"; } elsif ($field=~/^(accept|reject)_/) { $this->{$field}=qr/$params{$field}/i; } $this->{$field}=$params{$field}; } unless (exists $this->{name}) { $this->{name}="(unknown)"; $this->error("no name specified"); } $drivers{$this->{name}} = $this; $this->init; return $this; } sub init {} sub error { my $this=shift; if ($this->{required}) { warn('DbDriver "'.$this->{name}.'":', @_); exit 1; } else { warn('DbDriver "'.$this->{name}.'" warning:', @_); } } sub driver { my $this=shift; my $name=shift; return $drivers{$name}; } sub accept { my $this=shift; my $name=shift; my $type=shift; return if $this->{failed}; if ((exists $this->{accept_name} && $name !~ /$this->{accept_name}/) || (exists $this->{reject_name} && $name =~ /$this->{reject_name}/)) { debug "db $this->{name}" => "reject $name"; return; } if (exists $this->{accept_type} || exists $this->{reject_type}) { if (! defined $type || ! length $type) { my $template = Debconf::Template->get($this->getfield($name, 'template')); return 1 unless $template; # no type to act on $type=$template->type || ''; } return if exists $this->{accept_type} && $type !~ /$this->{accept_type}/; return if exists $this->{reject_type} && $type =~ /$this->{reject_type}/; } return 1; } sub ispassword { my $this=shift; my $item=shift; my $template=$this->getfield($item, 'template'); return unless defined $template; $template=Debconf::Template->get($template); return unless $template; my $type=$template->type || ''; return 1 if $type eq 'password'; return 0; } 1 PK ! � ��# # Debconf/Path.pmnu �[��� #!/usr/bin/perl # This file was preprocessed, do not edit! package Debconf::Path; use strict; use File::Spec; sub find { my $program=shift; my @path=File::Spec->path(); for my $dir (@path) { my $file=File::Spec->catfile($dir, $program); return 1 if -x $file; } return ''; } 1 PK ! @��� � Debconf/Config.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Config; use strict; use Debconf::Question; use Debconf::Gettext; use Debconf::Priority qw(priority_valid priority_list); use Debconf::Log qw(warn); use Debconf::Db; use fields qw(config templates frontend frontend_forced priority terse reshow admin_email log debug nowarnings smileys sigils noninteractive_seen c_values); our $config=fields::new('Debconf::Config'); our @config_files=("/etc/debconf.conf", "/usr/share/debconf/debconf.conf"); if ($ENV{DEBCONF_SYSTEMRC}) { unshift @config_files, $ENV{DEBCONF_SYSTEMRC}; } else { unshift @config_files, ((getpwuid($>))[7])."/.debconfrc"; } sub _hashify ($$) { my $text=shift; my $hash=shift; $text =~ s/\$\{([^}]+)\}/$ENV{$1}/eg; my %ret; my $i; foreach my $line (split /\n/, $text) { next if $line=~/^\s*#/; # comment next if $line=~/^\s*$/; # blank $line=~s/^\s+//; $line=~s/\s+$//; $i++; my ($key, $value)=split(/\s*:\s*/, $line, 2); $key=~tr/-/_/; die "Parse error" unless defined $key and length $key; $hash->{lc($key)}=$value; } return $i; } sub _env_to_driver { my $value=shift; my ($name, $options) = $value =~ m/^(\w+)(?:{(.*)})?$/; return unless $name; return $name if Debconf::DbDriver->driver($name); my %hash = @_; # defaults from params $hash{driver} = $name; if (defined $options) { foreach (split ' ', $options) { if (/^(\w+):(.*)/) { $hash{$1}=$2; } else { $hash{filename}=$_; } } } return Debconf::Db->makedriver(%hash)->{name}; } sub load { my $class=shift; my $cf=shift; my @defaults=@_; if (! $cf) { for my $file (@config_files) { $file = "$ENV{DPKG_ROOT}$file" if exists $ENV{DPKG_ROOT}; $cf=$file, last if -e $file; } } die "No config file found" unless $cf; open (DEBCONF_CONFIG, $cf) or die "$cf: $!\n"; local $/="\n\n"; # read a stanza at a time 1 until _hashify(<DEBCONF_CONFIG>, $config) || eof DEBCONF_CONFIG; if (! exists $config->{config}) { print STDERR "debconf: ".gettext("Config database not specified in config file.")."\n"; exit(1); } if (! exists $config->{templates}) { print STDERR "debconf: ".gettext("Template database not specified in config file.")."\n"; exit(1); } if (exists $config->{sigils} || exists $config->{smileys}) { print STDERR "debconf: ".gettext("The Sigils and Smileys options in the config file are no longer used. Please remove them.")."\n"; } while (<DEBCONF_CONFIG>) { my %config=(@defaults); if (exists $ENV{DEBCONF_DB_REPLACE}) { $config{readonly} = "true"; } if (exists $ENV{DPKG_ROOT}) { $config{root} = $ENV{DPKG_ROOT}; } next unless _hashify($_, \%config); eval { Debconf::Db->makedriver(%config); }; if ($@) { print STDERR "debconf: ".sprintf(gettext("Problem setting up the database defined by stanza %s of %s."),$., $cf)."\n"; die $@; } } close DEBCONF_CONFIG; if (exists $ENV{DEBCONF_DB_REPLACE}) { $config->{config} = _env_to_driver($ENV{DEBCONF_DB_REPLACE}, name => "_ENV_REPLACE"); Debconf::Db->makedriver( driver => "Pipe", name => "_ENV_REPLACE_templates", infd => "none", outfd => "none", ); my @template_stack = ("_ENV_REPLACE_templates", $config->{templates}); Debconf::Db->makedriver( driver => "Stack", name => "_ENV_stack_templates", stack => join(", ", @template_stack), ); $config->{templates} = "_ENV_stack_templates"; } my @finalstack = ($config->{config}); if (exists $ENV{DEBCONF_DB_OVERRIDE}) { unshift @finalstack, _env_to_driver($ENV{DEBCONF_DB_OVERRIDE}, name => "_ENV_OVERRIDE"); } if (exists $ENV{DEBCONF_DB_FALLBACK}) { push @finalstack, _env_to_driver($ENV{DEBCONF_DB_FALLBACK}, name => "_ENV_FALLBACK", readonly => "true"); } if (@finalstack > 1) { Debconf::Db->makedriver( driver => "Stack", name => "_ENV_stack", stack => join(", ", @finalstack), ); $config->{config} = "_ENV_stack"; } } sub getopt { my $class=shift; my $usage=shift; my $showusage=sub { # closure print STDERR $usage."\n"; print STDERR gettext(<<EOF); -f, --frontend Specify debconf frontend to use. -p, --priority Specify minimum priority question to show. --terse Enable terse mode. EOF exit 1; }; return unless grep { $_ =~ /^-/ } @ARGV; require Getopt::Long; Getopt::Long::Configure('bundling'); Getopt::Long::GetOptions( 'frontend|f=s', sub { shift; $class->frontend(shift); $config->frontend_forced(1) }, 'priority|p=s', sub { shift; $class->priority(shift) }, 'terse', sub { $config->{terse} = 'true' }, 'help|h', $showusage, @_, ) || $showusage->(); } sub frontend { my $class=shift; return $ENV{DEBIAN_FRONTEND} if exists $ENV{DEBIAN_FRONTEND}; $config->{frontend}=shift if @_; return $config->{frontend} if exists $config->{frontend}; my $ret='dialog'; my $question=Debconf::Question->get('debconf/frontend'); if ($question) { $ret=lcfirst($question->value) || $ret; } return $ret; } sub frontend_forced { my ($class, $val) = @_; $config->{frontend_forced} = $val if defined $val || exists $ENV{DEBIAN_FRONTEND}; return $config->{frontend_forced} ? 1 : 0; } sub priority { my $class=shift; return $ENV{DEBIAN_PRIORITY} if exists $ENV{DEBIAN_PRIORITY}; if (@_) { my $newpri=shift; if (! priority_valid($newpri)) { warn(sprintf(gettext("Ignoring invalid priority \"%s\""), $newpri)); warn(sprintf(gettext("Valid priorities are: %s"), join(" ", priority_list()))); } else { $config->{priority}=$newpri; } } return $config->{priority} if exists $config->{priority}; my $ret='high'; my $question=Debconf::Question->get('debconf/priority'); if ($question) { $ret=$question->value || $ret; } return $ret; } sub terse { my $class=shift; return $ENV{DEBCONF_TERSE} if exists $ENV{DEBCONF_TERSE}; $config->{terse}=$_[0] if @_; return $config->{terse} if exists $config->{terse}; return 'false'; } sub nowarnings { my $class=shift; return $ENV{DEBCONF_NOWARNINGS} if exists $ENV{DEBCONF_NOWARNINGS}; $config->{nowarnings}=$_[0] if @_; return $config->{nowarnings} if exists $config->{nowarnings}; return 'false'; } sub debug { my $class=shift; return $ENV{DEBCONF_DEBUG} if exists $ENV{DEBCONF_DEBUG}; return $config->{debug} if exists $config->{debug}; return ''; } sub admin_email { my $class=shift; return $ENV{DEBCONF_ADMIN_EMAIL} if exists $ENV{DEBCONF_ADMIN_EMAIL}; return $config->{admin_email} if exists $config->{admin_email}; return 'root'; } sub noninteractive_seen { my $class=shift; return $ENV{DEBCONF_NONINTERACTIVE_SEEN} if exists $ENV{DEBCONF_NONINTERACTIVE_SEEN}; return $config->{noninteractive_seen} if exists $config->{noninteractive_seen}; return 'false'; } sub c_values { my $class=shift; return $ENV{DEBCONF_C_VALUES} if exists $ENV{DEBCONF_C_VALUES}; return $config->{c_values} if exists $config->{c_values}; return 'false'; } sub AUTOLOAD { (my $field = our $AUTOLOAD) =~ s/.*://; my $class=shift; return $config->{$field}=shift if @_; return $config->{$field} if defined $config->{$field}; return ''; } 1 PK ! Z�[0 0 Debconf/FrontEnd.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::FrontEnd; use strict; use Debconf::Gettext; use Debconf::Priority; use Debconf::Log ':all'; use base qw(Debconf::Base); sub init { my $this=shift; $this->elements([]); $this->interactive(''); $this->capb(''); $this->title(''); $this->requested_title(''); $this->info(undef); $this->need_tty(1); } sub elementtype { my $this=shift; my $ret; if (ref $this) { ($ret) = ref($this) =~ m/Debconf::FrontEnd::(.*)/; } else { ($ret) = $this =~ m/Debconf::FrontEnd::(.*)/; } return $ret; } my %nouse; sub _loadelementclass { my $this=shift; my $type=shift; my $nodebug=shift; if (! UNIVERSAL::can("Debconf::Element::$type", 'new')) { return if $nouse{$type}; eval qq{use Debconf::Element::$type}; if ($@ || ! UNIVERSAL::can("Debconf::Element::$type", 'new')) { warn sprintf(gettext("Unable to load Debconf::Element::%s. Failed because: %s"), $type, $@) if ! $nodebug; $nouse{$type}=1; return; } } } sub makeelement { my $this=shift; my $question=shift; my $nodebug=shift; my $type=$this->elementtype.'::'.ucfirst($question->type); $type=~s/::$//; # in case the question has no type.. $this->_loadelementclass($type, $nodebug); my $element="Debconf::Element::$type"->new(question => $question); return if ! ref $element; return $element; } sub add { my $this=shift; my $element=shift; foreach (@{$this->elements}) { return if $element->question == $_->question; } $element->frontend($this); push @{$this->elements}, $element; } sub go { my $this=shift; $this->backup(''); foreach my $element (@{$this->elements}) { $element->show; return if $this->backup && $this->capb_backup; } return 1; } sub progress_start { my $this=shift; my $min=shift; my $max=shift; my $question=shift; my $type = $this->elementtype.'::Progress'; $this->_loadelementclass($type); my $element="Debconf::Element::$type"->new(question => $question); unless (ref $element) { return; } $element->frontend($this); $element->progress_min($min); $element->progress_max($max); $element->progress_cur($min); $element->start; $this->progress_bar($element); } sub progress_set { my $this=shift; my $value=shift; return $this->progress_bar->set($value); } sub progress_step { my $this=shift; my $inc=shift; return $this->progress_set($this->progress_bar->progress_cur + $inc); } sub progress_info { my $this=shift; my $question=shift; return $this->progress_bar->info($question); } sub progress_stop { my $this=shift; $this->progress_bar->stop; $this->progress_bar(undef); } sub clear { my $this=shift; $this->elements([]); } sub default_title { my $this=shift; $this->title(sprintf(gettext("Configuring %s"), shift)); $this->requested_title($this->title); } sub shutdown {} 1 PK ! M6�T T Debconf/Template/Transient.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Template::Transient; use strict; use base 'Debconf::Template'; use fields qw(_fields); sub new { my $this=shift; my $template=shift; unless (ref $this) { $this = fields::new($this); } $this->{template}=$template; $this->{_fields}={}; return $this; } sub get { die "get not supported on transient templates"; } sub fields { my $this=shift; return keys %{$this->{_fields}}; } sub clearall { my $this=shift; foreach my $field (keys %{$this->{_fields}}) { delete $this->{_fields}->{$field}; } } { my @langs=Debconf::Template::_getlangs(); sub AUTOLOAD { (my $field = our $AUTOLOAD) =~ s/.*://; no strict 'refs'; *$AUTOLOAD = sub { my $this=shift; return $this->{_fields}->{$field}=shift if @_; if ($Debconf::Template::i18n && @langs) { foreach my $lang (@langs) { return $this->{_fields}->{$field.'-'.lc($lang)} if exists $this->{_fields}->{$field.'-'.lc($lang)}; } } return $this->{_fields}->{$field}; }; goto &$AUTOLOAD; } } 1 PK ! ���� � Debconf/Encoding.pmnu �[��� #!/usr/bin/perl # This file was preprocessed, do not edit! package Debconf::Encoding; use strict; use warnings; our $charmap; BEGIN { no warnings; eval q{ use Text::Iconv }; use warnings; if (! $@) { $charmap = `locale charmap`; chomp $charmap; } no warnings; eval q{ use Text::WrapI18N; use Text::CharWidth }; use warnings; if (! $@ && Text::CharWidth::mblen("a") == 1) { *wrap = *Text::WrapI18N::wrap; *columns = *Text::WrapI18N::columns; *width = *Text::CharWidth::mbswidth; } else { require Text::Wrap; require Text::Tabs; sub _wrap { return Text::Tabs::expand(Text::Wrap::wrap(@_)) } *wrap = *_wrap; *columns = *Text::Wrap::columns; sub _dumbwidth { length shift } *width = *_dumbwidth; } } use base qw(Exporter); our @EXPORT_OK=qw(wrap $columns width convert $charmap to_Unicode); my $converter; my $old_input_charmap; sub convert { my $input_charmap = shift; my $string = shift; return unless defined $charmap; if (! defined $old_input_charmap || $input_charmap ne $old_input_charmap) { $converter = Text::Iconv->new($input_charmap, $charmap); $old_input_charmap = $input_charmap; } return $converter->convert($string); } my $unicode_conv; sub to_Unicode { my $string = shift; my $result; return $string if utf8::is_utf8($string); if (!defined $unicode_conv) { $unicode_conv = Text::Iconv->new($charmap, "UTF-8"); } $result = $unicode_conv->convert($string); utf8::decode($result); return $result; } 1 PK ! ��ʲ � Debconf/Db.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Db; use strict; use Debconf::Log qw{:all}; use Debconf::Config; use Debconf::DbDriver; our $config; our $templates; sub load { my $class=shift; Debconf::Config->load('', @_); # load default config file $config=Debconf::DbDriver->driver(Debconf::Config->config); if (not ref $config) { die "Configuration database \"".Debconf::Config->config. "\" was not initialized.\n"; } $templates=Debconf::DbDriver->driver(Debconf::Config->templates); if (not ref $templates) { die "Template database \"".Debconf::Config->templates. "\" was not initialized.\n"; } } sub makedriver { my $class=shift; my %config=@_; my $type=$config{driver} or die "driver type not specified (perhaps you need to re-read debconf.conf(5))"; if (! UNIVERSAL::can("Debconf::DbDriver::$type", 'new')) { eval qq{use Debconf::DbDriver::$type}; die $@ if $@; } delete $config{driver}; # not a field for the object debug db => "making DbDriver of type $type"; "Debconf::DbDriver::$type"->new(%config); } sub save { $config->shutdown if $config; $templates->shutdown if $templates; $config=''; $templates=''; } 1 PK ! X#O� � Debconf/Priority.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::Priority; use strict; use Debconf::Config; use base qw(Exporter); our @EXPORT_OK = qw(high_enough priority_valid priority_list); my %priorities=( 'low' => 0, 'medium' => 1, 'high' => 2, 'critical' => 3, ); sub high_enough { my $priority=shift; return 1 if ! exists $priorities{$priority}; return $priorities{$priority} >= $priorities{Debconf::Config->priority}; } sub priority_valid { my $priority=shift; return exists $priorities{$priority}; } sub priority_list { return sort { $priorities{$a} <=> $priorities{$b} } keys %priorities; } 1 PK ! ��O� � Debconf/AutoSelect.pmnu �[��� #!/usr/bin/perl -w # This file was preprocessed, do not edit! package Debconf::AutoSelect; use strict; use Debconf::Gettext; use Debconf::ConfModule; use Debconf::Config; use Debconf::Log qw(:all); use base qw(Exporter); our @EXPORT_OK = qw(make_frontend make_confmodule); our %EXPORT_TAGS = (all => [@EXPORT_OK]); BEGIN { eval { require Glib::Object::Introspection; }; } my %fallback=( 'Kde' => ['Qt', 'Dialog', 'Readline', 'Teletype'], 'Qt' => ['Dialog', 'Readline', 'Teletype'], 'Gnome' => ['Dialog', 'Readline', 'Teletype'], 'Web' => ['Dialog', 'Readline', 'Teletype'], 'Dialog' => ['Readline', 'Teletype'], 'Gtk' => ['Dialog', 'Readline', 'Teletype'], 'Readline' => ['Teletype', 'Dialog'], 'Editor' => ['Readline', 'Teletype'], 'Slang' => ['Dialog', 'Readline', 'Teletype'], 'Text' => ['Readline', 'Teletype', 'Dialog'], ); my $frontend; my $type; sub make_frontend { my $script=shift; my $starttype=ucfirst($type) if defined $type; if (! defined $starttype || ! length $starttype) { $starttype = Debconf::Config->frontend; if ($starttype =~ /^[A-Z]/) { warn "Please do not capitalize the first letter of the debconf frontend."; } $starttype=ucfirst($starttype); } my $showfallback=0; foreach $type ($starttype, @{$fallback{$starttype}}, 'Noninteractive') { if (! $showfallback) { debug user => "trying frontend $type"; } else { warn(sprintf(gettext("falling back to frontend: %s"), $type)); } $frontend=eval qq{ use Debconf::FrontEnd::$type; Debconf::FrontEnd::$type->new(); }; return $frontend if defined $frontend; warn sprintf(gettext("unable to initialize frontend: %s"), $type); $@=~s/\n.*//s; warn "($@)"; $showfallback=1; } die sprintf(gettext("Unable to start a frontend: %s"), $@); } sub make_confmodule { my $confmodule=Debconf::ConfModule->new(frontend => $frontend); $confmodule->startup(@_) if @_; return $confmodule; } 1 PK ! @{1�� �� URI.pmnu �[��� package URI; use strict; use warnings; our $VERSION = '5.10'; our ($ABS_REMOTE_LEADING_DOTS, $ABS_ALLOW_RELATIVE_SCHEME, $DEFAULT_QUERY_FORM_DELIMITER); my %implements; # mapping from scheme to implementor class # Some "official" character classes our $reserved = q(;/?:@&=+$,[]); our $mark = q(-_.!~*'()); #'; emacs our $unreserved = "A-Za-z0-9\Q$mark\E"; our $uric = quotemeta($reserved) . $unreserved . "%"; our $scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*'; use Carp (); use URI::Escape (); use overload ('""' => sub { ${$_[0]} }, '==' => sub { _obj_eq(@_) }, '!=' => sub { !_obj_eq(@_) }, fallback => 1, ); # Check if two objects are the same object sub _obj_eq { return overload::StrVal($_[0]) eq overload::StrVal($_[1]); } sub new { my($class, $uri, $scheme) = @_; $uri = defined ($uri) ? "$uri" : ""; # stringify # Get rid of potential wrapping $uri =~ s/^<(?:URL:)?(.*)>$/$1/; # $uri =~ s/^"(.*)"$/$1/; $uri =~ s/^\s+//; $uri =~ s/\s+$//; my $impclass; if ($uri =~ m/^($scheme_re):/so) { $scheme = $1; } else { if (($impclass = ref($scheme))) { $scheme = $scheme->scheme; } elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) { $scheme = $1; } } $impclass ||= implementor($scheme) || do { require URI::_foreign; $impclass = 'URI::_foreign'; }; return $impclass->_init($uri, $scheme); } sub new_abs { my($class, $uri, $base) = @_; $uri = $class->new($uri, $base); $uri->abs($base); } sub _init { my $class = shift; my($str, $scheme) = @_; # find all funny characters and encode the bytes. $str = $class->_uric_escape($str); $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o || $class->_no_scheme_ok; my $self = bless \$str, $class; $self; } sub _uric_escape { my($class, $str) = @_; $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego; utf8::downgrade($str); return $str; } my %require_attempted; sub implementor { my($scheme, $impclass) = @_; if (!$scheme || $scheme !~ /\A$scheme_re\z/o) { require URI::_generic; return "URI::_generic"; } $scheme = lc($scheme); if ($impclass) { # Set the implementor class for a given scheme my $old = $implements{$scheme}; $impclass->_init_implementor($scheme); $implements{$scheme} = $impclass; return $old; } my $ic = $implements{$scheme}; return $ic if $ic; # scheme not yet known, look for internal or # preloaded (with 'use') implementation $ic = "URI::$scheme"; # default location # turn scheme into a valid perl identifier by a simple transformation... $ic =~ s/\+/_P/g; $ic =~ s/\./_O/g; $ic =~ s/\-/_/g; no strict 'refs'; # check we actually have one for the scheme: unless (@{"${ic}::ISA"}) { if (not exists $require_attempted{$ic}) { # Try to load it my $_old_error = $@; eval "require $ic"; die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; $@ = $_old_error; } return undef unless @{"${ic}::ISA"}; } $ic->_init_implementor($scheme); $implements{$scheme} = $ic; $ic; } sub _init_implementor { my($class, $scheme) = @_; # Remember that one implementor class may actually # serve to implement several URI schemes. } sub clone { my $self = shift; my $other = $$self; bless \$other, ref $self; } sub TO_JSON { ${$_[0]} } sub _no_scheme_ok { 0 } sub _scheme { my $self = shift; unless (@_) { return undef unless $$self =~ /^($scheme_re):/o; return $1; } my $old; my $new = shift; if (defined($new) && length($new)) { Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o; $old = $1 if $$self =~ s/^($scheme_re)://o; my $newself = URI->new("$new:$$self"); $$self = $$newself; bless $self, ref($newself); } else { if ($self->_no_scheme_ok) { $old = $1 if $$self =~ s/^($scheme_re)://o; Carp::carp("Oops, opaque part now look like scheme") if $^W && $$self =~ m/^$scheme_re:/o } else { $old = $1 if $$self =~ m/^($scheme_re):/o; } } return $old; } sub scheme { my $scheme = shift->_scheme(@_); return undef unless defined $scheme; lc($scheme); } sub has_recognized_scheme { my $self = shift; return ref($self) !~ /^URI::_(?:foreign|generic)\z/; } sub opaque { my $self = shift; unless (@_) { $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die; return $1; } $$self =~ /^($scheme_re:)? # optional scheme ([^\#]*) # opaque (\#.*)? # optional fragment $/sx or die; my $old_scheme = $1; my $old_opaque = $2; my $old_frag = $3; my $new_opaque = shift; $new_opaque = "" unless defined $new_opaque; $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego; utf8::downgrade($new_opaque); $$self = defined($old_scheme) ? $old_scheme : ""; $$self .= $new_opaque; $$self .= $old_frag if defined $old_frag; $old_opaque; } sub path { goto &opaque } # alias sub fragment { my $self = shift; unless (@_) { return undef unless $$self =~ /\#(.*)/s; return $1; } my $old; $old = $1 if $$self =~ s/\#(.*)//s; my $new_frag = shift; if (defined $new_frag) { $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego; utf8::downgrade($new_frag); $$self .= "#$new_frag"; } $old; } sub as_string { my $self = shift; $$self; } sub as_iri { my $self = shift; my $str = $$self; if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) { # All this crap because the more obvious: # # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift }) # # doesn't work before Encode 2.39. Wait for a standard release # to bundle that version. require Encode; my $enc = Encode::find_encoding("UTF-8"); my $u = ""; while (length $str) { $u .= $enc->decode($str, Encode::FB_QUIET()); if (length $str) { # escape next char $u .= URI::Escape::escape_char(substr($str, 0, 1, "")); } } $str = $u; } return $str; } sub canonical { # Make sure scheme is lowercased, that we don't escape unreserved chars, # and that we use upcase escape sequences. my $self = shift; my $scheme = $self->_scheme || ""; my $uc_scheme = $scheme =~ /[A-Z]/; my $esc = $$self =~ /%[a-fA-F0-9]{2}/; return $self unless $uc_scheme || $esc; my $other = $self->clone; if ($uc_scheme) { $other->_scheme(lc $scheme); } if ($esc) { $$other =~ s{%([0-9a-fA-F]{2})} { my $a = chr(hex($1)); $a =~ /^[$unreserved]\z/o ? $a : "%\U$1" }ge; } return $other; } # Compare two URIs, subclasses will provide a more correct implementation sub eq { my($self, $other) = @_; $self = URI->new($self, $other) unless ref $self; $other = URI->new($other, $self) unless ref $other; ref($self) eq ref($other) && # same class $self->canonical->as_string eq $other->canonical->as_string; } # generic-URI transformation methods sub abs { $_[0]; } sub rel { $_[0]; } sub secure { 0 } # help out Storable sub STORABLE_freeze { my($self, $cloning) = @_; return $$self; } sub STORABLE_thaw { my($self, $cloning, $str) = @_; $$self = $str; } 1; __END__ =head1 NAME URI - Uniform Resource Identifiers (absolute and relative) =head1 SYNOPSIS use URI (); $u1 = URI->new("http://www.example.com"); $u2 = URI->new("foo", "http"); $u3 = $u2->abs($u1); $u4 = $u3->clone; $u5 = URI->new("HTTP://WWW.example.com:80")->canonical; $str = $u->as_string; $str = "$u"; $scheme = $u->scheme; $opaque = $u->opaque; $path = $u->path; $frag = $u->fragment; $u->scheme("ftp"); $u->host("ftp.example.com"); $u->path("cpan/"); =head1 DESCRIPTION This module implements the C<URI> class. Objects of this class represent "Uniform Resource Identifier references" as specified in RFC 2396 (and updated by RFC 2732). A Uniform Resource Identifier is a compact string of characters that identifies an abstract or physical resource. A Uniform Resource Identifier can be further classified as either a Uniform Resource Locator (URL) or a Uniform Resource Name (URN). The distinction between URL and URN does not matter to the C<URI> class interface. A "URI-reference" is a URI that may have additional information attached in the form of a fragment identifier. An absolute URI reference consists of three parts: a I<scheme>, a I<scheme-specific part> and a I<fragment> identifier. A subset of URI references share a common syntax for hierarchical namespaces. For these, the scheme-specific part is further broken down into I<authority>, I<path> and I<query> components. These URIs can also take the form of relative URI references, where the scheme (and usually also the authority) component is missing, but implied by the context of the URI reference. The three forms of URI reference syntax are summarized as follows: <scheme>:<scheme-specific-part>#<fragment> <scheme>://<authority><path>?<query>#<fragment> <path>?<query>#<fragment> The components into which a URI reference can be divided depend on the I<scheme>. The C<URI> class provides methods to get and set the individual components. The methods available for a specific C<URI> object depend on the scheme. =head1 CONSTRUCTORS The following methods construct new C<URI> objects: =over 4 =item $uri = URI->new( $str ) =item $uri = URI->new( $str, $scheme ) Constructs a new URI object. The string representation of a URI is given as argument, together with an optional scheme specification. Common URI wrappers like "" and <>, as well as leading and trailing white space, are automatically removed from the $str argument before it is processed further. The constructor determines the scheme, maps this to an appropriate URI subclass, constructs a new object of that class and returns it. If the scheme isn't one of those that URI recognizes, you still get an URI object back that you can access the generic methods on. The C<< $uri->has_recognized_scheme >> method can be used to test for this. The $scheme argument is only used when $str is a relative URI. It can be either a simple string that denotes the scheme, a string containing an absolute URI reference, or an absolute C<URI> object. If no $scheme is specified for a relative URI $str, then $str is simply treated as a generic URI (no scheme-specific methods available). The set of characters available for building URI references is restricted (see L<URI::Escape>). Characters outside this set are automatically escaped by the URI constructor. =item $uri = URI->new_abs( $str, $base_uri ) Constructs a new absolute URI object. The $str argument can denote a relative or absolute URI. If relative, then it is absolutized using $base_uri as base. The $base_uri must be an absolute URI. =item $uri = URI::file->new( $filename ) =item $uri = URI::file->new( $filename, $os ) Constructs a new I<file> URI from a file name. See L<URI::file>. =item $uri = URI::file->new_abs( $filename ) =item $uri = URI::file->new_abs( $filename, $os ) Constructs a new absolute I<file> URI from a file name. See L<URI::file>. =item $uri = URI::file->cwd Returns the current working directory as a I<file> URI. See L<URI::file>. =item $uri->clone Returns a copy of the $uri. =back =head1 COMMON METHODS The methods described in this section are available for all C<URI> objects. Methods that give access to components of a URI always return the old value of the component. The value returned is C<undef> if the component was not present. There is generally a difference between a component that is empty (represented as C<"">) and a component that is missing (represented as C<undef>). If an accessor method is given an argument, it updates the corresponding component in addition to returning the old value of the component. Passing an undefined argument removes the component (if possible). The description of each accessor method indicates whether the component is passed as an escaped (percent-encoded) or an unescaped string. A component that can be further divided into sub-parts are usually passed escaped, as unescaping might change its semantics. The common methods available for all URI are: =over 4 =item $uri->scheme =item $uri->scheme( $new_scheme ) Sets and returns the scheme part of the $uri. If the $uri is relative, then $uri->scheme returns C<undef>. If called with an argument, it updates the scheme of $uri, possibly changing the class of $uri, and returns the old scheme value. The method croaks if the new scheme name is illegal; a scheme name must begin with a letter and must consist of only US-ASCII letters, numbers, and a few special marks: ".", "+", "-". This restriction effectively means that the scheme must be passed unescaped. Passing an undefined argument to the scheme method makes the URI relative (if possible). Letter case does not matter for scheme names. The string returned by $uri->scheme is always lowercase. If you want the scheme just as it was written in the URI in its original case, you can use the $uri->_scheme method instead. =item $uri->has_recognized_scheme Returns TRUE if the URI scheme is one that URI recognizes. It will also be TRUE for relative URLs where a recognized scheme was provided to the constructor, even if C<< $uri->scheme >> returns C<undef> for these. =item $uri->opaque =item $uri->opaque( $new_opaque ) Sets and returns the scheme-specific part of the $uri (everything between the scheme and the fragment) as an escaped string. =item $uri->path =item $uri->path( $new_path ) Sets and returns the same value as $uri->opaque unless the URI supports the generic syntax for hierarchical namespaces. In that case the generic method is overridden to set and return the part of the URI between the I<host name> and the I<fragment>. =item $uri->fragment =item $uri->fragment( $new_frag ) Returns the fragment identifier of a URI reference as an escaped string. =item $uri->as_string Returns a URI object to a plain ASCII string. URI objects are also converted to plain strings automatically by overloading. This means that $uri objects can be used as plain strings in most Perl constructs. =item $uri->as_iri Returns a Unicode string representing the URI. Escaped UTF-8 sequences representing non-ASCII characters are turned into their corresponding Unicode code point. =item $uri->canonical Returns a normalized version of the URI. The rules for normalization are scheme-dependent. They usually involve lowercasing the scheme and Internet host name components, removing the explicit port specification if it matches the default port, uppercasing all escape sequences, and unescaping octets that can be better represented as plain characters. For efficiency reasons, if the $uri is already in normalized form, then a reference to it is returned instead of a copy. =item $uri->eq( $other_uri ) =item URI::eq( $first_uri, $other_uri ) Tests whether two URI references are equal. URI references that normalize to the same string are considered equal. The method can also be used as a plain function which can also test two string arguments. If you need to test whether two C<URI> object references denote the same object, use the '==' operator. =item $uri->abs( $base_uri ) Returns an absolute URI reference. If $uri is already absolute, then a reference to it is simply returned. If the $uri is relative, then a new absolute URI is constructed by combining the $uri and the $base_uri, and returned. =item $uri->rel( $base_uri ) Returns a relative URI reference if it is possible to make one that denotes the same resource relative to $base_uri. If not, then $uri is simply returned. =item $uri->secure Returns a TRUE value if the URI is considered to point to a resource on a secure channel, such as an SSL or TLS encrypted one. =back =head1 GENERIC METHODS The following methods are available to schemes that use the common/generic syntax for hierarchical namespaces. The descriptions of schemes below indicate which these are. Unrecognized schemes are assumed to support the generic syntax, and therefore the following methods: =over 4 =item $uri->authority =item $uri->authority( $new_authority ) Sets and returns the escaped authority component of the $uri. =item $uri->path =item $uri->path( $new_path ) Sets and returns the escaped path component of the $uri (the part between the host name and the query or fragment). The path can never be undefined, but it can be the empty string. =item $uri->path_query =item $uri->path_query( $new_path_query ) Sets and returns the escaped path and query components as a single entity. The path and the query are separated by a "?" character, but the query can itself contain "?". =item $uri->path_segments =item $uri->path_segments( $segment, ... ) Sets and returns the path. In a scalar context, it returns the same value as $uri->path. In a list context, it returns the unescaped path segments that make up the path. Path segments that have parameters are returned as an anonymous array. The first element is the unescaped path segment proper; subsequent elements are escaped parameter strings. Such an anonymous array uses overloading so it can be treated as a string too, but this string does not include the parameters. Note that absolute paths have the empty string as their first I<path_segment>, i.e. the I<path> C</foo/bar> have 3 I<path_segments>; "", "foo" and "bar". =item $uri->query =item $uri->query( $new_query ) Sets and returns the escaped query component of the $uri. =item $uri->query_form =item $uri->query_form( $key1 => $val1, $key2 => $val2, ... ) =item $uri->query_form( $key1 => $val1, $key2 => $val2, ..., $delim ) =item $uri->query_form( \@key_value_pairs ) =item $uri->query_form( \@key_value_pairs, $delim ) =item $uri->query_form( \%hash ) =item $uri->query_form( \%hash, $delim ) Sets and returns query components that use the I<application/x-www-form-urlencoded> format. Key/value pairs are separated by "&", and the key is separated from the value by a "=" character. The form can be set either by passing separate key/value pairs, or via an array or hash reference. Passing an empty array or an empty hash removes the query component, whereas passing no arguments at all leaves the component unchanged. The order of keys is undefined if a hash reference is passed. The old value is always returned as a list of separate key/value pairs. Assigning this list to a hash is unwise as the keys returned might repeat. The values passed when setting the form can be plain strings or references to arrays of strings. Passing an array of values has the same effect as passing the key repeatedly with one value at a time. All the following statements have the same effect: $uri->query_form(foo => 1, foo => 2); $uri->query_form(foo => [1, 2]); $uri->query_form([ foo => 1, foo => 2 ]); $uri->query_form([ foo => [1, 2] ]); $uri->query_form({ foo => [1, 2] }); The $delim parameter can be passed as ";" to force the key/value pairs to be delimited by ";" instead of "&" in the query string. This practice is often recommended for URLs embedded in HTML or XML documents as this avoids the trouble of escaping the "&" character. You might also set the $URI::DEFAULT_QUERY_FORM_DELIMITER variable to ";" for the same global effect. The C<URI::QueryParam> module can be loaded to add further methods to manipulate the form of a URI. See L<URI::QueryParam> for details. =item $uri->query_keywords =item $uri->query_keywords( $keywords, ... ) =item $uri->query_keywords( \@keywords ) Sets and returns query components that use the keywords separated by "+" format. The keywords can be set either by passing separate keywords directly or by passing a reference to an array of keywords. Passing an empty array removes the query component, whereas passing no arguments at all leaves the component unchanged. The old value is always returned as a list of separate words. =back =head1 SERVER METHODS For schemes where the I<authority> component denotes an Internet host, the following methods are available in addition to the generic methods. =over 4 =item $uri->userinfo =item $uri->userinfo( $new_userinfo ) Sets and returns the escaped userinfo part of the authority component. For some schemes this is a user name and a password separated by a colon. This practice is not recommended. Embedding passwords in clear text (such as URI) has proven to be a security risk in almost every case where it has been used. =item $uri->host =item $uri->host( $new_host ) Sets and returns the unescaped hostname. If the $new_host string ends with a colon and a number, then this number also sets the port. For IPv6 addresses the brackets around the raw address is removed in the return value from $uri->host. When setting the host attribute to an IPv6 address you can use a raw address or one enclosed in brackets. The address needs to be enclosed in brackets if you want to pass in a new port value as well. =item $uri->ihost Returns the host in Unicode form. Any IDNA A-labels are turned into U-labels. =item $uri->port =item $uri->port( $new_port ) Sets and returns the port. The port is a simple integer that should be greater than 0. If a port is not specified explicitly in the URI, then the URI scheme's default port is returned. If you don't want the default port substituted, then you can use the $uri->_port method instead. =item $uri->host_port =item $uri->host_port( $new_host_port ) Sets and returns the host and port as a single unit. The returned value includes a port, even if it matches the default port. The host part and the port part are separated by a colon: ":". For IPv6 addresses the bracketing is preserved; thus URI->new("http://[::1]/")->host_port returns "[::1]:80". Contrast this with $uri->host which will remove the brackets. =item $uri->default_port Returns the default port of the URI scheme to which $uri belongs. For I<http> this is the number 80, for I<ftp> this is the number 21, etc. The default port for a scheme can not be changed. =back =head1 SCHEME-SPECIFIC SUPPORT Scheme-specific support is provided for the following URI schemes. For C<URI> objects that do not belong to one of these, you can only use the common and generic methods. =over 4 =item B<data>: The I<data> URI scheme is specified in RFC 2397. It allows inclusion of small data items as "immediate" data, as if it had been included externally. C<URI> objects belonging to the data scheme support the common methods and two new methods to access their scheme-specific components: $uri->media_type and $uri->data. See L<URI::data> for details. =item B<file>: An old specification of the I<file> URI scheme is found in RFC 1738. A new RFC 2396 based specification in not available yet, but file URI references are in common use. C<URI> objects belonging to the file scheme support the common and generic methods. In addition, they provide two methods for mapping file URIs back to local file names; $uri->file and $uri->dir. See L<URI::file> for details. =item B<ftp>: An old specification of the I<ftp> URI scheme is found in RFC 1738. A new RFC 2396 based specification in not available yet, but ftp URI references are in common use. C<URI> objects belonging to the ftp scheme support the common, generic and server methods. In addition, they provide two methods for accessing the userinfo sub-components: $uri->user and $uri->password. =item B<gopher>: The I<gopher> URI scheme is specified in <draft-murali-url-gopher-1996-12-04> and will hopefully be available as a RFC 2396 based specification. C<URI> objects belonging to the gopher scheme support the common, generic and server methods. In addition, they support some methods for accessing gopher-specific path components: $uri->gopher_type, $uri->selector, $uri->search, $uri->string. =item B<http>: The I<http> URI scheme is specified in RFC 2616. The scheme is used to reference resources hosted by HTTP servers. C<URI> objects belonging to the http scheme support the common, generic and server methods. =item B<https>: The I<https> URI scheme is a Netscape invention which is commonly implemented. The scheme is used to reference HTTP servers through SSL connections. Its syntax is the same as http, but the default port is different. =item B<ldap>: The I<ldap> URI scheme is specified in RFC 2255. LDAP is the Lightweight Directory Access Protocol. An ldap URI describes an LDAP search operation to perform to retrieve information from an LDAP directory. C<URI> objects belonging to the ldap scheme support the common, generic and server methods as well as ldap-specific methods: $uri->dn, $uri->attributes, $uri->scope, $uri->filter, $uri->extensions. See L<URI::ldap> for details. =item B<ldapi>: Like the I<ldap> URI scheme, but uses a UNIX domain socket. The server methods are not supported, and the local socket path is available as $uri->un_path. The I<ldapi> scheme is used by the OpenLDAP package. There is no real specification for it, but it is mentioned in various OpenLDAP manual pages. =item B<ldaps>: Like the I<ldap> URI scheme, but uses an SSL connection. This scheme is deprecated, as the preferred way is to use the I<start_tls> mechanism. =item B<mailto>: The I<mailto> URI scheme is specified in RFC 2368. The scheme was originally used to designate the Internet mailing address of an individual or service. It has (in RFC 2368) been extended to allow setting of other mail header fields and the message body. C<URI> objects belonging to the mailto scheme support the common methods and the generic query methods. In addition, they support the following mailto-specific methods: $uri->to, $uri->headers. Note that the "foo@example.com" part of a mailto is I<not> the C<userinfo> and C<host> but instead the C<path>. This allows a mailto URI to contain multiple comma separated email addresses. =item B<mms>: The I<mms> URL specification can be found at L<http://sdp.ppona.com/>. C<URI> objects belonging to the mms scheme support the common, generic, and server methods, with the exception of userinfo and query-related sub-components. =item B<news>: The I<news>, I<nntp> and I<snews> URI schemes are specified in <draft-gilman-news-url-01> and will hopefully be available as an RFC 2396 based specification soon. (Update: as of April 2010, they are in L<RFC 5538|https://tools.ietf.org/html/rfc5538>. C<URI> objects belonging to the news scheme support the common, generic and server methods. In addition, they provide some methods to access the path: $uri->group and $uri->message. =item B<nntp>: See I<news> scheme. =item B<nntps>: See I<news> scheme and L<RFC 5538|https://tools.ietf.org/html/rfc5538>. =item B<pop>: The I<pop> URI scheme is specified in RFC 2384. The scheme is used to reference a POP3 mailbox. C<URI> objects belonging to the pop scheme support the common, generic and server methods. In addition, they provide two methods to access the userinfo components: $uri->user and $uri->auth =item B<rlogin>: An old specification of the I<rlogin> URI scheme is found in RFC 1738. C<URI> objects belonging to the rlogin scheme support the common, generic and server methods. =item B<rtsp>: The I<rtsp> URL specification can be found in section 3.2 of RFC 2326. C<URI> objects belonging to the rtsp scheme support the common, generic, and server methods, with the exception of userinfo and query-related sub-components. =item B<rtspu>: The I<rtspu> URI scheme is used to talk to RTSP servers over UDP instead of TCP. The syntax is the same as rtsp. =item B<rsync>: Information about rsync is available from L<http://rsync.samba.org/>. C<URI> objects belonging to the rsync scheme support the common, generic and server methods. In addition, they provide methods to access the userinfo sub-components: $uri->user and $uri->password. =item B<sip>: The I<sip> URI specification is described in sections 19.1 and 25 of RFC 3261. C<URI> objects belonging to the sip scheme support the common, generic, and server methods with the exception of path related sub-components. In addition, they provide two methods to get and set I<sip> parameters: $uri->params_form and $uri->params. =item B<sips>: See I<sip> scheme. Its syntax is the same as sip, but the default port is different. =item B<snews>: See I<news> scheme. Its syntax is the same as news, but the default port is different. =item B<telnet>: An old specification of the I<telnet> URI scheme is found in RFC 1738. C<URI> objects belonging to the telnet scheme support the common, generic and server methods. =item B<tn3270>: These URIs are used like I<telnet> URIs but for connections to IBM mainframes. C<URI> objects belonging to the tn3270 scheme support the common, generic and server methods. =item B<ssh>: Information about ssh is available at L<http://www.openssh.com/>. C<URI> objects belonging to the ssh scheme support the common, generic and server methods. In addition, they provide methods to access the userinfo sub-components: $uri->user and $uri->password. =item B<sftp>: C<URI> objects belonging to the sftp scheme support the common, generic and server methods. In addition, they provide methods to access the userinfo sub-components: $uri->user and $uri->password. =item B<urn>: The syntax of Uniform Resource Names is specified in RFC 2141. C<URI> objects belonging to the urn scheme provide the common methods, and also the methods $uri->nid and $uri->nss, which return the Namespace Identifier and the Namespace-Specific String respectively. The Namespace Identifier basically works like the Scheme identifier of URIs, and further divides the URN namespace. Namespace Identifier assignments are maintained at L<http://www.iana.org/assignments/urn-namespaces>. Letter case is not significant for the Namespace Identifier. It is always returned in lower case by the $uri->nid method. The $uri->_nid method can be used if you want it in its original case. =item B<urn>:B<isbn>: The C<urn:isbn:> namespace contains International Standard Book Numbers (ISBNs) and is described in RFC 3187. A C<URI> object belonging to this namespace has the following extra methods (if the Business::ISBN module is available): $uri->isbn, $uri->isbn_publisher_code, $uri->isbn_group_code (formerly isbn_country_code, which is still supported by issues a deprecation warning), $uri->isbn_as_ean. =item B<urn>:B<oid>: The C<urn:oid:> namespace contains Object Identifiers (OIDs) and is described in RFC 3061. An object identifier consists of sequences of digits separated by dots. A C<URI> object belonging to this namespace has an additional method called $uri->oid that can be used to get/set the oid value. In a list context, oid numbers are returned as separate elements. =back =head1 CONFIGURATION VARIABLES The following configuration variables influence how the class and its methods behave: =over 4 =item $URI::ABS_ALLOW_RELATIVE_SCHEME Some older parsers used to allow the scheme name to be present in the relative URL if it was the same as the base URL scheme. RFC 2396 says that this should be avoided, but you can enable this old behaviour by setting the $URI::ABS_ALLOW_RELATIVE_SCHEME variable to a TRUE value. The difference is demonstrated by the following examples: URI->new("http:foo")->abs("http://host/a/b") ==> "http:foo" local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; URI->new("http:foo")->abs("http://host/a/b") ==> "http:/host/a/foo" =item $URI::ABS_REMOTE_LEADING_DOTS You can also have the abs() method ignore excess ".." segments in the relative URI by setting $URI::ABS_REMOTE_LEADING_DOTS to a TRUE value. The difference is demonstrated by the following examples: URI->new("../../../foo")->abs("http://host/a/b") ==> "http://host/../../foo" local $URI::ABS_REMOTE_LEADING_DOTS = 1; URI->new("../../../foo")->abs("http://host/a/b") ==> "http://host/foo" =item $URI::DEFAULT_QUERY_FORM_DELIMITER This value can be set to ";" to have the query form C<key=value> pairs delimited by ";" instead of "&" which is the default. =back =head1 BUGS There are some things that are not quite right: =over =item * Using regexp variables like $1 directly as arguments to the URI accessor methods does not work too well with current perl implementations. I would argue that this is actually a bug in perl. The workaround is to quote them. Example: /(...)/ || die; $u->query("$1"); =item * The escaping (percent encoding) of chars in the 128 .. 255 range passed to the URI constructor or when setting URI parts using the accessor methods depend on the state of the internal UTF8 flag (see utf8::is_utf8) of the string passed. If the UTF8 flag is set the UTF-8 encoded version of the character is percent encoded. If the UTF8 flag isn't set the Latin-1 version (byte) of the character is percent encoded. This basically exposes the internal encoding of Perl strings. =back =head1 PARSING URIs WITH REGEXP As an alternative to this module, the following (official) regular expression can be used to decode a URI: my($scheme, $authority, $path, $query, $fragment) = $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; The C<URI::Split> module provides the function uri_split() as a readable alternative. =head1 SEE ALSO L<URI::file>, L<URI::WithBase>, L<URI::QueryParam>, L<URI::Escape>, L<URI::Split>, L<URI::Heuristic> RFC 2396: "Uniform Resource Identifiers (URI): Generic Syntax", Berners-Lee, Fielding, Masinter, August 1998. L<http://www.iana.org/assignments/uri-schemes> L<http://www.iana.org/assignments/urn-namespaces> L<http://www.w3.org/Addressing/> =head1 COPYRIGHT Copyright 1995-2009 Gisle Aas. Copyright 1995 Martijn Koster. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHORS / ACKNOWLEDGMENTS This module is based on the C<URI::URL> module, which in turn was (distantly) based on the C<wwwurl.pl> code in the libwww-perl for perl4 developed by Roy Fielding, as part of the Arcadia project at the University of California, Irvine, with contributions from Brooks Cutter. C<URI::URL> was developed by Gisle Aas, Tim Bunce, Roy Fielding and Martijn Koster with input from other people on the libwww-perl mailing list. C<URI> and related subclasses was developed by Gisle Aas. =cut PK ! � TimeDate.pmnu �[��� package TimeDate; use vars qw($VERSION); $VERSION = "1.21"; =pod This is an empty module which is just there to get ownership on TimeDate using first-come permissions from PAUSE. This was required during the release of 1.21 for transferring ownership. =cut 1; PK ! �/g�ډ ډ JSON/backportPP.pmnu �[��� package # This is JSON::backportPP JSON::PP; # JSON-2.0 use 5.005; use strict; use Exporter (); BEGIN { @JSON::backportPP::ISA = ('Exporter') } use overload (); use JSON::backportPP::Boolean; use Carp (); #use Devel::Peek; $JSON::backportPP::VERSION = '4.07'; @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); # instead of hash-access, i tried index-access for speed. # but this method is not faster than what i expected. so it will be changed. use constant P_ASCII => 0; use constant P_LATIN1 => 1; use constant P_UTF8 => 2; use constant P_INDENT => 3; use constant P_CANONICAL => 4; use constant P_SPACE_BEFORE => 5; use constant P_SPACE_AFTER => 6; use constant P_ALLOW_NONREF => 7; use constant P_SHRINK => 8; use constant P_ALLOW_BLESSED => 9; use constant P_CONVERT_BLESSED => 10; use constant P_RELAXED => 11; use constant P_LOOSE => 12; use constant P_ALLOW_BIGNUM => 13; use constant P_ALLOW_BAREKEY => 14; use constant P_ALLOW_SINGLEQUOTE => 15; use constant P_ESCAPE_SLASH => 16; use constant P_AS_NONBLESSED => 17; use constant P_ALLOW_UNKNOWN => 18; use constant P_ALLOW_TAGS => 19; use constant OLD_PERL => $] < 5.008 ? 1 : 0; use constant USE_B => $ENV{PERL_JSON_PP_USE_B} || 0; BEGIN { if (USE_B) { require B; } } BEGIN { my @xs_compati_bit_properties = qw( latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink allow_blessed convert_blessed relaxed allow_unknown allow_tags ); my @pp_bit_properties = qw( allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed ); # Perl version check, Unicode handling is enabled? # Helper module sets @JSON::PP::_properties. if ( OLD_PERL ) { my $helper = $] >= 5.006 ? 'JSON::backportPP::Compat5006' : 'JSON::backportPP::Compat5005'; eval qq| require $helper |; if ($@) { Carp::croak $@; } } for my $name (@xs_compati_bit_properties, @pp_bit_properties) { my $property_id = 'P_' . uc($name); eval qq/ sub $name { my \$enable = defined \$_[1] ? \$_[1] : 1; if (\$enable) { \$_[0]->{PROPS}->[$property_id] = 1; } else { \$_[0]->{PROPS}->[$property_id] = 0; } \$_[0]; } sub get_$name { \$_[0]->{PROPS}->[$property_id] ? 1 : ''; } /; } } # Functions my $JSON; # cache sub encode_json ($) { # encode ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); } sub decode_json { # decode ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); } # Obsoleted sub to_json($) { Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); } sub from_json($) { Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); } # Methods sub new { my $class = shift; my $self = { max_depth => 512, max_size => 0, indent_length => 3, }; $self->{PROPS}[P_ALLOW_NONREF] = 1; bless $self, $class; } sub encode { return $_[0]->PP_encode_json($_[1]); } sub decode { return $_[0]->PP_decode_json($_[1], 0x00000000); } sub decode_prefix { return $_[0]->PP_decode_json($_[1], 0x00000001); } # accessor # pretty printing sub pretty { my ($self, $v) = @_; my $enable = defined $v ? $v : 1; if ($enable) { # indent_length(3) for JSON::XS compatibility $self->indent(1)->space_before(1)->space_after(1); } else { $self->indent(0)->space_before(0)->space_after(0); } $self; } # etc sub max_depth { my $max = defined $_[1] ? $_[1] : 0x80000000; $_[0]->{max_depth} = $max; $_[0]; } sub get_max_depth { $_[0]->{max_depth}; } sub max_size { my $max = defined $_[1] ? $_[1] : 0; $_[0]->{max_size} = $max; $_[0]; } sub get_max_size { $_[0]->{max_size}; } sub boolean_values { my $self = shift; if (@_) { my ($false, $true) = @_; $self->{false} = $false; $self->{true} = $true; } else { delete $self->{false}; delete $self->{true}; } return $self; } sub get_boolean_values { my $self = shift; if (exists $self->{true} and exists $self->{false}) { return @$self{qw/false true/}; } return; } sub filter_json_object { if (defined $_[1] and ref $_[1] eq 'CODE') { $_[0]->{cb_object} = $_[1]; } else { delete $_[0]->{cb_object}; } $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; $_[0]; } sub filter_json_single_key_object { if (@_ == 1 or @_ > 3) { Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)"); } if (defined $_[2] and ref $_[2] eq 'CODE') { $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; } else { delete $_[0]->{cb_sk_object}->{$_[1]}; delete $_[0]->{cb_sk_object} unless %{$_[0]->{cb_sk_object} || {}}; } $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; $_[0]; } sub indent_length { if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { Carp::carp "The acceptable range of indent_length() is 0 to 15."; } else { $_[0]->{indent_length} = $_[1]; } $_[0]; } sub get_indent_length { $_[0]->{indent_length}; } sub sort_by { $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; $_[0]; } sub allow_bigint { Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead."); $_[0]->allow_bignum; } ############################### ### ### Perl => JSON ### { # Convert my $max_depth; my $indent; my $ascii; my $latin1; my $utf8; my $space_before; my $space_after; my $canonical; my $allow_blessed; my $convert_blessed; my $indent_length; my $escape_slash; my $bignum; my $as_nonblessed; my $allow_tags; my $depth; my $indent_count; my $keysort; sub PP_encode_json { my $self = shift; my $obj = shift; $indent_count = 0; $depth = 0; my $props = $self->{PROPS}; ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, $convert_blessed, $escape_slash, $bignum, $as_nonblessed, $allow_tags) = @{$props}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED, P_ALLOW_TAGS]; ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; $keysort = $canonical ? sub { $a cmp $b } : undef; if ($self->{sort_by}) { $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} : sub { $a cmp $b }; } encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") if(!ref $obj and !$props->[ P_ALLOW_NONREF ]); my $str = $self->object_to_json($obj); $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible unless ($ascii or $latin1 or $utf8) { utf8::upgrade($str); } if ($props->[ P_SHRINK ]) { utf8::downgrade($str, 1); } return $str; } sub object_to_json { my ($self, $obj) = @_; my $type = ref($obj); if($type eq 'HASH'){ return $self->hash_to_json($obj); } elsif($type eq 'ARRAY'){ return $self->array_to_json($obj); } elsif ($type) { # blessed object? if (blessed($obj)) { return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); if ( $allow_tags and $obj->can('FREEZE') ) { my $obj_class = ref $obj || $obj; $obj = bless $obj, $obj_class; my @results = $obj->FREEZE('JSON'); if ( @results and ref $results[0] ) { if ( refaddr( $obj ) eq refaddr( $results[0] ) ) { encode_error( sprintf( "%s::FREEZE method returned same object as was passed instead of a new one", ref $obj ) ); } } return '("'.$obj_class.'")['.join(',', @results).']'; } if ( $convert_blessed and $obj->can('TO_JSON') ) { my $result = $obj->TO_JSON(); if ( defined $result and ref( $result ) ) { if ( refaddr( $obj ) eq refaddr( $result ) ) { encode_error( sprintf( "%s::TO_JSON method returned same object as was passed instead of a new one", ref $obj ) ); } } return $self->object_to_json( $result ); } return "$obj" if ( $bignum and _is_bignum($obj) ); if ($allow_blessed) { return $self->blessed_to_json($obj) if ($as_nonblessed); # will be removed. return 'null'; } encode_error( sprintf("encountered object '%s', but neither allow_blessed, convert_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)", $obj) ); } else { return $self->value_to_json($obj); } } else{ return $self->value_to_json($obj); } } sub hash_to_json { my ($self, $obj) = @_; my @res; encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") if (++$depth > $max_depth); my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); for my $k ( _sort( $obj ) ) { if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized push @res, $self->string_to_json( $k ) . $del . ( ref $obj->{$k} ? $self->object_to_json( $obj->{$k} ) : $self->value_to_json( $obj->{$k} ) ); } --$depth; $self->_down_indent() if ($indent); return '{}' unless @res; return '{' . $pre . join( ",$pre", @res ) . $post . '}'; } sub array_to_json { my ($self, $obj) = @_; my @res; encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") if (++$depth > $max_depth); my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); for my $v (@$obj){ push @res, ref($v) ? $self->object_to_json($v) : $self->value_to_json($v); } --$depth; $self->_down_indent() if ($indent); return '[]' unless @res; return '[' . $pre . join( ",$pre", @res ) . $post . ']'; } sub _looks_like_number { my $value = shift; if (USE_B) { my $b_obj = B::svref_2object(\$value); my $flags = $b_obj->FLAGS; return 1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() ); return; } else { no warnings 'numeric'; # if the utf8 flag is on, it almost certainly started as a string return if utf8::is_utf8($value); # detect numbers # string & "" -> "" # number & "" -> 0 (with warning) # nan and inf can detect as numbers, so check with * 0 return unless length((my $dummy = "") & $value); return unless 0 + $value eq $value; return 1 if $value * 0 == 0; return -1; # inf/nan } } sub value_to_json { my ($self, $value) = @_; return 'null' if(!defined $value); my $type = ref($value); if (!$type) { if (_looks_like_number($value)) { return $value; } return $self->string_to_json($value); } elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ return $$value == 1 ? 'true' : 'false'; } else { if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { return $self->value_to_json("$value"); } if ($type eq 'SCALAR' and defined $$value) { return $$value eq '1' ? 'true' : $$value eq '0' ? 'false' : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' : encode_error("cannot encode reference to scalar"); } if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { return 'null'; } else { if ( $type eq 'SCALAR' or $type eq 'REF' ) { encode_error("cannot encode reference to scalar"); } else { encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); } } } } my %esc = ( "\n" => '\n', "\r" => '\r', "\t" => '\t', "\f" => '\f', "\b" => '\b', "\"" => '\"', "\\" => '\\\\', "\'" => '\\\'', ); sub string_to_json { my ($self, $arg) = @_; $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; $arg =~ s/\//\\\//g if ($escape_slash); $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; if ($ascii) { $arg = JSON_PP_encode_ascii($arg); } if ($latin1) { $arg = JSON_PP_encode_latin1($arg); } if ($utf8) { utf8::encode($arg); } return '"' . $arg . '"'; } sub blessed_to_json { my $reftype = reftype($_[1]) || ''; if ($reftype eq 'HASH') { return $_[0]->hash_to_json($_[1]); } elsif ($reftype eq 'ARRAY') { return $_[0]->array_to_json($_[1]); } else { return 'null'; } } sub encode_error { my $error = shift; Carp::croak "$error"; } sub _sort { defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; } sub _up_indent { my $self = shift; my $space = ' ' x $indent_length; my ($pre,$post) = ('',''); $post = "\n" . $space x $indent_count; $indent_count++; $pre = "\n" . $space x $indent_count; return ($pre,$post); } sub _down_indent { $indent_count--; } sub PP_encode_box { { depth => $depth, indent_count => $indent_count, }; } } # Convert sub _encode_ascii { join('', map { $_ <= 127 ? chr($_) : $_ <= 65535 ? sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); } unpack('U*', $_[0]) ); } sub _encode_latin1 { join('', map { $_ <= 255 ? chr($_) : $_ <= 65535 ? sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); } unpack('U*', $_[0]) ); } sub _encode_surrogates { # from perlunicode my $uni = $_[0] - 0x10000; return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); } sub _is_bignum { $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); } # # JSON => Perl # my $max_intsize; BEGIN { my $checkint = 1111; for my $d (5..64) { $checkint .= 1; my $int = eval qq| $checkint |; if ($int =~ /[eE]/) { $max_intsize = $d - 1; last; } } } { # PARSE my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org> b => "\x8", t => "\x9", n => "\xA", f => "\xC", r => "\xD", '\\' => '\\', '"' => '"', '/' => '/', ); my $text; # json data my $at; # offset my $ch; # first character my $len; # text length (changed according to UTF8 or NON UTF8) # INTERNAL my $depth; # nest counter my $encoding; # json text encoding my $is_valid_utf8; # temp variable my $utf8_len; # utf8 byte length # FLAGS my $utf8; # must be utf8 my $max_depth; # max nest number of objects and arrays my $max_size; my $relaxed; my $cb_object; my $cb_sk_object; my $F_HOOK; my $allow_bignum; # using Math::BigInt/BigFloat my $singlequote; # loosely quoting my $loose; # my $allow_barekey; # bareKey my $allow_tags; my $alt_true; my $alt_false; sub _detect_utf_encoding { my $text = shift; my @octets = unpack('C4', $text); return 'unknown' unless defined $octets[3]; return ( $octets[0] and $octets[1]) ? 'UTF-8' : (!$octets[0] and $octets[1]) ? 'UTF-16BE' : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' : ( $octets[2] ) ? 'UTF-16LE' : (!$octets[2] ) ? 'UTF-32LE' : 'unknown'; } sub PP_decode_json { my ($self, $want_offset); ($self, $text, $want_offset) = @_; ($at, $ch, $depth) = (0, '', 0); if ( !defined $text or ref $text ) { decode_error("malformed JSON string, neither array, object, number, string or atom"); } my $props = $self->{PROPS}; ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote, $allow_tags) = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE, P_ALLOW_TAGS]; ($alt_true, $alt_false) = @$self{qw/true false/}; if ( $utf8 ) { $encoding = _detect_utf_encoding($text); if ($encoding ne 'UTF-8' and $encoding ne 'unknown') { require Encode; Encode::from_to($text, $encoding, 'utf-8'); } else { utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); } } else { utf8::upgrade( $text ); utf8::encode( $text ); } $len = length $text; ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; if ($max_size > 1) { use bytes; my $bytes = length $text; decode_error( sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" , $bytes, $max_size), 1 ) if ($bytes > $max_size); } white(); # remove head white space decode_error("malformed JSON string, neither array, object, number, string or atom") unless defined $ch; # Is there a first character for JSON structure? my $result = value(); if ( !$props->[ P_ALLOW_NONREF ] and !ref $result ) { decode_error( 'JSON text must be an object or array (but found number, string, true, false or null,' . ' use allow_nonref to allow this)', 1); } Carp::croak('something wrong.') if $len < $at; # we won't arrive here. my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length white(); # remove tail white space return ( $result, $consumed ) if $want_offset; # all right if decode_prefix decode_error("garbage after JSON object") if defined $ch; $result; } sub next_chr { return $ch = undef if($at >= $len); $ch = substr($text, $at++, 1); } sub value { white(); return if(!defined $ch); return object() if($ch eq '{'); return array() if($ch eq '['); return tag() if($ch eq '('); return string() if($ch eq '"' or ($singlequote and $ch eq "'")); return number() if($ch =~ /[0-9]/ or $ch eq '-'); return word(); } sub string { my $utf16; my $is_utf8; ($is_valid_utf8, $utf8_len) = ('', 0); my $s = ''; # basically UTF8 flag on if($ch eq '"' or ($singlequote and $ch eq "'")){ my $boundChar = $ch; OUTER: while( defined(next_chr()) ){ if($ch eq $boundChar){ next_chr(); if ($utf16) { decode_error("missing low surrogate character in surrogate pair"); } utf8::decode($s) if($is_utf8); return $s; } elsif($ch eq '\\'){ next_chr(); if(exists $escapes{$ch}){ $s .= $escapes{$ch}; } elsif($ch eq 'u'){ # UNICODE handling my $u = ''; for(1..4){ $ch = next_chr(); last OUTER if($ch !~ /[0-9a-fA-F]/); $u .= $ch; } # U+D800 - U+DBFF if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? $utf16 = $u; } # U+DC00 - U+DFFF elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? unless (defined $utf16) { decode_error("missing high surrogate character in surrogate pair"); } $is_utf8 = 1; $s .= JSON_PP_decode_surrogates($utf16, $u) || next; $utf16 = undef; } else { if (defined $utf16) { decode_error("surrogate pair expected"); } if ( ( my $hex = hex( $u ) ) > 127 ) { $is_utf8 = 1; $s .= JSON_PP_decode_unicode($u) || next; } else { $s .= chr $hex; } } } else{ unless ($loose) { $at -= 2; decode_error('illegal backslash escape sequence in string'); } $s .= $ch; } } else{ if ( ord $ch > 127 ) { unless( $ch = is_valid_utf8($ch) ) { $at -= 1; decode_error("malformed UTF-8 character in JSON string"); } else { $at += $utf8_len - 1; } $is_utf8 = 1; } if (!$loose) { if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok if (!$relaxed or $ch ne "\t") { $at--; decode_error('invalid character encountered while parsing JSON string'); } } } $s .= $ch; } } } decode_error("unexpected end of string while parsing JSON string"); } sub white { while( defined $ch ){ if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){ next_chr(); } elsif($relaxed and $ch eq '/'){ next_chr(); if(defined $ch and $ch eq '/'){ 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); } elsif(defined $ch and $ch eq '*'){ next_chr(); while(1){ if(defined $ch){ if($ch eq '*'){ if(defined(next_chr()) and $ch eq '/'){ next_chr(); last; } } else{ next_chr(); } } else{ decode_error("Unterminated comment"); } } next; } else{ $at--; decode_error("malformed JSON string, neither array, object, number, string or atom"); } } else{ if ($relaxed and $ch eq '#') { # correctly? pos($text) = $at; $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; $at = pos($text); next_chr; next; } last; } } } sub array { my $a = $_[0] || []; # you can use this code to use another array ref object. decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') if (++$depth > $max_depth); next_chr(); white(); if(defined $ch and $ch eq ']'){ --$depth; next_chr(); return $a; } else { while(defined($ch)){ push @$a, value(); white(); if (!defined $ch) { last; } if($ch eq ']'){ --$depth; next_chr(); return $a; } if($ch ne ','){ last; } next_chr(); white(); if ($relaxed and $ch eq ']') { --$depth; next_chr(); return $a; } } } $at-- if defined $ch and $ch ne ''; decode_error(", or ] expected while parsing array"); } sub tag { decode_error('malformed JSON string, neither array, object, number, string or atom') unless $allow_tags; next_chr(); white(); my $tag = value(); return unless defined $tag; decode_error('malformed JSON string, (tag) must be a string') if ref $tag; white(); if (!defined $ch or $ch ne ')') { decode_error(') expected after tag'); } next_chr(); white(); my $val = value(); return unless defined $val; decode_error('malformed JSON string, tag value must be an array') unless ref $val eq 'ARRAY'; if (!eval { $tag->can('THAW') }) { decode_error('cannot decode perl-object (package does not exist)') if $@; decode_error('cannot decode perl-object (package does not have a THAW method)'); } $tag->THAW('JSON', @$val); } sub object { my $o = $_[0] || {}; # you can use this code to use another hash ref object. my $k; decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') if (++$depth > $max_depth); next_chr(); white(); if(defined $ch and $ch eq '}'){ --$depth; next_chr(); if ($F_HOOK) { return _json_object_hook($o); } return $o; } else { while (defined $ch) { $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); white(); if(!defined $ch or $ch ne ':'){ $at--; decode_error("':' expected"); } next_chr(); $o->{$k} = value(); white(); last if (!defined $ch); if($ch eq '}'){ --$depth; next_chr(); if ($F_HOOK) { return _json_object_hook($o); } return $o; } if($ch ne ','){ last; } next_chr(); white(); if ($relaxed and $ch eq '}') { --$depth; next_chr(); if ($F_HOOK) { return _json_object_hook($o); } return $o; } } } $at-- if defined $ch and $ch ne ''; decode_error(", or } expected while parsing object/hash"); } sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition my $key; while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ $key .= $ch; next_chr(); } return $key; } sub word { my $word = substr($text,$at-1,4); if($word eq 'true'){ $at += 3; next_chr; return defined $alt_true ? $alt_true : $JSON::PP::true; } elsif($word eq 'null'){ $at += 3; next_chr; return undef; } elsif($word eq 'fals'){ $at += 3; if(substr($text,$at,1) eq 'e'){ $at++; next_chr; return defined $alt_false ? $alt_false : $JSON::PP::false; } } $at--; # for decode_error report decode_error("'null' expected") if ($word =~ /^n/); decode_error("'true' expected") if ($word =~ /^t/); decode_error("'false' expected") if ($word =~ /^f/); decode_error("malformed JSON string, neither array, object, number, string or atom"); } sub number { my $n = ''; my $v; my $is_dec; my $is_exp; if($ch eq '-'){ $n = '-'; next_chr; if (!defined $ch or $ch !~ /\d/) { decode_error("malformed number (no digits after initial minus)"); } } # According to RFC4627, hex or oct digits are invalid. if($ch eq '0'){ my $peek = substr($text,$at,1); if($peek =~ /^[0-9a-dfA-DF]/){ # e may be valid (exponential) decode_error("malformed number (leading zero must not be followed by another digit)"); } $n .= $ch; next_chr; } while(defined $ch and $ch =~ /\d/){ $n .= $ch; next_chr; } if(defined $ch and $ch eq '.'){ $n .= '.'; $is_dec = 1; next_chr; if (!defined $ch or $ch !~ /\d/) { decode_error("malformed number (no digits after decimal point)"); } else { $n .= $ch; } while(defined(next_chr) and $ch =~ /\d/){ $n .= $ch; } } if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ $n .= $ch; $is_exp = 1; next_chr; if(defined($ch) and ($ch eq '+' or $ch eq '-')){ $n .= $ch; next_chr; if (!defined $ch or $ch =~ /\D/) { decode_error("malformed number (no digits after exp sign)"); } $n .= $ch; } elsif(defined($ch) and $ch =~ /\d/){ $n .= $ch; } else { decode_error("malformed number (no digits after exp sign)"); } while(defined(next_chr) and $ch =~ /\d/){ $n .= $ch; } } $v .= $n; if ($is_dec or $is_exp) { if ($allow_bignum) { require Math::BigFloat; return Math::BigFloat->new($v); } } else { if (length $v > $max_intsize) { if ($allow_bignum) { # from Adam Sussman require Math::BigInt; return Math::BigInt->new($v); } else { return "$v"; } } } return $is_dec ? $v/1.0 : 0+$v; } sub is_valid_utf8 { $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 : $_[0] =~ /[\xC2-\xDF]/ ? 2 : $_[0] =~ /[\xE0-\xEF]/ ? 3 : $_[0] =~ /[\xF0-\xF4]/ ? 4 : 0 ; return unless $utf8_len; my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); return ( $is_valid_utf8 =~ /^(?: [\x00-\x7F] |[\xC2-\xDF][\x80-\xBF] |[\xE0][\xA0-\xBF][\x80-\xBF] |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] |[\xED][\x80-\x9F][\x80-\xBF] |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] )$/x ) ? $is_valid_utf8 : ''; } sub decode_error { my $error = shift; my $no_rep = shift; my $str = defined $text ? substr($text, $at) : ''; my $mess = ''; my $type = 'U*'; if ( OLD_PERL ) { my $type = $] < 5.006 ? 'C*' : utf8::is_utf8( $str ) ? 'U*' # 5.6 : 'C*' ; } for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? $mess .= $c == 0x07 ? '\a' : $c == 0x09 ? '\t' : $c == 0x0a ? '\n' : $c == 0x0d ? '\r' : $c == 0x0c ? '\f' : $c < 0x20 ? sprintf('\x{%x}', $c) : $c == 0x5c ? '\\\\' : $c < 0x80 ? chr($c) : sprintf('\x{%x}', $c) ; if ( length $mess >= 20 ) { $mess .= '...'; last; } } unless ( length $mess ) { $mess = '(end of string)'; } Carp::croak ( $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" ); } sub _json_object_hook { my $o = $_[0]; my @ks = keys %{$o}; if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); if (@val == 0) { return $o; } elsif (@val == 1) { return $val[0]; } else { Carp::croak("filter_json_single_key_object callbacks must not return more than one scalar"); } } my @val = $cb_object->($o) if ($cb_object); if (@val == 0) { return $o; } elsif (@val == 1) { return $val[0]; } else { Carp::croak("filter_json_object callbacks must not return more than one scalar"); } } sub PP_decode_box { { text => $text, at => $at, ch => $ch, len => $len, depth => $depth, encoding => $encoding, is_valid_utf8 => $is_valid_utf8, }; } } # PARSE sub _decode_surrogates { # from perlunicode my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); my $un = pack('U*', $uni); utf8::encode( $un ); return $un; } sub _decode_unicode { my $un = pack('U', hex shift); utf8::encode( $un ); return $un; } # # Setup for various Perl versions (the code from JSON::PP58) # BEGIN { unless ( defined &utf8::is_utf8 ) { require Encode; *utf8::is_utf8 = *Encode::is_utf8; } if ( !OLD_PERL ) { *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; if ($] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. package # hide from PAUSE JSON::PP; require subs; subs->import('join'); eval q| sub join { return '' if (@_ < 2); my $j = shift; my $str = shift; for (@_) { $str .= $j . $_; } return $str; } |; } } sub JSON::PP::incr_parse { local $Carp::CarpLevel = 1; ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); } sub JSON::PP::incr_skip { ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; } sub JSON::PP::incr_reset { ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; } eval q{ sub JSON::PP::incr_text : lvalue { $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; if ( $_[0]->{_incr_parser}->{incr_pos} ) { Carp::croak("incr_text cannot be called when the incremental parser already started parsing"); } $_[0]->{_incr_parser}->{incr_text}; } } if ( $] >= 5.006 ); } # Setup for various Perl versions (the code from JSON::PP58) ############################### # Utilities # BEGIN { eval 'require Scalar::Util'; unless($@){ *JSON::PP::blessed = \&Scalar::Util::blessed; *JSON::PP::reftype = \&Scalar::Util::reftype; *JSON::PP::refaddr = \&Scalar::Util::refaddr; } else{ # This code is from Scalar::Util. # warn $@; eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; *JSON::PP::blessed = sub { local($@, $SIG{__DIE__}, $SIG{__WARN__}); ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; }; require B; my %tmap = qw( B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP ); *JSON::PP::reftype = sub { my $r = shift; return undef unless length(ref($r)); my $t = ref(B::svref_2object($r)); return exists $tmap{$t} ? $tmap{$t} : length(ref($$r)) ? 'REF' : 'SCALAR'; }; *JSON::PP::refaddr = sub { return undef unless length(ref($_[0])); my $addr; if(defined(my $pkg = blessed($_[0]))) { $addr .= bless $_[0], 'Scalar::Util::Fake'; bless $_[0], $pkg; } else { $addr .= $_[0] } $addr =~ /0x(\w+)/; local $^W; #no warnings 'portable'; hex($1); } } } # shamelessly copied and modified from JSON::XS code. $JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; sub is_bool { blessed $_[0] and ( $_[0]->isa("JSON::PP::Boolean") or $_[0]->isa("Types::Serialiser::BooleanBase") or $_[0]->isa("JSON::XS::Boolean") ); } sub true { $JSON::PP::true } sub false { $JSON::PP::false } sub null { undef; } ############################### package # hide from PAUSE JSON::PP::IncrParser; use strict; use constant INCR_M_WS => 0; # initial whitespace skipping use constant INCR_M_STR => 1; # inside string use constant INCR_M_BS => 2; # inside backslash use constant INCR_M_JSON => 3; # outside anything, count nesting use constant INCR_M_C0 => 4; use constant INCR_M_C1 => 5; use constant INCR_M_TFN => 6; use constant INCR_M_NUM => 7; $JSON::backportPP::IncrParser::VERSION = '1.01'; sub new { my ( $class ) = @_; bless { incr_nest => 0, incr_text => undef, incr_pos => 0, incr_mode => 0, }, $class; } sub incr_parse { my ( $self, $coder, $text ) = @_; $self->{incr_text} = '' unless ( defined $self->{incr_text} ); if ( defined $text ) { if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { utf8::upgrade( $self->{incr_text} ) ; utf8::decode( $self->{incr_text} ) ; } $self->{incr_text} .= $text; } if ( defined wantarray ) { my $max_size = $coder->get_max_size; my $p = $self->{incr_pos}; my @ret; { do { unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) { $self->_incr_parse( $coder ); if ( $max_size and $self->{incr_pos} > $max_size ) { Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size"); } unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) { # as an optimisation, do not accumulate white space in the incr buffer if ( $self->{incr_mode} == INCR_M_WS and $self->{incr_pos} ) { $self->{incr_pos} = 0; $self->{incr_text} = ''; } last; } } unless ( $coder->get_utf8 ) { utf8::upgrade( $self->{incr_text} ); utf8::decode( $self->{incr_text} ); } my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 ); push @ret, $obj; use bytes; $self->{incr_text} = substr( $self->{incr_text}, $offset || 0 ); $self->{incr_pos} = 0; $self->{incr_nest} = 0; $self->{incr_mode} = 0; last unless wantarray; } while ( wantarray ); } if ( wantarray ) { return @ret; } else { # in scalar context return defined $ret[0] ? $ret[0] : undef; } } } sub _incr_parse { my ($self, $coder) = @_; my $text = $self->{incr_text}; my $len = length $text; my $p = $self->{incr_pos}; INCR_PARSE: while ( $len > $p ) { my $s = substr( $text, $p, 1 ); last INCR_PARSE unless defined $s; my $mode = $self->{incr_mode}; if ( $mode == INCR_M_WS ) { while ( $len > $p ) { $s = substr( $text, $p, 1 ); last INCR_PARSE unless defined $s; if ( ord($s) > 0x20 ) { if ( $s eq '#' ) { $self->{incr_mode} = INCR_M_C0; redo INCR_PARSE; } else { $self->{incr_mode} = INCR_M_JSON; redo INCR_PARSE; } } $p++; } } elsif ( $mode == INCR_M_BS ) { $p++; $self->{incr_mode} = INCR_M_STR; redo INCR_PARSE; } elsif ( $mode == INCR_M_C0 or $mode == INCR_M_C1 ) { while ( $len > $p ) { $s = substr( $text, $p, 1 ); last INCR_PARSE unless defined $s; if ( $s eq "\n" ) { $self->{incr_mode} = $self->{incr_mode} == INCR_M_C0 ? INCR_M_WS : INCR_M_JSON; last; } $p++; } next; } elsif ( $mode == INCR_M_TFN ) { while ( $len > $p ) { $s = substr( $text, $p++, 1 ); next if defined $s and $s =~ /[rueals]/; last; } $p--; $self->{incr_mode} = INCR_M_JSON; last INCR_PARSE unless $self->{incr_nest}; redo INCR_PARSE; } elsif ( $mode == INCR_M_NUM ) { while ( $len > $p ) { $s = substr( $text, $p++, 1 ); next if defined $s and $s =~ /[0-9eE.+\-]/; last; } $p--; $self->{incr_mode} = INCR_M_JSON; last INCR_PARSE unless $self->{incr_nest}; redo INCR_PARSE; } elsif ( $mode == INCR_M_STR ) { while ( $len > $p ) { $s = substr( $text, $p, 1 ); last INCR_PARSE unless defined $s; if ( $s eq '"' ) { $p++; $self->{incr_mode} = INCR_M_JSON; last INCR_PARSE unless $self->{incr_nest}; redo INCR_PARSE; } elsif ( $s eq '\\' ) { $p++; if ( !defined substr($text, $p, 1) ) { $self->{incr_mode} = INCR_M_BS; last INCR_PARSE; } } $p++; } } elsif ( $mode == INCR_M_JSON ) { while ( $len > $p ) { $s = substr( $text, $p++, 1 ); if ( $s eq "\x00" ) { $p--; last INCR_PARSE; } elsif ( $s eq "\x09" or $s eq "\x0a" or $s eq "\x0d" or $s eq "\x20" ) { if ( !$self->{incr_nest} ) { $p--; # do not eat the whitespace, let the next round do it last INCR_PARSE; } next; } elsif ( $s eq 't' or $s eq 'f' or $s eq 'n' ) { $self->{incr_mode} = INCR_M_TFN; redo INCR_PARSE; } elsif ( $s =~ /^[0-9\-]$/ ) { $self->{incr_mode} = INCR_M_NUM; redo INCR_PARSE; } elsif ( $s eq '"' ) { $self->{incr_mode} = INCR_M_STR; redo INCR_PARSE; } elsif ( $s eq '[' or $s eq '{' ) { if ( ++$self->{incr_nest} > $coder->get_max_depth ) { Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); } next; } elsif ( $s eq ']' or $s eq '}' ) { if ( --$self->{incr_nest} <= 0 ) { last INCR_PARSE; } } elsif ( $s eq '#' ) { $self->{incr_mode} = INCR_M_C1; redo INCR_PARSE; } } } } $self->{incr_pos} = $p; $self->{incr_parsing} = $p ? 1 : 0; # for backward compatibility } sub incr_text { if ( $_[0]->{incr_pos} ) { Carp::croak("incr_text cannot be called when the incremental parser already started parsing"); } $_[0]->{incr_text}; } sub incr_skip { my $self = shift; $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_pos} ); $self->{incr_pos} = 0; $self->{incr_mode} = 0; $self->{incr_nest} = 0; } sub incr_reset { my $self = shift; $self->{incr_text} = undef; $self->{incr_pos} = 0; $self->{incr_mode} = 0; $self->{incr_nest} = 0; } ############################### 1; __END__ =pod =head1 NAME JSON::PP - JSON::XS compatible pure-Perl module. =head1 SYNOPSIS use JSON::PP; # exported functions, they croak on error # and expect/generate UTF-8 $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; # OO-interface $json = JSON::PP->new->ascii->pretty->allow_nonref; $pretty_printed_json_text = $json->encode( $perl_scalar ); $perl_scalar = $json->decode( $json_text ); # Note that JSON version 2.0 and above will automatically use # JSON::XS or JSON::PP, so you should be able to just: use JSON; =head1 DESCRIPTION JSON::PP is a pure perl JSON decoder/encoder, and (almost) compatible to much faster L<JSON::XS> written by Marc Lehmann in C. JSON::PP works as a fallback module when you use L<JSON> module without having installed JSON::XS. Because of this fallback feature of JSON.pm, JSON::PP tries not to be more JavaScript-friendly than JSON::XS (i.e. not to escape extra characters such as U+2028 and U+2029, etc), in order for you not to lose such JavaScript-friendliness silently when you use JSON.pm and install JSON::XS for speed or by accident. If you need JavaScript-friendly RFC7159-compliant pure perl module, try L<JSON::Tiny>, which is derived from L<Mojolicious> web framework and is also smaller and faster than JSON::PP. JSON::PP has been in the Perl core since Perl 5.14, mainly for CPAN toolchain modules to parse META.json. =head1 FUNCTIONAL INTERFACE This section is taken from JSON::XS almost verbatim. C<encode_json> and C<decode_json> are exported by default. =head2 encode_json $json_text = encode_json $perl_scalar Converts the given Perl data structure to a UTF-8 encoded, binary string (that is, the string contains octets only). Croaks on error. This function call is functionally identical to: $json_text = JSON::PP->new->utf8->encode($perl_scalar) Except being faster. =head2 decode_json $perl_scalar = decode_json $json_text The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries to parse that as an UTF-8 encoded JSON text, returning the resulting reference. Croaks on error. This function call is functionally identical to: $perl_scalar = JSON::PP->new->utf8->decode($json_text) Except being faster. =head2 JSON::PP::is_bool $is_boolean = JSON::PP::is_bool($scalar) Returns true if the passed scalar represents either JSON::PP::true or JSON::PP::false, two constants that act like C<1> and C<0> respectively and are also used to represent JSON C<true> and C<false> in Perl strings. See L<MAPPING>, below, for more information on how JSON values are mapped to Perl. =head1 OBJECT-ORIENTED INTERFACE This section is also taken from JSON::XS. The object oriented interface lets you configure your own encoding or decoding style, within the limits of supported formats. =head2 new $json = JSON::PP->new Creates a new JSON::PP object that can be used to de/encode JSON strings. All boolean flags described below are by default I<disabled> (with the exception of C<allow_nonref>, which defaults to I<enabled> since version C<4.0>). The mutators for flags all return the JSON::PP object again and thus calls can be chained: my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]}) => {"a": [1, 2]} =head2 ascii $json = $json->ascii([$enable]) $enabled = $json->get_ascii If C<$enable> is true (or missing), then the C<encode> method will not generate characters outside the code range C<0..127> (which is ASCII). Any Unicode characters outside that range will be escaped using either a single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. The resulting encoded JSON text can be treated as a native Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string, or any other superset of ASCII. If C<$enable> is false, then the C<encode> method will not escape Unicode characters unless required by the JSON syntax or other flags. This results in a faster and more compact format. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. The main use for this flag is to produce JSON texts that can be transmitted over a 7-bit channel, as the encoded JSON texts will not contain any 8 bit characters. JSON::PP->new->ascii(1)->encode([chr 0x10401]) => ["\ud801\udc01"] =head2 latin1 $json = $json->latin1([$enable]) $enabled = $json->get_latin1 If C<$enable> is true (or missing), then the C<encode> method will encode the resulting JSON text as latin1 (or iso-8859-1), escaping any characters outside the code range C<0..255>. The resulting string can be treated as a latin1-encoded JSON text or a native Unicode string. The C<decode> method will not be affected in any way by this flag, as C<decode> by default expects Unicode, which is a strict superset of latin1. If C<$enable> is false, then the C<encode> method will not escape Unicode characters unless required by the JSON syntax or other flags. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. The main use for this flag is efficiently encoding binary data as JSON text, as most octets will not be escaped, resulting in a smaller encoded size. The disadvantage is that the resulting JSON text is encoded in latin1 (and must correctly be treated as such when storing and transferring), a rare encoding for JSON. It is therefore most useful when you want to store data structures known to contain binary data efficiently in files or databases, not when talking to other JSON encoders/decoders. JSON::PP->new->latin1->encode (["\x{89}\x{abc}"] => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) =head2 utf8 $json = $json->utf8([$enable]) $enabled = $json->get_utf8 If C<$enable> is true (or missing), then the C<encode> method will encode the JSON result into UTF-8, as required by many protocols, while the C<decode> method expects to be handled an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any characters outside the range C<0..255>, they are thus useful for bytewise/binary I/O. In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 encoding families, as described in RFC4627. If C<$enable> is false, then the C<encode> method will return the JSON string as a (non-encoded) Unicode string, while C<decode> expects thus a Unicode string. Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. Example, output UTF-16BE-encoded JSON: use Encode; $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object); Example, decode UTF-32LE-encoded JSON: use Encode; $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext); =head2 pretty $json = $json->pretty([$enable]) This enables (or disables) all of the C<indent>, C<space_before> and C<space_after> (and in the future possibly more) flags in one call to generate the most readable (or most compact) form possible. =head2 indent $json = $json->indent([$enable]) $enabled = $json->get_indent If C<$enable> is true (or missing), then the C<encode> method will use a multiline format as output, putting every array member or object/hash key-value pair into its own line, indenting them properly. If C<$enable> is false, no newlines or indenting will be produced, and the resulting JSON text is guaranteed not to contain any C<newlines>. This setting has no effect when decoding JSON texts. The default indent space length is three. You can use C<indent_length> to change the length. =head2 space_before $json = $json->space_before([$enable]) $enabled = $json->get_space_before If C<$enable> is true (or missing), then the C<encode> method will add an extra optional space before the C<:> separating keys from values in JSON objects. If C<$enable> is false, then the C<encode> method will not add any extra space at those places. This setting has no effect when decoding JSON texts. You will also most likely combine this setting with C<space_after>. Example, space_before enabled, space_after and indent disabled: {"key" :"value"} =head2 space_after $json = $json->space_after([$enable]) $enabled = $json->get_space_after If C<$enable> is true (or missing), then the C<encode> method will add an extra optional space after the C<:> separating keys from values in JSON objects and extra whitespace after the C<,> separating key-value pairs and array members. If C<$enable> is false, then the C<encode> method will not add any extra space at those places. This setting has no effect when decoding JSON texts. Example, space_before and indent disabled, space_after enabled: {"key": "value"} =head2 relaxed $json = $json->relaxed([$enable]) $enabled = $json->get_relaxed If C<$enable> is true (or missing), then C<decode> will accept some extensions to normal JSON syntax (see below). C<encode> will not be affected in anyway. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. Currently accepted extensions are: =over 4 =item * list items can have an end-comma JSON I<separates> array elements and key-value pairs with commas. This can be annoying if you write JSON texts manually and want to be able to quickly append elements, so this extension accepts comma at the end of such items not just between them: [ 1, 2, <- this comma not normally allowed ] { "k1": "v1", "k2": "v2", <- this comma not normally allowed } =item * shell-style '#'-comments Whenever JSON allows whitespace, shell-style comments are additionally allowed. They are terminated by the first carriage-return or line-feed character, after which more white-space and comments are allowed. [ 1, # this comment not allowed in JSON # neither this one... ] =item * C-style multiple-line '/* */'-comments (JSON::PP only) Whenever JSON allows whitespace, C-style multiple-line comments are additionally allowed. Everything between C</*> and C<*/> is a comment, after which more white-space and comments are allowed. [ 1, /* this comment not allowed in JSON */ /* neither this one... */ ] =item * C++-style one-line '//'-comments (JSON::PP only) Whenever JSON allows whitespace, C++-style one-line comments are additionally allowed. They are terminated by the first carriage-return or line-feed character, after which more white-space and comments are allowed. [ 1, // this comment not allowed in JSON // neither this one... ] =item * literal ASCII TAB characters in strings Literal ASCII TAB characters are now allowed in strings (and treated as C<\t>). [ "Hello\tWorld", "Hello<TAB>World", # literal <TAB> would not normally be allowed ] =back =head2 canonical $json = $json->canonical([$enable]) $enabled = $json->get_canonical If C<$enable> is true (or missing), then the C<encode> method will output JSON objects by sorting their keys. This is adding a comparatively high overhead. If C<$enable> is false, then the C<encode> method will output key-value pairs in the order Perl stores them (which will likely change between runs of the same script, and can change even within the same run from 5.18 onwards). This option is useful if you want the same data structure to be encoded as the same JSON text (given the same overall settings). If it is disabled, the same hash might be encoded differently even if contains the same data, as key-value pairs have no inherent ordering in Perl. This setting has no effect when decoding JSON texts. This setting has currently no effect on tied hashes. =head2 allow_nonref $json = $json->allow_nonref([$enable]) $enabled = $json->get_allow_nonref Unlike other boolean options, this opotion is enabled by default beginning with version C<4.0>. If C<$enable> is true (or missing), then the C<encode> method can convert a non-reference into its corresponding string, number or null JSON value, which is an extension to RFC4627. Likewise, C<decode> will accept those JSON values instead of croaking. If C<$enable> is false, then the C<encode> method will croak if it isn't passed an arrayref or hashref, as JSON texts must either be an object or array. Likewise, C<decode> will croak if given something that is not a JSON object or array. Example, encode a Perl scalar as JSON value without enabled C<allow_nonref>, resulting in an error: JSON::PP->new->allow_nonref(0)->encode ("Hello, World!") => hash- or arrayref expected... =head2 allow_unknown $json = $json->allow_unknown([$enable]) $enabled = $json->get_allow_unknown If C<$enable> is true (or missing), then C<encode> will I<not> throw an exception when it encounters values it cannot represent in JSON (for example, filehandles) but instead will encode a JSON C<null> value. Note that blessed objects are not included here and are handled separately by c<allow_blessed>. If C<$enable> is false (the default), then C<encode> will throw an exception when it encounters anything it cannot encode as JSON. This option does not affect C<decode> in any way, and it is recommended to leave it off unless you know your communications partner. =head2 allow_blessed $json = $json->allow_blessed([$enable]) $enabled = $json->get_allow_blessed See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then the C<encode> method will not barf when it encounters a blessed reference that it cannot convert otherwise. Instead, a JSON C<null> value is encoded instead of the object. If C<$enable> is false (the default), then C<encode> will throw an exception when it encounters a blessed object that it cannot convert otherwise. This setting has no effect on C<decode>. =head2 convert_blessed $json = $json->convert_blessed([$enable]) $enabled = $json->get_convert_blessed See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then C<encode>, upon encountering a blessed object, will check for the availability of the C<TO_JSON> method on the object's class. If found, it will be called in scalar context and the resulting scalar will be encoded instead of the object. The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON> returns other blessed objects, those will be handled in the same way. C<TO_JSON> must take care of not causing an endless recursion cycle (== crash) in this case. The name of C<TO_JSON> was chosen because other methods called by the Perl core (== not by the user of the object) are usually in upper case letters and to avoid collisions with any C<to_json> function or method. If C<$enable> is false (the default), then C<encode> will not consider this type of conversion. This setting has no effect on C<decode>. =head2 allow_tags $json = $json->allow_tags([$enable]) $enabled = $json->get_allow_tags See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then C<encode>, upon encountering a blessed object, will check for the availability of the C<FREEZE> method on the object's class. If found, it will be used to serialise the object into a nonstandard tagged JSON value (that JSON decoders cannot decode). It also causes C<decode> to parse such tagged JSON values and deserialise them via a call to the C<THAW> method. If C<$enable> is false (the default), then C<encode> will not consider this type of conversion, and tagged JSON values will cause a parse error in C<decode>, as if tags were not part of the grammar. =head2 boolean_values $json->boolean_values([$false, $true]) ($false, $true) = $json->get_boolean_values By default, JSON booleans will be decoded as overloaded C<$JSON::PP::false> and C<$JSON::PP::true> objects. With this method you can specify your own boolean values for decoding - on decode, JSON C<false> will be decoded as a copy of C<$false>, and JSON C<true> will be decoded as C<$true> ("copy" here is the same thing as assigning a value to another variable, i.e. C<$copy = $false>). This is useful when you want to pass a decoded data structure directly to other serialisers like YAML, Data::MessagePack and so on. Note that this works only when you C<decode>. You can set incompatible boolean objects (like L<boolean>), but when you C<encode> a data structure with such boolean objects, you still need to enable C<convert_blessed> (and add a C<TO_JSON> method if necessary). Calling this method without any arguments will reset the booleans to their default values. C<get_boolean_values> will return both C<$false> and C<$true> values, or the empty list when they are set to the default. =head2 filter_json_object $json = $json->filter_json_object([$coderef]) When C<$coderef> is specified, it will be called from C<decode> each time it decodes a JSON object. The only argument is a reference to the newly-created hash. If the code references returns a single scalar (which need not be a reference), this value (or rather a copy of it) is inserted into the deserialised data structure. If it returns an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised hash will be inserted. This setting can slow down decoding considerably. When C<$coderef> is omitted or undefined, any existing callback will be removed and C<decode> will not change the deserialised hash in any way. Example, convert all JSON objects into the integer 5: my $js = JSON::PP->new->filter_json_object(sub { 5 }); # returns [5] $js->decode('[{}]'); # returns 5 $js->decode('{"a":1, "b":2}'); =head2 filter_json_single_key_object $json = $json->filter_json_single_key_object($key [=> $coderef]) Works remotely similar to C<filter_json_object>, but is only called for JSON objects having a single key named C<$key>. This C<$coderef> is called before the one specified via C<filter_json_object>, if any. It gets passed the single value in the JSON object. If it returns a single value, it will be inserted into the data structure. If it returns nothing (not even C<undef> but the empty list), the callback from C<filter_json_object> will be called next, as if no single-key callback were specified. If C<$coderef> is omitted or undefined, the corresponding callback will be disabled. There can only ever be one callback for a given key. As this callback gets called less often then the C<filter_json_object> one, decoding speed will not usually suffer as much. Therefore, single-key objects make excellent targets to serialise Perl objects into, especially as single-key JSON objects are as close to the type-tagged value concept as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not support this in any way, so you need to make sure your data never looks like a serialised Perl hash. Typical names for the single object key are C<__class_whatever__>, or C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even things like C<__class_md5sum(classname)__>, to reduce the risk of clashing with real hashes. Example, decode JSON objects of the form C<< { "__widget__" => <id> } >> into the corresponding C<< $WIDGET{<id>} >> object: # return whatever is in $WIDGET{5}: JSON::PP ->new ->filter_json_single_key_object (__widget__ => sub { $WIDGET{ $_[0] } }) ->decode ('{"__widget__": 5') # this can be used with a TO_JSON method in some "widget" class # for serialisation to json: sub WidgetBase::TO_JSON { my ($self) = @_; unless ($self->{id}) { $self->{id} = ..get..some..id..; $WIDGET{$self->{id}} = $self; } { __widget__ => $self->{id} } } =head2 shrink $json = $json->shrink([$enable]) $enabled = $json->get_shrink If C<$enable> is true (or missing), the string returned by C<encode> will be shrunk (i.e. downgraded if possible). The actual definition of what shrink does might change in future versions, but it will always try to save space at the expense of time. If C<$enable> is false, then JSON::PP does nothing. =head2 max_depth $json = $json->max_depth([$maximum_nesting_depth]) $max_depth = $json->get_max_depth Sets the maximum nesting level (default C<512>) accepted while encoding or decoding. If a higher nesting level is detected in JSON text or a Perl data structure, then the encoder and decoder will stop and croak at that point. Nesting level is defined by number of hash- or arrayrefs that the encoder needs to traverse to reach a given point or the number of C<{> or C<[> characters without their matching closing parenthesis crossed to reach a given character in a string. Setting the maximum depth to one disallows any nesting, so that ensures that the object is only a single hash/object or array. If no argument is given, the highest possible setting will be used, which is rarely useful. See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful. =head2 max_size $json = $json->max_size([$maximum_string_size]) $max_size = $json->get_max_size Set the maximum length a JSON text may have (in bytes) where decoding is being attempted. The default is C<0>, meaning no limit. When C<decode> is called on a string that is longer then this many bytes, it will not attempt to decode the string but throw an exception. This setting has no effect on C<encode> (yet). If no argument is given, the limit check will be deactivated (same as when C<0> is specified). See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful. =head2 encode $json_text = $json->encode($perl_scalar) Converts the given Perl value or data structure to its JSON representation. Croaks on error. =head2 decode $perl_scalar = $json->decode($json_text) The opposite of C<encode>: expects a JSON text and tries to parse it, returning the resulting simple scalar or reference. Croaks on error. =head2 decode_prefix ($perl_scalar, $characters) = $json->decode_prefix($json_text) This works like the C<decode> method, but instead of raising an exception when there is trailing garbage after the first JSON object, it will silently stop parsing there and return the number of characters consumed so far. This is useful if your JSON texts are not delimited by an outer protocol and you need to know where the JSON text ends. JSON::PP->new->decode_prefix ("[1] the tail") => ([1], 3) =head1 FLAGS FOR JSON::PP ONLY The following flags and properties are for JSON::PP only. If you use any of these, you can't make your application run faster by replacing JSON::PP with JSON::XS. If you need these and also speed boost, you might want to try L<Cpanel::JSON::XS>, a fork of JSON::XS by Reini Urban, which supports some of these (with a different set of incompatibilities). Most of these historical flags are only kept for backward compatibility, and should not be used in a new application. =head2 allow_singlequote $json = $json->allow_singlequote([$enable]) $enabled = $json->get_allow_singlequote If C<$enable> is true (or missing), then C<decode> will accept invalid JSON texts that contain strings that begin and end with single quotation marks. C<encode> will not be affected in any way. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. $json->allow_singlequote->decode(qq|{"foo":'bar'}|); $json->allow_singlequote->decode(qq|{'foo':"bar"}|); $json->allow_singlequote->decode(qq|{'foo':'bar'}|); =head2 allow_barekey $json = $json->allow_barekey([$enable]) $enabled = $json->get_allow_barekey If C<$enable> is true (or missing), then C<decode> will accept invalid JSON texts that contain JSON objects whose names don't begin and end with quotation marks. C<encode> will not be affected in any way. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. $json->allow_barekey->decode(qq|{foo:"bar"}|); =head2 allow_bignum $json = $json->allow_bignum([$enable]) $enabled = $json->get_allow_bignum If C<$enable> is true (or missing), then C<decode> will convert big integers Perl cannot handle as integer into L<Math::BigInt> objects and convert floating numbers into L<Math::BigFloat> objects. C<encode> will convert C<Math::BigInt> and C<Math::BigFloat> objects into JSON numbers. $json->allow_nonref->allow_bignum; $bigfloat = $json->decode('2.000000000000000000000000001'); print $json->encode($bigfloat); # => 2.000000000000000000000000001 See also L<MAPPING>. =head2 loose $json = $json->loose([$enable]) $enabled = $json->get_loose If C<$enable> is true (or missing), then C<decode> will accept invalid JSON texts that contain unescaped [\x00-\x1f\x22\x5c] characters. C<encode> will not be affected in any way. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. $json->loose->decode(qq|["abc def"]|); =head2 escape_slash $json = $json->escape_slash([$enable]) $enabled = $json->get_escape_slash If C<$enable> is true (or missing), then C<encode> will explicitly escape I<slash> (solidus; C<U+002F>) characters to reduce the risk of XSS (cross site scripting) that may be caused by C<< </script> >> in a JSON text, with the cost of bloating the size of JSON texts. This option may be useful when you embed JSON in HTML, but embedding arbitrary JSON in HTML (by some HTML template toolkit or by string interpolation) is risky in general. You must escape necessary characters in correct order, depending on the context. C<decode> will not be affected in any way. =head2 indent_length $json = $json->indent_length($number_of_spaces) $length = $json->get_indent_length This option is only useful when you also enable C<indent> or C<pretty>. JSON::XS indents with three spaces when you C<encode> (if requested by C<indent> or C<pretty>), and the number cannot be changed. JSON::PP allows you to change/get the number of indent spaces with these mutator/accessor. The default number of spaces is three (the same as JSON::XS), and the acceptable range is from C<0> (no indentation; it'd be better to disable indentation by C<indent(0)>) to C<15>. =head2 sort_by $json = $json->sort_by($code_ref) $json = $json->sort_by($subroutine_name) If you just want to sort keys (names) in JSON objects when you C<encode>, enable C<canonical> option (see above) that allows you to sort object keys alphabetically. If you do need to sort non-alphabetically for whatever reasons, you can give a code reference (or a subroutine name) to C<sort_by>, then the argument will be passed to Perl's C<sort> built-in function. As the sorting is done in the JSON::PP scope, you usually need to prepend C<JSON::PP::> to the subroutine name, and the special variables C<$a> and C<$b> used in the subrontine used by C<sort> function. Example: my %ORDER = (id => 1, class => 2, name => 3); $json->sort_by(sub { ($ORDER{$JSON::PP::a} // 999) <=> ($ORDER{$JSON::PP::b} // 999) or $JSON::PP::a cmp $JSON::PP::b }); print $json->encode([ {name => 'CPAN', id => 1, href => 'http://cpan.org'} ]); # [{"id":1,"name":"CPAN","href":"http://cpan.org"}] Note that C<sort_by> affects all the plain hashes in the data structure. If you need finer control, C<tie> necessary hashes with a module that implements ordered hash (such as L<Hash::Ordered> and L<Tie::IxHash>). C<canonical> and C<sort_by> don't affect the key order in C<tie>d hashes. use Hash::Ordered; tie my %hash, 'Hash::Ordered', (name => 'CPAN', id => 1, href => 'http://cpan.org'); print $json->encode([\%hash]); # [{"name":"CPAN","id":1,"href":"http://cpan.org"}] # order is kept =head1 INCREMENTAL PARSING This section is also taken from JSON::XS. In some cases, there is the need for incremental parsing of JSON texts. While this module always has to keep both JSON text and resulting Perl data structure in memory at one time, it does allow you to parse a JSON stream incrementally. It does so by accumulating text until it has a full JSON object, which it then can decode. This process is similar to using C<decode_prefix> to see if a full JSON object is available, but is much more efficient (and can be implemented with a minimum of method calls). JSON::PP will only attempt to parse the JSON text once it is sure it has enough text to get a decisive result, using a very simple but truly incremental parser. This means that it sometimes won't stop as early as the full parser, for example, it doesn't detect mismatched parentheses. The only thing it guarantees is that it starts decoding as soon as a syntactically valid JSON text has been seen. This means you need to set resource limits (e.g. C<max_size>) to ensure the parser will stop parsing in the presence if syntax errors. The following methods implement this incremental parser. =head2 incr_parse $json->incr_parse( [$string] ) # void context $obj_or_undef = $json->incr_parse( [$string] ) # scalar context @obj_or_empty = $json->incr_parse( [$string] ) # list context This is the central parsing function. It can both append new text and extract objects from the stream accumulated so far (both of these functions are optional). If C<$string> is given, then this string is appended to the already existing JSON fragment stored in the C<$json> object. After that, if the function is called in void context, it will simply return without doing anything further. This can be used to add more text in as many chunks as you want. If the method is called in scalar context, then it will try to extract exactly I<one> JSON object. If that is successful, it will return this object, otherwise it will return C<undef>. If there is a parse error, this method will croak just as C<decode> would do (one can then use C<incr_skip> to skip the erroneous part). This is the most common way of using the method. And finally, in list context, it will try to extract as many objects from the stream as it can find and return them, or the empty list otherwise. For this to work, there must be no separators (other than whitespace) between the JSON objects or arrays, instead they must be concatenated back-to-back. If an error occurs, an exception will be raised as in the scalar context case. Note that in this case, any previously-parsed JSON texts will be lost. Example: Parse some JSON arrays/objects in a given string and return them. my @objs = JSON::PP->new->incr_parse ("[5][7][1,2]"); =head2 incr_text $lvalue_string = $json->incr_text This method returns the currently stored JSON fragment as an lvalue, that is, you can manipulate it. This I<only> works when a preceding call to C<incr_parse> in I<scalar context> successfully returned an object. Under all other circumstances you must not call this function (I mean it. although in simple tests it might actually work, it I<will> fail under real world conditions). As a special exception, you can also call this method before having parsed anything. That means you can only use this function to look at or manipulate text before or after complete JSON objects, not while the parser is in the middle of parsing a JSON object. This function is useful in two cases: a) finding the trailing text after a JSON object or b) parsing multiple JSON objects separated by non-JSON text (such as commas). =head2 incr_skip $json->incr_skip This will reset the state of the incremental parser and will remove the parsed text from the input buffer so far. This is useful after C<incr_parse> died, in which case the input buffer and incremental parser state is left unchanged, to skip the text parsed so far and to reset the parse state. The difference to C<incr_reset> is that only text until the parse error occurred is removed. =head2 incr_reset $json->incr_reset This completely resets the incremental parser, that is, after this call, it will be as if the parser had never parsed anything. This is useful if you want to repeatedly parse JSON objects and want to ignore any trailing data, which means you have to reset the parser after each successful decode. =head1 MAPPING Most of this section is also taken from JSON::XS. This section describes how JSON::PP maps Perl values to JSON values and vice versa. These mappings are designed to "do the right thing" in most circumstances automatically, preserving round-tripping characteristics (what you put in comes out as something equivalent). For the more enlightened: note that in the following descriptions, lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl> refers to the abstract Perl language itself. =head2 JSON -> PERL =over 4 =item object A JSON object becomes a reference to a hash in Perl. No ordering of object keys is preserved (JSON does not preserve object key ordering itself). =item array A JSON array becomes a reference to an array in Perl. =item string A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON are represented by the same codepoints in the Perl string, so no manual decoding is necessary. =item number A JSON number becomes either an integer, numeric (floating point) or string scalar in perl, depending on its range and any fractional parts. On the Perl level, there is no difference between those as Perl handles all the conversion details, but an integer may take slightly less memory and might represent more values exactly than floating point numbers. If the number consists of digits only, JSON::PP will try to represent it as an integer value. If that fails, it will try to represent it as a numeric (floating point) value if that is possible without loss of precision. Otherwise it will preserve the number as a string value (in which case you lose roundtripping ability, as the JSON number will be re-encoded to a JSON string). Numbers containing a fractional or exponential part will always be represented as numeric (floating point) values, possibly at a loss of precision (in which case you might lose perfect roundtripping ability, but the JSON number will still be re-encoded as a JSON number). Note that precision is not accuracy - binary floating point values cannot represent most decimal fractions exactly, and when converting from and to floating point, JSON::PP only guarantees precision up to but not including the least significant bit. When C<allow_bignum> is enabled, big integer values and any numeric values will be converted into L<Math::BigInt> and L<Math::BigFloat> objects respectively, without becoming string scalars or losing precision. =item true, false These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>, respectively. They are overloaded to act almost exactly like the numbers C<1> and C<0>. You can check whether a scalar is a JSON boolean by using the C<JSON::PP::is_bool> function. =item null A JSON null atom becomes C<undef> in Perl. =item shell-style comments (C<< # I<text> >>) As a nonstandard extension to the JSON syntax that is enabled by the C<relaxed> setting, shell-style comments are allowed. They can start anywhere outside strings and go till the end of the line. =item tagged values (C<< (I<tag>)I<value> >>). Another nonstandard extension to the JSON syntax, enabled with the C<allow_tags> setting, are tagged values. In this implementation, the I<tag> must be a perl package/class name encoded as a JSON string, and the I<value> must be a JSON array encoding optional constructor arguments. See L<OBJECT SERIALISATION>, below, for details. =back =head2 PERL -> JSON The mapping from Perl to JSON is slightly more difficult, as Perl is a truly typeless language, so we can only guess which JSON type is meant by a Perl value. =over 4 =item hash references Perl hash references become JSON objects. As there is no inherent ordering in hash keys (or JSON objects), they will usually be encoded in a pseudo-random order. JSON::PP can optionally sort the hash keys (determined by the I<canonical> flag and/or I<sort_by> property), so the same data structure will serialise to the same JSON text (given same settings and version of JSON::PP), but this incurs a runtime overhead and is only rarely useful, e.g. when you want to compare some JSON text against another for equality. =item array references Perl array references become JSON arrays. =item other references Other unblessed references are generally not allowed and will cause an exception to be thrown, except for references to the integers C<0> and C<1>, which get turned into C<false> and C<true> atoms in JSON. You can also use C<JSON::PP::false> and C<JSON::PP::true> to improve readability. to_json [\0, JSON::PP::true] # yields [false,true] =item JSON::PP::true, JSON::PP::false These special values become JSON true and JSON false values, respectively. You can also use C<\1> and C<\0> directly if you want. =item JSON::PP::null This special value becomes JSON null. =item blessed objects Blessed objects are not directly representable in JSON, but C<JSON::PP> allows various ways of handling objects. See L<OBJECT SERIALISATION>, below, for details. =item simple scalars Simple Perl scalars (any scalar that is not a reference) are the most difficult objects to encode: JSON::PP will encode undefined scalars as JSON C<null> values, scalars that have last been used in a string context before encoding as JSON strings, and anything else as number value: # dump as number encode_json [2] # yields [2] encode_json [-3.0e17] # yields [-3e+17] my $value = 5; encode_json [$value] # yields [5] # used as string, so dump as string print $value; encode_json [$value] # yields ["5"] # undef becomes null encode_json [undef] # yields [null] You can force the type to be a JSON string by stringifying it: my $x = 3.1; # some variable containing a number "$x"; # stringified $x .= ""; # another, more awkward way to stringify print $x; # perl does it for you, too, quite often # (but for older perls) You can force the type to be a JSON number by numifying it: my $x = "3"; # some variable containing a string $x += 0; # numify it, ensuring it will be dumped as a number $x *= 1; # same thing, the choice is yours. You can not currently force the type in other, less obscure, ways. Since version 2.91_01, JSON::PP uses a different number detection logic that converts a scalar that is possible to turn into a number safely. The new logic is slightly faster, and tends to help people who use older perl or who want to encode complicated data structure. However, this may results in a different JSON text from the one JSON::XS encodes (and thus may break tests that compare entire JSON texts). If you do need the previous behavior for compatibility or for finer control, set PERL_JSON_PP_USE_B environmental variable to true before you C<use> JSON::PP (or JSON.pm). Note that numerical precision has the same meaning as under Perl (so binary to decimal conversion follows the same rules as in Perl, which can differ to other languages). Also, your perl interpreter might expose extensions to the floating point numbers of your platform, such as infinities or NaN's - these cannot be represented in JSON, and it is an error to pass those in. JSON::PP (and JSON::XS) trusts what you pass to C<encode> method (or C<encode_json> function) is a clean, validated data structure with values that can be represented as valid JSON values only, because it's not from an external data source (as opposed to JSON texts you pass to C<decode> or C<decode_json>, which JSON::PP considers tainted and doesn't trust). As JSON::PP doesn't know exactly what you and consumers of your JSON texts want the unexpected values to be (you may want to convert them into null, or to stringify them with or without normalisation (string representation of infinities/NaN may vary depending on platforms), or to croak without conversion), you're advised to do what you and your consumers need before you encode, and also not to numify values that may start with values that look like a number (including infinities/NaN), without validating. =back =head2 OBJECT SERIALISATION As JSON cannot directly represent Perl objects, you have to choose between a pure JSON representation (without the ability to deserialise the object automatically again), and a nonstandard extension to the JSON syntax, tagged values. =head3 SERIALISATION What happens when C<JSON::PP> encounters a Perl object depends on the C<allow_blessed>, C<convert_blessed>, C<allow_tags> and C<allow_bignum> settings, which are used in this order: =over 4 =item 1. C<allow_tags> is enabled and the object has a C<FREEZE> method. In this case, C<JSON::PP> creates a tagged JSON value, using a nonstandard extension to the JSON syntax. This works by invoking the C<FREEZE> method on the object, with the first argument being the object to serialise, and the second argument being the constant string C<JSON> to distinguish it from other serialisers. The C<FREEZE> method can return any number of values (i.e. zero or more). These values and the paclkage/classname of the object will then be encoded as a tagged JSON value in the following format: ("classname")[FREEZE return values...] e.g.: ("URI")["http://www.google.com/"] ("MyDate")[2013,10,29] ("ImageData::JPEG")["Z3...VlCg=="] For example, the hypothetical C<My::Object> C<FREEZE> method might use the objects C<type> and C<id> members to encode the object: sub My::Object::FREEZE { my ($self, $serialiser) = @_; ($self->{type}, $self->{id}) } =item 2. C<convert_blessed> is enabled and the object has a C<TO_JSON> method. In this case, the C<TO_JSON> method of the object is invoked in scalar context. It must return a single scalar that can be directly encoded into JSON. This scalar replaces the object in the JSON text. For example, the following C<TO_JSON> method will convert all L<URI> objects to JSON strings when serialised. The fact that these values originally were L<URI> objects is lost. sub URI::TO_JSON { my ($uri) = @_; $uri->as_string } =item 3. C<allow_bignum> is enabled and the object is a C<Math::BigInt> or C<Math::BigFloat>. The object will be serialised as a JSON number value. =item 4. C<allow_blessed> is enabled. The object will be serialised as a JSON null value. =item 5. none of the above If none of the settings are enabled or the respective methods are missing, C<JSON::PP> throws an exception. =back =head3 DESERIALISATION For deserialisation there are only two cases to consider: either nonstandard tagging was used, in which case C<allow_tags> decides, or objects cannot be automatically be deserialised, in which case you can use postprocessing or the C<filter_json_object> or C<filter_json_single_key_object> callbacks to get some real objects our of your JSON. This section only considers the tagged value case: a tagged JSON object is encountered during decoding and C<allow_tags> is disabled, a parse error will result (as if tagged values were not part of the grammar). If C<allow_tags> is enabled, C<JSON::PP> will look up the C<THAW> method of the package/classname used during serialisation (it will not attempt to load the package as a Perl module). If there is no such method, the decoding will fail with an error. Otherwise, the C<THAW> method is invoked with the classname as first argument, the constant string C<JSON> as second argument, and all the values from the JSON array (the values originally returned by the C<FREEZE> method) as remaining arguments. The method must then return the object. While technically you can return any Perl scalar, you might have to enable the C<allow_nonref> setting to make that work in all cases, so better return an actual blessed reference. As an example, let's implement a C<THAW> function that regenerates the C<My::Object> from the C<FREEZE> example earlier: sub My::Object::THAW { my ($class, $serialiser, $type, $id) = @_; $class->new (type => $type, id => $id) } =head1 ENCODING/CODESET FLAG NOTES This section is taken from JSON::XS. The interested reader might have seen a number of flags that signify encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be some confusion on what these do, so here is a short comparison: C<utf8> controls whether the JSON text created by C<encode> (and expected by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only control whether C<encode> escapes character values outside their respective codeset range. Neither of these flags conflict with each other, although some combinations make less sense than others. Care has been taken to make all flags symmetrical with respect to C<encode> and C<decode>, that is, texts encoded with any combination of these flag values will be correctly decoded when the same flags are used - in general, if you use different flag settings while encoding vs. when decoding you likely have a bug somewhere. Below comes a verbose discussion of these flags. Note that a "codeset" is simply an abstract set of character-codepoint pairs, while an encoding takes those codepoint numbers and I<encodes> them, in our case into octets. Unicode is (among other things) a codeset, UTF-8 is an encoding, and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at the same time, which can be confusing. =over 4 =item C<utf8> flag disabled When C<utf8> is disabled (the default), then C<encode>/C<decode> generate and expect Unicode strings, that is, characters with high ordinal Unicode values (> 255) will be encoded as such characters, and likewise such characters are decoded as-is, no changes to them will be done, except "(re-)interpreting" them as Unicode codepoints or Unicode characters, respectively (to Perl, these are the same thing in strings unless you do funny/weird/dumb stuff). This is useful when you want to do the encoding yourself (e.g. when you want to have UTF-16 encoded JSON texts) or when some other layer does the encoding for you (for example, when printing to a terminal using a filehandle that transparently encodes to UTF-8 you certainly do NOT want to UTF-8 encode your data first and have Perl encode it another time). =item C<utf8> flag enabled If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all characters using the corresponding UTF-8 multi-byte sequence, and will expect your input strings to be encoded as UTF-8, that is, no "character" of the input string must have any value > 255, as UTF-8 does not allow that. The C<utf8> flag therefore switches between two modes: disabled means you will get a Unicode string in Perl, enabled means you get an UTF-8 encoded octet/binary string in Perl. =item C<latin1> or C<ascii> flags enabled With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining characters as specified by the C<utf8> flag. If C<utf8> is disabled, then the result is also correctly encoded in those character sets (as both are proper subsets of Unicode, meaning that a Unicode string with all character values < 256 is the same thing as a ISO-8859-1 string, and a Unicode string with all character values < 128 is the same thing as an ASCII string in Perl). If C<utf8> is enabled, you still get a correct UTF-8-encoded string, regardless of these flags, just some more characters will be escaped using C<\uXXXX> then before. Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8 encoding, while ASCII-encoded strings are. That is because the ISO-8859-1 encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being a subset of Unicode), while ASCII is. Surprisingly, C<decode> will ignore these flags and so treat all input values as governed by the C<utf8> flag. If it is disabled, this allows you to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings. So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag - they only govern when the JSON output engine escapes a character or not. The main use for C<latin1> is to relatively efficiently store binary data as JSON, at the expense of breaking compatibility with most JSON decoders. The main use for C<ascii> is to force the output to not contain characters with values > 127, which means you can interpret the resulting string as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and 8-bit-encoding, and still get the same data structure back. This is useful when your channel for JSON transfer is not 8-bit clean or the encoding might be mangled in between (e.g. in mail), and works because ASCII is a proper subset of most 8-bit and multibyte encodings in use in the world. =back =head1 BUGS Please report bugs on a specific behavior of this module to RT or GitHub issues (preferred): L<https://github.com/makamaka/JSON-PP/issues> L<https://rt.cpan.org/Public/Dist/Display.html?Queue=JSON-PP> As for new features and requests to change common behaviors, please ask the author of JSON::XS (Marc Lehmann, E<lt>schmorp[at]schmorp.deE<gt>) first, by email (important!), to keep compatibility among JSON.pm backends. Generally speaking, if you need something special for you, you are advised to create a new module, maybe based on L<JSON::Tiny>, which is smaller and written in a much cleaner way than this module. =head1 SEE ALSO The F<json_pp> command line utility for quick experiments. L<JSON::XS>, L<Cpanel::JSON::XS>, and L<JSON::Tiny> for faster alternatives. L<JSON> and L<JSON::MaybeXS> for easy migration. L<JSON::backportPP::Compat5005> and L<JSON::backportPP::Compat5006> for older perl users. RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>) RFC7159 (L<http://www.ietf.org/rfc/rfc7159.txt>) RFC8259 (L<http://www.ietf.org/rfc/rfc8259.txt>) =head1 AUTHOR Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> =head1 CURRENT MAINTAINER Kenichi Ishigaki, E<lt>ishigaki[at]cpan.orgE<gt> =head1 COPYRIGHT AND LICENSE Copyright 2007-2016 by Makamaka Hannyaharamitu Most of the documentation is taken from JSON::XS by Marc Lehmann This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! 6! �� � JSON/backportPP/Compat5005.pmnu �[��� package # This is JSON::backportPP JSON::backportPP5005; use 5.005; use strict; my @properties; $JSON::PP5005::VERSION = '1.10'; BEGIN { sub utf8::is_utf8 { 0; # It is considered that UTF8 flag off for Perl 5.005. } sub utf8::upgrade { } sub utf8::downgrade { 1; # must always return true. } sub utf8::encode { } sub utf8::decode { } *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; # missing in B module. sub B::SVp_IOK () { 0x01000000; } sub B::SVp_NOK () { 0x02000000; } sub B::SVp_POK () { 0x04000000; } $INC{'bytes.pm'} = 1; # dummy } sub _encode_ascii { join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) ); } sub _encode_latin1 { join('', map { chr($_) } unpack('C*', $_[0]) ); } sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode my $bit = unpack('B32', pack('N', $uni)); if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) { my ($w, $x, $y, $z) = ($1, $2, $3, $4); return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z)); } else { Carp::croak("Invalid surrogate pair"); } } sub _decode_unicode { my ($u) = @_; my ($utf8bit); if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff return pack( 'H2', $1 ); } my $bit = unpack("B*", pack("H*", $u)); if ( $bit =~ /^00000(.....)(......)$/ ) { $utf8bit = sprintf('110%s10%s', $1, $2); } elsif ( $bit =~ /^(....)(......)(......)$/ ) { $utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3); } else { Carp::croak("Invalid escaped unicode"); } return pack('B*', $utf8bit); } sub JSON::PP::incr_text { $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; if ( $_[0]->{_incr_parser}->{incr_parsing} ) { Carp::croak("incr_text can not be called when the incremental parser already started parsing"); } $_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 ); $_[0]->{_incr_parser}->{incr_text}; } 1; __END__ =pod =head1 NAME JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005 =head1 DESCRIPTION JSON::PP calls internally. =head1 AUTHOR Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> =head1 COPYRIGHT AND LICENSE Copyright 2007-2012 by Makamaka Hannyaharamitu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! [ ��Q Q JSON/backportPP/Boolean.pmnu �[��� package # This is JSON::backportPP JSON::PP::Boolean; use strict; require overload; local $^W; overload::import('overload', "0+" => sub { ${$_[0]} }, "++" => sub { $_[0] = ${$_[0]} + 1 }, "--" => sub { $_[0] = ${$_[0]} - 1 }, fallback => 1, ); $JSON::backportPP::Boolean::VERSION = '4.07'; 1; __END__ =head1 NAME JSON::PP::Boolean - dummy module providing JSON::PP::Boolean =head1 SYNOPSIS # do not "use" yourself =head1 DESCRIPTION This module exists only to provide overload resolution for Storable and similar modules. See L<JSON::PP> for more info about this class. =head1 AUTHOR This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de> =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! +�d� � JSON/backportPP/Compat5006.pmnu �[��� package # This is JSON::backportPP JSON::backportPP56; use 5.006; use strict; my @properties; $JSON::PP56::VERSION = '1.08'; BEGIN { sub utf8::is_utf8 { my $len = length $_[0]; # char length { use bytes; # byte length; return $len != length $_[0]; # if !=, UTF8-flagged on. } } sub utf8::upgrade { ; # noop; } sub utf8::downgrade ($;$) { return 1 unless ( utf8::is_utf8( $_[0] ) ); if ( _is_valid_utf8( $_[0] ) ) { my $downgrade; for my $c ( unpack( "U*", $_[0] ) ) { if ( $c < 256 ) { $downgrade .= pack("C", $c); } else { $downgrade .= pack("U", $c); } } $_[0] = $downgrade; return 1; } else { Carp::croak("Wide character in subroutine entry") unless ( $_[1] ); 0; } } sub utf8::encode ($) { # UTF8 flag off if ( utf8::is_utf8( $_[0] ) ) { $_[0] = pack( "C*", unpack( "C*", $_[0] ) ); } else { $_[0] = pack( "U*", unpack( "C*", $_[0] ) ); $_[0] = pack( "C*", unpack( "C*", $_[0] ) ); } } sub utf8::decode ($) { # UTF8 flag on if ( _is_valid_utf8( $_[0] ) ) { utf8::downgrade( $_[0] ); $_[0] = pack( "U*", unpack( "U*", $_[0] ) ); } } *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; *JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates; *JSON::PP::JSON_PP_decode_unicode = \&JSON::PP::_decode_unicode; unless ( defined &B::SVp_NOK ) { # missing in B module. eval q{ sub B::SVp_NOK () { 0x02000000; } }; } } sub _encode_ascii { join('', map { $_ <= 127 ? chr($_) : $_ <= 65535 ? sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_)); } _unpack_emu($_[0]) ); } sub _encode_latin1 { join('', map { $_ <= 255 ? chr($_) : $_ <= 65535 ? sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_)); } _unpack_emu($_[0]) ); } sub _unpack_emu { # for Perl 5.6 unpack warnings return !utf8::is_utf8($_[0]) ? unpack('C*', $_[0]) : _is_valid_utf8($_[0]) ? unpack('U*', $_[0]) : unpack('C*', $_[0]); } sub _is_valid_utf8 { my $str = $_[0]; my $is_utf8; while ($str =~ /(?: ( [\x00-\x7F] |[\xC2-\xDF][\x80-\xBF] |[\xE0][\xA0-\xBF][\x80-\xBF] |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] |[\xED][\x80-\x9F][\x80-\xBF] |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] ) | (.) )/xg) { if (defined $1) { $is_utf8 = 1 if (!defined $is_utf8); } else { $is_utf8 = 0 if (!defined $is_utf8); if ($is_utf8) { # eventually, not utf8 return; } } } return $is_utf8; } 1; __END__ =pod =head1 NAME JSON::PP56 - Helper module in using JSON::PP in Perl 5.6 =head1 DESCRIPTION JSON::PP calls internally. =head1 AUTHOR Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> =head1 COPYRIGHT AND LICENSE Copyright 2007-2012 by Makamaka Hannyaharamitu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! �09��� �� Git.pmnu �[��� =head1 NAME Git - Perl interface to the Git version control system =cut package Git; use 5.008; use strict; use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); BEGIN { our ($VERSION, @ISA, @EXPORT, @EXPORT_OK); # Totally unstable API. $VERSION = '0.01'; =head1 SYNOPSIS use Git; my $version = Git::command_oneline('version'); git_cmd_try { Git::command_noisy('update-server-info') } '%s failed w/ code %d'; my $repo = Git->repository (Directory => '/srv/git/cogito.git'); my @revs = $repo->command('rev-list', '--since=last monday', '--all'); my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all'); my $lastrev = <$fh>; chomp $lastrev; $repo->command_close_pipe($fh, $c); my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ], STDERR => 0 ); my $sha1 = $repo->hash_and_insert_object('file.txt'); my $tempfile = tempfile(); my $size = $repo->cat_blob($sha1, $tempfile); =cut require Exporter; @ISA = qw(Exporter); @EXPORT = qw(git_cmd_try); # Methods which can be called as standalone functions as well: @EXPORT_OK = qw(command command_oneline command_noisy command_output_pipe command_input_pipe command_close_pipe command_bidi_pipe command_close_bidi_pipe version exec_path html_path hash_object git_cmd_try remote_refs prompt get_tz_offset get_record credential credential_read credential_write temp_acquire temp_is_locked temp_release temp_reset temp_path unquote_path); =head1 DESCRIPTION This module provides Perl scripts easy way to interface the Git version control system. The modules have an easy and well-tested way to call arbitrary Git commands; in the future, the interface will also provide specialized methods for doing easily operations which are not totally trivial to do over the generic command interface. While some commands can be executed outside of any context (e.g. 'version' or 'init'), most operations require a repository context, which in practice means getting an instance of the Git object using the repository() constructor. (In the future, we will also get a new_repository() constructor.) All commands called as methods of the object are then executed in the context of the repository. Part of the "repository state" is also information about path to the attached working copy (unless you work with a bare repository). You can also navigate inside of the working copy using the C<wc_chdir()> method. (Note that the repository object is self-contained and will not change working directory of your process.) TODO: In the future, we might also do my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master'); $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/'); my @refs = $remoterepo->refs(); Currently, the module merely wraps calls to external Git tools. In the future, it will provide a much faster way to interact with Git by linking directly to libgit. This should be completely opaque to the user, though (performance increase notwithstanding). =cut sub carp { require Carp; goto &Carp::carp } sub croak { require Carp; goto &Carp::croak } use Git::LoadCPAN::Error qw(:try); } =head1 CONSTRUCTORS =over 4 =item repository ( OPTIONS ) =item repository ( DIRECTORY ) =item repository () Construct a new repository object. C<OPTIONS> are passed in a hash like fashion, using key and value pairs. Possible options are: B<Repository> - Path to the Git repository. B<WorkingCopy> - Path to the associated working copy; not strictly required as many commands will happily crunch on a bare repository. B<WorkingSubdir> - Subdirectory in the working copy to work inside. Just left undefined if you do not want to limit the scope of operations. B<Directory> - Path to the Git working directory in its usual setup. The C<.git> directory is searched in the directory and all the parent directories; if found, C<WorkingCopy> is set to the directory containing it and C<Repository> to the C<.git> directory itself. If no C<.git> directory was found, the C<Directory> is assumed to be a bare repository, C<Repository> is set to point at it and C<WorkingCopy> is left undefined. If the C<$GIT_DIR> environment variable is set, things behave as expected as well. You should not use both C<Directory> and either of C<Repository> and C<WorkingCopy> - the results of that are undefined. Alternatively, a directory path may be passed as a single scalar argument to the constructor; it is equivalent to setting only the C<Directory> option field. Calling the constructor with no options whatsoever is equivalent to calling it with C<< Directory => '.' >>. In general, if you are building a standard porcelain command, simply doing C<< Git->repository() >> should do the right thing and setup the object to reflect exactly where the user is right now. =cut sub repository { my $class = shift; my @args = @_; my %opts = (); my $self; if (defined $args[0]) { if ($#args % 2 != 1) { # Not a hash. $#args == 0 or throw Error::Simple("bad usage"); %opts = ( Directory => $args[0] ); } else { %opts = @args; } } if (not defined $opts{Repository} and not defined $opts{WorkingCopy} and not defined $opts{Directory}) { $opts{Directory} = '.'; } if (defined $opts{Directory}) { -d $opts{Directory} or throw Error::Simple("Directory not found: $opts{Directory} $!"); my $search = Git->repository(WorkingCopy => $opts{Directory}); my $dir; try { $dir = $search->command_oneline(['rev-parse', '--git-dir'], STDERR => 0); } catch Git::Error::Command with { $dir = undef; }; require Cwd; if ($dir) { require File::Spec; File::Spec->file_name_is_absolute($dir) or $dir = $opts{Directory} . '/' . $dir; $opts{Repository} = Cwd::abs_path($dir); # If --git-dir went ok, this shouldn't die either. my $prefix = $search->command_oneline('rev-parse', '--show-prefix'); $dir = Cwd::abs_path($opts{Directory}) . '/'; if ($prefix) { if (substr($dir, -length($prefix)) ne $prefix) { throw Error::Simple("rev-parse confused me - $dir does not have trailing $prefix"); } substr($dir, -length($prefix)) = ''; } $opts{WorkingCopy} = $dir; $opts{WorkingSubdir} = $prefix; } else { # A bare repository? Let's see... $dir = $opts{Directory}; unless (-d "$dir/refs" and -d "$dir/objects" and -e "$dir/HEAD") { # Mimic git-rev-parse --git-dir error message: throw Error::Simple("fatal: Not a git repository: $dir"); } my $search = Git->repository(Repository => $dir); try { $search->command('symbolic-ref', 'HEAD'); } catch Git::Error::Command with { # Mimic git-rev-parse --git-dir error message: throw Error::Simple("fatal: Not a git repository: $dir"); } $opts{Repository} = Cwd::abs_path($dir); } delete $opts{Directory}; } $self = { opts => \%opts }; bless $self, $class; } =back =head1 METHODS =over 4 =item command ( COMMAND [, ARGUMENTS... ] ) =item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) Execute the given Git C<COMMAND> (specify it without the 'git-' prefix), optionally with the specified extra C<ARGUMENTS>. The second more elaborate form can be used if you want to further adjust the command execution. Currently, only one option is supported: B<STDERR> - How to deal with the command's error output. By default (C<undef>) it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause it to be thrown away. If you want to process it, you can get it in a filehandle you specify, but you must be extremely careful; if the error output is not very short and you want to read it in the same process as where you called C<command()>, you are set up for a nice deadlock! The method can be called without any instance or on a specified Git repository (in that case the command will be run in the repository context). In scalar context, it returns all the command output in a single string (verbatim). In array context, it returns an array containing lines printed to the command's stdout (without trailing newlines). In both cases, the command's stdin and stderr are the same as the caller's. =cut sub command { my ($fh, $ctx) = command_output_pipe(@_); if (not defined wantarray) { # Nothing to pepper the possible exception with. _cmd_close($ctx, $fh); } elsif (not wantarray) { local $/; my $text = <$fh>; try { _cmd_close($ctx, $fh); } catch Git::Error::Command with { # Pepper with the output: my $E = shift; $E->{'-outputref'} = \$text; throw $E; }; return $text; } else { my @lines = <$fh>; defined and chomp for @lines; try { _cmd_close($ctx, $fh); } catch Git::Error::Command with { my $E = shift; $E->{'-outputref'} = \@lines; throw $E; }; return @lines; } } =item command_oneline ( COMMAND [, ARGUMENTS... ] ) =item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) Execute the given C<COMMAND> in the same way as command() does but always return a scalar string containing the first line of the command's standard output. =cut sub command_oneline { my ($fh, $ctx) = command_output_pipe(@_); my $line = <$fh>; defined $line and chomp $line; try { _cmd_close($ctx, $fh); } catch Git::Error::Command with { # Pepper with the output: my $E = shift; $E->{'-outputref'} = \$line; throw $E; }; return $line; } =item command_output_pipe ( COMMAND [, ARGUMENTS... ] ) =item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) Execute the given C<COMMAND> in the same way as command() does but return a pipe filehandle from which the command output can be read. The function can return C<($pipe, $ctx)> in array context. See C<command_close_pipe()> for details. =cut sub command_output_pipe { _command_common_pipe('-|', @_); } =item command_input_pipe ( COMMAND [, ARGUMENTS... ] ) =item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) Execute the given C<COMMAND> in the same way as command_output_pipe() does but return an input pipe filehandle instead; the command output is not captured. The function can return C<($pipe, $ctx)> in array context. See C<command_close_pipe()> for details. =cut sub command_input_pipe { _command_common_pipe('|-', @_); } =item command_close_pipe ( PIPE [, CTX ] ) Close the C<PIPE> as returned from C<command_*_pipe()>, checking whether the command finished successfully. The optional C<CTX> argument is required if you want to see the command name in the error message, and it is the second value returned by C<command_*_pipe()> when called in array context. The call idiom is: my ($fh, $ctx) = $r->command_output_pipe('status'); while (<$fh>) { ... } $r->command_close_pipe($fh, $ctx); Note that you should not rely on whatever actually is in C<CTX>; currently it is simply the command name but in future the context might have more complicated structure. =cut sub command_close_pipe { my ($self, $fh, $ctx) = _maybe_self(@_); $ctx ||= '<unknown>'; _cmd_close($ctx, $fh); } =item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] ) Execute the given C<COMMAND> in the same way as command_output_pipe() does but return both an input pipe filehandle and an output pipe filehandle. The function will return C<($pid, $pipe_in, $pipe_out, $ctx)>. See C<command_close_bidi_pipe()> for details. =cut sub command_bidi_pipe { my ($pid, $in, $out); my ($self) = _maybe_self(@_); local %ENV = %ENV; my $cwd_save = undef; if ($self) { shift; require Cwd; $cwd_save = Cwd::getcwd(); _setup_git_cmd_env($self); } require IPC::Open2; $pid = IPC::Open2::open2($in, $out, 'git', @_); chdir($cwd_save) if $cwd_save; return ($pid, $in, $out, join(' ', @_)); } =item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] ) Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>, checking whether the command finished successfully. The optional C<CTX> argument is required if you want to see the command name in the error message, and it is the fourth value returned by C<command_bidi_pipe()>. The call idiom is: my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check'); print $out "000000000\n"; while (<$in>) { ... } $r->command_close_bidi_pipe($pid, $in, $out, $ctx); Note that you should not rely on whatever actually is in C<CTX>; currently it is simply the command name but in future the context might have more complicated structure. C<PIPE_IN> and C<PIPE_OUT> may be C<undef> if they have been closed prior to calling this function. This may be useful in a query-response type of commands where caller first writes a query and later reads response, eg: my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check'); print $out "000000000\n"; close $out; while (<$in>) { ... } $r->command_close_bidi_pipe($pid, $in, undef, $ctx); This idiom may prevent potential dead locks caused by data sent to the output pipe not being flushed and thus not reaching the executed command. =cut sub command_close_bidi_pipe { local $?; my ($self, $pid, $in, $out, $ctx) = _maybe_self(@_); _cmd_close($ctx, (grep { defined } ($in, $out))); waitpid $pid, 0; if ($? >> 8) { throw Git::Error::Command($ctx, $? >>8); } } =item command_noisy ( COMMAND [, ARGUMENTS... ] ) Execute the given C<COMMAND> in the same way as command() does but do not capture the command output - the standard output is not redirected and goes to the standard output of the caller application. While the method is called command_noisy(), you might want to as well use it for the most silent Git commands which you know will never pollute your stdout but you want to avoid the overhead of the pipe setup when calling them. The function returns only after the command has finished running. =cut sub command_noisy { my ($self, $cmd, @args) = _maybe_self(@_); _check_valid_cmd($cmd); my $pid = fork; if (not defined $pid) { throw Error::Simple("fork failed: $!"); } elsif ($pid == 0) { _cmd_exec($self, $cmd, @args); } if (waitpid($pid, 0) > 0 and $?>>8 != 0) { throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8); } } =item version () Return the Git version in use. =cut sub version { my $verstr = command_oneline('--version'); $verstr =~ s/^git version //; $verstr; } =item exec_path () Return path to the Git sub-command executables (the same as C<git --exec-path>). Useful mostly only internally. =cut sub exec_path { command_oneline('--exec-path') } =item html_path () Return path to the Git html documentation (the same as C<git --html-path>). Useful mostly only internally. =cut sub html_path { command_oneline('--html-path') } =item get_tz_offset ( TIME ) Return the time zone offset from GMT in the form +/-HHMM where HH is the number of hours from GMT and MM is the number of minutes. This is the equivalent of what strftime("%z", ...) would provide on a GNU platform. If TIME is not supplied, the current local time is used. =cut sub get_tz_offset { # some systems don't handle or mishandle %z, so be creative. my $t = shift || time; my @t = localtime($t); $t[5] += 1900; require Time::Local; my $gm = Time::Local::timegm(@t); my $sign = qw( + + - )[ $gm <=> $t ]; return sprintf("%s%02d%02d", $sign, (gmtime(abs($t - $gm)))[2,1]); } =item get_record ( FILEHANDLE, INPUT_RECORD_SEPARATOR ) Read one record from FILEHANDLE delimited by INPUT_RECORD_SEPARATOR, removing any trailing INPUT_RECORD_SEPARATOR. =cut sub get_record { my ($fh, $rs) = @_; local $/ = $rs; my $rec = <$fh>; chomp $rec if defined $rec; $rec; } =item prompt ( PROMPT , ISPASSWORD ) Query user C<PROMPT> and return answer from user. Honours GIT_ASKPASS and SSH_ASKPASS environment variables for querying the user. If no *_ASKPASS variable is set or an error occurred, the terminal is tried as a fallback. If C<ISPASSWORD> is set and true, the terminal disables echo. =cut sub prompt { my ($prompt, $isPassword) = @_; my $ret; if (exists $ENV{'GIT_ASKPASS'}) { $ret = _prompt($ENV{'GIT_ASKPASS'}, $prompt); } if (!defined $ret && exists $ENV{'SSH_ASKPASS'}) { $ret = _prompt($ENV{'SSH_ASKPASS'}, $prompt); } if (!defined $ret) { print STDERR $prompt; STDERR->flush; if (defined $isPassword && $isPassword) { require Term::ReadKey; Term::ReadKey::ReadMode('noecho'); $ret = ''; while (defined(my $key = Term::ReadKey::ReadKey(0))) { last if $key =~ /[\012\015]/; # \n\r $ret .= $key; } Term::ReadKey::ReadMode('restore'); print STDERR "\n"; STDERR->flush; } else { chomp($ret = <STDIN>); } } return $ret; } sub _prompt { my ($askpass, $prompt) = @_; return unless length $askpass; $prompt =~ s/\n/ /g; my $ret; open my $fh, "-|", $askpass, $prompt or return; $ret = <$fh>; $ret =~ s/[\015\012]//g; # strip \r\n, chomp does not work on all systems (i.e. windows) as expected close ($fh); return $ret; } =item repo_path () Return path to the git repository. Must be called on a repository instance. =cut sub repo_path { $_[0]->{opts}->{Repository} } =item wc_path () Return path to the working copy. Must be called on a repository instance. =cut sub wc_path { $_[0]->{opts}->{WorkingCopy} } =item wc_subdir () Return path to the subdirectory inside of a working copy. Must be called on a repository instance. =cut sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' } =item wc_chdir ( SUBDIR ) Change the working copy subdirectory to work within. The C<SUBDIR> is relative to the working copy root directory (not the current subdirectory). Must be called on a repository instance attached to a working copy and the directory must exist. =cut sub wc_chdir { my ($self, $subdir) = @_; $self->wc_path() or throw Error::Simple("bare repository"); -d $self->wc_path().'/'.$subdir or throw Error::Simple("subdir not found: $subdir $!"); # Of course we will not "hold" the subdirectory so anyone # can delete it now and we will never know. But at least we tried. $self->{opts}->{WorkingSubdir} = $subdir; } =item config ( VARIABLE ) Retrieve the configuration C<VARIABLE> in the same manner as C<config> does. In scalar context requires the variable to be set only one time (exception is thrown otherwise), in array context returns allows the variable to be set multiple times and returns all the values. =cut sub config { return _config_common({}, @_); } =item config_bool ( VARIABLE ) Retrieve the bool configuration C<VARIABLE>. The return value is usable as a boolean in perl (and C<undef> if it's not defined, of course). =cut sub config_bool { my $val = scalar _config_common({'kind' => '--bool'}, @_); # Do not rewrite this as return (defined $val && $val eq 'true') # as some callers do care what kind of falsehood they receive. if (!defined $val) { return undef; } else { return $val eq 'true'; } } =item config_path ( VARIABLE ) Retrieve the path configuration C<VARIABLE>. The return value is an expanded path or C<undef> if it's not defined. =cut sub config_path { return _config_common({'kind' => '--path'}, @_); } =item config_int ( VARIABLE ) Retrieve the integer configuration C<VARIABLE>. The return value is simple decimal number. An optional value suffix of 'k', 'm', or 'g' in the config file will cause the value to be multiplied by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output. It would return C<undef> if configuration variable is not defined. =cut sub config_int { return scalar _config_common({'kind' => '--int'}, @_); } =item config_regexp ( RE ) Retrieve the list of configuration key names matching the regular expression C<RE>. The return value is a list of strings matching this regex. =cut sub config_regexp { my ($self, $regex) = _maybe_self(@_); try { my @cmd = ('config', '--name-only', '--get-regexp', $regex); unshift @cmd, $self if $self; my @matches = command(@cmd); return @matches; } catch Git::Error::Command with { my $E = shift; if ($E->value() == 1) { my @matches = (); return @matches; } else { throw $E; } }; } # Common subroutine to implement bulk of what the config* family of methods # do. This currently wraps command('config') so it is not so fast. sub _config_common { my ($opts) = shift @_; my ($self, $var) = _maybe_self(@_); try { my @cmd = ('config', $opts->{'kind'} ? $opts->{'kind'} : ()); unshift @cmd, $self if $self; if (wantarray) { return command(@cmd, '--get-all', $var); } else { return command_oneline(@cmd, '--get', $var); } } catch Git::Error::Command with { my $E = shift; if ($E->value() == 1) { # Key not found. return; } else { throw $E; } }; } =item get_colorbool ( NAME ) Finds if color should be used for NAMEd operation from the configuration, and returns boolean (true for "use color", false for "do not use color"). =cut sub get_colorbool { my ($self, $var) = @_; my $stdout_to_tty = (-t STDOUT) ? "true" : "false"; my $use_color = $self->command_oneline('config', '--get-colorbool', $var, $stdout_to_tty); return ($use_color eq 'true'); } =item get_color ( SLOT, COLOR ) Finds color for SLOT from the configuration, while defaulting to COLOR, and returns the ANSI color escape sequence: print $repo->get_color("color.interactive.prompt", "underline blue white"); print "some text"; print $repo->get_color("", "normal"); =cut sub get_color { my ($self, $slot, $default) = @_; my $color = $self->command_oneline('config', '--get-color', $slot, $default); if (!defined $color) { $color = ""; } return $color; } =item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] ) This function returns a hashref of refs stored in a given remote repository. The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry contains the tag object while a C<refname^{}> entry gives the tagged objects. C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote> argument; either a URL or a remote name (if called on a repository instance). C<GROUPS> is an optional arrayref that can contain 'tags' to return all the tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array of strings containing a shell-like glob to further limit the refs returned in the hash; the meaning is again the same as the appropriate C<git-ls-remote> argument. This function may or may not be called on a repository instance. In the former case, remote names as defined in the repository are recognized as repository specifiers. =cut sub remote_refs { my ($self, $repo, $groups, $refglobs) = _maybe_self(@_); my @args; if (ref $groups eq 'ARRAY') { foreach (@$groups) { if ($_ eq 'heads') { push (@args, '--heads'); } elsif ($_ eq 'tags') { push (@args, '--tags'); } else { # Ignore unknown groups for future # compatibility } } } push (@args, $repo); if (ref $refglobs eq 'ARRAY') { push (@args, @$refglobs); } my @self = $self ? ($self) : (); # Ultra trickery my ($fh, $ctx) = Git::command_output_pipe(@self, 'ls-remote', @args); my %refs; while (<$fh>) { chomp; my ($hash, $ref) = split(/\t/, $_, 2); $refs{$ref} = $hash; } Git::command_close_pipe(@self, $fh, $ctx); return \%refs; } =item ident ( TYPE | IDENTSTR ) =item ident_person ( TYPE | IDENTSTR | IDENTARRAY ) This suite of functions retrieves and parses ident information, as stored in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus C<TYPE> can be either I<author> or I<committer>; case is insignificant). The C<ident> method retrieves the ident information from C<git var> and either returns it as a scalar string or as an array with the fields parsed. Alternatively, it can take a prepared ident string (e.g. from the commit object) and just parse it. C<ident_person> returns the person part of the ident - name and email; it can take the same arguments as C<ident> or the array returned by C<ident>. The synopsis is like: my ($name, $email, $time_tz) = ident('author'); "$name <$email>" eq ident_person('author'); "$name <$email>" eq ident_person($name); $time_tz =~ /^\d+ [+-]\d{4}$/; =cut sub ident { my ($self, $type) = _maybe_self(@_); my $identstr; if (lc $type eq lc 'committer' or lc $type eq lc 'author') { my @cmd = ('var', 'GIT_'.uc($type).'_IDENT'); unshift @cmd, $self if $self; $identstr = command_oneline(@cmd); } else { $identstr = $type; } if (wantarray) { return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/; } else { return $identstr; } } sub ident_person { my ($self, @ident) = _maybe_self(@_); $#ident == 0 and @ident = $self ? $self->ident($ident[0]) : ident($ident[0]); return "$ident[0] <$ident[1]>"; } =item hash_object ( TYPE, FILENAME ) Compute the SHA1 object id of the given C<FILENAME> considering it is of the C<TYPE> object type (C<blob>, C<commit>, C<tree>). The method can be called without any instance or on a specified Git repository, it makes zero difference. The function returns the SHA1 hash. =cut # TODO: Support for passing FILEHANDLE instead of FILENAME sub hash_object { my ($self, $type, $file) = _maybe_self(@_); command_oneline('hash-object', '-t', $type, $file); } =item hash_and_insert_object ( FILENAME ) Compute the SHA1 object id of the given C<FILENAME> and add the object to the object database. The function returns the SHA1 hash. =cut # TODO: Support for passing FILEHANDLE instead of FILENAME sub hash_and_insert_object { my ($self, $filename) = @_; carp "Bad filename \"$filename\"" if $filename =~ /[\r\n]/; $self->_open_hash_and_insert_object_if_needed(); my ($in, $out) = ($self->{hash_object_in}, $self->{hash_object_out}); unless (print $out $filename, "\n") { $self->_close_hash_and_insert_object(); throw Error::Simple("out pipe went bad"); } chomp(my $hash = <$in>); unless (defined($hash)) { $self->_close_hash_and_insert_object(); throw Error::Simple("in pipe went bad"); } return $hash; } sub _open_hash_and_insert_object_if_needed { my ($self) = @_; return if defined($self->{hash_object_pid}); ($self->{hash_object_pid}, $self->{hash_object_in}, $self->{hash_object_out}, $self->{hash_object_ctx}) = $self->command_bidi_pipe(qw(hash-object -w --stdin-paths --no-filters)); } sub _close_hash_and_insert_object { my ($self) = @_; return unless defined($self->{hash_object_pid}); my @vars = map { 'hash_object_' . $_ } qw(pid in out ctx); command_close_bidi_pipe(@$self{@vars}); delete @$self{@vars}; } =item cat_blob ( SHA1, FILEHANDLE ) Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and returns the number of bytes printed. =cut sub cat_blob { my ($self, $sha1, $fh) = @_; $self->_open_cat_blob_if_needed(); my ($in, $out) = ($self->{cat_blob_in}, $self->{cat_blob_out}); unless (print $out $sha1, "\n") { $self->_close_cat_blob(); throw Error::Simple("out pipe went bad"); } my $description = <$in>; if ($description =~ / missing$/) { carp "$sha1 doesn't exist in the repository"; return -1; } if ($description !~ /^[0-9a-fA-F]{40}(?:[0-9a-fA-F]{24})? \S+ (\d+)$/) { carp "Unexpected result returned from git cat-file"; return -1; } my $size = $1; my $blob; my $bytesLeft = $size; while (1) { last unless $bytesLeft; my $bytesToRead = $bytesLeft < 1024 ? $bytesLeft : 1024; my $read = read($in, $blob, $bytesToRead); unless (defined($read)) { $self->_close_cat_blob(); throw Error::Simple("in pipe went bad"); } unless (print $fh $blob) { $self->_close_cat_blob(); throw Error::Simple("couldn't write to passed in filehandle"); } $bytesLeft -= $read; } # Skip past the trailing newline. my $newline; my $read = read($in, $newline, 1); unless (defined($read)) { $self->_close_cat_blob(); throw Error::Simple("in pipe went bad"); } unless ($read == 1 && $newline eq "\n") { $self->_close_cat_blob(); throw Error::Simple("didn't find newline after blob"); } return $size; } sub _open_cat_blob_if_needed { my ($self) = @_; return if defined($self->{cat_blob_pid}); ($self->{cat_blob_pid}, $self->{cat_blob_in}, $self->{cat_blob_out}, $self->{cat_blob_ctx}) = $self->command_bidi_pipe(qw(cat-file --batch)); } sub _close_cat_blob { my ($self) = @_; return unless defined($self->{cat_blob_pid}); my @vars = map { 'cat_blob_' . $_ } qw(pid in out ctx); command_close_bidi_pipe(@$self{@vars}); delete @$self{@vars}; } =item credential_read( FILEHANDLE ) Reads credential key-value pairs from C<FILEHANDLE>. Reading stops at EOF or when an empty line is encountered. Each line must be of the form C<key=value> with a non-empty key. Function returns hash with all read values. Any white space (other than new-line character) is preserved. =cut sub credential_read { my ($self, $reader) = _maybe_self(@_); my %credential; while (<$reader>) { chomp; if ($_ eq '') { last; } elsif (!/^([^=]+)=(.*)$/) { throw Error::Simple("unable to parse git credential data:\n$_"); } $credential{$1} = $2; } return %credential; } =item credential_write( FILEHANDLE, CREDENTIAL_HASHREF ) Writes credential key-value pairs from hash referenced by C<CREDENTIAL_HASHREF> to C<FILEHANDLE>. Keys and values cannot contain new-lines or NUL bytes characters, and key cannot contain equal signs nor be empty (if they do Error::Simple is thrown). Any white space is preserved. If value for a key is C<undef>, it will be skipped. If C<'url'> key exists it will be written first. (All the other key-value pairs are written in sorted order but you should not depend on that). Once all lines are written, an empty line is printed. =cut sub credential_write { my ($self, $writer, $credential) = _maybe_self(@_); my ($key, $value); # Check if $credential is valid prior to writing anything while (($key, $value) = each %$credential) { if (!defined $key || !length $key) { throw Error::Simple("credential key empty or undefined"); } elsif ($key =~ /[=\n\0]/) { throw Error::Simple("credential key contains invalid characters: $key"); } elsif (defined $value && $value =~ /[\n\0]/) { throw Error::Simple("credential value for key=$key contains invalid characters: $value"); } } for $key (sort { # url overwrites other fields, so it must come first return -1 if $a eq 'url'; return 1 if $b eq 'url'; return $a cmp $b; } keys %$credential) { if (defined $credential->{$key}) { print $writer $key, '=', $credential->{$key}, "\n"; } } print $writer "\n"; } sub _credential_run { my ($self, $credential, $op) = _maybe_self(@_); my ($pid, $reader, $writer, $ctx) = command_bidi_pipe('credential', $op); credential_write $writer, $credential; close $writer; if ($op eq "fill") { %$credential = credential_read $reader; } if (<$reader>) { throw Error::Simple("unexpected output from git credential $op response:\n$_\n"); } command_close_bidi_pipe($pid, $reader, undef, $ctx); } =item credential( CREDENTIAL_HASHREF [, OPERATION ] ) =item credential( CREDENTIAL_HASHREF, CODE ) Executes C<git credential> for a given set of credentials and specified operation. In both forms C<CREDENTIAL_HASHREF> needs to be a reference to a hash which stores credentials. Under certain conditions the hash can change. In the first form, C<OPERATION> can be C<'fill'>, C<'approve'> or C<'reject'>, and function will execute corresponding C<git credential> sub-command. If it's omitted C<'fill'> is assumed. In case of C<'fill'> the values stored in C<CREDENTIAL_HASHREF> will be changed to the ones returned by the C<git credential fill> command. The usual usage would look something like: my %cred = ( 'protocol' => 'https', 'host' => 'example.com', 'username' => 'bob' ); Git::credential \%cred; if (try_to_authenticate($cred{'username'}, $cred{'password'})) { Git::credential \%cred, 'approve'; ... do more stuff ... } else { Git::credential \%cred, 'reject'; } In the second form, C<CODE> needs to be a reference to a subroutine. The function will execute C<git credential fill> to fill the provided credential hash, then call C<CODE> with C<CREDENTIAL_HASHREF> as the sole argument. If C<CODE>'s return value is defined, the function will execute C<git credential approve> (if return value yields true) or C<git credential reject> (if return value is false). If the return value is undef, nothing at all is executed; this is useful, for example, if the credential could neither be verified nor rejected due to an unrelated network error. The return value is the same as what C<CODE> returns. With this form, the usage might look as follows: if (Git::credential { 'protocol' => 'https', 'host' => 'example.com', 'username' => 'bob' }, sub { my $cred = shift; return !!try_to_authenticate($cred->{'username'}, $cred->{'password'}); }) { ... do more stuff ... } =cut sub credential { my ($self, $credential, $op_or_code) = (_maybe_self(@_), 'fill'); if ('CODE' eq ref $op_or_code) { _credential_run $credential, 'fill'; my $ret = $op_or_code->($credential); if (defined $ret) { _credential_run $credential, $ret ? 'approve' : 'reject'; } return $ret; } else { _credential_run $credential, $op_or_code; } } { # %TEMP_* Lexical Context my (%TEMP_FILEMAP, %TEMP_FILES); =item temp_acquire ( NAME ) Attempts to retrieve the temporary file mapped to the string C<NAME>. If an associated temp file has not been created this session or was closed, it is created, cached, and set for autoflush and binmode. Internally locks the file mapped to C<NAME>. This lock must be released with C<temp_release()> when the temp file is no longer needed. Subsequent attempts to retrieve temporary files mapped to the same C<NAME> while still locked will cause an error. This locking mechanism provides a weak guarantee and is not threadsafe. It does provide some error checking to help prevent temp file refs writing over one another. In general, the L<File::Handle> returned should not be closed by consumers as it defeats the purpose of this caching mechanism. If you need to close the temp file handle, then you should use L<File::Temp> or another temp file faculty directly. If a handle is closed and then requested again, then a warning will issue. =cut sub temp_acquire { my $temp_fd = _temp_cache(@_); $TEMP_FILES{$temp_fd}{locked} = 1; $temp_fd; } =item temp_is_locked ( NAME ) Returns true if the internal lock created by a previous C<temp_acquire()> call with C<NAME> is still in effect. When temp_acquire is called on a C<NAME>, it internally locks the temporary file mapped to C<NAME>. That lock will not be released until C<temp_release()> is called with either the original C<NAME> or the L<File::Handle> that was returned from the original call to temp_acquire. Subsequent attempts to call C<temp_acquire()> with the same C<NAME> will fail unless there has been an intervening C<temp_release()> call for that C<NAME> (or its corresponding L<File::Handle> that was returned by the original C<temp_acquire()> call). If true is returned by C<temp_is_locked()> for a C<NAME>, an attempt to C<temp_acquire()> the same C<NAME> will cause an error unless C<temp_release> is first called on that C<NAME> (or its corresponding L<File::Handle> that was returned by the original C<temp_acquire()> call). =cut sub temp_is_locked { my ($self, $name) = _maybe_self(@_); my $temp_fd = \$TEMP_FILEMAP{$name}; defined $$temp_fd && $$temp_fd->opened && $TEMP_FILES{$$temp_fd}{locked}; } =item temp_release ( NAME ) =item temp_release ( FILEHANDLE ) Releases a lock acquired through C<temp_acquire()>. Can be called either with the C<NAME> mapping used when acquiring the temp file or with the C<FILEHANDLE> referencing a locked temp file. Warns if an attempt is made to release a file that is not locked. The temp file will be truncated before being released. This can help to reduce disk I/O where the system is smart enough to detect the truncation while data is in the output buffers. Beware that after the temp file is released and truncated, any operations on that file may fail miserably until it is re-acquired. All contents are lost between each release and acquire mapped to the same string. =cut sub temp_release { my ($self, $temp_fd, $trunc) = _maybe_self(@_); if (exists $TEMP_FILEMAP{$temp_fd}) { $temp_fd = $TEMP_FILES{$temp_fd}; } unless ($TEMP_FILES{$temp_fd}{locked}) { carp "Attempt to release temp file '", $temp_fd, "' that has not been locked"; } temp_reset($temp_fd) if $trunc and $temp_fd->opened; $TEMP_FILES{$temp_fd}{locked} = 0; undef; } sub _temp_cache { my ($self, $name) = _maybe_self(@_); my $temp_fd = \$TEMP_FILEMAP{$name}; if (defined $$temp_fd and $$temp_fd->opened) { if ($TEMP_FILES{$$temp_fd}{locked}) { throw Error::Simple("Temp file with moniker '" . $name . "' already in use"); } } else { if (defined $$temp_fd) { # then we're here because of a closed handle. carp "Temp file '", $name, "' was closed. Opening replacement."; } my $fname; my $tmpdir; if (defined $self) { $tmpdir = $self->repo_path(); } my $n = $name; $n =~ s/\W/_/g; # no strange chars require File::Temp; ($$temp_fd, $fname) = File::Temp::tempfile( "Git_${n}_XXXXXX", UNLINK => 1, DIR => $tmpdir, ) or throw Error::Simple("couldn't open new temp file"); $$temp_fd->autoflush; binmode $$temp_fd; $TEMP_FILES{$$temp_fd}{fname} = $fname; } $$temp_fd; } =item temp_reset ( FILEHANDLE ) Truncates and resets the position of the C<FILEHANDLE>. =cut sub temp_reset { my ($self, $temp_fd) = _maybe_self(@_); truncate $temp_fd, 0 or throw Error::Simple("couldn't truncate file"); sysseek($temp_fd, 0, Fcntl::SEEK_SET()) and seek($temp_fd, 0, Fcntl::SEEK_SET()) or throw Error::Simple("couldn't seek to beginning of file"); sysseek($temp_fd, 0, Fcntl::SEEK_CUR()) == 0 and tell($temp_fd) == 0 or throw Error::Simple("expected file position to be reset"); } =item temp_path ( NAME ) =item temp_path ( FILEHANDLE ) Returns the filename associated with the given tempfile. =cut sub temp_path { my ($self, $temp_fd) = _maybe_self(@_); if (exists $TEMP_FILEMAP{$temp_fd}) { $temp_fd = $TEMP_FILEMAP{$temp_fd}; } $TEMP_FILES{$temp_fd}{fname}; } sub END { unlink values %TEMP_FILEMAP if %TEMP_FILEMAP; } } # %TEMP_* Lexical Context =item prefix_lines ( PREFIX, STRING [, STRING... ]) Prefixes lines in C<STRING> with C<PREFIX>. =cut sub prefix_lines { my $prefix = shift; my $string = join("\n", @_); $string =~ s/^/$prefix/mg; return $string; } =item unquote_path ( PATH ) Unquote a quoted path containing c-escapes as returned by ls-files etc. when not using -z or when parsing the output of diff -u. =cut { my %cquote_map = ( "a" => chr(7), "b" => chr(8), "t" => chr(9), "n" => chr(10), "v" => chr(11), "f" => chr(12), "r" => chr(13), "\\" => "\\", "\042" => "\042", ); sub unquote_path { local ($_) = @_; my ($retval, $remainder); if (!/^\042(.*)\042$/) { return $_; } ($_, $retval) = ($1, ""); while (/^([^\\]*)\\(.*)$/) { $remainder = $2; $retval .= $1; for ($remainder) { if (/^([0-3][0-7][0-7])(.*)$/) { $retval .= chr(oct($1)); $_ = $2; last; } if (/^([\\\042abtnvfr])(.*)$/) { $retval .= $cquote_map{$1}; $_ = $2; last; } # This is malformed throw Error::Simple("invalid quoted path $_[0]"); } $_ = $remainder; } $retval .= $_; return $retval; } } =item get_comment_line_char ( ) Gets the core.commentchar configuration value. The value falls-back to '#' if core.commentchar is set to 'auto'. =cut sub get_comment_line_char { my $comment_line_char = config("core.commentchar") || '#'; $comment_line_char = '#' if ($comment_line_char eq 'auto'); $comment_line_char = '#' if (length($comment_line_char) != 1); return $comment_line_char; } =item comment_lines ( STRING [, STRING... ]) Comments lines following core.commentchar configuration. =cut sub comment_lines { my $comment_line_char = get_comment_line_char; return prefix_lines("$comment_line_char ", @_); } =back =head1 ERROR HANDLING All functions are supposed to throw Perl exceptions in case of errors. See the L<Error> module on how to catch those. Most exceptions are mere L<Error::Simple> instances. However, the C<command()>, C<command_oneline()> and C<command_noisy()> functions suite can throw C<Git::Error::Command> exceptions as well: those are thrown when the external command returns an error code and contain the error code as well as access to the captured command's output. The exception class provides the usual C<stringify> and C<value> (command's exit code) methods and in addition also a C<cmd_output> method that returns either an array or a string with the captured command output (depending on the original function call context; C<command_noisy()> returns C<undef>) and $<cmdline> which returns the command and its arguments (but without proper quoting). Note that the C<command_*_pipe()> functions cannot throw this exception since it has no idea whether the command failed or not. You will only find out at the time you C<close> the pipe; if you want to have that automated, use C<command_close_pipe()>, which can throw the exception. =cut { package Git::Error::Command; @Git::Error::Command::ISA = qw(Error); sub new { my $self = shift; my $cmdline = '' . shift; my $value = 0 + shift; my $outputref = shift; my(@args) = (); local $Error::Depth = $Error::Depth + 1; push(@args, '-cmdline', $cmdline); push(@args, '-value', $value); push(@args, '-outputref', $outputref); $self->SUPER::new(-text => 'command returned error', @args); } sub stringify { my $self = shift; my $text = $self->SUPER::stringify; $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n"; } sub cmdline { my $self = shift; $self->{'-cmdline'}; } sub cmd_output { my $self = shift; my $ref = $self->{'-outputref'}; defined $ref or undef; if (ref $ref eq 'ARRAY') { return @$ref; } else { # SCALAR return $$ref; } } } =over 4 =item git_cmd_try { CODE } ERRMSG This magical statement will automatically catch any C<Git::Error::Command> exceptions thrown by C<CODE> and make your program die with C<ERRMSG> on its lips; the message will have %s substituted for the command line and %d for the exit status. This statement is useful mostly for producing more user-friendly error messages. In case of no exception caught the statement returns C<CODE>'s return value. Note that this is the only auto-exported function. =cut sub git_cmd_try(&$) { my ($code, $errmsg) = @_; my @result; my $err; my $array = wantarray; try { if ($array) { @result = &$code; } else { $result[0] = &$code; } } catch Git::Error::Command with { my $E = shift; $err = $errmsg; $err =~ s/\%s/$E->cmdline()/ge; $err =~ s/\%d/$E->value()/ge; # We can't croak here since Error.pm would mangle # that to Error::Simple. }; $err and croak $err; return $array ? @result : $result[0]; } =back =head1 COPYRIGHT Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>. This module is free software; it may be used, copied, modified and distributed under the terms of the GNU General Public Licence, either version 2, or (at your option) any later version. =cut # Take raw method argument list and return ($obj, @args) in case # the method was called upon an instance and (undef, @args) if # it was called directly. sub _maybe_self { UNIVERSAL::isa($_[0], 'Git') ? @_ : (undef, @_); } # Check if the command id is something reasonable. sub _check_valid_cmd { my ($cmd) = @_; $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd"); } # Common backend for the pipe creators. sub _command_common_pipe { my $direction = shift; my ($self, @p) = _maybe_self(@_); my (%opts, $cmd, @args); if (ref $p[0]) { ($cmd, @args) = @{shift @p}; %opts = ref $p[0] ? %{$p[0]} : @p; } else { ($cmd, @args) = @p; } _check_valid_cmd($cmd); my $fh; if ($^O eq 'MSWin32') { # ActiveState Perl #defined $opts{STDERR} and # warn 'ignoring STDERR option - running w/ ActiveState'; $direction eq '-|' or die 'input pipe for ActiveState not implemented'; # the strange construction with *ACPIPE is just to # explain the tie below that we want to bind to # a handle class, not scalar. It is not known if # it is something specific to ActiveState Perl or # just a Perl quirk. tie (*ACPIPE, 'Git::activestate_pipe', $cmd, @args); $fh = *ACPIPE; } else { my $pid = open($fh, $direction); if (not defined $pid) { throw Error::Simple("open failed: $!"); } elsif ($pid == 0) { if ($opts{STDERR}) { open (STDERR, '>&', $opts{STDERR}) or die "dup failed: $!"; } elsif (defined $opts{STDERR}) { open (STDERR, '>', '/dev/null') or die "opening /dev/null failed: $!"; } _cmd_exec($self, $cmd, @args); } } return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh; } # When already in the subprocess, set up the appropriate state # for the given repository and execute the git command. sub _cmd_exec { my ($self, @args) = @_; _setup_git_cmd_env($self); _execv_git_cmd(@args); die qq[exec "@args" failed: $!]; } # set up the appropriate state for git command sub _setup_git_cmd_env { my $self = shift; if ($self) { $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path(); $self->repo_path() and $self->wc_path() and $ENV{'GIT_WORK_TREE'} = $self->wc_path(); $self->wc_path() and chdir($self->wc_path()); $self->wc_subdir() and chdir($self->wc_subdir()); } } # Execute the given Git command ($_[0]) with arguments ($_[1..]) # by searching for it at proper places. sub _execv_git_cmd { exec('git', @_); } # Close pipe to a subprocess. sub _cmd_close { my $ctx = shift @_; foreach my $fh (@_) { if (close $fh) { # nop } elsif ($!) { # It's just close, no point in fatalities carp "error closing pipe: $!"; } elsif ($? >> 8) { # The caller should pepper this. throw Git::Error::Command($ctx, $? >> 8); } # else we might e.g. closed a live stream; the command # dying of SIGPIPE would drive us here. } } sub DESTROY { my ($self) = @_; $self->_close_hash_and_insert_object(); $self->_close_cat_blob(); } # Pipe implementation for ActiveState Perl. package Git::activestate_pipe; sub TIEHANDLE { my ($class, @params) = @_; # FIXME: This is probably horrible idea and the thing will explode # at the moment you give it arguments that require some quoting, # but I have no ActiveState clue... --pasky # Let's just hope ActiveState Perl does at least the quoting # correctly. my @data = qx{git @params}; bless { i => 0, data => \@data }, $class; } sub READLINE { my $self = shift; if ($self->{i} >= scalar @{$self->{data}}) { return undef; } my $i = $self->{i}; if (wantarray) { $self->{i} = $#{$self->{'data'}} + 1; return splice(@{$self->{'data'}}, $i); } $self->{i} = $i + 1; return $self->{'data'}->[ $i ]; } sub CLOSE { my $self = shift; delete $self->{data}; delete $self->{i}; } sub EOF { my $self = shift; return ($self->{i} >= scalar @{$self->{data}}); } 1; # Famous last words PK ! #"L L % Debian/Debhelper/Sequence/perl_dbi.pmnu �[��� # perl_dbi.pm - debhelper addon for running dh_perl_dbi # # Copyright 2010, Ansgar Burchardt <ansgar@debian.org> # # This program is free software, you can redistribute it and/or modify it # under the same terms as Perl itself. use warnings; use strict; use Debian::Debhelper::Dh_Lib; insert_after("dh_perl", "dh_perl_dbi"); 1; PK ! i�� � , Debian/Debhelper/Sequence/bash_completion.pmnu �[��� #!/usr/bin/perl use warnings; use strict; use Debian::Debhelper::Dh_Lib; insert_after("dh_installman", "dh_bash-completion"); 1; PK ! 'j˝� � Debian/AdduserCommon.pmnu �[��� use vars qw(@EXPORT $VAR1); # Common functions that are used in adduser and deluser # Copyright (C) 2000 Roland Bauerschmidt <rb@debian.org> # Most of the functions are adopted from the original adduser # Copyright (C) 1997, 1998, 1999 Guy Maor <maor@debian.org> # Copyright (C) 1995 Ted Hajek <tedhajek@boombox.micro.umn.edu> # Ian A. Murdock <imurdock@gnu.ai.mit.edu> # @EXPORT = qw(invalidate_nscd gtx dief warnf read_config get_users_groups get_group_members s_print s_printf systemcall); sub invalidate_nscd { # Check if we need to do make -C /var/yp for NIS my $nisconfig; if(-f "/etc/default/nis") { $nisconfig = "/etc/default/nis"; } elsif(-f "/etc/init.d/nis") { $nisconfig = "/etc/init.d/nis"; } # find out whether a local ypserv is running # We can ditch any rpcinfo error since if the portmapper is nonfunctional, # we couldn't connect to ypserv anyway. If this assumption is invalid, # please file a bug and suggest a better way. if(defined($nisconfig) && -f "/var/yp/Makefile" && -x "/usr/sbin/rpcinfo" && grep(/ypserv/, qx{/usr/sbin/rpcinfo -p 2>/dev/null})) { open(NISCONFIG, "<$nisconfig"); if(grep(/^NISSERVER=master/, <NISCONFIG>)) { system("make", "-C", "/var/yp"); } close(NISCONFIG); } # Check if we need to invalidate the NSCD cache my $nscd = &which('nscd',1); # this function replaces startnscd and stopnscd (closes: #54726) # We are ignoring any error messages given by nscd here since we # cannot expect the nscd maintainer and upstream to document their # interfaces. See #330929. if(defined($nscd) && -x $nscd) { my $table = shift; if ($table) { system ($nscd, "-i", $table); } else { # otherwise we invalidate passwd and group table system ($nscd, "-i", "passwd"); system ($nscd, "-i", "group"); } } } sub gtx { return gettext( shift ); } sub dief { my ($form,@argu)=@_; printf STDERR sprintf(gtx("%s: %s"), $0, $form), @argu; exit 1; } sub warnf { my ($form,@argu)=@_; printf STDERR sprintf(gtx("%s: %s"), $0, $form), @argu; } # parse the configuration file # parameters: # -- filename of the configuration file # -- a hash for the configuration data sub read_config { my ($conf_file, $configref) = @_; my ($var, $lcvar, $val); if (! -f $conf_file) { warnf gtx("`%s' does not exist. Using defaults.\n"),$conf_file if $verbose; return; } open (CONF, $conf_file) || dief ("%s: `%s'\n",$conf_file,$!); while (<CONF>) { chomp; next if /^#/ || /^\s*$/; if ((($var, $val) = /^\s*([_a-zA-Z0-9]+)\s*=\s*(.*)/) != 2) { warnf gtx("Couldn't parse `%s', line %d.\n"),$conf_file,$.; next; } $lcvar = lc $var; if (!defined($configref->{$lcvar})) { warnf gtx("Unknown variable `%s' at `%s', line %d.\n"),$var,$conf_file,$.; next; } $val =~ s/^"(.*)"$/$1/; $val =~ s/^'(.*)'$/$1/; $configref->{$lcvar} = $val; } close CONF || die "$!"; } # return a user's groups sub get_users_groups { my($user) = @_; my($name,$members,@groups); setgrent; while (($name,$members) = (getgrent)[0,3]) { for (split(/ /, $members)) { if ($user eq $_) { push @groups, $name; last; } } } endgrent; @groups; } # return a group's members sub get_group_members { my $group = shift; my @members; foreach (split(/ /, (getgrnam($group))[3])) { if (getpwuid(getpwnam($_)) eq $_ ) { push @members, $_; } } return @members; } sub s_print { print join(" ",@_) if($verbose); } sub s_printf { printf @_ if($verbose); } sub d_printf { printf @_ if((defined($verbose) && $verbose > 1) || (defined($debugging) && $debugging == 1)); } sub systemcall { my $c = join(' ', @_); print ("$c\n") if $verbose==2; if (system(@_)) { dief (gtx("`%s' returned error code %d. Exiting.\n"), $c, $?>>8) if ($?>>8); dief (gtx("`%s' exited from signal %d. Exiting.\n"), $c, $?&255); } } sub which { my ($progname, $nonfatal) = @_ ; for my $dir (split /:/, $ENV{"PATH"}) { if (-x "$dir/$progname" ) { return "$dir/$progname"; } } dief(gtx("Could not find program named `%s' in \$PATH.\n"), $progname) unless ($nonfatal); return 0; } # preseed the configuration variables # then read the config file /etc/adduser and overwrite the data hardcoded here sub preseed_config { my ($conflistref, $configref) = @_; $configref->{"system"} = 0; $configref->{"only_if_empty"} = 0; $configref->{"remove_home"} = 0; $configref->{"home"} = ""; $configref->{"remove_all_files"} = 0; $configref->{"backup"} = 0; $configref->{"backup_to"} = "."; $configref->{"dshell"} = "/bin/bash"; $configref->{"first_system_uid"} = 100; $configref->{"last_system_uid"} = 999; $configref->{"first_uid"} = 1000; $configref->{"last_uid"} = 59999; $configref->{"first_system_gid"} = 100; $configref->{"last_system_gid"} = 999; $configref->{"first_gid"} = 1000; $configref->{"last_gid"} = 59999; $configref->{"dhome"} = "/home"; $configref->{"skel"} = "/etc/skel"; $configref->{"usergroups"} = "yes"; $configref->{"users_gid"} = "100"; $configref->{"grouphomes"} = "no"; $configref->{"letterhomes"} = "no"; $configref->{"quotauser"} = ""; $configref->{"dir_mode"} = "0755"; $configref->{"setgid_home"} = "no"; $configref->{"no_del_paths"} = "^/$ ^/lost+found/.* ^/media/.* ^/mnt/.* ^/etc/.* ^/bin/.* ^/boot/.* ^/dev/.* ^/lib/.* ^/proc/.* ^/root/.* ^/sbin/.* ^/tmp/.* ^/sys/.* ^/srv/.* ^/opt/.* ^/initrd/.* ^/usr/.* ^/var/.*"; $configref->{"name_regex"} = "^[a-z][-a-z0-9_]*\$"; $configref->{"name_regex_system"} = "^[A-Za-z][-A-Za-z0-9_]*\$"; $configref->{"exclude_fstypes"} = "(proc|sysfs|usbfs|devpts|tmpfs)"; $configref->{"skel_ignore_regex"} = "dpkg-(old|new|dist)\$"; $configref->{"extra_groups"} = "dialout cdrom floppy audio video plugdev users"; $configref->{"add_extra_groups"} = 0; $configref->{"use_extrausers"} = 0; foreach( @$conflistref ) { read_config($_,$configref); } } # Local Variables: # mode:cperl # End: #vim:set ai et sts=4 sw=4 tw=0: PK ! 9�$b b # Debian/DebConf/Client/ConfModule.pmnu �[��� #!/usr/bin/perl # This is a stub module that just uses the new module, and is here for # backwards-compatability with pograms that use the old name. package Debian::DebConf::Client::ConfModule; use Debconf::Client::ConfModule; use Debconf::Log qw{debug}; print STDERR "Debian::DebConf::Client::ConfModule is deprecated, please use Debconf::Client::ConfModule instead.\n"; sub import { splice @_, 0, 1 => Debconf::Client::ConfModule; goto &{Debconf::Client::ConfModule->can('import')}; } sub AUTOLOAD { (my $sub = $AUTOLOAD) =~ s/.*:://; *$sub = \&{"Debconf::Client::ConfModule::$sub"}; goto &$sub; } 1 PK ! L�� � Text/WrapI18N.pmnu �[��� package Text::WrapI18N; require Exporter; use strict; use warnings; our @ISA = qw(Exporter); our @EXPORT = qw(wrap); our @EXPORT_OK = qw($columns $separator); our %EXPORT_TAGS = ('all' => [ @EXPORT, @EXPORT_OK ]); our $VERSION = '0.06'; use vars qw($columns $break $tabstop $separator $huge $unexpand $charmap); use Text::CharWidth qw(mbswidth mblen); BEGIN { $columns = 76; # $break, $separator, $huge, and $unexpand are not supported yet. $break = '\s'; $tabstop = 8; $separator = "\n"; $huge = 'wrap'; $unexpand = 1; undef $charmap; } sub wrap { my $top1=shift; my $top2=shift; my $text=shift; $text = $top1 . $text; # $out already-formatted text for output including current line # $len visible width of the current line without the current word # $word the current word which might be sent to the next line # $wlen visible width of the current word # $c the current character # $b whether to allow line-breaking after the current character # $cont_lf true when LF (line feed) characters appear continuously # $w visible width of the current character my $out = ''; my $len = 0; my $word = ''; my $wlen = 0; my $cont_lf = 0; my ($c, $w, $b); $text =~ s/\n+$/\n/; while(1) { if (length($text) == 0) { return $out . $word; } ($c, $text, $w, $b) = _extract($text); if ($c eq "\n") { $out .= $word . $separator; if (length($text) == 0) {return $out;} $len = 0; $text = $top2 . $text; $word = '' ; $wlen = 0; next; } elsif ($w == -1) { # all control characters other than LF are ignored next; } # when the current line have enough room # for the curren character if ($len + $wlen + $w <= $columns) { if ($c eq ' ' || $b) { $out .= $word . $c; $len += $wlen + $w; $word = ''; $wlen = 0; } else { $word .= $c; $wlen += $w; } next; } # when the current line overflows with the # current character if ($c eq ' ') { # the line ends by space $out .= $word . $separator; $len = 0; $text = $top2 . $text; $word = ''; $wlen = 0; } elsif ($wlen + $w <= $columns - length ($top2)) { # the current word is sent to next line $out .= $separator; $len = 0; $text = $top2 . $word . $c . $text; $word = ''; $wlen = 0; } else { # the current word is too long to fit a line $out .= $word . $separator; $len = 0; $text = $top2 . $c . $text; $word = ''; $wlen = 0; } } } # Extract one character from the beginning from the given string. # Supports multibyte encodings such as UTF-8, EUC-JP, EUC-KR, # GB2312, and Big5. # # return value: (character, rest string, width, line breakable) # character: a character. This may consist from multiple bytes. # rest string: given string without the extracted character. # width: number of columns which the character occupies on screen. # line breakable: true if the character allows line break after it. sub _extract { my $string=shift; my ($l, $c, $r, $w, $b, $u); if (length($string) == 0) { return ('', '', 0, 0); } $l = mblen($string); if ($l == 0 || $l == -1) { return ('?', substr($string,1), 1, 0); } $c = substr($string, 0, $l); $r = substr($string, $l); $w = mbswidth($c); if (!defined($charmap)) { $charmap = `/usr/bin/locale charmap`; } if ($charmap =~ /UTF.8/i) { # UTF-8 if ($l == 3) { # U+0800 - U+FFFF $u = (ord(substr($c,0,1))&0x0f) * 0x1000 + (ord(substr($c,1,1))&0x3f) * 0x40 + (ord(substr($c,2,1))&0x3f); $b = _isCJ($u); } elsif ($l == 4) { # U+10000 - U+10FFFF $u = (ord(substr($c,0,1))&7) * 0x40000 + (ord(substr($c,1,1))&0x3f) * 0x1000 + (ord(substr($c,2,1))&0x3f) * 0x40 + (ord(substr($c,3,1))&0x3f); $b = _isCJ($u); } else { $b = 0; } } elsif ($charmap =~ /(^EUC)|(^GB)|(^BIG)/i) { # East Asian legacy encodings # (EUC-JP, EUC-KR, GB2312, Big5, Big5HKSCS, and so on) if (ord(substr($c,0,1)) >= 0x80) {$b = 1;} else {$b = 0;} } else { $b = 0; } return ($c, $r, $w, $b); } # Returns 1 for Chinese and Japanese characters. This means that # these characters allow line wrapping after this character even # without whitespaces because these languages don't use whitespaces # between words. # # Character must be given in UCS-4 codepoint value. sub _isCJ { my $u=shift; if ($u >= 0x3000 && $u <= 0x312f) { if ($u == 0x300a || $u == 0x300c || $u == 0x300e || $u == 0x3010 || $u == 0x3014 || $u == 0x3016 || $u == 0x3018 || $u == 0x301a) {return 0;} return 1; } # CJK punctuations, Hiragana, Katakana, Bopomofo if ($u >= 0x31a0 && $u <= 0x31bf) {return 1;} # Bopomofo if ($u >= 0x31f0 && $u <= 0x31ff) {return 1;} # Katakana extension if ($u >= 0x3400 && $u <= 0x9fff) {return 1;} # Han Ideogram if ($u >= 0xf900 && $u <= 0xfaff) {return 1;} # Han Ideogram if ($u >= 0x20000 && $u <= 0x2ffff) {return 1;} # Han Ideogram return 0; } 1; __END__ =head1 NAME Text::WrapI18N - Line wrapping module with support for multibyte, fullwidth, and combining characters and languages without whitespaces between words =head1 SYNOPSIS use Text::WrapI18N qw(wrap $columns); wrap(firstheader, nextheader, texts); =head1 DESCRIPTION This module intends to be a better Text::Wrap module. This module is needed to support multibyte character encodings such as UTF-8, EUC-JP, EUC-KR, GB2312, and Big5. This module also supports characters with irregular widths, such as combining characters (which occupy zero columns on terminal, like diacritical marks in UTF-8) and fullwidth characters (which occupy two columns on terminal, like most of east Asian characters). Also, minimal handling of languages which doesn't use whitespaces between words (like Chinese and Japanese) is supported. Like Text::Wrap, hyphenation and "kinsoku" processing are not supported, to keep simplicity. I<wrap(firstheader, nextheader, texts)> is the main subroutine of Text::WrapI18N module to execute the line wrapping. Input parameters and output data emulate Text::Wrap. The texts have to be written in locale encoding. =head1 SEE ALSO locale(5), utf-8(7), charsets(7) =head1 AUTHOR Tomohiro KUBOTA, E<lt>kubota@debian.orgE<gt> =head1 COPYRIGHT AND LICENSE Copyright 2003 by Tomohiro KUBOTA This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! �Y���% �% Date/Format.pmnu �[��� # Copyright (c) 1995-2009 Graham Barr. This program is free # software; you can redistribute it and/or modify it under the same terms # as Perl itself. package Date::Format; use strict; use vars qw(@EXPORT @ISA $VERSION); require Exporter; $VERSION = "2.24"; @ISA = qw(Exporter); @EXPORT = qw(time2str strftime ctime asctime); sub time2str ($;$$) { Date::Format::Generic->time2str(@_); } sub strftime ($\@;$) { Date::Format::Generic->strftime(@_); } sub ctime ($;$) { my($t,$tz) = @_; Date::Format::Generic->time2str("%a %b %e %T %Y\n", $t, $tz); } sub asctime (\@;$) { my($t,$tz) = @_; Date::Format::Generic->strftime("%a %b %e %T %Y\n", $t, $tz); } ## ## ## package Date::Format::Generic; use vars qw($epoch $tzname); use Time::Zone; use Time::Local; sub ctime { my($me,$t,$tz) = @_; $me->time2str("%a %b %e %T %Y\n", $t, $tz); } sub asctime { my($me,$t,$tz) = @_; $me->strftime("%a %b %e %T %Y\n", $t, $tz); } sub _subs { my $fn; $_[1] =~ s/ %(O?[%a-zA-Z]) / ($_[0]->can("format_$1") || sub { $1 })->($_[0]); /sgeox; $_[1]; } sub strftime { my($pkg,$fmt,$time); ($pkg,$fmt,$time,$tzname) = @_; my $me = ref($pkg) ? $pkg : bless []; if(defined $tzname) { $tzname = uc $tzname; $tzname = sprintf("%+05d",$tzname) unless($tzname =~ /\D/); $epoch = timegm(@{$time}[0..5]); @$me = gmtime($epoch + tz_offset($tzname) - tz_offset()); } else { @$me = @$time; undef $epoch; } _subs($me,$fmt); } sub time2str { my($pkg,$fmt,$time); ($pkg,$fmt,$time,$tzname) = @_; my $me = ref($pkg) ? $pkg : bless [], $pkg; $epoch = $time; if(defined $tzname) { $tzname = uc $tzname; $tzname = sprintf("%+05d",$tzname) unless($tzname =~ /\D/); $time += tz_offset($tzname); @$me = gmtime($time); } else { @$me = localtime($time); } $me->[9] = $time; _subs($me,$fmt); } my(@DoW,@MoY,@DoWs,@MoYs,@AMPM,%format,@Dsuf); @DoW = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday); @MoY = qw(January February March April May June July August September October November December); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(AM PM); @Dsuf = (qw(th st nd rd th th th th th th)) x 3; @Dsuf[11,12,13] = qw(th th th); @Dsuf[30,31] = qw(th st); %format = ('x' => "%m/%d/%y", 'C' => "%a %b %e %T %Z %Y", 'X' => "%H:%M:%S", ); my @locale; my $locale = "/usr/share/lib/locale/LC_TIME/default"; local *LOCALE; if(open(LOCALE,"$locale")) { chop(@locale = <LOCALE>); close(LOCALE); @MoYs = @locale[0 .. 11]; @MoY = @locale[12 .. 23]; @DoWs = @locale[24 .. 30]; @DoW = @locale[31 .. 37]; @format{"X","x","C"} = @locale[38 .. 40]; @AMPM = @locale[41 .. 42]; } sub wkyr { my($wstart, $wday, $yday) = @_; $wday = ($wday + 7 - $wstart) % 7; return int(($yday - $wday + 13) / 7 - 1); } ## ## these 6 formatting routins need to be *copied* into the language ## specific packages ## my @roman = ('',qw(I II III IV V VI VII VIII IX)); sub roman { my $n = shift; $n =~ s/(\d)$//; my $r = $roman[ $1 ]; if($n =~ s/(\d)$//) { (my $t = $roman[$1]) =~ tr/IVX/XLC/; $r = $t . $r; } if($n =~ s/(\d)$//) { (my $t = $roman[$1]) =~ tr/IVX/CDM/; $r = $t . $r; } if($n =~ s/(\d)$//) { (my $t = $roman[$1]) =~ tr/IVX/M../; $r = $t . $r; } $r; } sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_P { lc($_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0]) } sub format_d { sprintf("%02d",$_[0]->[3]) } sub format_e { sprintf("%2d",$_[0]->[3]) } sub format_H { sprintf("%02d",$_[0]->[2]) } sub format_I { sprintf("%02d",$_[0]->[2] % 12 || 12)} sub format_j { sprintf("%03d",$_[0]->[7] + 1) } sub format_k { sprintf("%2d",$_[0]->[2]) } sub format_l { sprintf("%2d",$_[0]->[2] % 12 || 12)} sub format_L { $_[0]->[4] + 1 } sub format_m { sprintf("%02d",$_[0]->[4] + 1) } sub format_M { sprintf("%02d",$_[0]->[1]) } sub format_q { sprintf("%01d",int($_[0]->[4] / 3) + 1) } sub format_s { $epoch = timelocal(@{$_[0]}[0..5]) unless defined $epoch; sprintf("%d",$epoch) } sub format_S { sprintf("%02d",$_[0]->[0]) } sub format_U { wkyr(0, $_[0]->[6], $_[0]->[7]) } sub format_w { $_[0]->[6] } sub format_W { wkyr(1, $_[0]->[6], $_[0]->[7]) } sub format_y { sprintf("%02d",$_[0]->[5] % 100) } sub format_Y { sprintf("%04d",$_[0]->[5] + 1900) } sub format_Z { my $o = tz_local_offset(timelocal(@{$_[0]}[0..5])); defined $tzname ? $tzname : uc tz_name($o, $_[0]->[8]); } sub format_z { my $t = timelocal(@{$_[0]}[0..5]); my $o = defined $tzname ? tz_offset($tzname, $t) : tz_offset(undef,$t); sprintf("%+03d%02d", int($o / 3600), int(abs($o) % 3600) / 60); } sub format_c { &format_x . " " . &format_X } sub format_D { &format_m . "/" . &format_d . "/" . &format_y } sub format_r { &format_I . ":" . &format_M . ":" . &format_S . " " . &format_p } sub format_R { &format_H . ":" . &format_M } sub format_T { &format_H . ":" . &format_M . ":" . &format_S } sub format_t { "\t" } sub format_n { "\n" } sub format_o { sprintf("%2d%s",$_[0]->[3],$Dsuf[$_[0]->[3]]) } sub format_x { my $f = $format{'x'}; _subs($_[0],$f); } sub format_X { my $f = $format{'X'}; _subs($_[0],$f); } sub format_C { my $f = $format{'C'}; _subs($_[0],$f); } sub format_Od { roman(format_d(@_)) } sub format_Oe { roman(format_e(@_)) } sub format_OH { roman(format_H(@_)) } sub format_OI { roman(format_I(@_)) } sub format_Oj { roman(format_j(@_)) } sub format_Ok { roman(format_k(@_)) } sub format_Ol { roman(format_l(@_)) } sub format_Om { roman(format_m(@_)) } sub format_OM { roman(format_M(@_)) } sub format_Oq { roman(format_q(@_)) } sub format_Oy { roman(format_y(@_)) } sub format_OY { roman(format_Y(@_)) } sub format_G { int(($_[0]->[9] - 315993600) / 604800) } 1; __END__ =head1 NAME Date::Format - Date formating subroutines =head1 SYNOPSIS use Date::Format; @lt = localtime(time); print time2str($template, time); print strftime($template, @lt); print time2str($template, time, $zone); print strftime($template, @lt, $zone); print ctime(time); print asctime(@lt); print ctime(time, $zone); print asctime(@lt, $zone); =head1 DESCRIPTION This module provides routines to format dates into ASCII strings. They correspond to the C library routines C<strftime> and C<ctime>. =over 4 =item time2str(TEMPLATE, TIME [, ZONE]) C<time2str> converts C<TIME> into an ASCII string using the conversion specification given in C<TEMPLATE>. C<ZONE> if given specifies the zone which the output is required to be in, C<ZONE> defaults to your current zone. =item strftime(TEMPLATE, TIME [, ZONE]) C<strftime> is similar to C<time2str> with the exception that the time is passed as an array, such as the array returned by C<localtime>. =item ctime(TIME [, ZONE]) C<ctime> calls C<time2str> with the given arguments using the conversion specification C<"%a %b %e %T %Y\n"> =item asctime(TIME [, ZONE]) C<asctime> calls C<time2str> with the given arguments using the conversion specification C<"%a %b %e %T %Y\n"> =back =head1 MULTI-LANGUAGE SUPPORT Date::Format is capable of formating into several languages by creating a language specific object and calling methods, see L<Date::Language> my $lang = Date::Language->new('German'); $lang->time2str("%a %b %e %T %Y\n", time); I am open to suggestions on this. =head1 CONVERSION SPECIFICATION Each conversion specification is replaced by appropriate characters as described in the following list. The appropriate characters are determined by the LC_TIME category of the program's locale. %% PERCENT %a day of the week abbr %A day of the week %b month abbr %B month %c MM/DD/YY HH:MM:SS %C ctime format: Sat Nov 19 21:05:57 1994 %d numeric day of the month, with leading zeros (eg 01..31) %e like %d, but a leading zero is replaced by a space (eg 1..32) %D MM/DD/YY %G GPS week number (weeks since January 6, 1980) %h month abbr %H hour, 24 hour clock, leading 0's) %I hour, 12 hour clock, leading 0's) %j day of the year %k hour %l hour, 12 hour clock %L month number, starting with 1 %m month number, starting with 01 %M minute, leading 0's %n NEWLINE %o ornate day of month -- "1st", "2nd", "25th", etc. %p AM or PM %P am or pm (Yes %p and %P are backwards :) %q Quarter number, starting with 1 %r time format: 09:05:57 PM %R time format: 21:05 %s seconds since the Epoch, UCT %S seconds, leading 0's %t TAB %T time format: 21:05:57 %U week number, Sunday as first day of week %w day of the week, numerically, Sunday == 0 %W week number, Monday as first day of week %x date format: 11/19/94 %X time format: 21:05:57 %y year (2 digits) %Y year (4 digits) %Z timezone in ascii. eg: PST %z timezone in format -/+0000 C<%d>, C<%e>, C<%H>, C<%I>, C<%j>, C<%k>, C<%l>, C<%m>, C<%M>, C<%q>, C<%y> and C<%Y> can be output in Roman numerals by prefixing the letter with C<O>, e.g. C<%OY> will output the year as roman numerals. =head1 LIMITATION The functions in this module are limited to the time range that can be represented by the time_t data type, i.e. 1901-12-13 20:45:53 GMT to 2038-01-19 03:14:07 GMT. =head1 AUTHOR Graham Barr <gbarr@pobox.com> =head1 COPYRIGHT Copyright (c) 1995-2009 Graham Barr. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! '`=�� � Date/Language/Occitan.pmnu �[��� ## ## Occitan tables, contributed by Quentn PAGÈS ## package Date::Language::Occitan; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.04"; @DoW = qw(dimenge diluns dimars dimècres dijòus divendres dissabte); @MoY = qw(genièr febrièr mars abrial mai junh julhet agost octòbre novembre decembre); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; $MoYs[6] = 'jul'; @AMPM = qw(AM PM); @Dsuf = ((qw(er e e e e e e e e e)) x 3, 'er'); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! �9 | | Date/Language/Romanian.pmnu �[��� ## ## Italian tables ## package Date::Language::Romanian; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @MoY = qw(ianuarie februarie martie aprilie mai iunie iulie august septembrie octombrie noembrie decembrie); @DoW = qw(duminica luni marti miercuri joi vineri sambata); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(AM PM); @Dsuf = ('') x 31; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! �1UU U Date/Language/Hungarian.pmnu �[��� ## ## Hungarian tables based on English ## # # This is a just-because-I-stumbled-across-it # -and-my-wife-is-Hungarian release: if Graham or # someone adds to docs to Date::Format, I'd be # glad to correct bugs and extend as neeed. # package Date::Language::Hungarian; =head1 NAME Date::Language::Hungarian - Magyar format for Date::Format =head1 SYNOPSIS my $lang = Date::Language->new('Hungarian'); print $lang->time2str("%a %b %e %T %Y", time); @lt = localtime(time); print $lang->time2str($template, time); print $lang->strftime($template, @lt); print $lang->time2str($template, time, $zone); print $lang->strftime($template, @lt, $zone); print $lang->ctime(time); print $lang->asctime(@lt); print $lang->ctime(time, $zone); print $lang->asctime(@lt, $zone); See L<Date::Format>. =head1 AUTHOR Paula Goddard (paula -at- paulacska -dot- com) =head1 LICENCE Made available under the same terms as Perl itself. =cut use strict; use warnings; use base "Date::Language"; use vars qw( @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); $VERSION = "1.01"; @DoW = qw(Vas�rnap H�tf� Kedd Szerda Cs�t�rt�k P�ntek Szombat); @MoY = qw(Janu�r Febru�r M�rcius �prilis M�jus J�nius J�lius Augusztus Szeptember Okt�ber November December); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(DE. DU.); # There is no 'th or 'nd in Hungarian, just a dot @Dsuf = (".") x 31; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_P { lc($_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0]) } sub format_o { $_[0]->[3].'.' } sub format_D { &format_y . "." . &format_m . "." . &format_d } sub format_y { sprintf("%02d",$_[0]->[5] % 100) } sub format_d { sprintf("%02d",$_[0]->[3]) } sub format_m { sprintf("%02d",$_[0]->[4] + 1) } 1; PK ! ҅�� � Date/Language/Austrian.pmnu �[��� ## ## Austrian tables ## package Date::Language::Austrian; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @MoY = qw(J�nner Feber M�rz April Mai Juni Juli August September Oktober November Dezember); @MoYs = qw(J�n Feb M�r Apr Mai Jun Jul Aug Sep Oct Nov Dez); @DoW = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag); @DoWs = qw(Son Mon Die Mit Don Fre Sam); use Date::Language::English (); @AMPM = @{Date::Language::English::AMPM}; @Dsuf = @{Date::Language::English::Dsuf}; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! kEY4( ( Date/Language/Gedeo.pmnu �[��� ## ## Gedeo tables ## package Date::Language::Gedeo; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "0.99"; @DoW = qw( Sanbbattaa Sanno Masano Roobe Hamusse Arbe Qiddamme); @MoY = ( "Oritto", "Birre'a", "Onkkollessa", "Saddasa", "Arrasa", "Qammo", "Ella", "Waacibajje", "Canissa", "Addolessa", "Bittitotessa", "Hegeya" ); @DoWs = map { substr($_,0,3) } @DoW; $DoWs[0] = "Snb"; $DoWs[1] = "Sno"; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(gorsa warreti-udumma); @Dsuf = (qw(th st nd rd th th th th th th)) x 3; @Dsuf[11,12,13] = qw(th th th); @Dsuf[30,31] = qw(th st); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! d�� � Date/Language/Czech.pmnu �[��� ## ## Czech tables ## ## Contributed by Honza Pazdziora package Date::Language::Czech; use vars qw(@ISA @DoW @DoWs @MoY @MoYs @MoY2 @AMPM %MoY %DoW $VERSION); @ISA = qw(Date::Language Date::Format::Generic); $VERSION = "1.01"; @MoY = qw(leden �nor b�ezen duben kv�ten �erven �ervenec srpen z�� ��jen listopad prosinec); @MoYs = qw(led �nor b�e dub kv� �vn �ec srp z�� ��j lis pro); @MoY2 = @MoY; for (@MoY2) { s!en$!na! or s!ec$!ce! or s!ad$!adu! or s!or$!ora!; } @DoW = qw(ned�le pond�l� �ter� st�eda �tvrtek p�tek sobota); @DoWs = qw(Ne Po �t St �t P� So); @AMPM = qw(dop. odp.); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_d { $_[0]->[3] } sub format_m { $_[0]->[4] + 1 } sub format_o { $_[0]->[3] . '.' } sub format_Q { $MoY2[$_[0]->[4]] } sub time2str { my $ref = shift; my @a = @_; $a[0] =~ s/(%[do]\.?\s?)%B/$1%Q/; $ref->SUPER::time2str(@a); } sub strftime { my $ref = shift; my @a = @_; $a[0] =~ s/(%[do]\.?\s?)%B/$1%Q/; $ref->SUPER::time2str(@a); } 1; PK ! H� � � Date/Language/Sidama.pmnu �[��� ## ## Sidama tables ## package Date::Language::Sidama; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "0.99"; @DoW = qw(Sambata Sanyo Maakisanyo Roowe Hamuse Arbe Qidaame); @MoY = qw(January February March April May June July August September October November December); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(soodo hawwaro); @Dsuf = (qw(th st nd rd th th th th th th)) x 3; @Dsuf[11,12,13] = qw(th th th); @Dsuf[30,31] = qw(th st); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! |p�0� � Date/Language/Tigrinya.pmnu �[��� ## ## Tigrinya tables ## package Date::Language::Tigrinya; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.00"; @DoW = ( "\x{1230}\x{1295}\x{1260}\x{1275}", "\x{1230}\x{1291}\x{12ed}", "\x{1230}\x{1209}\x{1235}", "\x{1228}\x{1261}\x{12d5}", "\x{1213}\x{1219}\x{1235}", "\x{12d3}\x{122d}\x{1262}", "\x{1240}\x{12f3}\x{121d}" ); @MoY = ( "\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}", "\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}", "\x{121b}\x{122d}\x{127d}", "\x{12a4}\x{1355}\x{1228}\x{120d}", "\x{121c}\x{12ed}", "\x{1301}\x{1295}", "\x{1301}\x{120b}\x{12ed}", "\x{12a6}\x{1308}\x{1235}\x{1275}", "\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}", "\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}", "\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}", "\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}" ); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = ( "\x{1295}/\x{1230}", "\x{12F5}/\x{1230}" ); @Dsuf = ("\x{12ed}" x 31); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! ���J� � Date/Language/Amharic.pmnu �[��� ## ## Amharic tables ## package Date::Language::Amharic; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.00"; if ( $] >= 5.006 ) { @DoW = ( "\x{12a5}\x{1211}\x{12f5}", "\x{1230}\x{129e}", "\x{121b}\x{12ad}\x{1230}\x{129e}", "\x{1228}\x{1261}\x{12d5}", "\x{1210}\x{1219}\x{1235}", "\x{12d3}\x{122d}\x{1265}", "\x{1245}\x{12f3}\x{121c}" ); @MoY = ( "\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}", "\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}", "\x{121b}\x{122d}\x{127d}", "\x{12a4}\x{1355}\x{1228}\x{120d}", "\x{121c}\x{12ed}", "\x{1301}\x{1295}", "\x{1301}\x{120b}\x{12ed}", "\x{12a6}\x{1308}\x{1235}\x{1275}", "\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}", "\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}", "\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}", "\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}" ); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = ( "\x{1320}\x{12cb}\x{1275}", "\x{12a8}\x{1230}\x{12d3}\x{1275}" ); @Dsuf = ("\x{129b}" x 31); } else { @DoW = ( "እሑድ", "ሰኞ", "ማክሰኞ", "ረቡዕ", "ሐሙስ", "ዓርብ", "ቅዳሜ" ); @MoY = ( "ጃንዩወሪ", "ፌብሩወሪ", "ማርች", "ኤፕረል", "ሜይ", "ጁን", "ጁላይ", "ኦገስት", "ሴፕቴምበር", "ኦክተውበር", "ኖቬምበር", "ዲሴምበር" ); @DoWs = map { substr($_,0,9) } @DoW; @MoYs = map { substr($_,0,9) } @MoY; @AMPM = ( "ጠዋት", "ከሰዓት" ); @Dsuf = ("ኛ" x 31); } @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! U�!�> > Date/Language/Dutch.pmnu �[��� ## ## Dutch tables ## Contributed by Johannes la Poutre <jlpoutre@corp.nl.home.com> ## package Date::Language::Dutch; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.02"; @MoY = qw(januari februari maart april mei juni juli augustus september oktober november december); @MoYs = map(substr($_, 0, 3), @MoY); $MoYs[2] = 'mrt'; # mrt is more common (Frank Maas) @DoW = map($_ . "dag", qw(zon maan dins woens donder vrij zater)); @DoWs = map(substr($_, 0, 2), @DoW); # these aren't normally used... @AMPM = qw(VM NM); @Dsuf = ('e') x 31; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_o { sprintf("%2de",$_[0]->[3]) } 1; PK ! ���<� � Date/Language/Italian.pmnu �[��� ## ## Italian tables ## package Date::Language::Italian; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @MoY = qw(Gennaio Febbraio Marzo Aprile Maggio Giugno Luglio Agosto Settembre Ottobre Novembre Dicembre); @MoYs = qw(Gen Feb Mar Apr Mag Giu Lug Ago Set Ott Nov Dic); @DoW = qw(Domenica Lunedi Martedi Mercoledi Giovedi Venerdi Sabato); @DoWs = qw(Dom Lun Mar Mer Gio Ven Sab); use Date::Language::English (); @AMPM = @{Date::Language::English::AMPM}; @Dsuf = @{Date::Language::English::Dsuf}; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! ϣ�� Date/Language/German.pmnu �[��� ## ## German tables ## package Date::Language::German; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.02"; @MoY = qw(Januar Februar M�rz April Mai Juni Juli August September Oktober November Dezember); @MoYs = qw(Jan Feb M�r Apr Mai Jun Jul Aug Sep Okt Nov Dez); @DoW = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag); @DoWs = qw(Son Mon Die Mit Don Fre Sam); use Date::Language::English (); @AMPM = @{Date::Language::English::AMPM}; @Dsuf = @{Date::Language::English::Dsuf}; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_o { sprintf("%2d.",$_[0]->[3]) } 1; PK ! Ŵ�-� � Date/Language/Oromo.pmnu �[��� ## ## Oromo tables ## package Date::Language::Oromo; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "0.99"; @DoW = qw(Dilbata Wiixata Qibxata Roobii Kamiisa Jimaata Sanbata); @MoY = qw(Amajjii Guraandhala Bitooteessa Elba Caamsa Waxabajjii Adooleessa Hagayya Fuulbana Onkololeessa Sadaasa Muddee); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(WD WB); @Dsuf = (qw(th st nd rd th th th th th th)) x 3; @Dsuf[11,12,13] = qw(th th th); @Dsuf[30,31] = qw(th st); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! �t�qh h Date/Language/Russian.pmnu �[��� ## ## Russian tables ## ## Contributed by Danil Pismenny <dapi@mail.ru> package Date::Language::Russian; use vars qw(@ISA @DoW @DoWs @MoY @MoYs @MoY2 @AMPM %MoY %DoW $VERSION); @ISA = qw(Date::Language Date::Format::Generic); $VERSION = "1.01"; @MoY = qw(����� ������ ��� ������ �� ��� ��� ������ �������� ������� ������ ������); @MoY2 = qw(����� ������ ��� ������ �� ��� ��� ������ �������� ������� ������ ������); @MoYs = qw(��� ��� ��� ��� �� �� �� ��� ��� ��� ��� ���); @DoW = qw(����������� ������� ���� ������� ������ ������ �����������); @DoWs = qw(�� �� �� �� �� �� ��); @DoWs2 = qw(��� ��� ��� ��� ��� ��� ���); @AMPM = qw(�� ��); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_d { $_[0]->[3] } sub format_m { $_[0]->[4] + 1 } sub format_o { $_[0]->[3] . '.' } sub format_Q { $MoY2[$_[0]->[4]] } sub str2time { my ($self,$value) = @_; map {$value=~s/(\s|^)$DoWs2[$_](\s)/$DoWs[$_]$2/ig} (0..6); $value=~s/(\s+|^)��(\s+)/$1���$2/; return $self->SUPER::str2time($value); } 1; PK ! i[Wj� � Date/Language/Somali.pmnu �[��� ## ## Somali tables ## package Date::Language::Somali; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "0.99"; @DoW = qw(Axad Isniin Salaaso Arbaco Khamiis Jimco Sabti); @MoY = ( "Bisha Koobaad", "Bisha Labaad", "Bisha Saddexaad", "Bisha Afraad", "Bisha Shanaad", "Bisha Lixaad", "Bisha Todobaad", "Bisha Sideedaad", "Bisha Sagaalaad", "Bisha Tobnaad", "Bisha Kow iyo Tobnaad", "Bisha Laba iyo Tobnaad" ); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = ( "Kob", "Lab", "Sad", "Afr", "Sha", "Lix", "Tod", "Sid", "Sag", "Tob", "KIT", "LIT" ); @AMPM = qw(SN GN); @Dsuf = (qw(th st nd rd th th th th th th)) x 3; @Dsuf[11,12,13] = qw(th th th); @Dsuf[30,31] = qw(th st); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! 7��m� � Date/Language/Spanish.pmnu �[��� ## ## Spanish tables ## package Date::Language::Spanish; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.00"; @DoW = qw(domingo lunes martes mi�rcoles jueves viernes s�bado); @MoY = qw(enero febrero marzo abril mayo junio julio agosto septiembre octubre noviembre diciembre); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(AM PM); @Dsuf = ((qw(ro do ro to to to mo vo no mo)) x 3, 'ro'); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! f0��� � Date/Language/Norwegian.pmnu �[��� ## ## Norwegian tables ## package Date::Language::Norwegian; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @MoY = qw(Januar Februar Mars April Mai Juni Juli August September Oktober November Desember); @MoYs = qw(Jan Feb Mar Apr Mai Jun Jul Aug Sep Okt Nov Des); @DoW = qw(S�ndag Mandag Tirsdag Onsdag Torsdag Fredag L�rdag S�ndag); @DoWs = qw(S�n Man Tir Ons Tor Fre L�r S�n); use Date::Language::English (); @AMPM = @{Date::Language::English::AMPM}; @Dsuf = @{Date::Language::English::Dsuf}; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! ��� � Date/Language/English.pmnu �[��� ## ## English tables ## package Date::Language::English; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @DoW = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday); @MoY = qw(January February March April May June July August September October November December); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(AM PM); @Dsuf = (qw(th st nd rd th th th th th th)) x 3; @Dsuf[11,12,13] = qw(th th th); @Dsuf[30,31] = qw(th st); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! 4E&S� � Date/Language/Brazilian.pmnu �[��� ## ## Brazilian tables, contributed by Christian Tosta (tosta@cce.ufmg.br) ## package Date::Language::Brazilian; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @DoW = qw(Domingo Segunda Ter�a Quarta Quinta Sexta S�bado); @MoY = qw(Janeiro Fevereiro Mar�o Abril Maio Junho Julho Agosto Setembro Outubro Novembro Dezembro); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(AM PM); @Dsuf = (qw(mo ro do ro to to to mo vo no)) x 3; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! <6�p p ! Date/Language/TigrinyaEritrean.pmnu �[��� ## ## Tigrinya-Eritrean tables ## package Date::Language::TigrinyaEritrean; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.00"; if ( $] >= 5.006 ) { @DoW = ( "\x{1230}\x{1295}\x{1260}\x{1275}", "\x{1230}\x{1291}\x{12ed}", "\x{1230}\x{1209}\x{1235}", "\x{1228}\x{1261}\x{12d5}", "\x{1213}\x{1219}\x{1235}", "\x{12d3}\x{122d}\x{1262}", "\x{1240}\x{12f3}\x{121d}" ); @MoY = ( "\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}", "\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}", "\x{121b}\x{122d}\x{127d}", "\x{12a4}\x{1355}\x{1228}\x{120d}", "\x{121c}\x{12ed}", "\x{1301}\x{1295}", "\x{1301}\x{120b}\x{12ed}", "\x{12a6}\x{1308}\x{1235}\x{1275}", "\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}", "\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}", "\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}", "\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}" ); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = ( "\x{1295}/\x{1230}", "\x{12F5}/\x{1230}" ); @Dsuf = ("\x{12ed}" x 31); } else { @DoW = ( "ሰንበት", "ሰኑይ", "ሰሉስ", "ረቡዕ", "ሓሙስ", "ዓርቢ", "ቀዳም" ); @MoY = ( "ጥሪ", "ለካቲት", "መጋቢት", "ሚያዝያ", "ግንቦት", "ሰነ", "ሓምለ", "ነሓሰ", "መስከረም", "ጥቅምቲ", "ሕዳር", "ታሕሳስ" ); @DoWs = map { substr($_,0,9) } @DoW; @MoYs = map { substr($_,0,9) } @MoY; @AMPM = ( "ን/ሰ", "ድ/ሰ" ); @Dsuf = ("ይ" x 31); } @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! {K� Date/Language/Russian_koi8r.pmnu �[��� ## ## Russian koi8r ## package Date::Language::Russian_koi8r; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @DoW = qw(����������� ����������� ������� ���� ������� ������ ������); @MoY = qw(����� ������ ��� ������ �� ��� ��� ������ �������� ������� ������ ������); @DoWs = qw(��� ��� ��� ��� ��� ��� ���); #@DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(AM PM); @Dsuf = ('e') x 31; #@Dsuf[11,12,13] = qw(� � �); #@Dsuf[30,31] = qw(� �); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_o { sprintf("%2de",$_[0]->[3]) } 1; PK ! ?� Ob b Date/Language/Swedish.pmnu �[��� ## ## Swedish tables ## Contributed by Matthew Musgrove <muskrat@mindless.com> ## Corrected by dempa ## package Date::Language::Swedish; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @MoY = qw(januari februari mars april maj juni juli augusti september oktober november december); @MoYs = map { substr($_,0,3) } @MoY; @DoW = map($_ . "dagen", qw(s�n m�n tis ons tors fre l�r)); @DoWs = map { substr($_,0,2) } @DoW; # the ordinals are not typically used in modern times @Dsuf = ('a' x 2, 'e' x 29); use Date::Language::English (); @AMPM = @{Date::Language::English::AMPM}; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_o { sprintf("%2de",$_[0]->[3]) } 1; PK ! N�zz Date/Language/Afar.pmnu �[��� ## ## Afar tables ## package Date::Language::Afar; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "0.99"; @DoW = qw(Acaada Etleeni Talaata Arbaqa Kamiisi Gumqata Sabti); @MoY = ( "Qunxa Garablu", "Kudo", "Ciggilta Kudo", "Agda Baxis", "Caxah Alsa", "Qasa Dirri", "Qado Dirri", "Liiqen", "Waysu", "Diteli", "Ximoli", "Kaxxa Garablu" ); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(saaku carra); @Dsuf = (qw(th st nd rd th th th th th th)) x 3; @Dsuf[11,12,13] = qw(th th th); @Dsuf[30,31] = qw(th st); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! p½\� � Date/Language/French.pmnu �[��� ## ## French tables, contributed by Emmanuel Bataille (bem@residents.frmug.org) ## package Date::Language::French; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.04"; @DoW = qw(dimanche lundi mardi mercredi jeudi vendredi samedi); @MoY = qw(janvier f�vrier mars avril mai juin juillet ao�t septembre octobre novembre d�cembre); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; $MoYs[6] = 'jul'; @AMPM = qw(AM PM); @Dsuf = ((qw(er e e e e e e e e e)) x 3, 'er'); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_o { $_[0]->[3] } 1; PK ! �po� � " Date/Language/TigrinyaEthiopian.pmnu �[��� ## ## Tigrinya-Ethiopian tables ## package Date::Language::TigrinyaEthiopian; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.00"; if ( $] >= 5.006 ) { @DoW = ( "\x{1230}\x{1295}\x{1260}\x{1275}", "\x{1230}\x{1291}\x{12ed}", "\x{1230}\x{1209}\x{1235}", "\x{1228}\x{1261}\x{12d5}", "\x{1213}\x{1219}\x{1235}", "\x{12d3}\x{122d}\x{1262}", "\x{1240}\x{12f3}\x{121d}" ); @MoY = ( "\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}", "\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}", "\x{121b}\x{122d}\x{127d}", "\x{12a4}\x{1355}\x{1228}\x{120d}", "\x{121c}\x{12ed}", "\x{1301}\x{1295}", "\x{1301}\x{120b}\x{12ed}", "\x{12a6}\x{1308}\x{1235}\x{1275}", "\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}", "\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}", "\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}", "\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}" ); @DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = ( "\x{1295}/\x{1230}", "\x{12F5}/\x{1230}" ); @Dsuf = ("\x{12ed}" x 31); } else { @DoW = ( "ሰንበት", "ሰኑይ", "ሰሉስ", "ረቡዕ", "ሓሙስ", "ዓርቢ", "ቀዳም" ); @MoY = ( "ጃንዩወሪ", "ፌብሩወሪ", "ማርች", "ኤፕረል", "ሜይ", "ጁን", "ጁላይ", "ኦገስት", "ሴፕቴምበር", "ኦክተውበር", "ኖቬምበር", "ዲሴምበር" ); @DoWs = map { substr($_,0,9) } @DoW; @MoYs = map { substr($_,0,9) } @MoY; @AMPM = ( "ን/ሰ", "ድ/ሰ" ); @Dsuf = ("ይ" x 31); } @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! ��"h Date/Language/Russian_cp1251.pmnu �[��� ## ## Russian cp1251 ## package Date::Language::Russian_cp1251; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @DoW = qw(���������� ���������� ������� ����� ������� ����� �������); @MoY = qw(����� ������ ���� ����� ��� �� �� ������ ������ ����� ���� ������); @DoWs = qw(��� ��� ��� ��� ��� ��� ���); #@DoWs = map { substr($_,0,3) } @DoW; @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(AM PM); @Dsuf = ('e') x 31; #@Dsuf[11,12,13] = qw(� � �); #@Dsuf[30,31] = qw(� �); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_o { sprintf("%2de",$_[0]->[3]) } 1; PK ! ��D`� � Date/Language/Finnish.pmnu �[��� ## ## Finnish tables ## Contributed by Matthew Musgrove <muskrat@mindless.com> ## Corrected by roke ## package Date::Language::Finnish; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; # In Finnish, the names of the months and days are only capitalized at the beginning of sentences. @MoY = map($_ . "kuu", qw(tammi helmi maalis huhti touko kes� hein� elo syys loka marras joulu)); @DoW = qw(sunnuntai maanantai tiistai keskiviikko torstai perjantai lauantai); # it is not customary to use abbreviated names of months or days # per Graham's suggestion: @MoYs = @MoY; @DoWs = @DoW; # the short form of ordinals @Dsuf = ('.') x 31; # doesn't look like this is normally used... @AMPM = qw(ap ip); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_o { sprintf("%2de",$_[0]->[3]) } 1;PK ! �_b Date/Language/Turkish.pmnu �[��� #----------------------------------------------------# # # Turkish tables # Burak G�rsoy <burak@cpan.org> # Last modified: Sat Nov 15 20:28:32 2003 # # use Date::Language; # my $turkish = Date::Language->new('Turkish'); # print $turkish->time2str("%e %b %Y, %a %T\n", time); # print $turkish->str2time("25 Haz 1996 21:09:55 +0100"); #----------------------------------------------------# package Date::Language::Turkish; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION %DsufMAP); @ISA = qw(Date::Language); $VERSION = "1.0"; @DoW = qw(Pazar Pazartesi Sal� �ar�amba Per�embe Cuma Cumartesi); @MoY = qw(Ocak �ubat Mart Nisan May�s Haziran Temmuz A�ustos Eyl�l Ekim Kas�m Aral�k); @DoWs = map { substr($_,0,3) } @DoW; $DoWs[1] = 'Pzt'; # Since we'll get two 'Paz' s $DoWs[-1] = 'Cmt'; # Since we'll get two 'Cum' s @MoYs = map { substr($_,0,3) } @MoY; @AMPM = ('',''); # no am-pm thingy # not easy as in english... maybe we can just use a dot "." ? :) %DsufMAP = ( (map {$_ => 'inci', $_+10 => 'inci', $_+20 => 'inci' } 1,2,5,8 ), (map {$_ => 'nci', $_+10 => 'nci', $_+20 => 'nci' } 7 ), (map {$_ => 'nci', $_+10 => 'nci', $_+20 => 'nci' } 2 ), (map {$_ => '�nc�', $_+10 => '�nc�', $_+20 => '�nc�' } 3,4 ), (map {$_ => 'uncu', $_+10 => 'uncu', $_+20 => 'uncu' } 9 ), (map {$_ => 'nc�', $_+10 => 'nc�', $_+20 => 'nc�' } 6 ), (map {$_ => 'uncu', } 10,30 ), 20 => 'nci', 31 => 'inci', ); @Dsuf = map{ $DsufMAP{$_} } sort {$a <=> $b} keys %DsufMAP; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[ $_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[ $_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { '' } # disable sub format_P { '' } # disable sub format_o { sprintf("%2d%s",$_[0]->[3],$Dsuf[$_[0]->[3]-1]) } 1; __END__ PK ! �73 � � Date/Language/Chinese_GB.pmnu �[��� ## ## English tables ## package Date::Language::Chinese_GB; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @DoW = qw(������ ����һ ���ڶ� ����� ������ ������ �����); @MoY = qw(һ�� ���� ��� ���� ���� ���� ���� ���� ���� ʮ�� ʮһ�� ʮ����); @DoWs = map { $_ } @DoW; @MoYs = map { $_ } @MoY; @AMPM = qw(���� ����); @Dsuf = (qw(�� �� �� �� �� �� �� �� �� ��)) x 3; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_o { sprintf("%2d%s",$_[0]->[3],"��") } 1; PK ! ��� � Date/Language/Chinese.pmnu �[��� ## ## English tables ## package Date::Language::Chinese; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.00"; @DoW = qw(星期日 星期一 星期二 星期三 星期四 星期五 星期六); @MoY = qw(一月 二月 三月 四月 五月 六月 七月 八月 九月 十月 十一月 十二月); @DoWs = map { $_ } @DoW; @MoYs = map { $_ } @MoY; @AMPM = qw(上午 下午); @Dsuf = (qw(日 日 日 日 日 日 日 日 日 日)) x 3; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_o { sprintf("%2d%s",$_[0]->[3],"日") } 1; PK ! ��C� Date/Language/Icelandic.pmnu �[��� ## ## Icelandic tables ## package Date::Language::Icelandic; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @MoY = qw(Jan�ar Febr�ar Mars Apr�l Ma� J�ni J�li �g�st September Okt�ber N�vember Desember); @MoYs = qw(Jan Feb Mar Apr Ma� J�n J�l �g� Sep Okt N�v Des); @DoW = qw(Sunnudagur M�nudagur �ri�judagur Mi�vikudagur Fimmtudagur F�studagur Laugardagur Sunnudagur); @DoWs = qw(Sun M�n �ri Mi� Fim F�s Lau Sun); use Date::Language::English (); @AMPM = @{Date::Language::English::AMPM}; @Dsuf = @{Date::Language::English::Dsuf}; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! (!p Date/Language/Greek.pmnu �[��� ## ## Greek tables ## ## Traditional date format is: DoW DD{eta} MoY Year (%A %o %B %Y) ## ## Matthew Musgrove <muskrat@mindless.com> ## Translations gratiously provided by Menelaos Stamatelos <men@kwsn.net> ## This module returns unicode (utf8) encoded characters. You will need to ## take the necessary steps for this to display correctly. ## package Date::Language::Greek; use utf8; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.00"; @DoW = ( "\x{039a}\x{03c5}\x{03c1}\x{03b9}\x{03b1}\x{03ba}\x{03ae}", "\x{0394}\x{03b5}\x{03c5}\x{03c4}\x{03ad}\x{03c1}\x{03b1}", "\x{03a4}\x{03c1}\x{03af}\x{03c4}\x{03b7}", "\x{03a4}\x{03b5}\x{03c4}\x{03ac}\x{03c1}\x{03c4}\x{03b7}", "\x{03a0}\x{03ad}\x{03bc}\x{03c0}\x{03c4}\x{03b7}", "\x{03a0}\x{03b1}\x{03c1}\x{03b1}\x{03c3}\x{03ba}\x{03b5}\x{03c5}\x{03ae}", "\x{03a3}\x{03ac}\x{03b2}\x{03b2}\x{03b1}\x{03c4}\x{03bf}", ); @MoY = ( "\x{0399}\x{03b1}\x{03bd}\x{03bf}\x{03c5}\x{03b1}\x{03c1}\x{03af}\x{03bf}\x{03c5}", "\x{03a6}\x{03b5}\x{03b2}\x{03c1}\x{03bf}\x{03c5}\x{03b1}\x{03c1}\x{03af}\x{03bf}\x{03c5}", "\x{039c}\x{03b1}\x{03c1}\x{03c4}\x{03af}\x{03bf}\x{03c5}", "\x{0391}\x{03c0}\x{03c1}\x{03b9}\x{03bb}\x{03af}\x{03c5}", "\x{039c}\x{03b1}\x{0390}\x{03bf}\x{03c5}", "\x{0399}\x{03bf}\x{03c5}\x{03bd}\x{03af}\x{03bf}\x{03c5}", "\x{0399}\x{03bf}\x{03c5}\x{03bb}\x{03af}\x{03bf}\x{03c5}", "\x{0391}\x{03c5}\x{03b3}\x{03bf}\x{03cd}\x{03c3}\x{03c4}\x{03bf}\x{03c5}", "\x{03a3}\x{03b5}\x{03c0}\x{03c4}\x{03b5}\x{03bc}\x{03c4}\x{03bf}\x{03c5}", "\x{039f}\x{03ba}\x{03c4}\x{03c9}\x{03b2}\x{03c1}\x{03af}\x{03bf}\x{03c5}", "\x{039d}\x{03bf}\x{03b5}\x{03bc}\x{03b2}\x{03c1}\x{03af}\x{03bf}\x{03c5}", "\x{0394}\x{03b5}\x{03ba}\x{03b5}\x{03bc}\x{03b2}\x{03c1}\x{03bf}\x{03c5}", ); @DoWs = ( "\x{039a}\x{03c5}", "\x{0394}\x{03b5}", "\x{03a4}\x{03c1}", "\x{03a4}\x{03b5}", "\x{03a0}\x{03b5}", "\x{03a0}\x{03b1}", "\x{03a3}\x{03b1}", ); @MoYs = ( "\x{0399}\x{03b1}\x{03bd}", "\x{03a6}\x{03b5}", "\x{039c}\x{03b1}\x{03c1}", "\x{0391}\x{03c0}\x{03c1}", "\x{039c}\x{03b1}", "\x{0399}\x{03bf}\x{03c5}\x{03bd}", "\x{0399}\x{03bf}\x{03c5}\x{03bb}", "\x{0391}\x{03c5}\x{03b3}", "\x{03a3}\x{03b5}\x{03c0}", "\x{039f}\x{03ba}", "\x{039d}\x{03bf}", "\x{0394}\x{03b5}", ); @AMPM = ("\x{03c0}\x{03bc}", "\x{03bc}\x{03bc}"); @Dsuf = ("\x{03b7}" x 31); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_o { sprintf("%2d%s",$_[0]->[3],"\x{03b7}") } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! ���� Date/Language/Bulgarian.pmnu �[��� ## ## Bulgarian tables contributed by Krasimir Berov ## package Date::Language::Bulgarian; use strict; use warnings; use utf8; use base qw(Date::Language); our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW, $VERSION); $VERSION = "1.01"; @DoW = qw(неделя понеделник вторник сряда четвъртък петък събота); @MoY = qw(януари февруари март април май юни юли август септември октомври ноември декември); @DoWs = qw(нд пн вт ср чт пт сб); @MoYs = map { substr($_,0,3) } @MoY; @AMPM = qw(AM PM); @Dsuf = (qw(ти ви ри ти ти ти ти ми ми ти)) x 3; @Dsuf[11,12,13] = qw(ти ти ти); @Dsuf[30,31] = qw(ти ви); @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } sub format_o { ($_[0]->[3]<10?' ':'').$_[0]->[3].$Dsuf[$_[0]->[3]] } 1; __END__ =encoding utf8 =head1 NAME Date::Language::Bulgarian - localization for Date::Format =head1 DESCRIPTION This is Bulgarian localization for Date::Format. It is important to note that this module source code is in utf8. All strings which it outputs are in utf8, so it is safe to use it currently only with English. You are left alone to try and convert the output when using different Date::Language::* in the same application. This should be addresed in the future. =head1 SYNOPSIS use strict; use warnings; use Date::Language; local $\=$/; my $template ='%a %b %e %T %Y (%Y-%m-%d %H:%M:%S)'; my $time=1290883821; #or just use time(); my @lt = localtime($time); my %languages = qw(English GMT German EEST Bulgarian EET); binmode(select,':utf8'); foreach my $l(keys %languages){ my $lang = Date::Language->new($l); my $zone = $languages{$l}; print $/. "$l $zone"; print $lang->time2str($template, $time); print $lang->time2str($template, $time, $zone); print $lang->strftime($template, \@lt); } =head1 AUTHOR Krasimir Berov (berov@cpan.org) =head1 COPYRIGHT Copyright (c) 2010 Krasimir Berov. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! � �� Date/Language/Danish.pmnu �[��� ## ## Danish tables ## package Date::Language::Danish; use Date::Language (); use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION); @ISA = qw(Date::Language); $VERSION = "1.01"; @MoY = qw(Januar Februar Marts April Maj Juni Juli August September Oktober November December); @MoYs = qw(Jan Feb Mar Apr Maj Jun Jul Aug Sep Okt Nov Dec); @DoW = qw(S�ndag Mandag Tirsdag Onsdag Torsdag Fredag L�rdag S�ndag); @DoWs = qw(S�n Man Tir Ons Tor Fre L�r S�n); use Date::Language::English (); @AMPM = @{Date::Language::English::AMPM}; @Dsuf = @{Date::Language::English::Dsuf}; @MoY{@MoY} = (0 .. scalar(@MoY)); @MoY{@MoYs} = (0 .. scalar(@MoYs)); @DoW{@DoW} = (0 .. scalar(@DoW)); @DoW{@DoWs} = (0 .. scalar(@DoWs)); # Formatting routines sub format_a { $DoWs[$_[0]->[6]] } sub format_A { $DoW[$_[0]->[6]] } sub format_b { $MoYs[$_[0]->[4]] } sub format_B { $MoY[$_[0]->[4]] } sub format_h { $MoYs[$_[0]->[4]] } sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] } 1; PK ! U�N��# �# Date/Parse.pmnu �[��� # Copyright (c) 1995-2009 Graham Barr. This program is free # software; you can redistribute it and/or modify it under the same terms # as Perl itself. package Date::Parse; require 5.000; use strict; use vars qw($VERSION @ISA @EXPORT); use Time::Local; use Carp; use Time::Zone; use Exporter; @ISA = qw(Exporter); @EXPORT = qw(&strtotime &str2time &strptime); $VERSION = "2.33"; my %month = ( january => 0, february => 1, march => 2, april => 3, may => 4, june => 5, july => 6, august => 7, september => 8, sept => 8, october => 9, november => 10, december => 11, ); my %day = ( sunday => 0, monday => 1, tuesday => 2, tues => 2, wednesday => 3, wednes => 3, thursday => 4, thur => 4, thurs => 4, friday => 5, saturday => 6, ); my @suf = (qw(th st nd rd th th th th th th)) x 3; @suf[11,12,13] = qw(th th th); #Abbreviations map { $month{substr($_,0,3)} = $month{$_} } keys %month; map { $day{substr($_,0,3)} = $day{$_} } keys %day; my $strptime = <<'ESQ'; my %month = map { lc $_ } %$mon_ref; my $daypat = join("|", map { lc $_ } reverse sort keys %$day_ref); my $monpat = join("|", reverse sort keys %month); my $sufpat = join("|", reverse sort map { lc $_ } @$suf_ref); my %ampm = ( 'a' => 0, # AM 'p' => 12, # PM ); my($AM, $PM) = (0,12); sub { my $dtstr = lc shift; my $merid = 24; my($century,$year,$month,$day,$hh,$mm,$ss,$zone,$dst,$frac); $zone = tz_offset(shift) if @_; 1 while $dtstr =~ s#\([^\(\)]*\)# #o; $dtstr =~ s#(\A|\n|\Z)# #sog; # ignore day names $dtstr =~ s#([\d\w\s])[\.\,]\s#$1 #sog; $dtstr =~ s/,/ /g; $dtstr =~ s#($daypat)\s*(den\s)?\b# #o; # Time: 12:00 or 12:00:00 with optional am/pm return unless $dtstr =~ /\S/; if ($dtstr =~ s/\s(\d{4})([-:]?)(\d\d?)\2(\d\d?)(?:[-Tt ](\d\d?)(?:([-:]?)(\d\d?)(?:\6(\d\d?)(?:[.,](\d+))?)?)?)?(?=\D)/ /) { ($year,$month,$day,$hh,$mm,$ss,$frac) = ($1,$3-1,$4,$5,$7,$8,$9); } unless (defined $hh) { if ($dtstr =~ s#[:\s](\d\d?):(\d\d?)(:(\d\d?)(?:\.\d+)?)?(z)?\s*(?:([ap])\.?m?\.?)?\s# #o) { ($hh,$mm,$ss) = ($1,$2,$4); $zone = 0 if $5; $merid = $ampm{$6} if $6; } # Time: 12 am elsif ($dtstr =~ s#\s(\d\d?)\s*([ap])\.?m?\.?\s# #o) { ($hh,$mm,$ss) = ($1,0,0); $merid = $ampm{$2}; } } if (defined $hh and $hh <= 12 and $dtstr =~ s# ([ap])\.?m?\.?\s# #o) { $merid = $ampm{$1}; } unless (defined $year) { # Date: 12-June-96 (using - . or /) if ($dtstr =~ s#\s(\d\d?)([\-\./])($monpat)(\2(\d\d+))?\s# #o) { ($month,$day) = ($month{$3},$1); $year = $5 if $5; } # Date: 12-12-96 (using '-', '.' or '/' ) elsif ($dtstr =~ s#\s(\d+)([\-\./])(\d\d?)(\2(\d+))?\s# #o) { ($month,$day) = ($1 - 1,$3); if ($5) { $year = $5; # Possible match for 1995-01-24 (short mainframe date format); ($year,$month,$day) = ($1, $3 - 1, $5) if $month > 12; return if length($year) > 2 and $year < 1901; } } elsif ($dtstr =~ s#\s(\d+)\s*($sufpat)?\s*($monpat)# #o) { ($month,$day) = ($month{$3},$1); } elsif ($dtstr =~ s#($monpat)\s*(\d+)\s*($sufpat)?\s# #o) { ($month,$day) = ($month{$1},$2); } elsif ($dtstr =~ s#($monpat)([\/-])(\d+)[\/-]# #o) { ($month,$day) = ($month{$1},$3); } # Date: 961212 elsif ($dtstr =~ s#\s(\d\d)(\d\d)(\d\d)\s# #o) { ($year,$month,$day) = ($1,$2-1,$3); } $year = $1 if !defined($year) and $dtstr =~ s#\s(\d{2}(\d{2})?)[\s\.,]# #o; } # Zone $dst = 1 if $dtstr =~ s#\bdst\b##o; if ($dtstr =~ s#\s"?([a-z]{3,4})(dst|\d+[a-z]*|_[a-z]+)?"?\s# #o) { $dst = 1 if $2 and $2 eq 'dst'; $zone = tz_offset($1); return unless defined $zone; } elsif ($dtstr =~ s#\s([a-z]{3,4})?([\-\+]?)-?(\d\d?):?(\d\d)?(00)?\s# #o) { my $m = defined($4) ? "$2$4" : 0; my $h = "$2$3"; $zone = defined($1) ? tz_offset($1) : 0; return unless defined $zone; $zone += 60 * ($m + (60 * $h)); } if ($dtstr =~ /\S/) { # now for some dumb dates if ($dtstr =~ s/^\s*(ut?|z)\s*$//) { $zone = 0; } elsif ($dtstr =~ s#\s([a-z]{3,4})?([\-\+]?)-?(\d\d?)(\d\d)?(00)?\s# #o) { my $m = defined($4) ? "$2$4" : 0; my $h = "$2$3"; $zone = defined($1) ? tz_offset($1) : 0; return unless defined $zone; $zone += 60 * ($m + (60 * $h)); } return if $dtstr =~ /\S/o; } if (defined $hh) { if ($hh == 12) { $hh = 0 if $merid == $AM; } elsif ($merid == $PM) { $hh += 12; } } if (defined $year && $year > 1900) { $century = int($year / 100); $year -= 1900; } $zone += 3600 if defined $zone && $dst; $ss += "0.$frac" if $frac; return ($ss,$mm,$hh,$day,$month,$year,$zone,$century); } ESQ use vars qw($day_ref $mon_ref $suf_ref $obj); sub gen_parser { local($day_ref,$mon_ref,$suf_ref,$obj) = @_; if($obj) { my $obj_strptime = $strptime; substr($obj_strptime,index($strptime,"sub")+6,0) = <<'ESQ'; shift; # package ESQ my $sub = eval "$obj_strptime" or die $@; return $sub; } eval "$strptime" or die $@; } *strptime = gen_parser(\%day,\%month,\@suf); sub str2time { my @t = strptime(@_); return undef unless @t; my($ss,$mm,$hh,$day,$month,$year,$zone, $century) = @t; my @lt = localtime(time); $hh ||= 0; $mm ||= 0; $ss ||= 0; my $frac = $ss - int($ss); $ss = int $ss; $month = $lt[4] unless(defined $month); $day = $lt[3] unless(defined $day); $year = ($month > $lt[4]) ? ($lt[5] - 1) : $lt[5] unless(defined $year); # we were given a 4 digit year, so let's keep using those $year += 1900 if defined $century; return undef unless($month <= 11 && $day >= 1 && $day <= 31 && $hh <= 23 && $mm <= 59 && $ss <= 59); my $result; if (defined $zone) { $result = eval { local $SIG{__DIE__} = sub {}; # Ick! timegm($ss,$mm,$hh,$day,$month,$year); }; return undef if !defined $result or $result == -1 && join("",$ss,$mm,$hh,$day,$month,$year) ne "595923311169"; $result -= $zone; } else { $result = eval { local $SIG{__DIE__} = sub {}; # Ick! timelocal($ss,$mm,$hh,$day,$month,$year); }; return undef if !defined $result or $result == -1 && join("",$ss,$mm,$hh,$day,$month,$year) ne join("",(localtime(-1))[0..5]); } return $result + $frac; } 1; __END__ =head1 NAME Date::Parse - Parse date strings into time values =head1 SYNOPSIS use Date::Parse; $time = str2time($date); ($ss,$mm,$hh,$day,$month,$year,$zone) = strptime($date); =head1 DESCRIPTION C<Date::Parse> provides two routines for parsing date strings into time values. =over 4 =item str2time(DATE [, ZONE]) C<str2time> parses C<DATE> and returns a unix time value, or undef upon failure. C<ZONE>, if given, specifies the timezone to assume when parsing if the date string does not specify a timezone. =item strptime(DATE [, ZONE]) C<strptime> takes the same arguments as str2time but returns an array of values C<($ss,$mm,$hh,$day,$month,$year,$zone,$century)>. Elements are only defined if they could be extracted from the date string. The C<$zone> element is the timezone offset in seconds from GMT. An empty array is returned upon failure. =back =head1 MULTI-LANGUAGE SUPPORT Date::Parse is capable of parsing dates in several languages, these include English, French, German and Italian. $lang = Date::Language->new('German'); $lang->str2time("25 Jun 1996 21:09:55 +0100"); =head1 EXAMPLE DATES Below is a sample list of dates that are known to be parsable with Date::Parse 1995:01:24T09:08:17.1823213 ISO-8601 1995-01-24T09:08:17.1823213 Wed, 16 Jun 94 07:29:35 CST Comma and day name are optional Thu, 13 Oct 94 10:13:13 -0700 Wed, 9 Nov 1994 09:50:32 -0500 (EST) Text in ()'s will be ignored. 21 dec 17:05 Will be parsed in the current time zone 21-dec 17:05 21/dec 17:05 21/dec/93 17:05 1999 10:02:18 "GMT" 16 Nov 94 22:28:20 PST =head1 LIMITATION Date::Parse uses L<Time::Local> internally, so is limited to only parsing dates which result in valid values for Time::Local::timelocal. This generally means dates between 1901-12-17 00:00:00 GMT and 2038-01-16 23:59:59 GMT =head1 BUGS When both the month and the date are specified in the date as numbers they are always parsed assuming that the month number comes before the date. This is the usual format used in American dates. The reason why it is like this and not dynamic is that it must be deterministic. Several people have suggested using the current locale, but this will not work as the date being parsed may not be in the format of the current locale. My plans to address this, which will be in a future release, is to allow the programmer to state what order they want these values parsed in. =head1 AUTHOR Graham Barr <gbarr@pobox.com> =head1 COPYRIGHT Copyright (c) 1995-2009 Graham Barr. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! �� Wl l Date/Language.pmnu �[��� package Date::Language; use strict; use Time::Local; use Carp; use vars qw($VERSION @ISA); require Date::Format; $VERSION = "1.10"; @ISA = qw(Date::Format::Generic); sub new { my $self = shift; my $type = shift || $self; $type =~ s/^(\w+)$/Date::Language::$1/; croak "Bad language" unless $type =~ /^[\w:]+$/; eval "require $type" or croak $@; bless [], $type; } # Stop AUTOLOAD being called ;-) sub DESTROY {} sub AUTOLOAD { use vars qw($AUTOLOAD); if($AUTOLOAD =~ /::strptime\Z/o) { my $self = $_[0]; my $type = ref($self) || $self; require Date::Parse; no strict 'refs'; *{"${type}::strptime"} = Date::Parse::gen_parser( \%{"${type}::DoW"}, \%{"${type}::MoY"}, \@{"${type}::Dsuf"}, 1); goto &{"${type}::strptime"}; } croak "Undefined method &$AUTOLOAD called"; } sub str2time { my $me = shift; my @t = $me->strptime(@_); return undef unless @t; my($ss,$mm,$hh,$day,$month,$year,$zone) = @t; my @lt = localtime(time); $hh ||= 0; $mm ||= 0; $ss ||= 0; $month = $lt[4] unless(defined $month); $day = $lt[3] unless(defined $day); $year = ($month > $lt[4]) ? ($lt[5] - 1) : $lt[5] unless(defined $year); return defined $zone ? timegm($ss,$mm,$hh,$day,$month,$year) - $zone : timelocal($ss,$mm,$hh,$day,$month,$year); } 1; __END__ =head1 NAME Date::Language - Language specific date formating and parsing =head1 SYNOPSIS use Date::Language; my $lang = Date::Language->new('German'); $lang->time2str("%a %b %e %T %Y\n", time); =head1 DESCRIPTION L<Date::Language> provides objects to parse and format dates for specific languages. Available languages are Afar French Russian_cp1251 Amharic Gedeo Russian_koi8r Austrian German Sidama Brazilian Greek Somali Chinese Hungarian Spanish Chinese_GB Icelandic Swedish Czech Italian Tigrinya Danish Norwegian TigrinyaEritrean Dutch Oromo TigrinyaEthiopian English Romanian Turkish Finnish Russian Bulgarian Occitan =head1 METHODS =over =item time2str See L<Date::Format/time2str> =item strftime See L<Date::Format/strftime> =item ctime See L<Date::Format/ctime> =item asctime See L<Date::Format/asctime> =item str2time See L<Date::Parse/str2time> =item strptime See L<Date::Parse/strptime> =back PK ! �����L �L IO/HTML.pmnu �[��� #--------------------------------------------------------------------- package IO::HTML; # # Copyright 2020 Christopher J. Madsen # # Author: Christopher J. Madsen <perl@cjmweb.net> # Created: 14 Jan 2012 # # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the # GNU General Public License or the Artistic License for more details. # # ABSTRACT: Open an HTML file with automatic charset detection #--------------------------------------------------------------------- use 5.008; use strict; use warnings; use Carp 'croak'; use Encode 2.10 qw(decode find_encoding); # need utf-8-strict encoding use Exporter 5.57 'import'; our $VERSION = '1.004'; # This file is part of IO-HTML 1.004 (September 26, 2020) our $bytes_to_check ||= 1024; our $default_encoding ||= 'cp1252'; our @EXPORT = qw(html_file); our @EXPORT_OK = qw(find_charset_in html_file_and_encoding html_outfile sniff_encoding); our %EXPORT_TAGS = ( rw => [qw( html_file html_file_and_encoding html_outfile )], all => [ @EXPORT, @EXPORT_OK ], ); #===================================================================== sub html_file { (&html_file_and_encoding)[0]; # return just the filehandle } # end html_file # Note: I made html_file and html_file_and_encoding separate functions # (instead of making html_file context-sensitive) because I wanted to # use html_file in function calls (i.e. list context) without having # to write "scalar html_file" all the time. sub html_file_and_encoding { my ($filename, $options) = @_; $options ||= {}; open(my $in, '<:raw', $filename) or croak "Failed to open $filename: $!"; my ($encoding, $bom) = sniff_encoding($in, $filename, $options); if (not defined $encoding) { croak "No default encoding specified" unless defined($encoding = $default_encoding); $encoding = find_encoding($encoding) if $options->{encoding}; } # end if we didn't find an encoding binmode $in, sprintf(":encoding(%s):crlf", $options->{encoding} ? $encoding->name : $encoding); return ($in, $encoding, $bom); } # end html_file_and_encoding #--------------------------------------------------------------------- sub html_outfile { my ($filename, $encoding, $bom) = @_; if (not defined $encoding) { croak "No default encoding specified" unless defined($encoding = $default_encoding); } # end if we didn't find an encoding elsif (ref $encoding) { $encoding = $encoding->name; } open(my $out, ">:encoding($encoding)", $filename) or croak "Failed to open $filename: $!"; print $out "\x{FeFF}" if $bom; return $out; } # end html_outfile #--------------------------------------------------------------------- sub sniff_encoding { my ($in, $filename, $options) = @_; $filename = 'file' unless defined $filename; $options ||= {}; my $pos = tell $in; croak "Could not seek $filename: $!" if $pos < 0; croak "Could not read $filename: $!" unless defined read $in, my($buf), $bytes_to_check; seek $in, $pos, 0 or croak "Could not seek $filename: $!"; # Check for BOM: my $bom; my $encoding = do { if ($buf =~ /^\xFe\xFF/) { $bom = 2; 'UTF-16BE'; } elsif ($buf =~ /^\xFF\xFe/) { $bom = 2; 'UTF-16LE'; } elsif ($buf =~ /^\xEF\xBB\xBF/) { $bom = 3; 'utf-8-strict'; } else { find_charset_in($buf, $options); # check for <meta charset> } }; # end $encoding if ($bom) { seek $in, $bom, 1 or croak "Could not seek $filename: $!"; $bom = 1; } elsif (not defined $encoding) { # try decoding as UTF-8 my $test = decode('utf-8-strict', $buf, Encode::FB_QUIET); if ($buf =~ /^(?: # nothing left over | [\xC2-\xDF] # incomplete 2-byte char | [\xE0-\xEF] [\x80-\xBF]? # incomplete 3-byte char | [\xF0-\xF4] [\x80-\xBF]{0,2} # incomplete 4-byte char )\z/x and $test =~ /[^\x00-\x7F]/) { $encoding = 'utf-8-strict'; } # end if valid UTF-8 with at least one multi-byte character: } # end if testing for UTF-8 if (defined $encoding and $options->{encoding} and not ref $encoding) { $encoding = find_encoding($encoding); } # end if $encoding is a string and we want an object return wantarray ? ($encoding, $bom) : $encoding; } # end sniff_encoding #===================================================================== # Based on HTML5 8.2.2.2 Determining the character encoding: # Get attribute from current position of $_ sub _get_attribute { m!\G[\x09\x0A\x0C\x0D /]+!gc; # skip whitespace or / return if /\G>/gc or not /\G(=?[^\x09\x0A\x0C\x0D =]*)/gc; my ($name, $value) = (lc $1, ''); if (/\G[\x09\x0A\x0C\x0D ]*=[\x09\x0A\x0C\x0D ]*/gc) { if (/\G"/gc) { # Double-quoted attribute value /\G([^"]*)("?)/gc; return unless $2; # Incomplete attribute (missing closing quote) $value = lc $1; } elsif (/\G'/gc) { # Single-quoted attribute value /\G([^']*)('?)/gc; return unless $2; # Incomplete attribute (missing closing quote) $value = lc $1; } else { # Unquoted attribute value /\G([^\x09\x0A\x0C\x0D >]*)/gc; $value = lc $1; } } # end if attribute has value return wantarray ? ($name, $value) : 1; } # end _get_attribute # Examine a meta value for a charset: sub _get_charset_from_meta { for (shift) { while (/charset[\x09\x0A\x0C\x0D ]*=[\x09\x0A\x0C\x0D ]*/ig) { return $1 if (/\G"([^"]*)"/gc or /\G'([^']*)'/gc or /\G(?!['"])([^\x09\x0A\x0C\x0D ;]+)/gc); } } # end for value return undef; } # end _get_charset_from_meta #--------------------------------------------------------------------- sub find_charset_in { for (shift) { my $options = shift || {}; # search only the first $bytes_to_check bytes (default 1024) my $stop = length > $bytes_to_check ? $bytes_to_check : length; my $expect_pragma = (defined $options->{need_pragma} ? $options->{need_pragma} : 1); pos() = 0; while (pos() < $stop) { if (/\G<!--.*?(?<=--)>/sgc) { } # Skip comment elsif (m!\G<meta(?=[\x09\x0A\x0C\x0D /])!gic) { my ($got_pragma, $need_pragma, $charset); while (my ($name, $value) = &_get_attribute) { if ($name eq 'http-equiv' and $value eq 'content-type') { $got_pragma = 1; } elsif ($name eq 'content' and not defined $charset) { $need_pragma = $expect_pragma if defined($charset = _get_charset_from_meta($value)); } elsif ($name eq 'charset') { $charset = $value; $need_pragma = 0; } } # end while more attributes in this <meta> tag if (defined $need_pragma and (not $need_pragma or $got_pragma)) { $charset = 'UTF-8' if $charset =~ /^utf-?16/; $charset = 'cp1252' if $charset eq 'iso-8859-1'; # people lie if (my $encoding = find_encoding($charset)) { return $options->{encoding} ? $encoding : $encoding->name; } # end if charset is a recognized encoding } # end if found charset } # end elsif <meta elsif (m!\G</?[a-zA-Z][^\x09\x0A\x0C\x0D >]*!gc) { 1 while &_get_attribute; } # end elsif some other tag elsif (m{\G<[!/?][^>]*}gc) { } # skip unwanted things elsif (m/\G</gc) { } # skip < that doesn't open anything we recognize # Advance to the next <: m/\G[^<]+/gc; } # end while not at search boundary } # end for string return undef; # Couldn't find a charset } # end find_charset_in #--------------------------------------------------------------------- # Shortcuts for people who don't like exported functions: *file = \&html_file; *file_and_encoding = \&html_file_and_encoding; *outfile = \&html_outfile; #===================================================================== # Package Return Value: 1; __END__ =head1 NAME IO::HTML - Open an HTML file with automatic charset detection =head1 VERSION This document describes version 1.004 of IO::HTML, released September 26, 2020. =head1 SYNOPSIS use IO::HTML; # exports html_file by default use HTML::TreeBuilder; my $tree = HTML::TreeBuilder->new_from_file( html_file('foo.html') ); # Alternative interface: open(my $in, '<:raw', 'bar.html'); my $encoding = IO::HTML::sniff_encoding($in, 'bar.html'); =head1 DESCRIPTION IO::HTML provides an easy way to open a file containing HTML while automatically determining its encoding. It uses the HTML5 encoding sniffing algorithm specified in section 8.2.2.2 of the draft standard. The algorithm as implemented here is: =over =item 1. If the file begins with a byte order mark indicating UTF-16LE, UTF-16BE, or UTF-8, then that is the encoding. =item 2. If the first C<$bytes_to_check> bytes of the file contain a C<< <meta> >> tag that indicates the charset, and Encode recognizes the specified charset name, then that is the encoding. (This portion of the algorithm is implemented by C<find_charset_in>.) The C<< <meta> >> tag can be in one of two formats: <meta charset="..."> <meta http-equiv="Content-Type" content="...charset=..."> The search is case-insensitive, and the order of attributes within the tag is irrelevant. Any additional attributes of the tag are ignored. The first matching tag with a recognized encoding ends the search. =item 3. If the first C<$bytes_to_check> bytes of the file are valid UTF-8 (with at least 1 non-ASCII character), then the encoding is UTF-8. =item 4. If all else fails, use the default character encoding. The HTML5 standard suggests the default encoding should be locale dependent, but currently it is always C<cp1252> unless you set C<$IO::HTML::default_encoding> to a different value. Note: C<sniff_encoding> does not apply this step; only C<html_file> does that. =back =head1 SUBROUTINES =head2 html_file $filehandle = html_file($filename, \%options); This function (exported by default) is the primary entry point. It opens the file specified by C<$filename> for reading, uses C<sniff_encoding> to find a suitable encoding layer, and applies it. It also applies the C<:crlf> layer. If the file begins with a BOM, the filehandle is positioned just after the BOM. The optional second argument is a hashref containing options. The possible keys are described under C<find_charset_in>. If C<sniff_encoding> is unable to determine the encoding, it defaults to C<$IO::HTML::default_encoding>, which is set to C<cp1252> (a.k.a. Windows-1252) by default. According to the standard, the default should be locale dependent, but that is not currently implemented. It dies if the file cannot be opened, or if C<sniff_encoding> cannot determine the encoding and C<$IO::HTML::default_encoding> has been set to C<undef>. =head2 html_file_and_encoding ($filehandle, $encoding, $bom) = html_file_and_encoding($filename, \%options); This function (exported only by request) is just like C<html_file>, but returns more information. In addition to the filehandle, it returns the name of the encoding used, and a flag indicating whether a byte order mark was found (if C<$bom> is true, the file began with a BOM). This may be useful if you want to write the file out again (especially in conjunction with the C<html_outfile> function). The optional second argument is a hashref containing options. The possible keys are described under C<find_charset_in>. It dies if the file cannot be opened, or if C<sniff_encoding> cannot determine the encoding and C<$IO::HTML::default_encoding> has been set to C<undef>. The result of calling C<html_file_and_encoding> in scalar context is undefined (in the C sense of there is no guarantee what you'll get). =head2 html_outfile $filehandle = html_outfile($filename, $encoding, $bom); This function (exported only by request) opens C<$filename> for output using C<$encoding>, and writes a BOM to it if C<$bom> is true. If C<$encoding> is C<undef>, it defaults to C<$IO::HTML::default_encoding>. C<$encoding> may be either an encoding name or an Encode::Encoding object. It dies if the file cannot be opened, or if both C<$encoding> and C<$IO::HTML::default_encoding> are C<undef>. =head2 sniff_encoding ($encoding, $bom) = sniff_encoding($filehandle, $filename, \%options); This function (exported only by request) runs the HTML5 encoding sniffing algorithm on C<$filehandle> (which must be seekable, and should have been opened in C<:raw> mode). C<$filename> is used only for error messages (if there's a problem using the filehandle), and defaults to "file" if omitted. The optional third argument is a hashref containing options. The possible keys are described under C<find_charset_in>. It returns Perl's canonical name for the encoding, which is not necessarily the same as the MIME or IANA charset name. It returns C<undef> if the encoding cannot be determined. C<$bom> is true if the file began with a byte order mark. In scalar context, it returns only C<$encoding>. The filehandle's position is restored to its original position (normally the beginning of the file) unless C<$bom> is true. In that case, the position is immediately after the BOM. Tip: If you want to run C<sniff_encoding> on a file you've already loaded into a string, open an in-memory file on the string, and pass that handle: ($encoding, $bom) = do { open(my $fh, '<', \$string); sniff_encoding($fh) }; (This only makes sense if C<$string> contains bytes, not characters.) =head2 find_charset_in $encoding = find_charset_in($string_containing_HTML, \%options); This function (exported only by request) looks for charset information in a C<< <meta> >> tag in a possibly-incomplete HTML document using the "two step" algorithm specified by HTML5. It does not look for a BOM. The C<< <meta> >> tag must begin within the first C<$IO::HTML::bytes_to_check> bytes of the string. It returns Perl's canonical name for the encoding, which is not necessarily the same as the MIME or IANA charset name. It returns C<undef> if no charset is specified or if the specified charset is not recognized by the Encode module. The optional second argument is a hashref containing options. The following keys are recognized: =over =item C<encoding> If true, return the L<Encode::Encoding> object instead of its name. Defaults to false. =item C<need_pragma> If true (the default), follow the HTML5 spec and examine the C<content> attribute only of C<< <meta http-equiv="Content-Type" >>. If set to 0, relax the HTML5 spec, and look for "charset=" in the C<content> attribute of I<every> meta tag. =back =head1 EXPORTS By default, only C<html_file> is exported. Other functions may be exported on request. For people who prefer not to export functions, all functions beginning with C<html_> have an alias without that prefix (e.g. you can call C<IO::HTML::file(...)> instead of C<IO::HTML::html_file(...)>. These aliases are not exportable. =for Pod::Coverage file file_and_encoding outfile The following export tags are available: =over =item C<:all> All exportable functions. =item C<:rw> C<html_file>, C<html_file_and_encoding>, C<html_outfile>. =back =head1 SEE ALSO The HTML5 specification, section 8.2.2.2 Determining the character encoding: L<http://www.w3.org/TR/html5/syntax.html#determining-the-character-encoding> =head1 DIAGNOSTICS =over =item C<< Could not read %s: %s >> The specified file could not be read from for the reason specified by C<$!>. =item C<< Could not seek %s: %s >> The specified file could not be rewound for the reason specified by C<$!>. =item C<< Failed to open %s: %s >> The specified file could not be opened for reading for the reason specified by C<$!>. =item C<< No default encoding specified >> The C<sniff_encoding> algorithm didn't find an encoding to use, and you set C<$IO::HTML::default_encoding> to C<undef>. =back =head1 CONFIGURATION AND ENVIRONMENT There are two global variables that affect IO::HTML. If you need to change them, you should do so using C<local> if possible: my $file = do { # This file may define the charset later in the header local $IO::HTML::bytes_to_check = 4096; html_file(...); }; =over =item C<$bytes_to_check> This is the number of bytes that C<sniff_encoding> will read from the stream. It is also the number of bytes that C<find_charset_in> will search for a C<< <meta> >> tag containing charset information. It must be a positive integer. The HTML 5 specification recommends using the default value of 1024, but some pages do not follow the specification. =item C<$default_encoding> This is the encoding that C<html_file> and C<html_file_and_encoding> will use if no encoding can be detected by C<sniff_encoding>. The default value is C<cp1252> (a.k.a. Windows-1252). Setting it to C<undef> will cause the file subroutines to croak if C<sniff_encoding> fails to determine the encoding. (C<sniff_encoding> itself does not use C<$default_encoding>). =back =head1 DEPENDENCIES IO::HTML has no non-core dependencies for Perl 5.8.7+. With earlier versions of Perl 5.8, you need to upgrade L<Encode> to at least version 2.10, and you may need to upgrade L<Exporter> to at least version 5.57. =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS No bugs have been reported. =head1 AUTHOR Christopher J. Madsen S<C<< <perl AT cjmweb.net> >>> Please report any bugs or feature requests to S<C<< <bug-IO-HTML AT rt.cpan.org> >>> or through the web interface at L<< http://rt.cpan.org/Public/Bug/Report.html?Queue=IO-HTML >>. You can follow or contribute to IO-HTML's development at L<< https://github.com/madsen/io-html >>. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2020 by Christopher J. Madsen. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. =cut PK ! �n P� � Time/Zone.pmnu �[��� package Time::Zone; =head1 NAME Time::Zone -- miscellaneous timezone manipulations routines =head1 SYNOPSIS use Time::Zone; print tz2zone(); print tz2zone($ENV{'TZ'}); print tz2zone($ENV{'TZ'}, time()); print tz2zone($ENV{'TZ'}, undef, $isdst); $offset = tz_local_offset(); $offset = tz_offset($TZ); =head1 DESCRIPTION This is a collection of miscellaneous timezone manipulation routines. C<tz2zone()> parses the TZ environment variable and returns a timezone string suitable for inclusion in L<date(1)>-like output. It opionally takes a timezone string, a time, and a is-dst flag. C<tz_local_offset()> determins the offset from GMT time in seconds. It only does the calculation once. C<tz_offset()> determines the offset from GMT in seconds of a specified timezone. C<tz_name()> determines the name of the timezone based on its offset =head1 AUTHORS Graham Barr <gbarr@pobox.com> David Muir Sharnoff <muir@idiom.com> Paul Foley <paul@ascent.com> =cut require 5.002; require Exporter; use Carp; use strict; use vars qw(@ISA @EXPORT $VERSION @tz_local); @ISA = qw(Exporter); @EXPORT = qw(tz2zone tz_local_offset tz_offset tz_name); $VERSION = "2.24"; # Parts stolen from code by Paul Foley <paul@ascent.com> sub tz2zone (;$$$) { my($TZ, $time, $isdst) = @_; use vars qw(%tzn_cache); $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : '' unless $TZ; # Hack to deal with 'PST8PDT' format of TZ # Note that this can't deal with all the esoteric forms, but it # does recognize the most common: [:]STDoff[DST[off][,rule]] if (! defined $isdst) { my $j; $time = time() unless $time; ($j, $j, $j, $j, $j, $j, $j, $j, $isdst) = localtime($time); } if (defined $tzn_cache{$TZ}->[$isdst]) { return $tzn_cache{$TZ}->[$isdst]; } if ($TZ =~ /^ ( [^:\d+\-,] {3,} ) ( [+-] ? \d {1,2} ( : \d {1,2} ) {0,2} ) ( [^\d+\-,] {3,} )? /x ) { my $dsttz = defined($4) ? $4 : $1; $TZ = $isdst ? $dsttz : $1; $tzn_cache{$TZ} = [ $1, $dsttz ]; } else { $tzn_cache{$TZ} = [ $TZ, $TZ ]; } return $TZ; } sub tz_local_offset (;$) { my ($time) = @_; $time = time() unless $time; my (@l) = localtime($time); my $isdst = $l[8]; if (defined($tz_local[$isdst])) { return $tz_local[$isdst]; } $tz_local[$isdst] = &calc_off($time); return $tz_local[$isdst]; } sub calc_off { my ($time) = @_; my (@l) = localtime($time); my (@g) = gmtime($time); my $off; $off = $l[0] - $g[0] + ($l[1] - $g[1]) * 60 + ($l[2] - $g[2]) * 3600; # subscript 7 is yday. if ($l[7] == $g[7]) { # done } elsif ($l[7] == $g[7] + 1) { $off += 86400; } elsif ($l[7] == $g[7] - 1) { $off -= 86400; } elsif ($l[7] < $g[7]) { # crossed over a year boundry! # localtime is beginning of year, gmt is end # therefore local is ahead $off += 86400; } else { $off -= 86400; } return $off; } # constants CONFIG: { use vars qw(%dstZone %zoneOff %dstZoneOff %Zone); my @dstZone = ( # "ndt" => -2*3600-1800, # Newfoundland Daylight "brst" => -2*3600, # Brazil Summer Time (East Daylight) "adt" => -3*3600, # Atlantic Daylight "edt" => -4*3600, # Eastern Daylight "cdt" => -5*3600, # Central Daylight "mdt" => -6*3600, # Mountain Daylight "pdt" => -7*3600, # Pacific Daylight "akdt" => -8*3600, # Alaska Daylight "ydt" => -8*3600, # Yukon Daylight "hdt" => -9*3600, # Hawaii Daylight "bst" => +1*3600, # British Summer "mest" => +2*3600, # Middle European Summer "metdst" => +2*3600, # Middle European DST "sst" => +2*3600, # Swedish Summer "fst" => +2*3600, # French Summer "cest" => +2*3600, # Central European Daylight "eest" => +3*3600, # Eastern European Summer "msd" => +4*3600, # Moscow Daylight "wadt" => +8*3600, # West Australian Daylight "kdt" => +10*3600, # Korean Daylight # "cadt" => +10*3600+1800, # Central Australian Daylight "aedt" => +11*3600, # Eastern Australian Daylight "eadt" => +11*3600, # Eastern Australian Daylight "nzd" => +13*3600, # New Zealand Daylight "nzdt" => +13*3600, # New Zealand Daylight ); my @Zone = ( "gmt" => 0, # Greenwich Mean "ut" => 0, # Universal (Coordinated) "utc" => 0, "wet" => 0, # Western European "wat" => -1*3600, # West Africa "at" => -2*3600, # Azores "fnt" => -2*3600, # Brazil Time (Extreme East - Fernando Noronha) "brt" => -3*3600, # Brazil Time (East Standard - Brasilia) # For completeness. BST is also British Summer, and GST is also Guam Standard. # "bst" => -3*3600, # Brazil Standard # "gst" => -3*3600, # Greenland Standard # "nft" => -3*3600-1800,# Newfoundland # "nst" => -3*3600-1800,# Newfoundland Standard "mnt" => -4*3600, # Brazil Time (West Standard - Manaus) "ewt" => -4*3600, # U.S. Eastern War Time "ast" => -4*3600, # Atlantic Standard "est" => -5*3600, # Eastern Standard "act" => -5*3600, # Brazil Time (Extreme West - Acre) "cst" => -6*3600, # Central Standard "mst" => -7*3600, # Mountain Standard "pst" => -8*3600, # Pacific Standard "akst" => -9*3600, # Alaska Standard "yst" => -9*3600, # Yukon Standard "hst" => -10*3600, # Hawaii Standard "cat" => -10*3600, # Central Alaska "ahst" => -10*3600, # Alaska-Hawaii Standard "nt" => -11*3600, # Nome "idlw" => -12*3600, # International Date Line West "cet" => +1*3600, # Central European "mez" => +1*3600, # Central European (German) "ect" => +1*3600, # Central European (French) "met" => +1*3600, # Middle European "mewt" => +1*3600, # Middle European Winter "swt" => +1*3600, # Swedish Winter "set" => +1*3600, # Seychelles "fwt" => +1*3600, # French Winter "eet" => +2*3600, # Eastern Europe, USSR Zone 1 "ukr" => +2*3600, # Ukraine "bt" => +3*3600, # Baghdad, USSR Zone 2 "msk" => +3*3600, # Moscow # "it" => +3*3600+1800,# Iran "zp4" => +4*3600, # USSR Zone 3 "zp5" => +5*3600, # USSR Zone 4 # "ist" => +5*3600+1800,# Indian Standard "zp6" => +6*3600, # USSR Zone 5 # For completeness. NST is also Newfoundland Stanard, and SST is also Swedish Summer. # "nst" => +6*3600+1800,# North Sumatra # "sst" => +7*3600, # South Sumatra, USSR Zone 6 # "jt" => +7*3600+1800,# Java (3pm in Cronusland!) "wst" => +8*3600, # West Australian Standard "hkt" => +8*3600, # Hong Kong "cct" => +8*3600, # China Coast, USSR Zone 7 "jst" => +9*3600, # Japan Standard, USSR Zone 8 "kst" => +9*3600, # Korean Standard # "cast" => +9*3600+1800,# Central Australian Standard "aest" => +10*3600, # Eastern Australian Standard "east" => +10*3600, # Eastern Australian Standard "gst" => +10*3600, # Guam Standard, USSR Zone 9 "nzt" => +12*3600, # New Zealand "nzst" => +12*3600, # New Zealand Standard "idle" => +12*3600, # International Date Line East ); %Zone = @Zone; %dstZone = @dstZone; %zoneOff = reverse(@Zone); %dstZoneOff = reverse(@dstZone); } sub tz_offset (;$$) { my ($zone, $time) = @_; return &tz_local_offset($time) unless($zone); $time = time() unless $time; my(@l) = localtime($time); my $dst = $l[8]; $zone = lc $zone; if($zone =~ /^(([\-\+])\d\d?)(\d\d)$/) { my $v = $2 . $3; return $1 * 3600 + $v * 60; } elsif (exists $dstZone{$zone} && ($dst || !exists $Zone{$zone})) { return $dstZone{$zone}; } elsif(exists $Zone{$zone}) { return $Zone{$zone}; } undef; } sub tz_name (;$$) { my ($off, $dst) = @_; $off = tz_offset() unless(defined $off); $dst = (localtime(time))[8] unless(defined $dst); if (exists $dstZoneOff{$off} && ($dst || !exists $zoneOff{$off})) { return $dstZoneOff{$off}; } elsif (exists $zoneOff{$off}) { return $zoneOff{$off}; } sprintf("%+05d", int($off / 60) * 100 + $off % 60); } 1; PK ! �" �P P Git/IndexInfo.pmnu �[��� package Git::IndexInfo; use strict; use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); use Git qw/command_input_pipe command_close_pipe/; sub new { my ($class) = @_; my $hash_algo = Git::config('extensions.objectformat') || 'sha1'; my ($gui, $ctx) = command_input_pipe(qw/update-index -z --index-info/); bless { gui => $gui, ctx => $ctx, nr => 0, hash_algo => $hash_algo}, $class; } sub remove { my ($self, $path) = @_; my $length = $self->{hash_algo} eq 'sha256' ? 64 : 40; if (print { $self->{gui} } '0 ', 0 x $length, "\t", $path, "\0") { return ++$self->{nr}; } undef; } sub update { my ($self, $mode, $hash, $path) = @_; if (print { $self->{gui} } $mode, ' ', $hash, "\t", $path, "\0") { return ++$self->{nr}; } undef; } sub DESTROY { my ($self) = @_; command_close_pipe($self->{gui}, $self->{ctx}); } 1; PK ! R��T T Git/Packet.pmnu �[��� package Git::Packet; use 5.008; use strict; use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); BEGIN { require Exporter; if ($] < 5.008003) { *import = \&Exporter::import; } else { # Exporter 5.57 which supports this invocation was # released with perl 5.8.3 Exporter->import('import'); } } our @EXPORT = qw( packet_compare_lists packet_bin_read packet_txt_read packet_key_val_read packet_bin_write packet_txt_write packet_flush packet_initialize packet_read_capabilities packet_read_and_check_capabilities packet_check_and_write_capabilities ); our @EXPORT_OK = @EXPORT; sub packet_compare_lists { my ($expect, @result) = @_; my $ix; if (scalar @$expect != scalar @result) { return undef; } for ($ix = 0; $ix < $#result; $ix++) { if ($expect->[$ix] ne $result[$ix]) { return undef; } } return 1; } sub packet_bin_read { my $buffer; my $bytes_read = read STDIN, $buffer, 4; if ( $bytes_read == 0 ) { # EOF - Git stopped talking to us! return ( -1, "" ); } elsif ( $bytes_read != 4 ) { die "invalid packet: '$buffer'"; } my $pkt_size = hex($buffer); if ( $pkt_size == 0 ) { return ( 1, "" ); } elsif ( $pkt_size > 4 ) { my $content_size = $pkt_size - 4; $bytes_read = read STDIN, $buffer, $content_size; if ( $bytes_read != $content_size ) { die "invalid packet ($content_size bytes expected; $bytes_read bytes read)"; } return ( 0, $buffer ); } else { die "invalid packet size: $pkt_size"; } } sub remove_final_lf_or_die { my $buf = shift; if ( $buf =~ s/\n$// ) { return $buf; } die "A non-binary line MUST be terminated by an LF.\n" . "Received: '$buf'"; } sub packet_txt_read { my ( $res, $buf ) = packet_bin_read(); if ( $res != -1 and $buf ne '' ) { $buf = remove_final_lf_or_die($buf); } return ( $res, $buf ); } # Read a text packet, expecting that it is in the form "key=value" for # the given $key. An EOF does not trigger any error and is reported # back to the caller (like packet_txt_read() does). Die if the "key" # part of "key=value" does not match the given $key, or the value part # is empty. sub packet_key_val_read { my ( $key ) = @_; my ( $res, $buf ) = packet_txt_read(); if ( $res == -1 or ( $buf =~ s/^$key=// and $buf ne '' ) ) { return ( $res, $buf ); } die "bad $key: '$buf'"; } sub packet_bin_write { my $buf = shift; print STDOUT sprintf( "%04x", length($buf) + 4 ); print STDOUT $buf; STDOUT->flush(); } sub packet_txt_write { packet_bin_write( $_[0] . "\n" ); } sub packet_flush { print STDOUT sprintf( "%04x", 0 ); STDOUT->flush(); } sub packet_initialize { my ($name, $version) = @_; packet_compare_lists([0, $name . "-client"], packet_txt_read()) || die "bad initialize"; packet_compare_lists([0, "version=" . $version], packet_txt_read()) || die "bad version"; packet_compare_lists([1, ""], packet_bin_read()) || die "bad version end"; packet_txt_write( $name . "-server" ); packet_txt_write( "version=" . $version ); packet_flush(); } sub packet_read_capabilities { my @cap; while (1) { my ( $res, $buf ) = packet_bin_read(); if ( $res == -1 ) { die "unexpected EOF when reading capabilities"; } return ( $res, @cap ) if ( $res != 0 ); $buf = remove_final_lf_or_die($buf); unless ( $buf =~ s/capability=// ) { die "bad capability buf: '$buf'"; } push @cap, $buf; } } # Read remote capabilities and check them against capabilities we require sub packet_read_and_check_capabilities { my @required_caps = @_; my ($res, @remote_caps) = packet_read_capabilities(); my %remote_caps = map { $_ => 1 } @remote_caps; foreach (@required_caps) { unless (exists($remote_caps{$_})) { die "required '$_' capability not available from remote" ; } } return %remote_caps; } # Check our capabilities we want to advertise against the remote ones # and then advertise our capabilities sub packet_check_and_write_capabilities { my ($remote_caps, @our_caps) = @_; foreach (@our_caps) { unless (exists($remote_caps->{$_})) { die "our capability '$_' is not available from remote" } packet_txt_write( "capability=" . $_ ); } packet_flush(); } 1; PK ! 9�P�k k Git/LoadCPAN.pmnu �[��� package Git::LoadCPAN; use 5.008; use strict; use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); =head1 NAME Git::LoadCPAN - Wrapper for loading modules from the CPAN (OS) or Git's own copy =head1 DESCRIPTION The Perl code in Git depends on some modules from the CPAN, but we don't want to make those a hard requirement for anyone building from source. Therefore the L<Git::LoadCPAN> namespace shipped with Git contains wrapper modules like C<Git::LoadCPAN::Module::Name> that will first attempt to load C<Module::Name> from the OS, and if that doesn't work will fall back on C<FromCPAN::Module::Name> shipped with Git itself. Usually distributors will not ship with Git's Git::FromCPAN tree at all via the C<NO_PERL_CPAN_FALLBACKS> option, preferring to use their own packaging of CPAN modules instead. This module is only intended to be used for code shipping in the C<git.git> repository. Use it for anything else at your peril! =cut # NO_PERL_CPAN_FALLBACKS_STR evades the sed search-replace from the # Makefile, and allows for detecting whether the module is loaded from # perl/Git as opposed to perl/build/Git, which is useful for one-off # testing without having Error.pm et al installed. use constant NO_PERL_CPAN_FALLBACKS_STR => '@@' . 'NO_PERL_CPAN_FALLBACKS' . '@@'; use constant NO_PERL_CPAN_FALLBACKS => ( q[1] ne '' and q[1] ne NO_PERL_CPAN_FALLBACKS_STR ); sub import { shift; my $caller = caller; my %args = @_; my $module = exists $args{module} ? delete $args{module} : die "BUG: Expected 'module' parameter!"; my $import = exists $args{import} ? delete $args{import} : die "BUG: Expected 'import' parameter!"; die "BUG: Too many arguments!" if keys %args; # Foo::Bar to Foo/Bar.pm my $package_pm = $module; $package_pm =~ s[::][/]g; $package_pm .= '.pm'; eval { require $package_pm; 1; } or do { my $error = $@ || "Zombie Error"; if (NO_PERL_CPAN_FALLBACKS) { chomp(my $error = sprintf <<'THEY_PROMISED', $module); BUG: The '%s' module is not here, but NO_PERL_CPAN_FALLBACKS was set! Git needs this Perl module from the CPAN, and will by default ship with a copy of it. This Git was built with NO_PERL_CPAN_FALLBACKS, meaning that whoever built it promised to provide this module. You're seeing this error because they broke that promise, and we can't load our fallback version, since we were asked not to install it. If you're seeing this error and didn't package Git yourself the package you're using is broken, or your system is broken. This error won't appear if Git is built without NO_PERL_CPAN_FALLBACKS (instead we'll use our fallback version of the module). THEY_PROMISED die $error; } my $Git_LoadCPAN_pm_path = $INC{"Git/LoadCPAN.pm"} || die "BUG: Should have our own path from %INC!"; require File::Basename; my $Git_LoadCPAN_pm_root = File::Basename::dirname($Git_LoadCPAN_pm_path) || die "BUG: Can't figure out lib/Git dirname from '$Git_LoadCPAN_pm_path'!"; require File::Spec; my $Git_pm_FromCPAN_root = File::Spec->catdir($Git_LoadCPAN_pm_root, '..', 'FromCPAN'); die "BUG: '$Git_pm_FromCPAN_root' should be a directory!" unless -d $Git_pm_FromCPAN_root; local @INC = ($Git_pm_FromCPAN_root, @INC); require $package_pm; }; if ($import) { no strict 'refs'; *{"${caller}::import"} = sub { shift; use strict 'refs'; unshift @_, $module; goto &{"${module}::import"}; }; use strict 'refs'; } } 1; PK ! ao�� � Git/I18N.pmnu �[��� package Git::I18N; use 5.008; use strict; use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); BEGIN { require Exporter; if ($] < 5.008003) { *import = \&Exporter::import; } else { # Exporter 5.57 which supports this invocation was # released with perl 5.8.3 Exporter->import('import'); } } our @EXPORT = qw(__ __n N__); our @EXPORT_OK = @EXPORT; # See Git::LoadCPAN's NO_PERL_CPAN_FALLBACKS_STR for a description of # this "'@@' [...] '@@'" pattern. use constant NO_GETTEXT_STR => '@@' . 'NO_GETTEXT' . '@@'; use constant NO_GETTEXT => ( q[] ne '' and q[] ne NO_GETTEXT_STR ); sub __bootstrap_locale_messages { our $TEXTDOMAIN = 'git'; our $TEXTDOMAINDIR ||= $ENV{GIT_TEXTDOMAINDIR} || '/usr/share/locale'; die "NO_GETTEXT=" . NO_GETTEXT_STR if NO_GETTEXT; require POSIX; POSIX->import(qw(setlocale)); # Non-core prerequisite module require Locale::Messages; Locale::Messages->import(qw(:locale_h :libintl_h)); setlocale(LC_MESSAGES(), ''); setlocale(LC_CTYPE(), ''); textdomain($TEXTDOMAIN); bindtextdomain($TEXTDOMAIN => $TEXTDOMAINDIR); return; } BEGIN { # Used by our test script to see if it should test fallbacks or # not. our $__HAS_LIBRARY = 1; local $@; eval { __bootstrap_locale_messages(); *__ = \&Locale::Messages::gettext; *__n = \&Locale::Messages::ngettext; 1; } or do { # Tell test.pl that we couldn't load the gettext library. $Git::I18N::__HAS_LIBRARY = 0; # Just a fall-through no-op *__ = sub ($) { $_[0] }; *__n = sub ($$$) { $_[2] == 1 ? $_[0] : $_[1] }; }; sub N__($) { return shift; } } 1; __END__ =head1 NAME Git::I18N - Perl interface to Git's Gettext localizations =head1 SYNOPSIS use Git::I18N; print __("Welcome to Git!\n"); printf __("The following error occurred: %s\n"), $error; printf __n("committed %d file\n", "committed %d files\n", $files), $files; =head1 DESCRIPTION Git's internal Perl interface to gettext via L<Locale::Messages>. If L<Locale::Messages> can't be loaded (it's not a core module) we provide stub passthrough fallbacks. This is a distilled interface to gettext, see C<info '(gettext)Perl'> for the full interface. This module implements only a small part of it. =head1 FUNCTIONS =head2 __($) L<Locale::Messages>'s gettext function if all goes well, otherwise our passthrough fallback function. =head2 __n($$$) L<Locale::Messages>'s ngettext function or passthrough fallback function. =head2 N__($) No-operation that only returns its argument. Use this if you want xgettext to extract the text to the pot template but do not want to trigger retrival of the translation at run time. =head1 AUTHOR E<AElig>var ArnfjE<ouml>rE<eth> Bjarmason <avarab@gmail.com> =head1 COPYRIGHT Copyright 2010 E<AElig>var ArnfjE<ouml>rE<eth> Bjarmason <avarab@gmail.com> =cut PK ! 6�q�� � Git/LoadCPAN/Mail/Address.pmnu �[��� package Git::LoadCPAN::Mail::Address; use 5.008; use strict; use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); use Git::LoadCPAN ( module => 'Mail::Address', import => 0, ); 1; PK ! ��<=� � Git/LoadCPAN/Error.pmnu �[��� package Git::LoadCPAN::Error; use 5.008; use strict; use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); use Git::LoadCPAN ( module => 'Error', import => 1, ); 1; PK ! H���� � PgCommon.pmnu �[��� =head1 NAME PgCommon - Common functions for the postgresql-common framework =head1 COPYRIGHT AND LICENSE (C) 2008-2009 Martin Pitt <mpitt@debian.org> (C) 2012-2021 Christoph Berg <myon@debian.org> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either L<version 2 of the License|https://www.gnu.org/licenses/old-licenses/gpl-2.0.html>, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. =cut package PgCommon; use strict; use IPC::Open3; use Socket; use POSIX; use Exporter; our $VERSION = 1.00; our @ISA = ('Exporter'); our @EXPORT = qw/error user_cluster_map get_cluster_port set_cluster_port get_cluster_socketdir set_cluster_socketdir cluster_port_running get_cluster_start_conf set_cluster_start_conf set_cluster_pg_ctl_conf get_program_path cluster_info validate_cluster_owner get_versions get_newest_version version_exists get_version_clusters next_free_port cluster_exists install_file change_ugid system_or_error config_bool replace_v_c get_db_encoding get_db_locales get_cluster_locales get_cluster_controldata get_cluster_databases cluster_conf_filename read_cluster_conf_file read_pg_hba read_pidfile valid_hba_method/; our @EXPORT_OK = qw/$confroot $binroot $rpm $have_python2 quote_conf_value read_conf_file get_conf_value set_conf_value set_conffile_value disable_conffile_value disable_conf_value replace_conf_value cluster_data_directory get_file_device check_pidfile_running/; =head1 CONTENTS =head2 error Print an error message to stderr and die with exit status 1 =cut sub error { $! = 1; # force exit code 1 die "Error: $_[0]\n"; } =head2 prepare_exec, restore_exec Functions for configuration =cut our $confroot = '/etc/postgresql'; if ($ENV{'PG_CLUSTER_CONF_ROOT'}) { ($confroot) = $ENV{'PG_CLUSTER_CONF_ROOT'} =~ /(.*)/; # untaint } our $common_confdir = "/etc/postgresql-common"; if ($ENV{'PGSYSCONFDIR'}) { ($common_confdir) = $ENV{'PGSYSCONFDIR'} =~ /(.*)/; # untaint } my $mapfile = "$common_confdir/user_clusters"; our $binroot = "/usr/lib/postgresql/"; #redhat# $binroot = "/usr/pgsql-"; our $rpm = 0; #redhat# $rpm = 1; our $defaultport = 5432; our $have_python2 = 0; # python2 removed in bullseye+ #py2#$have_python2 = 1; { my %saved_env; # untaint the environment for executing an external program # Optional arguments: list of additional variables sub prepare_exec { my @cleanvars = qw/PATH IFS ENV BASH_ENV CDPATH/; push @cleanvars, @_; %saved_env = (); foreach (@cleanvars) { $saved_env{$_} = $ENV{$_}; delete $ENV{$_}; } $ENV{'PATH'} = ''; } # restore the environment after prepare_exec() sub restore_exec { foreach (keys %saved_env) { if (defined $saved_env{$_}) { $ENV{$_} = $saved_env{$_}; } else { delete $ENV{$_}; } } } } =head2 config_bool returns '1' if the argument is a configuration file value that stands for true (ON, TRUE, YES, or 1, case insensitive), '0' if the argument represents a false value (OFF, FALSE, NO, or 0, case insensitive), or undef otherwise. =cut sub config_bool { return undef unless defined($_[0]); return 1 if ($_[0] =~ /^(on|true|yes|1)$/i); return 0 if ($_[0] =~ /^(off|false|no|0)$/i); return undef; } =head2 quote_conf_value Quotes a value with single quotes Arguments: <value> Returns: quoted string =cut sub quote_conf_value ($) { my $value = shift; return $value if ($value =~ /^-?[\d.]+$/); # integer or float return $value if ($value =~ /^\w+$/); # plain word $value =~ s/'/''/g; # else quote it return "'$value'"; } =head2 replace_v_c Replaces %v and %c placeholders Arguments: <string> <version> <cluster> Returns: string =cut sub replace_v_c ($$$) { my ($str, $version, $cluster) = @_; $str =~ s/%([vc%])/$1 eq 'v' ? $version : $1 eq 'c' ? $cluster : '%'/eg; return $str; } =head2 read_conf_file Read a 'var = value' style configuration file and return a hash with the values. Error out if the file cannot be read. If the file name ends with '.conf', the keys will be normalized to lower case (suitable for e.g. postgresql.conf), otherwise kept intact (suitable for environment). Arguments: <path> Returns: hash (empty if file does not exist) =cut sub read_conf_file { my ($config_path) = @_; my %conf; local (*F); sub get_absolute_path { my ($path, $parent_path) = @_; return $path if ($path =~ m!^/!); # path is absolute # else strip filename component from parent path $parent_path =~ s!/[^/]*$!!; return "$parent_path/$path"; } if (open F, $config_path) { while (<F>) { if (/^\s*(?:#.*)?$/) { next; } elsif(/^\s*include_dir\s*=?\s*'([^']+)'\s*(?:#.*)?$/i) { # read included configuration directory and merge into %conf # files in the directory will be read in ascending order my $path = $1; my $absolute_path = get_absolute_path($path, $config_path); next unless -e $absolute_path && -d $absolute_path; my $dir; opendir($dir, $absolute_path) or next; foreach my $filename (sort readdir($dir) ) { next if ($filename =~ m/^\./ or not $filename =~/\.conf$/ ); my %include_conf = read_conf_file("$absolute_path/$filename"); while ( my ($k, $v) = each(%include_conf) ) { $conf{$k} = $v; } } closedir($dir); } elsif (/^\s*include(?:_if_exists)?\s*=?\s*'([^']+)'\s*(?:#.*)?$/i) { # read included file and merge into %conf my $path = $1; my $absolute_path = get_absolute_path($path, $config_path); my %include_conf = read_conf_file($absolute_path); while ( my ($k, $v) = each(%include_conf) ) { $conf{$k} = $v; } } elsif (/^\s*([a-zA-Z0-9_.-]+)\s*(?:=|\s)\s*'((?:[^']|''|(?:(?<=\\)'))*)'\s*(?:#.*)?$/i) { # string value my $v = $2; my $k = $1; $k = lc $k if $config_path =~ /\.conf$/; $v =~ s/\\(.)/$1/g; $v =~ s/''/'/g; $conf{$k} = $v; } elsif (m{^\s*([a-zA-Z0-9_.-]+)\s*(?:=|\s)\s*(-?[[:alnum:]][[:alnum:]._:/+-]*)\s*(?:\#.*)?$}i) { # simple value (string/float) my $v = $2; my $k = $1; $k = lc $k if $config_path =~ /\.conf$/; $conf{$k} = $v; } else { chomp; error "invalid line $. in $config_path: $_"; } } close F; } return %conf; } =head2 cluster_conf_filename Returns path to cluster config file from a cluster configuration directory (with /etc/postgresql-common/<file name> as fallback) and return a hash with the values. Error out if the file cannot be read. If config file name is postgresql.auto.conf, read from PGDATA Arguments: <version> <cluster> <config file name> Returns: hash (empty if the file does not exist) =cut sub cluster_conf_filename { my ($version, $cluster, $configfile) = @_; if ($configfile eq 'postgresql.auto.conf') { my $data_directory = cluster_data_directory($version, $cluster); return "$data_directory/$configfile"; } my $fname = "$confroot/$version/$cluster/$configfile"; -e $fname or $fname = "$common_confdir/$configfile"; return $fname; } =head2 read_cluster_conf_file Read a 'var = value' style configuration file from a cluster configuration Arguments: <version> <cluster> <config file name> Returns: hash (empty if the file does not exist) =cut sub read_cluster_conf_file { my ($version, $cluster, $configfile) = @_; my %conf = read_conf_file(cluster_conf_filename($version, $cluster, $configfile)); if ($version >= 9.4 and $configfile eq 'postgresql.conf') { # merge settings changed by ALTER SYSTEM # data_directory cannot be changed by ALTER SYSTEM my $data_directory = cluster_data_directory($version, $cluster, \%conf); my %auto_conf = read_conf_file "$data_directory/postgresql.auto.conf"; foreach my $guc (keys %auto_conf) { next if ($guc eq 'data_directory'); # defend against pg_upgradecluster bug in 200..202 $conf{$guc} = $auto_conf{$guc}; } } return %conf; } =head2 get_conf_value Return parameter from a PostgreSQL configuration file, or undef if the parameter does not exist. Arguments: <version> <cluster> <config file name> <parameter name> =cut sub get_conf_value { my %conf = (read_cluster_conf_file $_[0], $_[1], $_[2]); return $conf{$_[3]}; } =head2 set_conffile_value Set parameter of a PostgreSQL configuration file. Arguments: <config file name> <parameter name> <value> =cut sub set_conffile_value { my ($fname, $key, $value) = ($_[0], $_[1], quote_conf_value($_[2])); my @lines; # read configuration file lines open (F, $fname) or die "Error: could not open $fname for reading"; push @lines, $_ while (<F>); close F; my $found = 0; # first, search for an uncommented setting for (my $i=0; $i <= $#lines; ++$i) { if ($lines[$i] =~ /^\s*($key)(\s*(?:=|\s)\s*)\w+\b((?:\s*#.*)?)/i or $lines[$i] =~ /^\s*($key)(\s*(?:=|\s)\s*)'[^']*'((?:\s*#.*)?)/i) { $lines[$i] = "$1$2$value$3\n"; $found = 1; last; } } # now check if the setting exists as a comment; if so, change that instead # of appending if (!$found) { for (my $i=0; $i <= $#lines; ++$i) { if ($lines[$i] =~ /^\s*#\s*($key)(\s*(?:=|\s)\s*)\w+\b((?:\s*#.*)?)/i or $lines[$i] =~ /^\s*#\s*($key)(\s*(?:=|\s)\s*)'[^']*'((?:\s*#.*)?)/i) { $lines[$i] = "$1$2$value$3\n"; $found = 1; last; } } } # not found anywhere, append it push (@lines, "$key = $value\n") unless $found; # write configuration file lines open (F, ">$fname.new") or die "Error: could not open $fname.new for writing"; foreach (@lines) { print F $_ or die "writing $fname.new: $!"; } close F; # copy permissions my @st = stat $fname or die "stat: $!"; chown $st[4], $st[5], "$fname.new"; # might fail as non-root chmod $st[2], "$fname.new" or die "chmod: $!"; rename "$fname.new", "$fname" or die "rename $fname.new $fname: $!"; } =head2 set_conf_value Set parameter of a PostgreSQL cluster configuration file. Arguments: <version> <cluster> <config file name> <parameter name> <value> =cut sub set_conf_value { return set_conffile_value(cluster_conf_filename($_[0], $_[1], $_[2]), $_[3], $_[4]); } =head2 disable_conffile_value Disable a parameter in a PostgreSQL configuration file by prepending it with a '#'. Appends an optional explanatory comment <reason> if given. Arguments: <config file name> <parameter name> <reason> =cut sub disable_conffile_value { my ($fname, $key, $reason) = @_; my @lines; # read configuration file lines open (F, $fname) or die "Error: could not open $fname for reading"; push @lines, $_ while (<F>); close F; my $changed = 0; for (my $i=0; $i <= $#lines; ++$i) { if ($lines[$i] =~ /^\s*$key\s*(?:=|\s)/i) { $lines[$i] =~ s/^/#/; $lines[$i] =~ s/$/ #$reason/ if $reason; $changed = 1; last; } } # write configuration file lines if ($changed) { open (F, ">$fname.new") or die "Error: could not open $fname.new for writing"; foreach (@lines) { print F $_ or die "writing $fname.new: $!"; } close F; # copy permissions my @st = stat $fname or die "stat: $!"; chown $st[4], $st[5], "$fname.new"; # might fail as non-root chmod $st[2], "$fname.new" or die "chmod: $1"; rename "$fname.new", "$fname"; } } =head2 disable_conf_value Disable a parameter in a PostgreSQL cluster configuration file by prepending it with a '#'. Appends an optional explanatory comment <reason> if given. Arguments: <version> <cluster> <config file name> <parameter name> <reason> =cut sub disable_conf_value { return disable_conffile_value(cluster_conf_filename($_[0], $_[1], $_[2]), $_[3], $_[4]); } =head2 replace_conf_value Replace a parameter in a PostgreSQL configuration file. The old parameter is prepended with a '#' and gets an optional explanatory comment <reason> appended, if given. The new parameter is inserted directly after the old one. Arguments: <version> <cluster> <config file name> <old parameter name> <reason> <new parameter name> <new value> =cut sub replace_conf_value { my ($version, $cluster, $configfile, $oldparam, $reason, $newparam, $val) = @_; my $fname = cluster_conf_filename($version, $cluster, $configfile); my @lines; # quote $val if necessary unless ($val =~ /^\w+$/) { $val = "'$val'"; } # read configuration file lines open (F, $fname) or die "Error: could not open $fname for reading"; push @lines, $_ while (<F>); close F; my $found = 0; for (my $i = 0; $i <= $#lines; ++$i) { if ($lines[$i] =~ /^\s*$oldparam\s*(?:=|\s)/i) { $lines[$i] = '#'.$lines[$i]; chomp $lines[$i]; $lines[$i] .= ' #'.$reason."\n" if $reason; # insert the new param splice @lines, $i+1, 0, "$newparam = $val\n"; ++$i; $found = 1; last; } } return if !$found; # write configuration file lines open (F, ">$fname.new") or die "Error: could not open $fname.new for writing"; foreach (@lines) { print F $_ or die "writing $fname.new: $!"; } close F; # copy permissions my @st = stat $fname or die "stat: $!"; chown $st[4], $st[5], "$fname.new"; # might fail as non-root chmod $st[2], "$fname.new" or die "chmod: $1"; rename "$fname.new", "$fname"; } =head2 get_cluster_port Return the port of a particular cluster Arguments: <version> <cluster> =cut sub get_cluster_port { return get_conf_value($_[0], $_[1], 'postgresql.conf', 'port') || $defaultport; } =head2 set_cluster_port Set the port of a particular cluster. Arguments: <version> <cluster> <port> =cut sub set_cluster_port { set_conf_value $_[0], $_[1], 'postgresql.conf', 'port', $_[2]; } =head2 cluster_data_directory Return cluster data directory. Arguments: <version> <cluster name> [<config_hash>] =cut sub cluster_data_directory { my $d; if ($_[2]) { $d = ${$_[2]}{'data_directory'}; } else { $d = get_conf_value($_[0], $_[1], 'postgresql.conf', 'data_directory'); } my $confdir = "$confroot/$_[0]/$_[1]"; if (!$d) { # fall back to /pgdata symlink (supported by earlier p-common releases) $d = readlink "$confdir/pgdata"; } if (!$d and -l $confdir and -f "$confdir/PG_VERSION") { # symlink from /etc/postgresql $d = readlink $confdir; } if (!$d and -f "$confdir/PG_VERSION") { # PGDATA in /etc/postgresql $d = $confdir; } ($d) = $d =~ /(.*)/ if defined $d; #untaint return $d; } =head2 get_cluster_socketdir Return the socket directory of a particular cluster or undef if the cluster does not exist. Arguments: <version> <cluster> =cut sub get_cluster_socketdir { # if it is explicitly configured, just return it my $socketdir = get_conf_value($_[0], $_[1], 'postgresql.conf', $_[0] >= 9.3 ? 'unix_socket_directories' : 'unix_socket_directory'); $socketdir =~ s/\s*,.*// if ($socketdir); # ignore additional directories for now return $socketdir if $socketdir; #redhat# return '/tmp'; # RedHat PGDG packages default to /tmp # try to determine whether this is a postgres owned cluster and we default # to /var/run/postgresql $socketdir = '/var/run/postgresql'; my @socketdirstat = stat $socketdir; error "Cannot stat $socketdir" unless @socketdirstat; if ($_[0] && $_[1]) { my $datadir = cluster_data_directory $_[0], $_[1]; error "Invalid data directory for cluster $_[0] $_[1]" unless $datadir; my @datadirstat = stat $datadir; unless (@datadirstat) { my @p = split '/', $datadir; my $parent = join '/', @p[0..($#p-1)]; error "$datadir is not accessible; please fix the directory permissions ($parent/ should be world readable)" unless @datadirstat; } $socketdir = '/tmp' if $socketdirstat[4] != $datadirstat[4]; } return $socketdir; } =head2 set_cluster_socketdir Set the socket directory of a particular cluster. Arguments: <version> <cluster> <directory> =cut sub set_cluster_socketdir { set_conf_value $_[0], $_[1], 'postgresql.conf', $_[0] >= 9.3 ? 'unix_socket_directories' : 'unix_socket_directory', $_[2]; } =head2 get_program_path Return the path of a program of a particular version. Arguments: <program name> [<version>] =cut sub get_program_path { my ($program, $version) = @_; return '' unless defined $program; $version //= get_newest_version($program); my $path = "$binroot$version/bin/$program"; ($path) = $path =~ /(.*)/; #untaint return $path if -x $path; return ''; } =head2 cluster_port_running Check whether a postgres server is running at the specified port. Arguments: <version> <cluster> <port> =cut sub cluster_port_running { die "port_running: invalid port $_[2]" if $_[2] !~ /\d+/; my $socketdir = get_cluster_socketdir $_[0], $_[1]; my $socketpath = "$socketdir/.s.PGSQL.$_[2]"; return 0 unless -S $socketpath; socket(SRV, PF_UNIX, SOCK_STREAM, 0) or die "socket: $!"; my $running = connect(SRV, sockaddr_un($socketpath)); close SRV; return $running ? 1 : 0; } =head2 get_cluster_start_conf Read, verify, and return the current start.conf setting. Arguments: <version> <cluster> Returns: auto | manual | disabled =cut sub get_cluster_start_conf { my $start_conf = "$confroot/$_[0]/$_[1]/start.conf"; if (-e $start_conf) { open F, $start_conf or error "Could not open $start_conf: $!"; while (<F>) { s/#.*$//; s/^\s*//; s/\s*$//; next unless $_; close F; return $1 if (/^(auto|manual|disabled)/); error "Invalid mode in $start_conf, must be one of auto, manual, disabled"; } close F; } return 'auto'; # default } =head2 set_cluster_start_conf Change start.conf setting. Arguments: <version> <cluster> <value> <value> = auto | manual | disabled =cut sub set_cluster_start_conf { my ($v, $c, $val) = @_; error "Invalid mode: '$val'" unless $val eq 'auto' || $val eq 'manual' || $val eq 'disabled'; my $perms = 0644; # start.conf setting my $start_conf = "$confroot/$_[0]/$_[1]/start.conf"; my $text; if (-e $start_conf) { open F, $start_conf or error "Could not open $start_conf: $!"; while (<F>) { if (/^\s*(?:auto|manual|disabled)\b(.*$)/) { $text .= $val . $1 . "\n"; } else { $text .= $_; } } # preserve permissions if it already exists $perms = (stat F)[2]; error "Could not get permissions of $start_conf: $!" unless $perms; close F; } else { $text = "# Automatic startup configuration # auto: automatically start the cluster # manual: manual startup with pg_ctlcluster/postgresql@.service only # disabled: refuse to start cluster # See pg_createcluster(1) for details. When running from systemd, # invoke 'systemctl daemon-reload' after editing this file. $val "; } open F, '>' . $start_conf or error "Could not open $start_conf for writing: $!"; chmod $perms, $start_conf; print F $text; close F; } =head2 set_cluster_pg_ctl_conf Change pg_ctl.conf setting. Arguments: <version> <cluster> <options> <options> = options passed to pg_ctl(1) =cut sub set_cluster_pg_ctl_conf { my ($v, $c, $opts) = @_; my $perms = 0644; # pg_ctl.conf setting my $pg_ctl_conf = "$confroot/$v/$c/pg_ctl.conf"; my $text = "# Automatic pg_ctl configuration # This configuration file contains cluster specific options to be passed to # pg_ctl(1). pg_ctl_options = '$opts' "; open F, '>' . $pg_ctl_conf or error "Could not open $pg_ctl_conf for writing: $!"; chmod $perms, $pg_ctl_conf; print F $text; close F; } =head2 read_pidfile Return the PID from an existing PID file or undef if it does not exist. Arguments: <pid file path> =cut sub read_pidfile { return undef unless -e $_[0]; if (open PIDFILE, $_[0]) { my $pid = <PIDFILE>; close PIDFILE; return undef unless ($pid); chomp $pid; ($pid) = $pid =~ /^(\d+)\s*$/; # untaint return $pid; } else { return undef; } } =head2 check_pidfile_running Check whether a pid file is present and belongs to a running postgres. Returns undef if it cannot be determined Arguments: <pid file path> postgres does not clean up the PID file when it stops, and it is not world readable, so only its absence is a definitive result; if it is present, we need to read it and check the PID, which will only work as root =cut sub check_pidfile_running { return 0 if ! -e $_[0]; my $pid = read_pidfile $_[0]; if (defined $pid and open CL, "/proc/$pid/cmdline") { my $cmdline = <CL>; close CL; if ($cmdline and $cmdline =~ /\bpostgres\b/) { return 1; } else { return 0; } } return undef; } =head2 cluster_supervisor Determine if a cluster is managed by a supervisor (pacemaker, patroni). Returns undef if it cannot be determined Arguments: <pid file path> postgres does not clean up the PID file when it stops, and it is not world readable, so only its absence is a definitive result; if it is present, we need to read it and check the PID, which will only work as root =cut sub cluster_supervisor { return undef if ! -e $_[0]; my $pid = read_pidfile $_[0]; if (defined $pid and open(CG, "/proc/$pid/cgroup")) { local $/; # enable localized slurp mode my $cgroup = <CG>; close CG; if ($cgroup and $cgroup =~ /\b(pacemaker|patroni)\b/) { return $1; } } return undef; } =head2 cluster_info Return a hash with information about a specific cluster (which needs to exist). Arguments: <version> <cluster name> Returns: information hash (keys: pgdata, port, running, logfile [unless it has a custom one], configdir, owneruid, ownergid, waldir, socketdir, config->postgresql.conf) =cut sub cluster_info { my ($v, $c) = @_; error 'cluster_info must be called with <version> <cluster> arguments' unless ($v and $c); my %result; $result{'configdir'} = "$confroot/$v/$c"; $result{'configuid'} = (stat "$result{configdir}/postgresql.conf")[4]; my %postgresql_conf = read_cluster_conf_file $v, $c, 'postgresql.conf'; $result{'config'} = \%postgresql_conf; $result{'pgdata'} = cluster_data_directory $v, $c, \%postgresql_conf; return %result unless (keys %postgresql_conf); $result{'port'} = $postgresql_conf{'port'} || $defaultport; $result{'socketdir'} = get_cluster_socketdir $v, $c; # if we can determine the running status with the pid file, prefer that if ($postgresql_conf{'external_pid_file'} && $postgresql_conf{'external_pid_file'} ne '(none)') { $result{'running'} = check_pidfile_running $postgresql_conf{'external_pid_file'}; my $supervisor = cluster_supervisor($postgresql_conf{'external_pid_file'}); $result{supervisor} = $supervisor if ($supervisor); } # otherwise fall back to probing the port; this is unreliable if the port # was changed in the configuration file in the meantime if (!defined ($result{'running'})) { $result{'running'} = cluster_port_running ($v, $c, $result{'port'}); } if ($result{'pgdata'}) { ($result{'owneruid'}, $result{'ownergid'}) = (stat $result{'pgdata'})[4,5]; if ($v >= 12) { $result{'recovery'} = 1 if (-e "$result{'pgdata'}/recovery.signal" or -e "$result{'pgdata'}/standby.signal"); } else { $result{'recovery'} = 1 if (-e "$result{'pgdata'}/recovery.conf"); } my $waldirname = $v >= 10 ? 'pg_wal' : 'pg_xlog'; if (-l "$result{pgdata}/$waldirname") { # custom wal directory ($result{waldir}) = readlink("$result{pgdata}/$waldirname") =~ /(.*)/; # untaint } } $result{'start'} = get_cluster_start_conf $v, $c; # default log file (possibly used only for early startup messages) my $log_symlink = $result{'configdir'} . "/log"; if (-l $log_symlink) { ($result{'logfile'}) = readlink ($log_symlink) =~ /(.*)/; # untaint } else { $result{'logfile'} = "/var/log/postgresql/postgresql-$v-$c.log"; } return %result; } =head2 validate_cluster_owner Checks if the owner of a cluster is valid, and the owner of the config matches the owner of the data directory. Arguments: cluster_info hash reference =cut sub validate_cluster_owner($) { my $info = shift; unless ($info->{pgdata}) { error "Cluster data directory is unknown"; } unless (-d $info->{pgdata}) { error "$info->{pgdata} is not accessible or does not exist"; } unless (defined $info->{owneruid}) { error "Could not determine owner of $info->{pgdata}"; } if ($info->{owneruid} == 0) { error "Data directory $info->{pgdata} must not be owned by root"; } unless (getpwuid $info->{owneruid}) { error "The cluster is owned by user id $info->{owneruid} which does not exist"; } unless (getgrgid $info->{ownergid}) { error "The cluster is owned by group id $info->{ownergid} which does not exist"; } # owneruid and configuid need to match, unless configuid is root if (($< == 0 or $> == 0) and $info->{configuid} != 0 and $info->{configuid} != $info->{owneruid}) { my $configowner = (getpwuid $info->{configuid})[0] || "(unknown)"; my $dataowner = (getpwuid $info->{owneruid})[0]; error "Config owner ($configowner:$info->{configuid}) and data owner ($dataowner:$info->{owneruid}) do not match, and config owner is not root"; } } =head2 get_versions Return an array of all available versions (by binaries and postgresql.conf files) Arguments: binary to scan for (optional, defaults to postgres) =cut sub get_versions { my $program = shift // 'postgres'; my %versions = (); # enumerate psql versions from /usr/lib/postgresql/* (or /usr/pgsql-*) my $dir = $binroot; #redhat# $dir = '/usr'; if (opendir (D, $dir)) { my $entry; while (defined ($entry = readdir D)) { next if $entry eq '.' || $entry eq '..'; my $pfx = ''; #redhat# $pfx = "pgsql-"; ($entry) = $entry =~ /^$pfx(\d+\.?\d+)$/; # untaint $versions{$entry} = 1 if $entry and get_program_path ($program, $entry); } closedir D; } # enumerate server versions from /etc/postgresql/* if ($program eq 'postgres' and opendir (D, $confroot)) { my $v; while (defined ($v = readdir D)) { next if $v eq '.' || $v eq '..'; ($v) = $v =~ /^(\d+\.?\d+)$/; # untaint next unless ($v); if (opendir (C, "$confroot/$v")) { my $c; while (defined ($c = readdir C)) { if (-e "$confroot/$v/$c/postgresql.conf") { $versions{$v} = 1; last; } } closedir C; } } closedir D; } return sort { $a <=> $b } keys %versions; } =head2 get_newest_version Return the newest available version Arguments: binary to scan for (optional) =cut sub get_newest_version { my $program = shift // undef; my @versions = get_versions($program); return undef unless (@versions); return $versions[-1]; } =head2 version_exists Check whether a version exists =cut sub version_exists { my ($version) = @_; return get_program_path ('psql', $version); } =head2 get_version_clusters Return an array of all available clusters of given version Arguments: <version> =cut sub get_version_clusters { my $vdir = $confroot.'/'.$_[0].'/'; my @clusters = (); if (opendir (D, $vdir)) { my $entry; while (defined ($entry = readdir D)) { next if $entry eq '.' || $entry eq '..'; ($entry) = $entry =~ /^(.*)$/; # untaint my $conf = "$vdir$entry/postgresql.conf"; if (-e $conf or -l $conf) { # existing file, or dead symlink push @clusters, $entry; } } closedir D; } return sort @clusters; } =head2 cluster_exists Check if a cluster exists. Arguments: <version> <cluster> =cut sub cluster_exists { for my $c (get_version_clusters $_[0]) { return 1 if $c eq $_[1]; } return 0; } =head2 next_free_port Return the next free PostgreSQL port. =cut sub next_free_port { # create list of already used ports my @ports; for my $v (get_versions) { for my $c (get_version_clusters $v) { push @ports, get_cluster_port ($v, $c); } } my $port; for ($port = $defaultport; $port < 65536; ++$port) { next if grep { $_ == $port } @ports; # check if port is already in use my ($have_ip4, $res4, $have_ip6, $res6); if (socket (SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp'))) { # IPv4 $have_ip4 = 1; $res4 = bind (SOCK, sockaddr_in($port, INADDR_ANY)); } $have_ip6 = 0; no strict; # avoid compilation errors with Perl < 5.14 if (exists $Socket::{"IN6ADDR_ANY"}) { # IPv6 if (socket (SOCK, PF_INET6, SOCK_STREAM, getprotobyname('tcp'))) { $have_ip6 = 1; $res6 = bind (SOCK, sockaddr_in6($port, Socket::IN6ADDR_ANY)); } } use strict; unless ($have_ip4 or $have_ip6) { # require at least one protocol to work (PostgreSQL needs it anyway # for the stats collector) die "could not create socket: $!"; } close SOCK; # return port if it is available on all supported protocols return $port if ($have_ip4 ? $res4 : 1) and ($have_ip6 ? $res6 : 1); } die "no free port found"; } =head2 user_cluster_map Return the PostgreSQL version, cluster, and database to connect to. Version is always set (defaulting to the version of the default port if no matching entry is found, or finally to the latest installed version if there are no clusters at all), cluster and database may be 'undef'. If only one cluster exists, and no matching entry is found in the map files, that cluster is returned. =cut sub user_cluster_map { my ($user, $pwd, $uid, $gid) = getpwuid $>; my $group = (getgrgid $gid)[0]; # check per-user configuration file my $home = $ENV{"HOME"} || (getpwuid $>)[7]; my $homemapfile = $home . '/.postgresqlrc'; if (open MAP, $homemapfile) { while (<MAP>) { s/#.*//; next if /^\s*$/; my ($v,$c,$db) = split; if (!version_exists $v) { print "Warning: $homemapfile line $.: version $v does not exist\n"; next; } if (!cluster_exists $v, $c and $c !~ /^(\S+):(\d*)$/) { print "Warning: $homemapfile line $.: cluster $v/$c does not exist\n"; next; } if ($db) { close MAP; return ($v, $c, ($db eq "*") ? undef : $db); } else { print "Warning: ignoring invalid line $. in $homemapfile\n"; next; } } close MAP; } # check global map file if (open MAP, $mapfile) { while (<MAP>) { s/#.*//; next if /^\s*$/; my ($u,$g,$v,$c,$db) = split; if (!$db) { print "Warning: ignoring invalid line $. in $mapfile\n"; next; } if (!version_exists $v) { print "Warning: $mapfile line $.: version $v does not exist\n"; next; } if (!cluster_exists $v, $c and $c !~ /^(\S+):(\d*)$/) { print "Warning: $mapfile line $.: cluster $v/$c does not exist\n"; next; } if (($u eq "*" || $u eq $user) && ($g eq "*" || $g eq $group)) { close MAP; return ($v,$c, ($db eq "*") ? undef : $db); } } close MAP; } # if only one cluster exists, use that my $count = 0; my ($last_version, $last_cluster, $defaultport_version, $defaultport_cluster); for my $v (get_versions) { for my $c (get_version_clusters $v) { my $port = get_cluster_port ($v, $c); $last_version = $v; $last_cluster = $c; if ($port == $defaultport) { $defaultport_version = $v; $defaultport_cluster = $c; } ++$count; } } return ($last_version, $last_cluster, undef) if $count == 1; if ($count == 0) { # if there are no local clusters, use latest clients for accessing # network clusters return (get_newest_version('psql'), undef, undef); } # more than one cluster exists, return cluster at default port return ($defaultport_version, $defaultport_cluster, undef); } =head2 install_file Copy a file to a destination and setup permissions Arguments: <source file> <destination file or dir> <uid> <gid> <permissions> =cut sub install_file { my ($source, $dest, $uid, $gid, $perm) = @_; if (system 'install', '-o', $uid, '-g', $gid, '-m', $perm, $source, $dest) { error "install_file: could not install $source to $dest"; } } =head2 change_ugid Change effective and real user and group id. Also activates all auxiliary groups the user is in. Exits with an error message if user/group ID cannot be changed. Arguments: <user id> <group id> =cut sub change_ugid { my ($uid, $gid) = @_; # auxiliary groups my $uname = (getpwuid $uid)[0]; prepare_exec; my $groups = "$gid " . `/usr/bin/id -G $uname`; restore_exec; $) = $groups; $( = $gid; $> = $< = $uid; error 'Could not change user id' if $< != $uid; error 'Could not change group id' if $( != $gid; } =head2 system_or_error Run a command and error out if it exits with a non-zero status. Arguments: <command ...> =cut sub system_or_error { my $ret = system @_; if ($ret) { my $message = "@_ failed with exit code $ret"; $message .= ": $!" if ($!); error $message; } } =head2 get_db_encoding Return the encoding of a particular database in a cluster. This requires access privileges to that database, so this function should be called as the cluster owner. Arguments: <version> <cluster> <database> Returns: Encoding or undef if it cannot be determined. =cut sub get_db_encoding { my ($version, $cluster, $db) = @_; my $port = get_cluster_port $version, $cluster; my $socketdir = get_cluster_socketdir $version, $cluster; my $psql = get_program_path 'psql'; return undef unless ($port && $socketdir && $psql); # try to swich to cluster owner prepare_exec 'LC_ALL'; $ENV{'LC_ALL'} = 'C'; my $orig_euid = $>; $> = (stat (cluster_data_directory $version, $cluster))[4]; open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtc', 'select getdatabaseencoding()', $db or die "Internal error: could not call $psql to determine db encoding: $!"; my $out = <PSQL>; close PSQL; $> = $orig_euid; restore_exec; return undef if $?; chomp $out; ($out) = $out =~ /^([\w.-]+)$/; # untaint return $out; } =head2 get_db_locales Return locale of a particular database in a cluster. This requires access privileges to that database, so this function should be called as the cluster owner. (For versions >= 8.4; for older versions use get_cluster_locales()). Arguments: <version> <cluster> <database> Returns: (LC_CTYPE, LC_COLLATE) or (undef,undef) if it cannot be determined. =cut sub get_db_locales { my ($version, $cluster, $db) = @_; my $port = get_cluster_port $version, $cluster; my $socketdir = get_cluster_socketdir $version, $cluster; my $psql = get_program_path 'psql'; return undef unless ($port && $socketdir && $psql); my ($ctype, $collate); # try to switch to cluster owner prepare_exec 'LC_ALL'; $ENV{'LC_ALL'} = 'C'; my $orig_euid = $>; $> = (stat (cluster_data_directory $version, $cluster))[4]; open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtc', 'SHOW lc_ctype', $db or die "Internal error: could not call $psql to determine db lc_ctype: $!"; my $out = <PSQL> // error 'could not determine db lc_ctype'; close PSQL; ($ctype) = $out =~ /^([\w.\@-]+)$/; # untaint open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtc', 'SHOW lc_collate', $db or die "Internal error: could not call $psql to determine db lc_collate: $!"; $out = <PSQL> // error 'could not determine db lc_collate'; close PSQL; ($collate) = $out =~ /^([\w.\@-]+)$/; # untaint $> = $orig_euid; restore_exec; chomp $ctype; chomp $collate; return ($ctype, $collate) unless $?; return (undef, undef); } =head2 get_cluster_locales Return the CTYPE and COLLATE locales of a cluster. This needs to be called as root or as the cluster owner. (For versions <= 8.3; for >= 8.4, use get_db_locales()). Arguments: <version> <cluster> Returns: (LC_CTYPE, LC_COLLATE) or (undef,undef) if it cannot be determined. =cut sub get_cluster_locales { my ($version, $cluster) = @_; my ($lc_ctype, $lc_collate) = (undef, undef); if ($version >= '8.4') { print STDERR "Error: get_cluster_locales() does not work for 8.4+\n"; exit 1; } my $pg_controldata = get_program_path 'pg_controldata', $version; if (! -e $pg_controldata) { print STDERR "Error: pg_controldata not found, please install postgresql-$version\n"; exit 1; } prepare_exec ('LC_ALL', 'LANG', 'LANGUAGE'); $ENV{'LC_ALL'} = 'C'; my $result = open (CTRL, '-|', $pg_controldata, (cluster_data_directory $version, $cluster)); restore_exec; return (undef, undef) unless defined $result; while (<CTRL>) { if (/^LC_CTYPE\W*(\S+)\s*$/) { $lc_ctype = $1; } elsif (/^LC_COLLATE\W*(\S+)\s*$/) { $lc_collate = $1; } } close CTRL; return ($lc_ctype, $lc_collate); } =head2 get_cluster_controldata Return the pg_control data for a cluster Arguments: <version> <cluster> Returns: hashref =cut sub get_cluster_controldata { my ($version, $cluster) = @_; my $pg_controldata = get_program_path 'pg_controldata', $version; if (! -e $pg_controldata) { print STDERR "Error: pg_controldata not found, please install postgresql-$version\n"; exit 1; } prepare_exec ('LC_ALL', 'LANG', 'LANGUAGE'); $ENV{'LC_ALL'} = 'C'; my $result = open (CTRL, '-|', $pg_controldata, (cluster_data_directory $version, $cluster)); restore_exec; return undef unless defined $result; my $data = {}; while (<CTRL>) { if (/^(.+?):\s*(.*)/) { $data->{$1} = $2; } else { error "Invalid pg_controldata output: $_"; } } close CTRL; return $data; } =head2 get_cluster_databases Return an array with all databases of a cluster. This requires connection privileges to template1, so this function should be called as the cluster owner. Arguments: <version> <cluster> Returns: array of database names or undef on error. =cut sub get_cluster_databases { my ($version, $cluster) = @_; my $port = get_cluster_port $version, $cluster; my $socketdir = get_cluster_socketdir $version, $cluster; my $psql = get_program_path 'psql'; return undef unless ($port && $socketdir && $psql); # try to swich to cluster owner prepare_exec 'LC_ALL'; $ENV{'LC_ALL'} = 'C'; my $orig_euid = $>; $> = (stat (cluster_data_directory $version, $cluster))[4]; my @dbs; my @fields; if (open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtl') { while (<PSQL>) { chomp; @fields = split '\|'; next if $#fields < 2; # remove access privs which get line broken push (@dbs, $fields[0]); } close PSQL; } $> = $orig_euid; restore_exec; return $? ? undef : @dbs; } =head2 get_file_device Return the device name a file is stored at. Arguments: <file path> Returns: device name, or '' if it cannot be determined. =cut sub get_file_device { my $dev = ''; prepare_exec; my $pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR, '/bin/df', $_[0]); waitpid $pid, 0; # we simply ignore exit code and stderr while (<CHLD_OUT>) { if (/^\/dev/) { $dev = (split)[0]; } } restore_exec; close CHLD_IN; close CHLD_OUT; close CHLD_ERR; return $dev; } =head2 parse_hba_line Parse a single pg_hba.conf line. Arguments: <line> Returns: Hash reference (or only line and type==undef for invalid lines) =over 4 =item * line -> the verbatim pg_hba line =item * type -> comment, local, host, hostssl, hostnossl, undef =item * db -> database name =item * user -> user name =item * method -> trust, reject, md5, crypt, password, krb5, ident, pam =item * ip -> ip address =item * mask -> network mask (either a single number as number of bits, or bit mask) =back =cut sub parse_hba_line { my $l = $_[0]; chomp $l; # comment line? return { 'type' => 'comment', 'line' => $l } if ($l =~ /^\s*($|#)/); my $res = { 'line' => $l }; my @tok = split /\s+/, $l; goto error if $#tok < 3; $$res{'type'} = shift @tok; $$res{'db'} = shift @tok; $$res{'user'} = shift @tok; # local connection? if ($$res{'type'} eq 'local') { goto error if $#tok > 1; goto error unless valid_hba_method($tok[0]); $$res{'method'} = join (' ', @tok); return $res; } # host connection? if ($$res{'type'} =~ /^host((no)?ssl)?$/) { my ($i, $c) = split '/', (shift @tok); goto error unless $i; $$res{'ip'} = $i; # CIDR mask given? if (defined $c) { goto error if $c !~ /^(\d+)$/; $$res{'mask'} = $c; } else { $$res{'mask'} = shift @tok; } goto error if $#tok > 1; goto error unless valid_hba_method($tok[0]); $$res{'method'} = join (' ', @tok); return $res; } error: $$res{'type'} = undef; return $res; } =head2 read_pg_hba Parse given pg_hba.conf file. Arguments: <pg_hba.conf path> Returns: Array with hash refs; for hash contents, see parse_hba_line(). =cut sub read_pg_hba { open HBA, $_[0] or return undef; my @hba; while (<HBA>) { my $r = parse_hba_line $_; push @hba, $r; } close HBA; return @hba; } =head2 valid_hba_method Check if hba method is known Argument: hba method Returns: True if method is valid =cut sub valid_hba_method { my $method = $_[0]; my %valid_methods = qw/trust 1 reject 1 md5 1 crypt 1 password 1 krb5 1 ident 1 pam 1/; return exists($valid_methods{$method}); } 1; PK ! ��!�^ �^ Config/IniFiles.pmnu �[��� package Config::IniFiles; require 5.008; use strict; use warnings; our $VERSION = '3.000003'; use Carp; use Symbol 'gensym', 'qualify_to_ref'; # For the 'any data type' hack use Fcntl qw( SEEK_SET SEEK_CUR ); use List::Util 1.33 qw(any none); use File::Basename qw( dirname ); use File::Temp qw/ tempfile /; @Config::IniFiles::errors = (); # $Header: /home/shlomi/progs/perl/cpan/Config/IniFiles/config-inifiles-cvsbackup/config-inifiles/IniFiles.pm,v 2.41 2003-12-08 10:50:56 domq Exp $ sub _nocase { my $self = shift; if (@_) { $self->{nocase} = ( shift(@_) ? 1 : 0 ); } return $self->{nocase}; } sub _is_parm_in_sect { my ( $self, $sect, $parm ) = @_; return any { $_ eq $parm } @{ $self->{myparms}{$sect} }; } sub new { my $class = shift; my %parms = @_; my $errs = 0; my @groups = (); my $self = bless { default => '', fallback => undef, fallback_used => 0, imported => undef, v => {}, cf => undef, nomultiline => 0, handle_trailing_comment => 0, }, $class; if ( ref( $parms{-import} ) && ( $parms{-import}->isa('Config::IniFiles') ) ) { $self->{imported} = $parms{-import}; # ReadConfig will load the data $self->{negativedeltas} = 1; } elsif ( defined $parms{-import} ) { carp "Invalid -import value \"$parms{-import}\" was ignored."; } # end if delete $parms{-import}; # Copy the original parameters so we # can use them when we build new sections %{ $self->{startup_settings} } = %parms; # Parse options my ( $k, $v ); $self->_nocase(0); # Handle known parameters first in this order, # because each() could return parameters in any order if ( defined( $v = delete $parms{'-file'} ) ) { # Should we be pedantic and check that the file exists? # .. no, because now it could be a handle, IO:: object or something else $self->{cf} = $v; } if ( defined( $v = delete $parms{'-nocase'} ) ) { $self->_nocase($v); } if ( defined( $v = delete $parms{'-default'} ) ) { $self->{default} = $self->_nocase ? lc($v) : $v; } if ( defined( $v = delete $parms{'-fallback'} ) ) { $self->{fallback} = $self->_nocase ? lc($v) : $v; } if ( defined( $v = delete $parms{'-reloadwarn'} ) ) { $self->{reloadwarn} = $v ? 1 : 0; } if ( defined( $v = delete $parms{'-nomultiline'} ) ) { $self->{nomultiline} = $v ? 1 : 0; } if ( defined( $v = delete $parms{'-allowcontinue'} ) ) { $self->{allowcontinue} = $v ? 1 : 0; } if ( defined( $v = delete $parms{'-allowempty'} ) ) { $self->{allowempty} = $v ? 1 : 0; } if ( defined( $v = delete $parms{'-negativedeltas'} ) ) { $self->{negativedeltas} = $v ? 1 : 0; } if ( defined( $v = delete $parms{'-commentchar'} ) ) { if ( !defined $v || length($v) != 1 ) { carp "Comment character must be unique."; $errs++; } elsif ( $v =~ /[\[\]=\w]/ ) { # must not be square bracket, equal sign or alphanumeric carp "Illegal comment character."; $errs++; } else { $self->{comment_char} = $v; } } if ( defined( $v = delete $parms{'-allowedcommentchars'} ) ) { # must not be square bracket, equal sign or alphanumeric if ( !defined $v || $v =~ /[\[\]=\w]/ ) { carp "Illegal value for -allowedcommentchars."; $errs++; } else { $self->{allowed_comment_char} = $v; } } if ( defined( $v = delete $parms{'-handle_trailing_comment'} ) ) { $self->{handle_trailing_comment} = $v ? 1 : 0; } if ( defined( $v = delete $parms{'-php_compat'} ) ) { $self->{php_compat} = $v ? 1 : 0; } $self->{comment_char} = '#' unless exists $self->{comment_char}; $self->{allowed_comment_char} = ';' unless exists $self->{allowed_comment_char}; # make sure that comment character is always allowed $self->{allowed_comment_char} .= $self->{comment_char}; $self->{_comments_at_end_of_file} = []; # Any other parameters are unknown while ( ( $k, $v ) = each %parms ) { carp "Unknown named parameter $k=>$v"; $errs++; } return undef if $errs; if ( $self->ReadConfig ) { return $self; } else { return undef; } } sub _caseify { my ( $self, @refs ) = @_; if ( $self->_nocase ) { foreach my $ref ( grep { defined } @refs[ 0 .. 1 ] ) { ${$ref} = lc( ${$ref} ); } } if ( $self->{php_compat} ) { foreach my $ref ( grep { defined } @refs[ 1 .. 1 ] ) { ${$ref} =~ s{\[\]$}{}; } foreach my $ref ( grep { defined } @refs[ 2 .. $#refs ] ) { if ( length( ${$ref} ) >= 2 ) { my $quote = substr( ${$ref}, 0, 1 ); if ( ( $quote eq q{"} or $quote eq q{'} ) and substr( ${$ref}, -1, 1 ) eq $quote ) { ${$ref} = substr( ${$ref}, 1, -1 ); ${$ref} =~ s{$quote$quote}{}g; ${$ref} =~ s{\\$quote}{$quote}g if $quote eq q{"}; } } } } return; } sub val { my ( $self, $sect, $parm, $def ) = @_; # Always return undef on bad parameters if ( not( defined($sect) && defined($parm) ) ) { return; } $self->_caseify( \$sect, \$parm ); my $val_sect = defined( $self->{v}{$sect}{$parm} ) ? $sect : $self->{default}; my $val = $self->{v}{$val_sect}{$parm}; # If the value is undef, make it $def instead (which could just be undef) if ( !defined($val) ) { $val = $def; } # Return the value in the desired context if (wantarray) { if ( ref($val) eq "ARRAY" ) { return @$val; } elsif ( defined($val) ) { return $val; } else { return; } } elsif ( ref($val) eq "ARRAY" ) { return join( ( defined($/) ? $/ : "\n" ), @$val ); } else { return $val; } } sub exists { my ( $self, $sect, $parm ) = @_; $self->_caseify( \$sect, \$parm ); return ( exists $self->{v}{$sect}{$parm} ); } sub push { my ( $self, $sect, $parm, @vals ) = @_; return undef if not defined $sect; return undef if not defined $parm; $self->_caseify( \$sect, \$parm ); return undef if ( !defined( $self->{v}{$sect}{$parm} ) ); return 1 if ( !@vals ); $self->_touch_parameter( $sect, $parm ); $self->{EOT}{$sect}{$parm} = 'EOT' if ( !defined $self->{EOT}{$sect}{$parm} ); $self->{v}{$sect}{$parm} = [ $self->{v}{$sect}{$parm} ] unless ( ref( $self->{v}{$sect}{$parm} ) eq "ARRAY" ); CORE::push @{ $self->{v}{$sect}{$parm} }, @vals; return 1; } sub setval { my $self = shift; my $sect = shift; my $parm = shift; my @val = @_; return undef if not defined $sect; return undef if not defined $parm; $self->_caseify( \$sect, \$parm ); if ( defined( $self->{v}{$sect}{$parm} ) ) { $self->_touch_parameter( $sect, $parm ); if ( @val > 1 ) { $self->{v}{$sect}{$parm} = \@val; $self->{EOT}{$sect}{$parm} = 'EOT'; } else { $self->{v}{$sect}{$parm} = shift @val; } return 1; } else { return undef; } } sub newval { my $self = shift; my $sect = shift; my $parm = shift; my @val = @_; return undef if not defined $sect; return undef if not defined $parm; $self->_caseify( \$sect, \$parm ); $self->AddSection($sect); if ( none { $_ eq $parm } @{ $self->{parms}{$sect} } ) { CORE::push( @{ $self->{parms}{$sect} }, $parm ); } $self->_touch_parameter( $sect, $parm ); if ( @val > 1 ) { $self->{v}{$sect}{$parm} = \@val; if ( !defined $self->{EOT}{$sect}{$parm} ) { $self->{EOT}{$sect}{$parm} = 'EOT'; } } else { $self->{v}{$sect}{$parm} = shift @val; } return 1; } sub delval { my $self = shift; my $sect = shift; my $parm = shift; return undef if not defined $sect; return undef if not defined $parm; $self->_caseify( \$sect, \$parm ); $self->{parms}{$sect} = [ grep { $_ ne $parm } @{ $self->{parms}{$sect} } ]; $self->_touch_parameter( $sect, $parm ); delete $self->{v}{$sect}{$parm}; return 1; } # Auxiliary function to make deep (aliasing-free) copies of data # structures. Ignores blessed objects in tree (could be taught not # to, if needed) sub _deepcopy { my $ref = shift; if ( !ref($ref) ) { return $ref; } if ( UNIVERSAL::isa( $ref, "ARRAY" ) ) { return [ map { _deepcopy($_) } @$ref ]; } if ( UNIVERSAL::isa( $ref, "HASH" ) ) { my $return = {}; foreach my $k ( keys %$ref ) { $return->{$k} = _deepcopy( $ref->{$k} ); } return $return; } carp "Unhandled data structure in $ref, cannot _deepcopy()"; } # Internal method, gets the next line, taking proper care of line endings. sub _nextline { my ( $self, $fh ) = @_; my $s = ''; if ( !exists $self->{line_ends} ) { # no $self->{line_ends} is a hint set by caller that we are at # the first line (kludge kludge). { local $/ = \1; my $nextchar; do { $nextchar = <$fh>; return undef if ( !defined $nextchar ); $s .= $nextchar; } until ( $s =~ m/((\015|\012|\025|\n)$)/s ); $self->{line_ends} = $1; if ( $nextchar eq "\x0d" ) { # peek at the next char $nextchar = <$fh>; if ( $nextchar eq "\x0a" ) { $self->{line_ends} .= "\x0a"; } else { seek $fh, -1, SEEK_CUR(); } } } # If there's a UTF BOM (Byte-Order-Mark) in the first # character of the first line then remove it before processing # ( http://www.unicode.org/unicode/faq/utf_bom.html#22 ) $s =~ s/\A//; return $s; } else { local $/ = $self->{line_ends}; return scalar <$fh>; } } # Internal method, closes or resets the file handle. To be called # whenever ReadConfig() returns. sub _rollback { my ( $self, $fh ) = @_; # Only close if this is a filename, if it's # an open handle, then just roll back to the start if ( !ref( $self->{cf} ) ) { close($fh) or Carp::confess("close failed: $!"); } else { # Attempt to rollback to beginning, no problem if this fails (e.g. STDIN) seek( $fh, 0, SEEK_SET() ); } # end if } sub _no_filename { my $self = shift; my $fn = $self->{cf}; return ( not( defined($fn) && length($fn) ) ); } sub _read_line_num { my $self = shift; if (@_) { $self->{_read_line_num} = shift; } return $self->{_read_line_num}; } # Reads the next line and removes the end of line from it. sub _read_next_line { my ( $self, $fh ) = @_; my $line = $self->_nextline($fh); if ( !defined($line) ) { return undef; } $self->_read_line_num( $self->_read_line_num() + 1 ); # Remove line ending char(s) $line =~ s/(\015\012?|\012|\025|\n)\z//; return $line; } sub _add_error { my ( $self, $msg ) = @_; CORE::push( @Config::IniFiles::errors, $msg ); return; } # The current section - used for parsing. sub _curr_sect { my $self = shift; if (@_) { $self->{_curr_sect} = shift; } return $self->{_curr_sect}; } # The current parameter - used for parsing. sub _curr_parm { my $self = shift; if (@_) { $self->{_curr_parm} = shift; } return $self->{_curr_parm}; } # Current location - section and parameter. sub _curr_loc { my $self = shift; return ( $self->_curr_sect, $self->_curr_parm ); } # The current value - used in parsing. sub _curr_val { my $self = shift; if (@_) { $self->{_curr_val} = shift; } return $self->{_curr_val}; } sub _curr_cmts { my $self = shift; if (@_) { $self->{_curr_cmts} = shift; } return $self->{_curr_cmts}; } sub _curr_end_comment { my $self = shift; if (@_) { $self->{_curr_end_comment} = shift; } return $self->{_curr_end_comment}; } my $RET_CONTINUE = 1; my $RET_BREAK; sub _ReadConfig_handle_comment { my ( $self, $line ) = @_; if ( $self->{negativedeltas} and my ($to_delete) = $line =~ m/\A$self->{comment_char} (.*) is deleted\z/ ) { if ( my ($sect) = $to_delete =~ m/\A\[(.*)\]\z/ ) { $self->DeleteSection($sect); } else { $self->delval( $self->_curr_sect, $to_delete ); } } else { CORE::push( @{ $self->_curr_cmts }, $line ); } return $RET_CONTINUE; } sub _ReadConfig_new_section { my ( $self, $sect ) = @_; $self->_caseify( undef, \$sect ); $self->_curr_sect($sect); $self->AddSection( $self->_curr_sect ); $self->SetSectionComment( $self->_curr_sect, @{ $self->_curr_cmts } ); $self->_curr_cmts( [] ); return $RET_CONTINUE; } sub _handle_fallback_sect { my ($self) = @_; if ( ( !defined( $self->_curr_sect ) ) and defined( $self->{fallback} ) ) { $self->_curr_sect( $self->{fallback} ); $self->{fallback_used}++; } return; } sub _ReadConfig_load_value { my ( $self, $val_aref ) = @_; # Now load value if ( exists $self->{v}{ $self->_curr_sect }{ $self->_curr_parm } && exists $self->{myparms}{ $self->_curr_sect } && $self->_is_parm_in_sect( $self->_curr_loc ) ) { $self->push( $self->_curr_loc, @$val_aref ); } else { # Loaded parameters shadow imported ones, instead of appending # to them $self->newval( $self->_curr_loc, @$val_aref ); } return; } sub _test_for_fallback_or_no_sect { my ( $self, $fh ) = @_; $self->_handle_fallback_sect; if ( !defined $self->_curr_sect ) { $self->_add_error( sprintf( '%d: %s', $self->_read_line_num(), qq#parameter found outside a section# ) ); $self->_rollback($fh); return $RET_BREAK; } return $RET_CONTINUE; } sub _ReadConfig_handle_here_doc_param { my ( $self, $fh, $eotmark, $val_aref ) = @_; my $foundeot = 0; my $startline = $self->_read_line_num(); HERE_DOC_LOOP: while ( defined( my $line = $self->_read_next_line($fh) ) ) { if ( $line eq $eotmark ) { $foundeot = 1; last HERE_DOC_LOOP; } else { # Untaint my ($contents) = $line =~ /(.*)/ms; CORE::push( @$val_aref, $contents ); } } if ( !$foundeot ) { $self->_add_error( sprintf( '%d: %s', $startline, qq#no end marker ("$eotmark") found# ) ); $self->_rollback($fh); return $RET_BREAK; } return $RET_CONTINUE; } sub _ReadConfig_handle_non_here_doc_param { my ( $self, $fh, $val_aref ) = @_; my $allCmt = $self->{allowed_comment_char}; my $end_commenthandle = $self->{handle_trailing_comment}; # process continuation lines, if any $self->_process_continue_val($fh); # we should split value and comments if there is any comment if ( $end_commenthandle and my ( $value_to_assign, $end_comment_to_assign ) = $self->_curr_val =~ /(.*?)\s*[$allCmt]\s*(.*)$/ ) { $self->_curr_val($value_to_assign); $self->_curr_end_comment($end_comment_to_assign); } else { $self->_curr_end_comment(q{}); } @{$val_aref} = ( $self->_curr_val ); return; } sub _ReadConfig_populate_values { my ( $self, $val_aref, $eotmark ) = @_; $self->_ReadConfig_load_value($val_aref); $self->SetParameterComment( $self->_curr_loc, @{ $self->_curr_cmts } ); $self->_curr_cmts( [] ); if ( defined $eotmark ) { $self->SetParameterEOT( $self->_curr_loc, $eotmark ); } # if handle_trailing_comment is off, this line makes no sense, since all $end_comment="" $self->SetParameterTrailingComment( $self->_curr_loc, $self->_curr_end_comment ); return; } sub _ReadConfig_param_assignment { my ( $self, $fh, $line, $parm, $value_to_assign ) = @_; $self->_caseify( undef, \$parm, \$value_to_assign ); $self->_curr_val($value_to_assign); $self->_curr_end_comment( undef() ); if ( !defined( $self->_test_for_fallback_or_no_sect($fh) ) ) { return $RET_BREAK; } $self->_curr_parm($parm); my @val = (); my $eotmark; if ( ($eotmark) = $self->_curr_val =~ /\A<<(.*)$/ ) { if ( !defined( $self->_ReadConfig_handle_here_doc_param( $fh, $eotmark, \@val ) ) ) { return $RET_BREAK; } } else { $self->_ReadConfig_handle_non_here_doc_param( $fh, \@val ); } $self->_ReadConfig_populate_values( \@val, $eotmark ); return $RET_CONTINUE; } # Return 1 to continue - undef to terminate the loop. sub _ReadConfig_handle_line { my ( $self, $fh, $line ) = @_; my $allCmt = $self->{allowed_comment_char}; # ignore blank lines if ( $line =~ /\A\s*\z/ ) { return $RET_CONTINUE; } # collect comments if ( $line =~ /\A\s*[$allCmt]/ ) { return $self->_ReadConfig_handle_comment($line); } # New Section if ( my ($sect) = $line =~ /\A\s*\[\s*(\S|\S.*\S)\s*\]\s*\z/ ) { return $self->_ReadConfig_new_section($sect); } # New parameter if ( my ( $parm, $value_to_assign ) = $line =~ /^\s*([^=]*?[^=\s])\s*=\s*(.*)$/ ) { return $self->_ReadConfig_param_assignment( $fh, $line, $parm, $value_to_assign ); } $self->_add_error( sprintf( "Line %d in file %s is malformed:\n\t\%s", $self->_read_line_num(), $self->GetFileName(), $line ) ); return $RET_CONTINUE; } sub _ReadConfig_lines_loop { my ( $self, $fh ) = @_; $self->_curr_sect( undef() ); $self->_curr_parm( undef() ); $self->_curr_val( undef() ); $self->_curr_cmts( [] ); while ( defined( my $line = $self->_read_next_line($fh) ) ) { if ( !defined( scalar( $self->_ReadConfig_handle_line( $fh, $line ) ) ) ) { return undef; } } return 1; } sub ReadConfig { my $self = shift; @Config::IniFiles::errors = (); # Initialize (and clear out) storage hashes $self->{sects} = []; $self->{parms} = {}; $self->{group} = {}; $self->{v} = {}; $self->{sCMT} = {}; $self->{pCMT} = {}; $self->{EOT} = {}; $self->{mysects} = []; # A pair of hashes to remember which params are loaded $self->{myparms} = {}; # or set using the API vs. imported - useful for $self->{peCMT} = {}; # this will store trailing comments at the end of single-line params $self->{e} = {}; # If a section already exists $self->{mye} = {}; # If a section already exists # import shadowing, see below, and WriteConfig($fn, -delta=>1) if ( defined $self->{imported} ) { foreach my $field (qw(sects parms group v sCMT pCMT EOT e)) { $self->{$field} = _deepcopy( $self->{imported}->{$field} ); } } if ( $self->_no_filename ) { return 1; } # If we want warnings, then send one to the STDERR log if ( $self->{reloadwarn} ) { my ( $ss, $mm, $hh, $DD, $MM, $YY ) = ( localtime(time) )[ 0 .. 5 ]; printf STDERR "PID %d reloading config file %s at %d.%02d.%02d %02d:%02d:%02d\n", $$, $self->{cf}, $YY + 1900, $MM + 1, $DD, $hh, $mm, $ss; } # Get a filehandle, allowing almost any type of 'file' parameter my $fh = $self->_make_filehandle( $self->{cf} ); if ( !$fh ) { carp "Failed to open $self->{cf}: $!"; return undef; } # Get mod time of file so we can retain it (if not from STDIN) # also check if it's a real file (could have been a filehandle made from a scalar). if ( ref($fh) ne "IO::Scalar" && -e $fh ) { if ( not exists $self->{file_mode} ) { my @stats = stat $fh; $self->{file_mode} = sprintf( "%04o", $stats[2] ) if defined $stats[2]; } } # The first lines of the file must be blank, comments or start with [ my $first = ''; delete $self->{line_ends}; # Marks start of parsing for _nextline() $self->_read_line_num(0); if ( !defined( $self->_ReadConfig_lines_loop($fh) ) ) { return undef; } # Special case: return undef if file is empty. (suppress this line to # restore the more intuitive behaviour of accepting empty files) if ( !keys %{ $self->{v} } && !$self->{allowempty} ) { $self->_add_error("Empty file treated as error"); $self->_rollback($fh); return undef; } if ( defined( my $defaultsect = $self->{startup_settings}->{-default} ) ) { $self->AddSection($defaultsect); } $self->_SetEndComments( @{ $self->_curr_cmts } ); $self->_rollback($fh); return ( @Config::IniFiles::errors ? undef : 1 ); } sub Sections { my $self = shift; return @{ _aref_or_empty( $self->{sects} ) }; } sub SectionExists { my $self = shift; my $sect = shift; return undef if not defined $sect; $self->_caseify( \$sect ); return ( ( exists $self->{e}{$sect} ) ? 1 : 0 ); } sub _AddSection_Helper { my ( $self, $sect ) = @_; $self->{e}{$sect} = 1; CORE::push @{ $self->{sects} }, $sect; $self->_touch_section($sect); $self->SetGroupMember($sect); # Set up the parameter names and values lists $self->{parms}{$sect} ||= []; if ( !defined( $self->{v}{$sect} ) ) { $self->{sCMT}{$sect} = []; $self->{pCMT}{$sect} = {}; # Comments above parameters $self->{parms}{$sect} = []; $self->{v}{$sect} = {}; } return; } sub AddSection { my ( $self, $sect ) = @_; return undef if not defined $sect; $self->_caseify( \$sect ); if ( $self->SectionExists($sect) ) { return; } return $self->_AddSection_Helper($sect); } # Marks a section as modified by us (this includes deleted by us). sub _touch_section { my ( $self, $sect ) = @_; $self->{mysects} ||= []; unless ( exists $self->{mye}{$sect} ) { CORE::push @{ $self->{mysects} }, $sect; $self->{mye}{$sect} = 1; } return; } # Marks a parameter as modified by us (this includes deleted by us). sub _touch_parameter { my ( $self, $sect, $parm ) = @_; $self->_touch_section($sect); return if ( !exists $self->{v}{$sect} ); $self->{myparms}{$sect} ||= []; if ( !$self->_is_parm_in_sect( $sect, $parm ) ) { CORE::push @{ $self->{myparms}{$sect} }, $parm; } return; } sub DeleteSection { my $self = shift; my $sect = shift; return undef if not defined $sect; $self->_caseify( \$sect ); # This is done the fast way, change if data structure changes!! delete $self->{v}{$sect}; delete $self->{sCMT}{$sect}; delete $self->{pCMT}{$sect}; delete $self->{EOT}{$sect}; delete $self->{parms}{$sect}; delete $self->{myparms}{$sect}; delete $self->{e}{$sect}; $self->{sects} = [ grep { $_ ne $sect } @{ $self->{sects} } ]; $self->_touch_section($sect); $self->RemoveGroupMember($sect); return 1; } # end DeleteSection sub RenameSection { my $self = shift; my $old_sect = shift; my $new_sect = shift; my $include_groupmembers = shift; return undef unless $self->CopySection( $old_sect, $new_sect, $include_groupmembers ); return $self->DeleteSection($old_sect); } # end RenameSection sub CopySection { my $self = shift; my $old_sect = shift; my $new_sect = shift; my $include_groupmembers = shift; if ( not defined $old_sect or not defined $new_sect or !$self->SectionExists($old_sect) or $self->SectionExists($new_sect) ) { return undef; } $self->_caseify( \$new_sect ); $self->_AddSection_Helper($new_sect); # This is done the fast way, change if data structure changes!! foreach my $key (qw(v sCMT pCMT EOT parms myparms e)) { next unless exists $self->{$key}{$old_sect}; $self->{$key}{$new_sect} = Config::IniFiles::_deepcopy( $self->{$key}{$old_sect} ); } if ($include_groupmembers) { foreach my $old_groupmember ( $self->GroupMembers($old_sect) ) { my $new_groupmember = $old_groupmember; $new_groupmember =~ s/\A\Q$old_sect\E/$new_sect/; $self->CopySection( $old_groupmember, $new_groupmember ); } } return 1; } # end CopySection sub _aref_or_empty { my ($aref) = @_; return ( ( defined($aref) and ref($aref) eq 'ARRAY' ) ? $aref : [] ); } sub Parameters { my $self = shift; my $sect = shift; return undef if not defined $sect; $self->_caseify( \$sect ); return @{ _aref_or_empty( $self->{parms}{$sect} ) }; } sub Groups { my $self = shift; if ( ref( $self->{group} ) eq 'HASH' ) { return keys %{ $self->{group} }; } else { return (); } } sub _group_member_handling_skeleton { my ( $self, $sect, $method ) = @_; return undef if not defined $sect; if ( !( my ($group) = ( $sect =~ /\A(\S+)\s+\S/ ) ) ) { return 1; } else { return $self->$method( $sect, $group ); } } sub _SetGroupMember_helper { my ( $self, $sect, $group ) = @_; if ( not exists( $self->{group}{$group} ) ) { $self->{group}{$group} = []; } if ( none { $_ eq $sect } @{ $self->{group}{$group} } ) { CORE::push @{ $self->{group}{$group} }, $sect; } return; } sub SetGroupMember { my ( $self, $sect ) = @_; return $self->_group_member_handling_skeleton( $sect, '_SetGroupMember_helper' ); } sub _RemoveGroupMember_helper { my ( $self, $sect, $group ) = @_; if ( !exists $self->{group}{$group} ) { return; } $self->{group}{$group} = [ grep { $_ ne $sect } @{ $self->{group}{$group} } ]; return; } sub RemoveGroupMember { my ( $self, $sect ) = @_; return $self->_group_member_handling_skeleton( $sect, '_RemoveGroupMember_helper' ); } sub GroupMembers { my ( $self, $group ) = @_; return undef if not defined $group; $self->_caseify( \$group ); return @{ _aref_or_empty( $self->{group}{$group} ) }; } sub SetWriteMode { my ( $self, $mode ) = @_; if ( not( defined($mode) && ( $mode =~ m/[0-7]{3}/ ) ) ) { return undef; } return ( $self->{file_mode} = $mode ); } sub GetWriteMode { my $self = shift; return $self->{file_mode}; } sub _write_config_to_filename { my ( $self, $filename, %parms ) = @_; if ( -e $filename ) { if ( not( -w $filename ) ) { #carp "File $filename is not writable. Refusing to write config"; return undef; } if ( not exists $self->{file_mode} ) { my $mode = ( stat $filename )[2]; $self->{file_mode} = sprintf "%04o", ( $mode & 0777 ); } #carp "Using mode $self->{file_mode} for file $file"; } my ( $fh, $new_file ); # We need to trap the exception that tempfile() may throw and instead # carp() and return undef() because that was the previous behaviour: # # See RT #77039 ( https://rt.cpan.org/Ticket/Display.html?id=77039 ) eval { ( $fh, $new_file ) = tempfile( "temp.ini-XXXXXXXXXX", DIR => dirname($filename) ); # Convert the filehandle to a "text" filehandle suitable for use # on Windows (and other platforms). # # This may break compatibility for ultra-old perls (ones before 5.6.0) # so I say - Good Riddance! if ( $^O =~ m/\AMSWin/ ) { binmode $fh, ':crlf'; } }; if ($@) { carp("Unable to write temp config file: $!"); return undef; } $self->OutputConfigToFileHandle( $fh, $parms{-delta} ); close($fh) or Carp::confess("close failed: $!"); if ( !rename( $new_file, $filename ) ) { carp "Unable to rename temp config file ($new_file) to ${filename}: $!"; return undef; } if ( exists $self->{file_mode} ) { if ( not chmod( oct( $self->{file_mode} ), $filename ) ) { carp "Unable to chmod $filename!"; } } return 1; } sub _write_config_with_a_made_fh { my ( $self, $fh, %parms ) = @_; # Only roll back if it's not STDIN (if it is, Carp) if ( $fh == \*STDIN ) { carp "Cannot write configuration file to STDIN."; } else { seek( $fh, 0, SEEK_SET() ); # Make sure to keep the previous junk out. # See: # https://rt.cpan.org/Public/Bug/Display.html?id=103496 truncate( $fh, 0 ); $self->OutputConfigToFileHandle( $fh, $parms{-delta} ); seek( $fh, 0, SEEK_SET() ); } # end if return 1; } sub _write_config_to_fh { my ( $self, $file, %parms ) = @_; # Get a filehandle, allowing almost any type of 'file' parameter ## NB: If this were a filename, this would fail because _make_file ## opens a read-only handle, but we have already checked that case ## so re-using the logic is ok [JW/WADG] my $fh = $self->_make_filehandle($file); if ( !$fh ) { carp "Could not find a filehandle for the input stream ($file): $!"; return undef; } return $self->_write_config_with_a_made_fh( $fh, %parms ); } sub WriteConfig { my ( $self, $file, %parms ) = @_; return undef unless defined $file; # If we are using a filename, then do mode checks and write to a # temporary file to avoid a race condition if ( !ref($file) ) { return $self->_write_config_to_filename( $file, %parms ); } # Otherwise, reset to the start of the file and write, unless we are using # STDIN else { return $self->_write_config_to_fh( $file, %parms ); } } sub RewriteConfig { my $self = shift; if ( $self->_no_filename ) { return 1; } return $self->WriteConfig( $self->{cf} ); } sub GetFileName { my $self = shift; return $self->{cf}; } sub SetFileName { my ( $self, $new_filename ) = @_; if ( length($new_filename) > 0 ) { return ( $self->{cf} = $new_filename ); } else { return undef; } } sub _calc_eot_mark { my ( $self, $sect, $parm, $val ) = @_; my $eotmark = $self->{EOT}{$sect}{$parm} || 'EOT'; # Make sure the $eotmark does not occur inside the string. my @letters = ( 'A' .. 'Z' ); my $joined_val = join( q{ }, @$val ); while ( index( $joined_val, $eotmark ) >= 0 ) { $eotmark .= $letters[ rand(@letters) ]; } return $eotmark; } sub _OutputParam { my ( $self, $sect, $parm, $val, $end_comment, $output_cb ) = @_; my $line_loop = sub { my ($mapper) = @_; foreach my $line ( @{$val}[ 0 .. $#$val - 1 ] ) { $output_cb->( $mapper->($line) ); } $output_cb->( $mapper->( $val->[-1] ), ( $end_comment ? (" $self->{comment_char} $end_comment") : () ), ); return; }; if ( !@$val ) { # An empty variable - see: # https://rt.cpan.org/Public/Bug/Display.html?id=68554 $output_cb->("$parm="); } elsif ( ( @$val == 1 ) or $self->{nomultiline} ) { $line_loop->( sub { my ($line) = @_; return "$parm=$line"; } ); } else { my $eotmark = $self->_calc_eot_mark( $sect, $parm, $val ); $output_cb->("$parm= <<$eotmark"); $line_loop->( sub { my ($line) = @_; return $line; } ); $output_cb->($eotmark); } return; } sub OutputConfig { my ( $self, $delta ) = @_; return $self->OutputConfigToFileHandle( select(), $delta ); } sub _output_comments { my ( $self, $print_line, $comments_aref ) = @_; if ( ref($comments_aref) eq 'ARRAY' ) { foreach my $comment (@$comments_aref) { $print_line->($comment); } } return; } sub _process_continue_val { my ( $self, $fh ) = @_; if ( not $self->{allowcontinue} ) { return; } my $val = $self->_curr_val; while ( $val =~ s/\\\z// ) { $val .= $self->_read_next_line($fh); } $self->_curr_val($val); return; } sub _output_param_total { my ( $self, $sect, $parm, $print_line, $split_val, $delta ) = @_; if ( !defined $self->{v}{$sect}{$parm} ) { if ($delta) { $print_line->("$self->{comment_char} $parm is deleted"); } else { warn "Weird unknown parameter $parm" if $^W; } return; } $self->_output_comments( $print_line, $self->{pCMT}{$sect}{$parm} ); my $val = $self->{v}{$sect}{$parm}; my $end_comment = $self->{peCMT}{$sect}{$parm}; return if !defined($val); # No parameter exists !! $self->_OutputParam( $sect, $parm, $split_val->($val), ( defined($end_comment) ? $end_comment : "" ), $print_line, ); return; } sub _output_section { my ( $self, $sect, $print_line, $split_val, $delta, $position ) = @_; if ( !defined $self->{v}{$sect} ) { if ($delta) { $print_line->("$self->{comment_char} [$sect] is deleted"); } else { warn "Weird unknown section $sect" if $^W; } return; } return if not defined $self->{v}{$sect}; $print_line->() if ( $position > 0 ); $self->_output_comments( $print_line, $self->{sCMT}{$sect} ); if ( !( $self->{fallback_used} and $sect eq $self->{fallback} ) ) { $print_line->("[$sect]"); } return if ref( $self->{v}{$sect} ) ne 'HASH'; foreach my $parm ( @{ $self->{ $delta ? "myparms" : "parms" }{$sect} } ) { $self->_output_param_total( $sect, $parm, $print_line, $split_val, $delta ); } return; } sub OutputConfigToFileHandle { # We need no strict 'refs' to be able to print to $fh if it points # to a glob filehandle. no strict 'refs'; my ( $self, $fh, $delta ) = @_; my $ors = $self->{line_ends} || $\ || "\n"; # $\ is normally unset, but use input by default my $print_line = sub { print {$fh} ( @_, $ors ) or die "Config-IniFiles cannot print to filehandle (out-of-space?). Aborting!"; return; }; my $split_val = sub { my ($val) = @_; return ( ( ref($val) eq 'ARRAY' ) ? $val : [ split /[$ors]/, $val, -1 ] ); }; my $position = 0; foreach my $sect ( @{ $self->{ $delta ? "mysects" : "sects" } } ) { $self->_output_section( $sect, $print_line, $split_val, $delta, $position++ ); } $self->_output_comments( $print_line, [ $self->_GetEndComments() ] ); return 1; } sub SetSectionComment { my ( $self, $sect, @comment ) = @_; if ( not( defined($sect) && @comment ) ) { return undef; } $self->_caseify( \$sect ); $self->_touch_section($sect); # At this point it's possible to have a comment for a section that # doesn't exist. This comment will not get written to the INI file. $self->{sCMT}{$sect} = $self->_markup_comments( \@comment ); return scalar @comment; } # this helper makes sure that each line is preceded with the correct comment # character sub _markup_comments { my ( $self, $comment_aref ) = @_; my $allCmt = $self->{allowed_comment_char}; my $cmtChr = $self->{comment_char}; my $is_comment = qr/\A\s*[$allCmt]/; # TODO : Maybe create a qr// out of it. return [ map { ( $_ =~ $is_comment ) ? $_ : "$cmtChr $_" } @$comment_aref ]; } sub _return_comment { my ( $self, $comment_aref ) = @_; my $delim = defined($/) ? $/ : "\n"; return wantarray() ? @$comment_aref : join( $delim, @$comment_aref ); } sub GetSectionComment { my ( $self, $sect ) = @_; return undef if not defined $sect; $self->_caseify( \$sect ); if ( !exists $self->{sCMT}{$sect} ) { return undef; } return $self->_return_comment( $self->{sCMT}{$sect} ); } sub DeleteSectionComment { my $self = shift; my $sect = shift; return undef if not defined $sect; $self->_caseify( \$sect ); $self->_touch_section($sect); delete $self->{sCMT}{$sect}; return; } sub SetParameterComment { my ( $self, $sect, $parm, @comment ) = @_; if ( not( defined($sect) && defined($parm) && @comment ) ) { return undef; } $self->_caseify( \$sect, \$parm ); $self->_touch_parameter( $sect, $parm ); # Note that at this point, it's possible to have a comment for a parameter, # without that parameter actually existing in the INI file. $self->{pCMT}{$sect}{$parm} = $self->_markup_comments( \@comment ); return scalar @comment; } sub _SetEndComments { my $self = shift; my @comments = @_; $self->{_comments_at_end_of_file} = \@comments; return 1; } sub _GetEndComments { my $self = shift; return @{ $self->{_comments_at_end_of_file} }; } sub GetParameterComment { my ( $self, $sect, $parm ) = @_; if ( not( defined($sect) && defined($parm) ) ) { return undef; } $self->_caseify( \$sect, \$parm ); if ( not( exists( $self->{pCMT}{$sect} ) && exists( $self->{pCMT}{$sect}{$parm} ) ) ) { return undef; } return $self->_return_comment( $self->{pCMT}{$sect}{$parm} ); } sub DeleteParameterComment { my ( $self, $sect, $parm ) = @_; if ( not( defined($sect) && defined($parm) ) ) { return undef; } $self->_caseify( \$sect, \$parm ); # If the parameter doesn't exist, our goal has already been achieved if ( exists( $self->{pCMT}{$sect} ) && exists( $self->{pCMT}{$sect}{$parm} ) ) { $self->_touch_parameter( $sect, $parm ); delete $self->{pCMT}{$sect}{$parm}; } return 1; } sub GetParameterEOT { my ( $self, $sect, $parm ) = @_; if ( not( defined($sect) && defined($parm) ) ) { return undef; } $self->_caseify( \$sect, \$parm ); return $self->{EOT}{$sect}{$parm}; } sub SetParameterEOT { my ( $self, $sect, $parm, $EOT ) = @_; if ( not( defined($sect) && defined($parm) && defined($EOT) ) ) { return undef; } $self->_caseify( \$sect, \$parm ); $self->_touch_parameter( $sect, $parm ); $self->{EOT}{$sect}{$parm} = $EOT; return; } sub DeleteParameterEOT { my ( $self, $sect, $parm ) = @_; if ( not( defined($sect) && defined($parm) ) ) { return undef; } $self->_caseify( \$sect, \$parm ); $self->_touch_parameter( $sect, $parm ); delete $self->{EOT}{$sect}{$parm}; return; } sub SetParameterTrailingComment { my ( $self, $sect, $parm, $cmt ) = @_; if ( not( defined($sect) && defined($parm) && defined($cmt) ) ) { return undef; } $self->_caseify( \$sect, \$parm ); # confirm the parameter exist return undef if not exists $self->{v}{$sect}{$parm}; $self->_touch_parameter( $sect, $parm ); $self->{peCMT}{$sect}{$parm} = $cmt; return 1; } sub GetParameterTrailingComment { my ( $self, $sect, $parm ) = @_; if ( not( defined($sect) && defined($parm) ) ) { return undef; } $self->_caseify( \$sect, \$parm ); # confirm the parameter exist return undef if not exists $self->{v}{$sect}{$parm}; return $self->{peCMT}{$sect}{$parm}; } sub Delete { my $self = shift; foreach my $section ( $self->Sections() ) { $self->DeleteSection($section); } return 1; } # end Delete ############################################################ # # TIEHASH Methods # # Description: # These methods allow you to tie a hash to the # Config::IniFiles object. Note that, when tied, the # user wants to look at thinks like $ini{sec}{parm}, but the # TIEHASH only provides one level of hash interface, so the # root object gets asked for a $ini{sec}, which this # implements. To further tie the {parm} hash, the internal # class Config::IniFiles::_section, is provided, below. # ############################################################ # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2000May09 Created method JW # ---------------------------------------------------------- sub TIEHASH { my $class = shift; my %parms = @_; # Get a new object my $self = $class->new(%parms); return $self; } # end TIEHASH # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2000May09 Created method JW # ---------------------------------------------------------- sub FETCH { my $self = shift; my ($key) = @_; $self->{_section_cache} ||= {}; $self->_caseify( \$key ); return if ( !$self->{v}{$key} ); return $self->{_section_cache}->{$key} if exists $self->{_section_cache}->{$key}; my %retval; tie %retval, 'Config::IniFiles::_section', $self, $key; return $self->{_section_cache}->{$key} = \%retval; } # end FETCH # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2000Jun14 Fixed bug where wrong ref was saved JW # 2000Oct09 Fixed possible but in %parms with defaults JW # 2001Apr04 Fixed -nocase problem in storing JW # ---------------------------------------------------------- sub STORE { my $self = shift; my ( $key, $ref ) = @_; return undef unless ref($ref) eq 'HASH'; $self->_caseify( \$key ); $self->AddSection($key); $self->{v}{$key} = {%$ref}; $self->{parms}{$key} = [ keys %$ref ]; $self->{myparms}{$key} = [ keys %$ref ]; return 1; } # end STORE # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2000May09 Created method JW # 2000Dec17 Now removes comments, groups and EOTs too JW # 2001Arp04 Fixed -nocase problem JW # ---------------------------------------------------------- sub DELETE { my $self = shift; my ($key) = @_; my $retval = $self->FETCH($key); $self->DeleteSection($key); return $retval; } # end DELETE # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2000May09 Created method JW # ---------------------------------------------------------- sub CLEAR { my $self = shift; return $self->Delete(); } # end CLEAR # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2000May09 Created method JW # ---------------------------------------------------------- sub FIRSTKEY { my $self = shift; $self->{tied_enumerator} = 0; return $self->NEXTKEY(); } # end FIRSTKEY # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2000May09 Created method JW # ---------------------------------------------------------- sub NEXTKEY { my $self = shift; my ($last) = @_; my $i = $self->{tied_enumerator}++; my $key = $self->{sects}[$i]; return if ( !defined $key ); return wantarray ? ( $key, $self->FETCH($key) ) : $key; } # end NEXTKEY # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2000May09 Created method JW # 2001Apr04 Fixed -nocase bug and false true bug JW # ---------------------------------------------------------- sub EXISTS { my $self = shift; my ($key) = @_; return $self->SectionExists($key); } # end EXISTS # ---------------------------------------------------------- # DESTROY is used by TIEHASH and the Perl garbage collector, # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2000May09 Created method JW # ---------------------------------------------------------- sub DESTROY { # my $self = shift; } # end if # ---------------------------------------------------------- # Sub: _make_filehandle # # Args: $thing # $thing An input source # # Description: Takes an input source - a filehandle, # filehandle glob, reference to a filehandle glob, IO::File # object or scalar filename - and returns a file handle to # read from it with. # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 06Dec2001 Added to support input from any source JW # ---------------------------------------------------------- sub _make_filehandle { my $self = shift; # # This code is 'borrowed' from Lincoln D. Stein's GD.pm module # with modification for this module. Thanks Lincoln! # no strict 'refs'; my $thing = shift; if ( ref($thing) eq "SCALAR" ) { if ( eval { require IO::Scalar; $IO::Scalar::VERSION >= 2.109; } ) { return IO::Scalar->new($thing); } else { warn "SCALAR reference as file descriptor requires IO::stringy " . "v2.109 or later" if ($^W); return; } } return $thing if defined( fileno $thing ); # otherwise try qualifying it into caller's package my $fh = qualify_to_ref( $thing, caller(1) ); return $fh if defined( fileno $fh ); # otherwise treat it as a file to open $fh = gensym; open( $fh, $thing ) || return; return $fh; } # end _make_filehandle ############################################################ # # INTERNAL PACKAGE: Config::IniFiles::_section # # Description: # This package is used to provide a single-level TIEHASH # interface to the sections in the IniFile. When tied, the # user wants to look at thinks like $ini{sec}{parm}, but the # TIEHASH only provides one level of hash interface, so the # root object gets asked for a $ini{sec} and must return a # has reference that accurately covers the '{parm}' part. # # This package is only used when tied and is inter-woven # between the sections and their parameters when the TIEHASH # method is called by Perl. It's a very simple implementation # of a tied hash object that simply maps onto the object API. # ############################################################ # Date Modification Author # ---------------------------------------------------------- # 2000.May.09 Created to excapsulate TIEHASH interface JW ############################################################ package Config::IniFiles::_section; use strict; use warnings; use Carp; use vars qw( $VERSION ); $Config::IniFiles::_section::VERSION = 2.16; # ---------------------------------------------------------- # Sub: Config::IniFiles::_section::TIEHASH # # Args: $class, $config, $section # $class The class that this is being tied to. # $config The parent Config::IniFiles object # $section The section this tied object refers to # # Description: Builds the object that implements accesses to # the tied hash. # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # ---------------------------------------------------------- sub TIEHASH { my $proto = shift; my $class = ref($proto) || $proto; my ( $config, $section ) = @_; # Make a new object return bless { config => $config, section => $section }, $class; } # end TIEHASH # ---------------------------------------------------------- # Sub: Config::IniFiles::_section::FETCH # # Args: $key # $key The name of the key whose value to get # # Description: Returns the value associated with $key. If # the value is a list, returns a list reference. # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2000Jun15 Fixed bugs in -default handler JW # 2000Dec07 Fixed another bug in -deault handler JW # 2002Jul04 Returning scalar values (Bug:447532) AS # ---------------------------------------------------------- sub FETCH { my ( $self, $key ) = @_; my @retval = $self->{config}->val( $self->{section}, $key ); return ( @retval <= 1 ) ? $retval[0] : \@retval; } # end FETCH # ---------------------------------------------------------- # Sub: Config::IniFiles::_section::STORE # # Args: $key, @val # $key The key under which to store the value # @val The value to store, either an array or a scalar # # Description: Sets the value for the specified $key # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2001Apr04 Fixed -nocase bug JW # ---------------------------------------------------------- sub STORE { my ( $self, $key, @val ) = @_; return $self->{config}->newval( $self->{section}, $key, @val ); } # end STORE # ---------------------------------------------------------- # Sub: Config::IniFiles::_section::DELETE # # Args: $key # $key The key to remove from the hash # # Description: Removes the specified key from the hash and # returns its former value. # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2001Apr04 Fixed -nocase bug JW # ---------------------------------------------------------- sub DELETE { my ( $self, $key ) = @_; my $retval = $self->{config}->val( $self->{section}, $key ); $self->{config}->delval( $self->{section}, $key ); return $retval; } # end DELETE # ---------------------------------------------------------- # Sub: Config::IniFiles::_section::CLEAR # # Args: (None) # # Description: Empties the entire hash # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # ---------------------------------------------------------- sub CLEAR { my ($self) = @_; return $self->{config}->DeleteSection( $self->{section} ); } # end CLEAR # ---------------------------------------------------------- # Sub: Config::IniFiles::_section::EXISTS # # Args: $key # $key The key to look for # # Description: Returns whether the key exists # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # 2001Apr04 Fixed -nocase bug JW # ---------------------------------------------------------- sub EXISTS { my ( $self, $key ) = @_; return $self->{config}->exists( $self->{section}, $key ); } # end EXISTS # ---------------------------------------------------------- # Sub: Config::IniFiles::_section::FIRSTKEY # # Args: (None) # # Description: Returns the first key in the hash # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # ---------------------------------------------------------- sub FIRSTKEY { my $self = shift; $self->{tied_enumerator} = 0; return $self->NEXTKEY(); } # end FIRSTKEY # ---------------------------------------------------------- # Sub: Config::IniFiles::_section::NEXTKEY # # Args: $last # $last The last key accessed by the iterator # # Description: Returns the next key in line # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # ---------------------------------------------------------- sub NEXTKEY { my $self = shift; my ($last) = @_; my $i = $self->{tied_enumerator}++; my @keys = $self->{config}->Parameters( $self->{section} ); my $key = $keys[$i]; return if ( !defined $key ); return wantarray ? ( $key, $self->FETCH($key) ) : $key; } # end NEXTKEY # ---------------------------------------------------------- # Sub: Config::IniFiles::_section::DESTROY # # Args: (None) # # Description: Called on cleanup # ---------------------------------------------------------- # Date Modification Author # ---------------------------------------------------------- # ---------------------------------------------------------- sub DESTROY { # my $self = shift } # end DESTROY 1; 1; # Please keep the following within the last four lines of the file #[JW for editor]:mode=perl:tabSize=8:indentSize=2:noTabs=true:indentOnEnter=true: __END__ =pod =encoding UTF-8 =head1 NAME Config::IniFiles - A module for reading .ini-style configuration files. =head1 VERSION version 3.000003 =head1 SYNOPSIS use Config::IniFiles; my $cfg = Config::IniFiles->new( -file => "/path/configfile.ini" ); print "The value is " . $cfg->val( 'Section', 'Parameter' ) . "." if $cfg->val( 'Section', 'Parameter' ); =head1 DESCRIPTION Config::IniFiles provides a way to have readable configuration files outside your Perl script. Configurations can be imported (inherited, stacked,...), sections can be grouped, and settings can be accessed from a tied hash. =head1 FILE FORMAT INI files consist of a number of sections, each preceded with the section name in square brackets, followed by parameter names and their values. [a section] Parameter=Value [section 2] AnotherParameter=Some value Setting=Something else Parameter=Different scope than the one in the first section The first non-blank character of the line indicating a section must be a left bracket and the last non-blank character of a line indicating a section must be a right bracket. The characters making up the section name can be any symbols at all. However section names must be unique. Parameters are specified in each section as Name=Value. Any spaces around the equals sign will be ignored, and the value extends to the end of the line (including any whitespace at the end of the line. Parameter names are localized to the namespace of the section, but must be unique within a section. Both the hash mark (#) and the semicolon (;) are comment characters. by default (this can be changed by configuration). Lines that begin with either of these characters will be ignored. Any amount of whitespace may precede the comment character. Multi-line or multi-valued parameters may also be defined ala UNIX "here document" syntax: Parameter=<<EOT value/line 1 value/line 2 EOT You may use any string you want in place of "EOT". Note that whatever follows the "<<" and what appears at the end of the text MUST match exactly, including any trailing whitespace. Alternately, as a configuration option (default is off), continuation lines can be allowed: [Section] Parameter=this parameter \ spreads across \ a few lines =head1 USAGE -- Object Interface Get a new Config::IniFiles object with the I<new> method: $cfg = Config::IniFiles->new( -file => "/path/config_file.ini" ); $cfg = new Config::IniFiles -file => "/path/config_file.ini"; Optional named parameters may be specified after the configuration file name. See the I<new> in the B<METHODS> section, below. Values from the config file are fetched with the val method: $value = $cfg->val('Section', 'Parameter'); If you want a multi-line/value field returned as an array, just specify an array as the receiver: @values = $cfg->val('Section', 'Parameter'); =head1 METHODS =head2 new ( [-option=>value ...] ) Returns a new configuration object (or "undef" if the configuration file has an error, in which case check the global C<@Config::IniFiles::errors> array for reasons why). One Config::IniFiles object is required per configuration file. The following named parameters are available: =over 10 =item I<-file> filename Specifies a file to load the parameters from. This 'file' may actually be any of the following things: 1) the pathname of a file $cfg = Config::IniFiles->new( -file => "/path/to/config_file.ini" ); 2) a simple filehandle $cfg = Config::IniFiles->new( -file => STDIN ); 3) a filehandle glob open( CONFIG, "/path/to/config_file.ini" ); $cfg = Config::IniFiles->new( -file => *CONFIG ); 4) a reference to a glob open( CONFIG, "/path/to/config_file.ini" ); $cfg = Config::IniFiles->new( -file => \*CONFIG ); 5) an IO::File object $io = IO::File->new( "/path/to/config_file.ini" ); $cfg = Config::IniFiles->new( -file => $io ); or open my $fh, '<', "/path/to/config_file.ini" or die $!; $cfg = Config::IniFiles->new( -file => $fh ); 6) A reference to a scalar (requires newer versions of IO::Scalar) $ini_file_contents = <<EOT [section name] Parameter=A value Setting=Another value EOT $cfg = Config::IniFiles->new( -file => \$ini_file_contents ); If this option is not specified, (i.e. you are creating a config file from scratch) you must specify a target file using L<SetFileName> in order to save the parameters. =item I<-default> section Specifies a section to be used for default values. For example, in the following configuration file, if you look up the "permissions" parameter in the "joe" section, there is none. [all] permissions=Nothing [jane] name=Jane permissions=Open files [joe] name=Joseph If you create your Config::IniFiles object with a default section of "all" like this: $cfg = Config::IniFiles->new( -file => "file.ini", -default => "all" ); Then requesting a value for a "permissions" in the [joe] section will check for a value from [all] before returning undef. $permissions = $cfg->val( "joe", "permissions"); // returns "Nothing" =item I<-fallback> section Specifies a section to be used for parameters outside a section. Default is none. Without -fallback specified (which is the default), reading a configuration file which has a parameter outside a section will fail. With this set to, say, "GENERAL", this configuration: wrong=wronger [joe] name=Joseph will be assumed as: [GENERAL] wrong=wronger [joe] name=Joseph Note that Config::IniFiles will also omit the fallback section header when outputting such configuration. =item I<-nocase> 0|1 Set -nocase => 1 to handle the config file in a case-insensitive manner (case in values is preserved, however). By default, config files are case-sensitive (i.e., a section named 'Test' is not the same as a section named 'test'). Note that there is an added overhead for turning off case sensitivity. =item I<-import> object This allows you to import or inherit existing setting from another Config::IniFiles object. When importing settings from another object, sections with the same name will be merged and parameters that are defined in both the imported object and the I<-file> will take the value of given in the I<-file>. If a I<-default> section is also given on this call, and it does not coincide with the default of the imported object, the new default section will be used instead. If no I<-default> section is given, then the default of the imported object will be used. =item I<-allowcontinue> 0|1 Set -allowcontinue => 1 to enable continuation lines in the config file. i.e. if a line ends with a backslash C<\>, then the following line is appended to the parameter value, dropping the backslash and the newline character(s). Default behavior is to keep a trailing backslash C<\> as a parameter value. Note that continuation cannot be mixed with the "here" value syntax. =item I<-allowempty> 0|1 If set to 1, then empty files are allowed at L<ReadConfig|ReadConfig()> time. If set to 0 (the default), an empty configuration file is considered an error. =item I<-negativedeltas> 0|1 If set to 1 (the default if importing this object from another one), parses and honors lines of the following form in the configuration file: ; [somesection] is deleted or [inthissection] ; thisparameter is deleted If set to 0 (the default if not importing), these comments are treated like ordinary ones. The L<WriteConfig|WriteConfig($filename, -delta=>1)> form will output such comments to indicate deleted sections or parameters. This way, reloading a delta file using the same imported object produces the same results in memory again. See L<IMPORT / DELTA FEATURES> for more details. =item I<-commentchar> 'char' The default comment character is C<#>. You may change this by specifying this option to another character. This can be any character except alphanumeric characters, square brackets or the "equal" sign. =item I<-allowedcommentchars> 'chars' Allowed default comment characters are C<#> and C<;>. By specifying this option you may change the range of characters that are used to denote a comment line to include any set of characters Note: that the character specified by B<-commentchar> (see above) is I<always> part of the allowed comment characters. Note 2: The given string is evaluated as a regular expression character class, so '\' must be escaped if you wish to use it. =item I<-reloadwarn> 0|1 Set -reloadwarn => 1 to enable a warning message (output to STDERR) whenever the config file is reloaded. The reload message is of the form: PID <PID> reloading config file <file> at YYYY.MM.DD HH:MM:SS Default behavior is to not warn (i.e. -reloadwarn => 0). This is generally only useful when using Config::IniFiles in a server or daemon application. The application is still responsible for determining when the object is to be reloaded. =item I<-nomultiline> 0|1 Set -nomultiline => 1 to output multi-valued parameter as: param=value1 param=value2 instead of the default: param=<<EOT value1 value2 EOT As the latter might not be compatible with all applications. =item I<-handle_trailing_comment> 0|1 Set -handle_trailing_comment => 1 to enable support of parameter trailing comments. For example, if we have a parameter line like this: param1=value1;comment1 by default, handle_trailing_comment will be set to B<0>, and we will get I<value1;comment1> as the value of I<param1>. If we have -handle_trailing_comment set to B<1>, then we will get I<value1> as the value for I<param1>, and I<comment1> as the trailing comment of I<param1>. Set and get methods for trailing comments are provided as L</SetParameterTrailingComment> and L</GetParameterTrailingComment>. =item I<-php_compat> 0|1 Set -php_compat => 1 to enable support for PHP like configfiles. The differences between parse_ini_file and Config::IniFiles are: # parse_ini_file [group] val1="value" val2[]=1 val2[]=2 vs # Config::IniFiles [group] val1=value val2=1 val2=2 This option only affect parsing, not writing new configfiles. Some features from parse_ini_file are not compatible: [group] val1="val"'ue' val1[key]=1 =back =head2 val ($section, $parameter [, $default] ) Returns the value of the specified parameter (C<$parameter>) in section C<$section>, returns undef (or C<$default> if specified) if no section or no parameter for the given section exists. If you want a multi-line/value field returned as an array, just specify an array as the receiver: @values = $cfg->val('Section', 'Parameter'); A multi-line/value field that is returned in a scalar context will be joined using $/ (input record separator, default is \n) if defined, otherwise the values will be joined using \n. =head2 exists($section, $parameter) True if and only if there exists a section C<$section>, with a parameter C<$parameter> inside, not counting default values. =head2 push ($section, $parameter, $value, [ $value2, ...]) Pushes new values at the end of existing value(s) of parameter C<$parameter> in section C<$section>. See below for methods to write the new configuration back out to a file. You may not set a parameter that didn't exist in the original configuration file. B<push> will return I<undef> if this is attempted. See B<newval> below to do this. Otherwise, it returns 1. =head2 setval ($section, $parameter, $value, [ $value2, ... ]) Sets the value of parameter C<$parameter> in section C<$section> to C<$value> (or to a set of values). See below for methods to write the new configuration back out to a file. You may not set a parameter that didn't exist in the original configuration file. B<setval> will return I<undef> if this is attempted. See B<newval> below to do this. Otherwise, it returns 1. =head2 newval($section, $parameter, $value [, $value2, ...]) Assigns a new value, C<$value> (or set of values) to the parameter C<$parameter> in section C<$section> in the configuration file. =head2 delval($section, $parameter) Deletes the specified parameter from the configuration file =head2 ReadConfig Forces the configuration file to be re-read. Returns undef if the file can not be opened, no filename was defined (with the C<-file> option) when the object was constructed, or an error occurred while reading. If an error occurs while parsing the INI file the @Config::IniFiles::errors array will contain messages that might help you figure out where the problem is in the file. =head2 Sections Returns an array containing section names in the configuration file. If the I<nocase> option was turned on when the config object was created, the section names will be returned in lowercase. =head2 SectionExists ( $sect_name ) Returns 1 if the specified section exists in the INI file, 0 otherwise (undefined if section_name is not defined). =head2 AddSection ( $sect_name ) Ensures that the named section exists in the INI file. If the section already exists, nothing is done. In this case, the "new" section will possibly contain data already. If you really need to have a new section with no parameters in it, check that the name that you're adding isn't in the list of sections already. =head2 DeleteSection ( $sect_name ) Completely removes the entire section from the configuration. =head2 RenameSection ( $old_section_name, $new_section_name, $include_groupmembers) Renames a section if it does not already exist, optionally including groupmembers =head2 CopySection ( $old_section_name, $new_section_name, $include_groupmembers) Copies one section to another optionally including groupmembers =head2 Parameters ($sect_name) Returns an array containing the parameters contained in the specified section. =head2 Groups Returns an array containing the names of available groups. Groups are specified in the config file as new sections of the form [GroupName MemberName] This is useful for building up lists. Note that parameters within a "member" section are referenced normally (i.e., the section name is still "Groupname Membername", including the space) - the concept of Groups is to aid people building more complex configuration files. =head2 SetGroupMember ( $sect ) Makes sure that the specified section is a member of the appropriate group. Only intended for use in newval. =head2 RemoveGroupMember ( $sect ) Makes sure that the specified section is no longer a member of the appropriate group. Only intended for use in DeleteSection. =head2 GroupMembers ($group) Returns an array containing the members of specified $group. Each element of the array is a section name. For example, given the sections [Group Element 1] ... [Group Element 2] ... GroupMembers would return ("Group Element 1", "Group Element 2"). =head2 SetWriteMode ($mode) Sets the mode (permissions) to use when writing the INI file. $mode must be a string representation of the octal mode. =head2 GetWriteMode ($mode) Gets the current mode (permissions) to use when writing the INI file. $mode is a string representation of the octal mode. =head2 WriteConfig ($filename [, %options]) Writes out a new copy of the configuration file. A temporary file is written out and then renamed to the specified filename. Also see B<BUGS> below. If C<-delta> is set to a true value in %options, and this object was imported from another (see L</new>), only the differences between this object and the imported one will be recorded. Negative deltas will be encoded into comments, so that a subsequent invocation of I<new()> with the same imported object produces the same results (see the I<-negativedeltas> option in L</new>). C<%options> is not required. Returns true on success, C<undef> on failure. =head2 RewriteConfig Same as WriteConfig, but specifies that the original configuration file should be rewritten. =head2 GetFileName Returns the filename associated with this INI file. If no filename has been specified, returns undef. =head2 SetFileName ($filename) If you created the Config::IniFiles object without initialising from a file, or if you just want to change the name of the file to use for ReadConfig/RewriteConfig from now on, use this method. Returns $filename if that was a valid name, undef otherwise. =head2 $ini->OutputConfigToFileHandle($fh, $delta) Writes OutputConfig to the $fh filehandle. $delta should be set to 1 1 if writing only delta. This is a newer and safer version of C<OutputConfig()> and one is encouraged to use it instead. =head2 $ini->OutputConfig($delta) Writes OutputConfig to STDOUT. Use select() to redirect STDOUT to the output target before calling this function. Optional argument should be set to 1 if writing only a delta. Also see OutputConfigToFileHandle =head2 SetSectionComment($section, @comment) Sets the comment for section $section to the lines contained in @comment. Each comment line will be prepended with the comment character (default is C<#>) if it doesn't already have a comment character (ie: if the line does not start with whitespace followed by an allowed comment character, default is C<#> and C<;>). To clear a section comment, use DeleteSectionComment ($section) =head2 GetSectionComment ($section) Returns a list of lines, being the comment attached to section $section. In scalar context, returns a string containing the lines of the comment separated by newlines. The lines are presented as-is, with whatever comment character was originally used on that line. =head2 DeleteSectionComment ($section) Removes the comment for the specified section. =head2 SetParameterComment ($section, $parameter, @comment) Sets the comment attached to a particular parameter. Any line of @comment that does not have a comment character will be prepended with one. See L</SetSectionComment($section, @comment)> above =head2 GetParameterComment ($section, $parameter) Gets the comment attached to a parameter. In list context returns all comments - in scalar context returns them joined by newlines. =head2 DeleteParameterComment ($section, $parameter) Deletes the comment attached to a parameter. =head2 GetParameterEOT ($section, $parameter) Accessor method for the EOT text (in fact, style) of the specified parameter. If any text is used as an EOT mark, this will be returned. If the parameter was not recorded using HERE style multiple lines, GetParameterEOT returns undef. =head2 $cfg->SetParameterEOT ($section, $parameter, $EOT) Accessor method for the EOT text for the specified parameter. Sets the HERE style marker text to the value $EOT. Once the EOT text is set, that parameter will be saved in HERE style. To un-set the EOT text, use DeleteParameterEOT ($section, $parameter). =head2 DeleteParameterEOT ($section, $parameter) Removes the EOT marker for the given section and parameter. When writing a configuration file, if no EOT marker is defined then "EOT" is used. =head2 SetParameterTrailingComment ($section, $parameter, $cmt) Set the end trailing comment for the given section and parameter. If there is a old comment for the parameter, it will be overwritten by the new one. If there is a new parameter trailing comment to be added, the value should be added first. =head2 GetParameterTrailingComment ($section, $parameter) An accessor method to read the trailing comment after the parameter. The trailing comment will be returned if there is one. A null string will be returned if the parameter exists but there is no comment for it. otherwise, L<undef> will be returned. =head2 Delete Deletes the entire configuration file in memory. =head1 USAGE -- Tied Hash =head2 tie %ini, 'Config::IniFiles', (-file=>$filename, [-option=>value ...] ) Using C<tie>, you can tie a hash to a B<Config::IniFiles> object. This creates a new object which you can access through your hash, so you use this instead of the B<new> method. This actually creates a hash of hashes to access the values in the INI file. The options you provide through C<tie> are the same as given for the B<new> method, above. Here's an example: use Config::IniFiles; my %ini; tie %ini, 'Config::IniFiles', ( -file => "/path/configfile.ini" ); print "We have $ini{Section}{Parameter}." if $ini{Section}{Parameter}; Accessing and using the hash works just like accessing a regular hash and many of the object methods are made available through the hash interface. For those methods that do not coincide with the hash paradigm, you can use the Perl C<tied> function to get at the underlying object tied to the hash and call methods on that object. For example, to write the hash out to a new ini file, you would do something like this: tied( %ini )->WriteConfig( "/newpath/newconfig.ini" ) || die "Could not write settings to new file."; =head2 $val = $ini{$section}{$parameter} Returns the value of $parameter in $section. Multiline values accessed through a hash will be returned as a list in list context and a concatenated value in scalar context. =head2 $ini{$section}{$parameter} = $value; Sets the value of C<$parameter> in C<$section> to C<$value>. To set a multiline or multi-value parameter just assign an array reference to the hash entry, like this: $ini{$section}{$parameter} = [$value1, $value2, ...]; If the parameter did not exist in the original file, it will be created. However, Perl does not seem to extend autovivification to tied hashes. That means that if you try to say $ini{new_section}{new_paramters} = $val; and the section 'new_section' does not exist, then Perl won't properly create it. In order to work around this you will need to create a hash reference in that section and then assign the parameter value. Something like this should do nicely: $ini{new_section} = {}; $ini{new_section}{new_paramters} = $val; =head2 %hash = %{$ini{$section}} Using the tie interface, you can copy whole sections of the ini file into another hash. Note that this makes a copy of the entire section. The new hash in no longer tied to the ini file, In particular, this means -default and -nocase settings will not apply to C<%hash>. =head2 $ini{$section} = {}; %{$ini{$section}} = %parameters; Through the hash interface, you have the ability to replace the entire section with a new set of parameters. This call will fail, however, if the argument passed in NOT a hash reference. You must use both lines, as shown above so that Perl recognizes the section as a hash reference context before COPYing over the values from your C<%parameters> hash. =head2 delete $ini{$section}{$parameter} When tied to a hash, you can use the Perl C<delete> function to completely remove a parameter from a section. =head2 delete $ini{$section} The tied interface also allows you to delete an entire section from the ini file using the Perl C<delete> function. =head2 %ini = (); If you really want to delete B<all> the items in the ini file, this will do it. Of course, the changes won't be written to the actual file unless you call B<RewriteConfig> on the object tied to the hash. =head2 Parameter names =over 4 =item my @keys = keys %{$ini{$section}} =item while (($k, $v) = each %{$ini{$section}}) {...} =item if( exists %{$ini{$section}}, $parameter ) {...} =back When tied to a hash, you use the Perl C<keys> and C<each> functions to iteratively list the parameters (C<keys>) or parameters and their values (C<each>) in a given section. You can also use the Perl C<exists> function to see if a parameter is defined in a given section. Note that none of these will return parameter names that are part of the default section (if set), although accessing an unknown parameter in the specified section will return a value from the default section if there is one. =head2 Section names =over 4 =item foreach( keys %ini ) {...} =item while (($k, $v) = each %ini) {...} =item if( exists %ini, $section ) {...} =back When tied to a hash, you use the Perl C<keys> and C<each> functions to iteratively list the sections in the ini file. You can also use the Perl C<exists> function to see if a section is defined in the file. =head1 IMPORT / DELTA FEATURES The I<-import> option to L</new> allows one to stack one I<Config::IniFiles> object on top of another (which might be itself stacked in turn and so on recursively, but this is beyond the point). The effect, as briefly explained in L</new>, is that the fields appearing in the composite object will be a superposition of those coming from the ``original'' one and the lines coming from the file, the latter taking precedence. For example, let's say that C<$master> and C<overlay> were created like this: my $master = Config::IniFiles->new(-file => "master.ini"); my $overlay = Config::IniFiles->new(-file => "overlay.ini", -import => $master); If the contents of C<master.ini> and C<overlay.ini> are respectively ; master.ini [section1] arg0=unchanged from master.ini arg1=val1 [section2] arg2=val2 and ; overlay.ini [section1] arg1=overridden Then C<< $overlay->val("section1", "arg1") >> is "overridden", while C<< $overlay->val("section1", "arg0") >> is "unchanged from master.ini". This feature may be used to ship a ``global defaults'' configuration file for a Perl application, that can be overridden piecewise by a much shorter, per-site configuration file. Assuming UNIX-style path names, this would be done like this: my $defaultconfig = Config::IniFiles->new (-file => "/usr/share/myapp/myapp.ini.default"); my $config = Config::IniFiles->new (-file => "/etc/myapp.ini", -import => $defaultconfig); # Now use $config and forget about $defaultconfig in the rest of # the program Starting with version 2.39, I<Config::IniFiles> also provides features to keep the importing / per-site configuration file small, by only saving those options that were modified by the running program. That is, if one calls $overlay->setval("section1", "arg1", "anotherval"); $overlay->newval("section3", "arg3", "val3"); $overlay->WriteConfig('overlay.ini', -delta=>1); C<overlay.ini> would now contain ; overlay.ini [section1] arg1=anotherval [section3] arg3=val3 This is called a I<delta file> (see L</WriteConfig>). The untouched [section2] and arg0 do not appear, and the config file is therefore shorter; while of course, reloading the configuration into C<$master> and C<$overlay>, either through C<< $overlay->ReadConfig() >> or through the same code as above (e.g. when application restarts), would yield exactly the same result had the overlay object been saved in whole to the file system. The only problem with this delta technique is one cannot delete the default values in the overlay configuration file, only change them. This is solved by a file format extension, enabled by the I<-negativedeltas> option to L</new>: if, say, one would delete parameters like this, $overlay->DeleteSection("section2"); $overlay->delval("section1", "arg0"); $overlay->WriteConfig('overlay.ini', -delta=>1); The I<overlay.ini> file would now read: ; overlay.ini [section1] ; arg0 is deleted arg1=anotherval ; [section2] is deleted [section3] arg3=val3 Assuming C<$overlay> was later re-read with C<< -negativedeltas => 1 >>, the parser would interpret the deletion comments to yield the correct result, that is, [section2] and arg0 would cease to exist in the C<$overlay> object. =head1 DIAGNOSTICS =head2 @Config::IniFiles::errors Contains a list of errors encountered while parsing the configuration file. If the I<new> method returns B<undef>, check the value of this to find out what's wrong. This value is reset each time a config file is read. =head1 BUGS =over 3 =item * The output from [Re]WriteConfig/OutputConfig might not be as pretty as it can be. Comments are tied to whatever was immediately below them. And case is not preserved for Section and Parameter names if the -nocase option was used. =item * No locking is done by [Re]WriteConfig. When writing servers, take care that only the parent ever calls this, and consider making your own backup. =back =head1 Data Structure Note that this is only a reference for the package maintainers - one of the upcoming revisions to this package will include a total clean up of the data structure. $iniconf->{cf} = "config_file_name" ->{startup_settings} = \%orginal_object_parameters ->{imported} = $object WHERE $object->isa("Config::IniFiles") ->{nocase} = 0 ->{reloadwarn} = 0 ->{sects} = \@sections ->{mysects} = \@sections ->{sCMT}{$sect} = \@comment_lines ->{group}{$group} = \@group_members ->{parms}{$sect} = \@section_parms ->{myparms}{$sect} = \@section_parms ->{EOT}{$sect}{$parm} = "end of text string" ->{pCMT}{$sect}{$parm} = \@comment_lines ->{v}{$sect}{$parm} = $value OR \@values ->{e}{$sect} = 1 OR does not exist ->{mye}{$sect} = 1 OR does not exists =head1 AUTHOR and ACKNOWLEDGEMENTS The original code was written by Scott Hutton. Then handled for a time by Rich Bowen (thanks!), and was later managed by Jeremy Wadsack (thanks!), and now is managed by Shlomi Fish ( L<http://www.shlomifish.org/> ) with many contributions from various other people. In particular, special thanks go to (in roughly chronological order): Bernie Cosell, Alan Young, Alex Satrapa, Mike Blazer, Wilbert van de Pieterman, Steve Campbell, Robert Konigsberg, Scott Dellinger, R. Bernstein, Daniel Winkelmann, Pires Claudio, Adrian Phillips, Marek Rouchal, Luc St Louis, Adam Fischler, Kay Röpke, Matt Wilson, Raviraj Murdeshwar and Slaven Rezic, Florian Pfaff Geez, that's a lot of people. And apologies to the folks who were missed. If you want someone to bug about this, that would be: Shlomi Fish <shlomif@cpan.org> If you want more information, or want to participate, go to: L<http://sourceforge.net/projects/config-inifiles/> Please submit bug reports using the Request Tracker interface at L<https://rt.cpan.org/Public/Dist/Display.html?Name=Config-IniFiles> . Development discussion occurs on the mailing list config-inifiles-dev@lists.sourceforge.net, which you can subscribe to by going to the project web site (link above). =head1 LICENSE This software is copyright (c) 2000 by Scott Hutton and the rest of the Config::IniFiles contributors. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 AUTHOR Shlomi Fish <shlomif@cpan.org> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2000 by RBOW and others. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 BUGS Please report any bugs or feature requests on the bugtracker website L<https://github.com/shlomif/perl-Config-IniFiles/issues> When submitting a bug or request, please include a test-file or a patch to an existing test-file that illustrates the bug or desired feature. =for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Perldoc You can find documentation for this module with the perldoc command. perldoc Config::IniFiles =head2 Websites The following websites have more information about this module, and may be of help to you. As always, in addition to those websites please use your favorite search engine to discover more resources. =over 4 =item * MetaCPAN A modern, open-source CPAN search engine, useful to view POD in HTML format. L<https://metacpan.org/release/Config-IniFiles> =item * RT: CPAN's Bug Tracker The RT ( Request Tracker ) website is the default bug/issue tracking system for CPAN. L<https://rt.cpan.org/Public/Dist/Display.html?Name=Config-IniFiles> =item * CPANTS The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution. L<http://cpants.cpanauthors.org/dist/Config-IniFiles> =item * CPAN Testers The CPAN Testers is a network of smoke testers who run automated tests on uploaded CPAN distributions. L<http://www.cpantesters.org/distro/C/Config-IniFiles> =item * CPAN Testers Matrix The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms. L<http://matrix.cpantesters.org/?dist=Config-IniFiles> =item * CPAN Testers Dependencies The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution. L<http://deps.cpantesters.org/?module=Config::IniFiles> =back =head2 Bugs / Feature Requests Please report any bugs or feature requests by email to C<bug-config-inifiles at rt.cpan.org>, or through the web interface at L<https://rt.cpan.org/Public/Bug/Report.html?Queue=Config-IniFiles>. You will be automatically notified of any progress on the request by the system. =head2 Source Code The code is open to the world, and available for you to hack on. Please feel free to browse it and play with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull from your repository :) L<https://github.com/shlomif/perl-Config-IniFiles> git clone git://github.com/shlomif/perl-Config-IniFiles.git =cut PK ! X��=� =� CGI.pmnu �[��� package CGI; require 5.008001; use Carp 'croak'; my $appease_cpants_kwalitee = q/ use strict; use warnings; #/; $CGI::VERSION='4.54'; use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); $_XHTML_DTD = ['-//W3C//DTD XHTML 1.0 Transitional//EN', 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd']; { local $^W = 0; $TAINTED = substr("$0$^X",0,0); } $MOD_PERL = 0; # no mod_perl by default #global settings $POST_MAX = -1; # no limit to uploaded files $DISABLE_UPLOADS = 0; $UNLINK_TMP_FILES = 1; $LIST_CONTEXT_WARN = 1; $ENCODE_ENTITIES = q{&<>"'}; $ALLOW_DELETE_CONTENT = 0; $COOKIE_CACHE = 0; # backcompat: cache was broken for years @SAVED_SYMBOLS = (); # >>>>> Here are some globals that you might want to adjust <<<<<< sub initialize_globals { # Set this to 1 to generate XTML-compatible output $XHTML = 1; # Change this to the preferred DTD to print in start_html() # or use default_dtd('text of DTD to use'); $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN', 'http://www.w3.org/TR/html4/loose.dtd' ] ; # Set this to 1 to enable NOSTICKY scripts # or: # 1) use CGI '-nosticky'; # 2) $CGI::NOSTICKY = 1; $NOSTICKY = 0; # Set this to 1 to enable NPH scripts # or: # 1) use CGI qw(-nph) # 2) CGI::nph(1) # 3) print header(-nph=>1) $NPH = 0; # Set this to 1 to enable debugging from @ARGV # Set to 2 to enable debugging from STDIN $DEBUG = 1; # Set this to 1 to generate automatic tab indexes $TABINDEX = 0; # Set this to 1 to cause files uploaded in multipart documents # to be closed, instead of caching the file handle # or: # 1) use CGI qw(:close_upload_files) # 2) $CGI::close_upload_files(1); # Uploads with many files run out of file handles. # Also, for performance, since the file is already on disk, # it can just be renamed, instead of read and written. $CLOSE_UPLOAD_FILES = 0; # Automatically determined -- don't change $EBCDIC = 0; # Change this to 1 to suppress redundant HTTP headers $HEADERS_ONCE = 0; # separate the name=value pairs by semicolons rather than ampersands $USE_PARAM_SEMICOLONS = 1; # Do not include undefined params parsed from query string # use CGI qw(-no_undef_params); $NO_UNDEF_PARAMS = 0; # return everything as utf-8 $PARAM_UTF8 = 0; # make param('PUTDATA') act like file upload $PUTDATA_UPLOAD = 0; # Add QUERY_STRING to POST request $APPEND_QUERY_STRING = 0; # Other globals that you shouldn't worry about. undef $Q; $BEEN_THERE = 0; $DTD_PUBLIC_IDENTIFIER = ""; undef @QUERY_PARAM; undef %QUERY_PARAM; undef %EXPORT; undef $QUERY_CHARSET; undef %QUERY_FIELDNAMES; undef %QUERY_TMPFILES; # prevent complaints by mod_perl 1; } # ------------------ START OF THE LIBRARY ------------ # make mod_perlhappy initialize_globals(); # FIGURE OUT THE OS WE'RE RUNNING UNDER # Some systems support the $^O variable. If not # available then require() the Config library unless ($OS) { unless ($OS = $^O) { require Config; $OS = $Config::Config{'osname'}; } } if ($OS =~ /^MSWin/i) { $OS = 'WINDOWS'; } elsif ($OS =~ /^VMS/i) { $OS = 'VMS'; } elsif ($OS =~ /^dos/i) { $OS = 'DOS'; } elsif ($OS =~ /^MacOS/i) { $OS = 'MACINTOSH'; } elsif ($OS =~ /^os2/i) { $OS = 'OS2'; } elsif ($OS =~ /^epoc/i) { $OS = 'EPOC'; } elsif ($OS =~ /^cygwin/i) { $OS = 'CYGWIN'; } elsif ($OS =~ /^NetWare/i) { $OS = 'NETWARE'; } else { $OS = 'UNIX'; } # Some OS logic. Binary mode enabled on DOS, NT and VMS $needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN|NETWARE)/; # This is the default class for the CGI object to use when all else fails. $DefaultClass = 'CGI' unless defined $CGI::DefaultClass; # The path separator is a slash, backslash or semicolon, depending # on the platform. $SL = { UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', NETWARE => '/', WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/' }->{$OS}; # This no longer seems to be necessary # Turn on NPH scripts by default when running under IIS server! # $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; # Turn on special checking for ActiveState's PerlEx $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; # Turn on special checking for Doug MacEachern's modperl # PerlEx::DBI tries to fool DBI by setting MOD_PERL if (exists $ENV{MOD_PERL} && ! $PERLEX) { # mod_perl handlers may run system() on scripts using CGI.pm; # Make sure so we don't get fooled by inherited $ENV{MOD_PERL} if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { $MOD_PERL = 2; require Apache2::Response; require Apache2::RequestRec; require Apache2::RequestUtil; require Apache2::RequestIO; require APR::Pool; } else { $MOD_PERL = 1; require Apache; } } # Define the CRLF sequence. I can't use a simple "\r\n" because the meaning # of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF # and sometimes CR). The most popular VMS web server # doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't # use ASCII, so \015\012 means something different. I find this all # really annoying. $EBCDIC = "\t" ne "\011"; if ($OS eq 'VMS') { $CRLF = "\n"; } elsif ($EBCDIC) { $CRLF= "\r\n"; } else { $CRLF = "\015\012"; } _set_binmode() if ($needs_binmode); sub _set_binmode { # rt #57524 - don't set binmode on filehandles if there are # already none default layers set on them my %default_layers = ( unix => 1, perlio => 1, stdio => 1, crlf => 1, ); foreach my $fh ( \*main::STDOUT, \*main::STDIN, \*main::STDERR, ) { my @modes = grep { ! $default_layers{$_} } PerlIO::get_layers( $fh ); if ( ! @modes ) { $CGI::DefaultClass->binmode( $fh ); } } } %EXPORT_TAGS = ( ':html2' => [ 'h1' .. 'h6', qw/ p br hr ol ul li dl dt dd menu code var strong em tt u i b blockquote pre img a address cite samp dfn html head base body Link nextid title meta kbd start_html end_html input Select option comment charset escapeHTML / ], ':html3' => [ qw/ div table caption th td TR Tr sup Sub strike applet Param nobr embed basefont style span layer ilayer font frameset frame script small big Area Map / ], ':html4' => [ qw/ abbr acronym bdo col colgroup del fieldset iframe ins label legend noframes noscript object optgroup Q thead tbody tfoot / ], ':form' => [ qw/ textfield textarea filefield password_field hidden checkbox checkbox_group submit reset defaults radio_group popup_menu button autoEscape scrolling_list image_button start_form end_form start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART / ], ':cgi' => [ qw/ param multi_param upload path_info path_translated request_uri url self_url script_name cookie Dump raw_cookie request_method query_string Accept user_agent remote_host content_type remote_addr referer server_name server_software server_port server_protocol virtual_port virtual_host remote_ident auth_type http append save_parameters restore_parameters param_fetch remote_user user_name header redirect import_names put Delete Delete_all url_param cgi_error env_query_string / ], ':netscape' => [qw/blink fontsize center/], ':ssl' => [qw/https/], ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/], # bulk export/import ':html' => [qw/:html2 :html3 :html4 :netscape/], ':standard' => [qw/:html2 :html3 :html4 :form :cgi :ssl/], ':all' => [qw/:html2 :html3 :html4 :netscape :form :cgi :ssl :push/] ); # to import symbols into caller sub import { my $self = shift; # This causes modules to clash. undef %EXPORT_OK; undef %EXPORT; $self->_setup_symbols(@_); my ($callpack, $callfile, $callline) = caller; if ( $callpack eq 'CGI::Fast' ) { # fixes GH #11 (and GH #12 in CGI::Fast since # sub import was added to CGI::Fast in 9537f90 # so we need to move up a level to export the # routines to the namespace of whatever is using # CGI::Fast ($callpack, $callfile, $callline) = caller(1); } # To allow overriding, search through the packages # Till we find one in which the correct subroutine is defined. my @packages = ($self,@{"$self\:\:ISA"}); for $sym (sort keys %EXPORT) { my $pck; my $def = $DefaultClass; for $pck (@packages) { if (defined(&{"$pck\:\:$sym"})) { $def = $pck; last; } } *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; } } sub expand_tags { my($tag) = @_; return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; my(@r); return ($tag) unless $EXPORT_TAGS{$tag}; for (@{$EXPORT_TAGS{$tag}}) { push(@r,&expand_tags($_)); } return @r; } #### Method: new # The new routine. This will check the current environment # for an existing query string, and initialize itself, if so. #### sub new { my($class,@initializer) = @_; my $self = {}; bless $self,ref $class || $class || $DefaultClass; # always use a tempfile $self->{'use_tempfile'} = 1; if (ref($initializer[0]) && (UNIVERSAL::isa($initializer[0],'Apache') || UNIVERSAL::isa($initializer[0],'Apache2::RequestRec') )) { $self->r(shift @initializer); } if (ref($initializer[0]) && (UNIVERSAL::isa($initializer[0],'CODE'))) { $self->upload_hook(shift @initializer, shift @initializer); $self->{'use_tempfile'} = shift @initializer if (@initializer > 0); } if ($MOD_PERL) { if ($MOD_PERL == 1) { $self->r(Apache->request) unless $self->r; my $r = $self->r; $r->register_cleanup(\&CGI::_reset_globals); $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; } else { # XXX: once we have the new API # will do a real PerlOptions -SetupEnv check $self->r(Apache2::RequestUtil->request) unless $self->r; my $r = $self->r; $r->subprocess_env unless exists $ENV{REQUEST_METHOD}; $r->pool->cleanup_register(\&CGI::_reset_globals); $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; } undef $NPH; } $self->_reset_globals if $PERLEX; $self->init(@initializer); return $self; } sub r { my $self = shift; my $r = $self->{'.r'}; $self->{'.r'} = shift if @_; $r; } sub upload_hook { my $self; if (ref $_[0] eq 'CODE') { $CGI::Q = $self = $CGI::DefaultClass->new(@_); } else { $self = shift; } my ($hook,$data,$use_tempfile) = @_; $self->{'.upload_hook'} = $hook; $self->{'.upload_data'} = $data; $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile; } #### Method: param / multi_param # Returns the value(s)of a named parameter. # If invoked in a list context, returns the # entire list. Otherwise returns the first # member of the list. # If name is not provided, return a list of all # the known parameters names available. # If more than one argument is provided, the # second and subsequent arguments are used to # set the value of the parameter. # # note that calling param() in list context # will raise a warning about potential bad # things, hence the multi_param method #### sub multi_param { # we don't need to set $LIST_CONTEXT_WARN to 0 here # because param() will check the caller before warning my @list_of_params = param( @_ ); return @list_of_params; } sub param { my($self,@p) = self_or_default(@_); return $self->all_parameters unless @p; # list context can be dangerous so warn: # http://blog.gerv.net/2014.10/new-class-of-vulnerability-in-perl-web-applications if ( wantarray && $LIST_CONTEXT_WARN == 1 ) { my ( $package, $filename, $line ) = caller; if ( $package ne 'CGI' ) { $LIST_CONTEXT_WARN++; # only warn once warn "CGI::param called in list context from $filename line $line, this can lead to vulnerabilities. " . 'See the warning in "Fetching the value or values of a single named parameter"'; } } my($name,$value,@other); # For compatibility between old calling style and use_named_parameters() style, # we have to special case for a single parameter present. if (@p > 1) { ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); my(@values); if (substr($p[0],0,1) eq '-') { @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); } else { for ($value,@other) { push(@values,$_) if defined($_); } } # If values is provided, then we set it. if (@values or defined $value) { $self->add_parameter($name); $self->{param}{$name}=[@values]; } } else { $name = $p[0]; } return unless defined($name) && $self->{param}{$name}; my @result = @{$self->{param}{$name}}; if ($PARAM_UTF8 && $name ne 'PUTDATA' && $name ne 'POSTDATA' && $name ne 'PATCHDATA') { eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions @result = map {ref $_ ? $_ : $self->_decode_utf8($_) } @result; } return wantarray ? @result : $result[0]; } sub _decode_utf8 { my ($self, $val) = @_; if (Encode::is_utf8($val)) { return $val; } else { return Encode::decode(utf8 => $val); } } sub self_or_default { return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI'); unless (defined($_[0]) && (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case ) { $Q = $CGI::DefaultClass->new unless defined($Q); unshift(@_,$Q); } return wantarray ? @_ : $Q; } sub self_or_CGI { local $^W=0; # prevent a warning if (defined($_[0]) && (substr(ref($_[0]),0,3) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI'))) { return @_; } else { return ($DefaultClass,@_); } } ######################################## # THESE METHODS ARE MORE OR LESS PRIVATE # GO TO THE __DATA__ SECTION TO SEE MORE # PUBLIC METHODS ######################################## # Initialize the query object from the environment. # If a parameter list is found, this object will be set # to a hash in which parameter names are keys # and the values are stored as lists # If a keyword list is found, this method creates a bogus # parameter list with the single parameter 'keywords'. sub init { my $self = shift; my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); my $is_xforms; my $initializer = shift; # for backward compatibility local($/) = "\n"; # set autoescaping on by default $self->{'escape'} = 1; # if we get called more than once, we want to initialize # ourselves from the original query (which may be gone # if it was read from STDIN originally.) if (@QUERY_PARAM && !defined($initializer)) { for my $name (@QUERY_PARAM) { my $val = $QUERY_PARAM{$name}; # always an arrayref; $self->param('-name'=>$name,'-value'=> $val); if (defined $val and ref $val eq 'ARRAY') { for my $fh (grep {defined($_) && ref($_) && defined(fileno($_))} @$val) { seek($fh,0,0); # reset the filehandle. } } } $self->charset($QUERY_CHARSET); $self->{'.fieldnames'} = {%QUERY_FIELDNAMES}; $self->{'.tmpfiles'} = {%QUERY_TMPFILES}; return; } $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; $fh = to_filehandle($initializer) if $initializer; # set charset to the safe ISO-8859-1 $self->charset('ISO-8859-1'); METHOD: { # avoid unreasonably large postings if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { #discard the post, unread $self->cgi_error("413 Request entity too large"); last METHOD; } # Process multipart postings, but only if the initializer is # not defined. if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'}) && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| && !defined($initializer) ) { my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; $self->read_multipart($boundary,$content_length); if ($APPEND_QUERY_STRING) { # Some people want to have their cake and eat it too! # Set $APPEND_QUERY_STRING = 1 to have the contents of the query string # APPENDED to the POST data. $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; } last METHOD; } # Process XForms postings. We know that we have XForms in the # following cases: # method eq 'POST' && content-type eq 'application/xml' # method eq 'POST' && content-type =~ /multipart\/related.+start=/ # There are more cases, actually, but for now, we don't support other # methods for XForm posts. # In a XForm POST, the QUERY_STRING is parsed normally. # If the content-type is 'application/xml', we just set the param # XForms:Model (referring to the xml syntax) param containing the # unparsed XML data. # In the case of multipart/related we set XForms:Model as above, but # the other parts are available as uploads with the Content-ID as the # the key. # See the URL below for XForms specs on this issue. # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) { if ($ENV{'CONTENT_TYPE'} eq 'application/xml') { my($param) = 'XForms:Model'; my($value) = ''; $self->add_parameter($param); $self->read_from_client(\$value,$content_length,0) if $content_length > 0; push (@{$self->{param}{$param}},$value); $is_xforms = 1; } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) { my($boundary,$start) = ($1,$2); my($param) = 'XForms:Model'; $self->add_parameter($param); my($value) = $self->read_multipart_related($start,$boundary,$content_length,0); push (@{$self->{param}{$param}},$value); $query_string = $self->_get_query_string_from_env; $is_xforms = 1; } } # If initializer is defined, then read parameters # from it. if (!$is_xforms && defined($initializer)) { if (UNIVERSAL::isa($initializer,'CGI')) { $query_string = $initializer->query_string; last METHOD; } if (ref($initializer) && ref($initializer) eq 'HASH') { for (sort keys %$initializer) { $self->param('-name'=>$_,'-value'=>$initializer->{$_}); } last METHOD; } if (defined($fh) && ($fh ne '')) { while (my $line = <$fh>) { chomp $line; last if $line =~ /^=$/; push(@lines,$line); } # massage back into standard format if ("@lines" =~ /=/) { $query_string=join("&",@lines); } else { $query_string=join("+",@lines); } last METHOD; } # last chance -- treat it as a string $initializer = $$initializer if ref($initializer) eq 'SCALAR'; $query_string = $initializer; last METHOD; } # If method is GET, HEAD or DELETE, fetch the query from # the environment. if ($is_xforms || $meth=~/^(GET|HEAD|DELETE)$/) { $query_string = $self->_get_query_string_from_env; $self->param($meth . 'DATA', $self->param('XForms:Model')) if $is_xforms; last METHOD; } if ($meth eq 'POST' || $meth eq 'PUT' || $meth eq 'PATCH') { if ( $content_length > 0 ) { if ( ( $PUTDATA_UPLOAD || $self->{'.upload_hook'} ) && !$is_xforms && ($meth eq 'POST' || $meth eq 'PUT' || $meth eq 'PATCH') && defined($ENV{'CONTENT_TYPE'}) && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ){ my $postOrPut = $meth . 'DATA' ; # POSTDATA/PUTDATA $self->read_postdata_putdata( $postOrPut, $content_length, $ENV{'CONTENT_TYPE'} ); $meth = ''; # to skip xform testing undef $query_string ; } else { $self->read_from_client(\$query_string,$content_length,0); } } if ($APPEND_QUERY_STRING) { # Some people want to have their cake and eat it too! # Set $APPEND_QUERY_STRING = 1 to have the contents of the query string # APPENDED to the POST data. $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; } last METHOD; } # If $meth is not of GET, POST, PUT or HEAD, assume we're # being debugged offline. # Check the command line and then the standard input for data. # We use the shellwords package in order to behave the way that # UN*X programmers expect. if ($DEBUG) { my $cmdline_ret = read_from_cmdline(); $query_string = $cmdline_ret->{'query_string'}; if (defined($cmdline_ret->{'subpath'})) { $self->path_info($cmdline_ret->{'subpath'}); } } } # YL: Begin Change for XML handler 10/19/2001 if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT' || $meth eq 'PATCH') && defined($ENV{'CONTENT_TYPE'}) && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) { my($param) = $meth . 'DATA' ; $self->add_parameter($param) ; push (@{$self->{param}{$param}},$query_string); undef $query_string ; } # YL: End Change for XML handler 10/19/2001 # We now have the query string in hand. We do slightly # different things for keyword lists and parameter lists. if (defined $query_string && length $query_string) { if ($query_string =~ /[&=;]/) { $self->parse_params($query_string); } else { $self->add_parameter('keywords'); $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)]; } } # Special case. Erase everything if there is a field named # .defaults. if ($self->param('.defaults')) { $self->delete_all(); } # hash containing our defined fieldnames $self->{'.fieldnames'} = {}; for ($self->param('.cgifields')) { $self->{'.fieldnames'}->{$_}++; } # Clear out our default submission button flag if present $self->delete('.submit'); $self->delete('.cgifields'); $self->save_request unless defined $initializer; } sub _get_query_string_from_env { my $self = shift; my $query_string = ''; if ( $MOD_PERL ) { $query_string = $self->r->args; if ( ! $query_string && $MOD_PERL == 2 ) { # possibly a redirect, inspect prev request # (->prev only supported under mod_perl2) if ( my $prev = $self->r->prev ) { $query_string = $prev->args; } } } $query_string ||= $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; if ( ! $query_string ) { # try to get from REDIRECT_ env variables, support # 5 levels of redirect and no more (RT #36312) REDIRECT: foreach my $r ( 1 .. 5 ) { my $key = join( '',( 'REDIRECT_' x $r ) ); $query_string ||= $ENV{"${key}QUERY_STRING"} if defined $ENV{"${key}QUERY_STRING"}; last REDIRECT if $query_string; } } return $query_string; } # FUNCTIONS TO OVERRIDE: # Turn a string into a filehandle sub to_filehandle { my $thingy = shift; return undef unless $thingy; return $thingy if UNIVERSAL::isa($thingy,'GLOB'); return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); if (!ref($thingy)) { my $caller = 1; while (my $package = caller($caller++)) { my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; return $tmp if defined(fileno($tmp)); } } return undef; } # send output to the browser sub put { my($self,@p) = self_or_default(@_); $self->print(@p); } # print to standard output (for overriding in mod_perl) sub print { shift; CORE::print(@_); } # get/set last cgi_error sub cgi_error { my ($self,$err) = self_or_default(@_); $self->{'.cgi_error'} = $err if defined $err; return $self->{'.cgi_error'}; } sub save_request { my($self) = @_; # We're going to play with the package globals now so that if we get called # again, we initialize ourselves in exactly the same way. This allows # us to have several of these objects. @QUERY_PARAM = $self->param; # save list of parameters for (@QUERY_PARAM) { next unless defined $_; $QUERY_PARAM{$_}=$self->{param}{$_}; } $QUERY_CHARSET = $self->charset; %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} }; } sub parse_params { my($self,$tosplit) = @_; my(@pairs) = split(/[&;]/,$tosplit); my($param,$value); for (@pairs) { ($param,$value) = split('=',$_,2); next unless defined $param; next if $NO_UNDEF_PARAMS and not defined $value; $value = '' unless defined $value; $param = unescape($param); $value = unescape($value); $self->add_parameter($param); push (@{$self->{param}{$param}},$value); } } sub add_parameter { my($self,$param)=@_; return unless defined $param; push (@{$self->{'.parameters'}},$param) unless defined($self->{param}{$param}); } sub all_parameters { my $self = shift; return () unless defined($self) && $self->{'.parameters'}; return () unless @{$self->{'.parameters'}}; return @{$self->{'.parameters'}}; } # put a filehandle into binary mode (DOS) sub binmode { return unless defined($_[1]) && ref ($_[1]) && defined fileno($_[1]); CORE::binmode($_[1]); } # back compatibility html tag generation functions - noop # since this is now the default having removed AUTOLOAD sub compile { 1; } sub _all_html_tags { return qw/ a abbr acronym address applet Area b base basefont bdo big blink blockquote body br caption center cite code col colgroup dd del dfn div dl dt em embed fieldset font fontsize frame frameset h1 h2 h3 h4 h5 h6 head hr html i iframe ilayer img input ins kbd label layer legend li Link Map menu meta nextid nobr noframes noscript object ol option p Param pre Q samp script Select small span strike strong style Sub sup table tbody td tfoot th thead title Tr TR tt u ul var / } foreach my $tag ( _all_html_tags() ) { *$tag = sub { return _tag_func($tag,@_); }; # start_html and end_html already exist as custom functions next if ($tag eq 'html'); foreach my $start_end ( qw/ start end / ) { my $start_end_function = "${start_end}_${tag}"; *$start_end_function = sub { return _tag_func($start_end_function,@_); }; } } sub _tag_func { my $tagname = shift; my ($q,$a,@rest) = self_or_default(@_); my($attr) = ''; if (ref($a) && ref($a) eq 'HASH') { my(@attr) = make_attributes($a,$q->{'escape'}); $attr = " @attr" if @attr; } else { unshift @rest,$a if defined $a; } $tagname = lc( $tagname ); if ($tagname=~/start_(\w+)/i) { return "<$1$attr>"; } elsif ($tagname=~/end_(\w+)/i) { return "</$1>"; } else { return $XHTML ? "<$tagname$attr />" : "<$tagname$attr>" unless @rest; my($tag,$untag) = ("<$tagname$attr>","</$tagname>"); my @result = map { "$tag$_$untag" } (ref($rest[0]) eq 'ARRAY') ? @{$rest[0]} : "@rest"; return "@result"; } } sub _selected { my $self = shift; my $value = shift; return '' unless $value; return $XHTML ? qq(selected="selected" ) : qq(selected ); } sub _checked { my $self = shift; my $value = shift; return '' unless $value; return $XHTML ? qq(checked="checked" ) : qq(checked ); } sub _reset_globals { initialize_globals(); } sub _setup_symbols { my $self = shift; # to avoid reexporting unwanted variables undef %EXPORT; for (@_) { if ( /^[:-]any$/ ) { warn "CGI -any pragma has been REMOVED. You should audit your code for any use " . "of none supported / incorrectly spelled tags and remove them" ; next; } $HEADERS_ONCE++, next if /^[:-]unique_headers$/; $NPH++, next if /^[:-]nph$/; $NOSTICKY++, next if /^[:-]nosticky$/; $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/; $DEBUG=2, next if /^[:-][Dd]ebug$/; $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; $PUTDATA_UPLOAD++, next if /^[:-](?:putdata_upload|postdata_upload|patchdata_upload)$/; $PARAM_UTF8++, next if /^[:-]utf8$/; $XHTML++, next if /^[:-]xhtml$/; $XHTML=0, next if /^[:-]no_?xhtml$/; $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/; $TABINDEX++, next if /^[:-]tabindex$/; $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/; $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/; for (&expand_tags($_)) { tr/a-zA-Z0-9_//cd; # don't allow weird function names $EXPORT{$_}++; } } @SAVED_SYMBOLS = @_; } sub charset { my ($self,$charset) = self_or_default(@_); $self->{'.charset'} = $charset if defined $charset; $self->{'.charset'}; } sub element_id { my ($self,$new_value) = self_or_default(@_); $self->{'.elid'} = $new_value if defined $new_value; sprintf('%010d',$self->{'.elid'}++); } sub element_tab { my ($self,$new_value) = self_or_default(@_); $self->{'.etab'} ||= 1; $self->{'.etab'} = $new_value if defined $new_value; my $tab = $self->{'.etab'}++; return '' unless $TABINDEX or defined $new_value; return qq(tabindex="$tab" ); } ##### # subroutine: read_postdata_putdata # # Unless file uploads are disabled # Reads BODY of POST/PUT request and stuffs it into tempfile # accessible as param POSTDATA/PUTDATA # # Also respects upload_hook # # based on subroutine read_multipart_related ##### sub read_postdata_putdata { my ( $self, $postOrPut, $content_length, $content_type ) = @_; my %header = ( "Content-Type" => $content_type, ); my $param = $postOrPut; # add this parameter to our list $self->add_parameter($param); UPLOADS: { # If we get here, then we are dealing with a potentially large # uploaded form. Save the data to a temporary file, then open # the file for reading. # skip the file if uploads disabled if ($DISABLE_UPLOADS) { my $buf; my $unit = $CGI::MultipartBuffer::INITIAL_FILLUNIT; my $len = $content_length; while ( $len > 0 ) { my $read = $self->read_from_client( \$buf, $unit, 0 ); $len -= $read; } last UPLOADS; } # SHOULD PROBABLY SKIP THIS IF NOT $self->{'use_tempfile'} # BUT THE REST OF CGI.PM DOESN'T, SO WHATEVER my $tmp_dir = $CGI::OS eq 'WINDOWS' ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) : undef; # File::Temp defaults to TMPDIR require CGI::File::Temp; my $filehandle = CGI::File::Temp->new( UNLINK => $UNLINK_TMP_FILES, DIR => $tmp_dir, ); $filehandle->_mp_filename( $postOrPut ); $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode && defined fileno($filehandle); my ($data); local ($\) = ''; my $totalbytes; my $unit = $CGI::MultipartBuffer::INITIAL_FILLUNIT; my $len = $content_length; $unit = $len; my $ZERO_LOOP_COUNTER =0; while( $len > 0 ) { my $bytesRead = $self->read_from_client( \$data, $unit, 0 ); $len -= $bytesRead ; # An apparent bug in the Apache server causes the read() # to return zero bytes repeatedly without blocking if the # remote user aborts during a file transfer. I don't know how # they manage this, but the workaround is to abort if we get # more than SPIN_LOOP_MAX consecutive zero reads. if ($bytesRead <= 0) { die "CGI.pm: Server closed socket during read_postdata_putdata (client aborted?).\n" if $ZERO_LOOP_COUNTER++ >= $SPIN_LOOP_MAX; } else { $ZERO_LOOP_COUNTER = 0; } if ( defined $self->{'.upload_hook'} ) { $totalbytes += length($data); &{ $self->{'.upload_hook'} }( $param, $data, $totalbytes, $self->{'.upload_data'} ); } print $filehandle $data if ( $self->{'use_tempfile'} ); undef $data; } # back up to beginning of file seek( $filehandle, 0, 0 ); ## Close the filehandle if requested this allows a multipart MIME ## upload to contain many files, and we won't die due to too many ## open file handles. The user can access the files using the hash ## below. close $filehandle if $CLOSE_UPLOAD_FILES; $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; # Save some information about the uploaded file where we can get # at it later. # Use the typeglob + filename as the key, as this is guaranteed to be # unique for each filehandle. Don't use the file descriptor as # this will be re-used for each filehandle if the # close_upload_files feature is used. $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { hndl => $filehandle, name => $filehandle->filename, info => {%header}, }; push( @{ $self->{param}{$param} }, $filehandle ); } return; } sub URL_ENCODED { 'application/x-www-form-urlencoded'; } sub MULTIPART { 'multipart/form-data'; } sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; } # Create a new multipart buffer sub new_MultipartBuffer { my($self,$boundary,$length) = @_; return CGI::MultipartBuffer->new($self,$boundary,$length); } # Read data from a file handle sub read_from_client { my($self, $buff, $len, $offset) = @_; local $^W=0; # prevent a warning return $MOD_PERL ? $self->r->read($$buff, $len, $offset) : read(\*STDIN, $$buff, $len, $offset); } #### Method: delete # Deletes the named parameter entirely. #### sub delete { my($self,@p) = self_or_default(@_); my(@names) = rearrange([NAME],@p); my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names; my %to_delete; for my $name (@to_delete) { CORE::delete $self->{param}{$name}; CORE::delete $self->{'.fieldnames'}->{$name}; $to_delete{$name}++; } @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); return; } #### Method: import_names # Import all parameters into the given namespace. # Assumes namespace 'Q' if not specified #### sub import_names { my($self,$namespace,$delete) = self_or_default(@_); $namespace = 'Q' unless defined($namespace); die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { # can anyone find an easier way to do this? for (sort keys %{"${namespace}::"}) { local *symbol = "${namespace}::${_}"; undef $symbol; undef @symbol; undef %symbol; } } my($param,@value,$var); for $param ($self->param) { # protect against silly names ($var = $param)=~tr/a-zA-Z0-9_/_/c; $var =~ s/^(?=\d)/_/; local *symbol = "${namespace}::$var"; @value = $self->param($param); @symbol = @value; $symbol = $value[0]; } } #### Method: keywords # Keywords acts a bit differently. Calling it in a list context # returns the list of keywords. # Calling it in a scalar context gives you the size of the list. #### sub keywords { my($self,@values) = self_or_default(@_); # If values is provided, then we set it. $self->{param}{'keywords'}=[@values] if @values; my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : (); @result; } # These are some tie() interfaces for compatibility # with Steve Brenner's cgi-lib.pl routines sub Vars { my $q = shift; my %in; tie(%in,CGI,$q); return %in if wantarray; return \%in; } # These are some tie() interfaces for compatibility # with Steve Brenner's cgi-lib.pl routines sub ReadParse { local(*in); if (@_) { *in = $_[0]; } else { my $pkg = caller(); *in=*{"${pkg}::in"}; } tie(%in,CGI); return scalar(keys %in); } sub PrintHeader { my($self) = self_or_default(@_); return $self->header(); } sub HtmlTop { my($self,@p) = self_or_default(@_); return $self->start_html(@p); } sub HtmlBot { my($self,@p) = self_or_default(@_); return $self->end_html(@p); } sub SplitParam { my ($param) = @_; my (@params) = split ("\0", $param); return (wantarray ? @params : $params[0]); } sub MethGet { return request_method() eq 'GET'; } sub MethPatch { return request_method() eq 'PATCH'; } sub MethPost { return request_method() eq 'POST'; } sub MethPut { return request_method() eq 'PUT'; } sub TIEHASH { my $class = shift; my $arg = $_[0]; if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) { return $arg; } return $Q ||= $class->new(@_); } sub STORE { my $self = shift; my $tag = shift; my $vals = shift; my @vals = defined($vals) && index($vals,"\0")!=-1 ? split("\0",$vals) : $vals; $self->param(-name=>$tag,-value=>\@vals); } sub FETCH { return $_[0] if $_[1] eq 'CGI'; return undef unless defined $_[0]->param($_[1]); return join("\0",$_[0]->param($_[1])); } sub FIRSTKEY { $_[0]->{'.iterator'}=0; $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; } sub NEXTKEY { $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; } sub EXISTS { exists $_[0]->{param}{$_[1]}; } sub DELETE { my ($self, $param) = @_; my $value = $self->FETCH($param); $self->delete($param); return $value; } sub CLEAR { %{$_[0]}=(); } #### #### # Append a new value to an existing query #### sub append { my($self,@p) = self_or_default(@_); my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p); my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); if (@values) { $self->add_parameter($name); push(@{$self->{param}{$name}},@values); } return $self->param($name); } #### Method: delete_all # Delete all parameters #### sub delete_all { my($self) = self_or_default(@_); my @param = $self->param(); $self->delete(@param); } sub Delete { my($self,@p) = self_or_default(@_); $self->delete(@p); } sub Delete_all { my($self,@p) = self_or_default(@_); $self->delete_all(@p); } #### Method: autoescape # If you want to turn off the autoescaping features, # call this method with undef as the argument sub autoEscape { my($self,$escape) = self_or_default(@_); my $d = $self->{'escape'}; $self->{'escape'} = $escape; $d; } #### Method: version # Return the current version #### sub version { return $VERSION; } #### Method: url_param # Return a parameter in the QUERY_STRING, regardless of # whether this was a POST or a GET #### sub url_param { my ($self,@p) = self_or_default(@_); my $name = shift(@p); return undef unless exists($ENV{QUERY_STRING}); unless (exists($self->{'.url_param'})) { $self->{'.url_param'}={}; # empty hash if ($ENV{QUERY_STRING} =~ /=/) { my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); my($param,$value); for (@pairs) { ($param,$value) = split('=',$_,2); next if ! defined($param); $param = unescape($param); $value = unescape($value); push(@{$self->{'.url_param'}->{$param}},$value); } } else { my @keywords = $self->parse_keywordlist($ENV{QUERY_STRING}); $self->{'.url_param'}{'keywords'} = \@keywords if @keywords; } } return keys %{$self->{'.url_param'}} unless defined($name); return () unless $self->{'.url_param'}->{$name}; return wantarray ? @{$self->{'.url_param'}->{$name}} : $self->{'.url_param'}->{$name}->[0]; } #### Method: Dump # Returns a string in which all the known parameter/value # pairs are represented as nested lists, mainly for the purposes # of debugging. #### sub Dump { my($self) = self_or_default(@_); my($param,$value,@result); return '<ul></ul>' unless $self->param; push(@result,"<ul>"); for $param ($self->param) { my($name)=$self->_maybe_escapeHTML($param); push(@result,"<li><strong>$name</strong></li>"); push(@result,"<ul>"); for $value ($self->param($param)) { $value = $self->_maybe_escapeHTML($value); $value =~ s/\n/<br \/>\n/g; push(@result,"<li>$value</li>"); } push(@result,"</ul>"); } push(@result,"</ul>"); return join("\n",@result); } #### Method as_string # # synonym for "dump" #### sub as_string { &Dump(@_); } #### Method: save # Write values out to a filehandle in such a way that they can # be reinitialized by the filehandle form of the new() method #### sub save { my($self,$filehandle) = self_or_default(@_); $filehandle = to_filehandle($filehandle); my($param); local($,) = ''; # set print field separator back to a sane value local($\) = ''; # set output line separator to a sane value for $param ($self->param) { my($escaped_param) = escape($param); my($value); for $value ($self->param($param)) { print $filehandle "$escaped_param=",escape("$value"),"\n" if length($escaped_param) or length($value); } } for (sort keys %{$self->{'.fieldnames'}}) { print $filehandle ".cgifields=",escape("$_"),"\n"; } print $filehandle "=\n"; # end of record } #### Method: save_parameters # An alias for save() that is a better name for exportation. # Only intended to be used with the function (non-OO) interface. #### sub save_parameters { my $fh = shift; return save(to_filehandle($fh)); } #### Method: restore_parameters # A way to restore CGI parameters from an initializer. # Only intended to be used with the function (non-OO) interface. #### sub restore_parameters { $Q = $CGI::DefaultClass->new(@_); } #### Method: multipart_init # Return a Content-Type: style header for server-push # This has to be NPH on most web servers, and it is advisable to set $| = 1 # # Many thanks to Ed Jordan <ed@fidalgo.net> for this # contribution, updated by Andrew Benham (adsb@bigfoot.com) #### sub multipart_init { my($self,@p) = self_or_default(@_); my($boundary,$charset,@other) = rearrange_header([BOUNDARY,CHARSET],@p); if (!$boundary) { $boundary = '------- =_'; my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z'); for (1..17) { $boundary .= $chrs[rand(scalar @chrs)]; } } $self->{'separator'} = "$CRLF--$boundary$CRLF"; $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; $type = SERVER_PUSH($boundary); return $self->header( -nph => 0, -type => $type, -charset => $charset, (map { split "=", $_, 2 } @other), ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; } #### Method: multipart_start # Return a Content-Type: style header for server-push, start of section # # Many thanks to Ed Jordan <ed@fidalgo.net> for this # contribution, updated by Andrew Benham (adsb@bigfoot.com) #### sub multipart_start { my(@header); my($self,@p) = self_or_default(@_); my($type,$charset,@other) = rearrange([TYPE,CHARSET],@p); $type = $type || 'text/html'; if ($charset) { push(@header,"Content-Type: $type; charset=$charset"); } else { push(@header,"Content-Type: $type"); } # rearrange() was designed for the HTML portion, so we # need to fix it up a little. for (@other) { # Don't use \s because of perl bug 21951 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e; } push(@header,@other); my $header = join($CRLF,@header)."${CRLF}${CRLF}"; return $header; } #### Method: multipart_end # Return a MIME boundary separator for server-push, end of section # # Many thanks to Ed Jordan <ed@fidalgo.net> for this # contribution #### sub multipart_end { my($self,@p) = self_or_default(@_); return $self->{'separator'}; } #### Method: multipart_final # Return a MIME boundary separator for server-push, end of all sections # # Contributed by Andrew Benham (adsb@bigfoot.com) #### sub multipart_final { my($self,@p) = self_or_default(@_); return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF; } #### Method: header # Return a Content-Type: style header # #### sub header { my($self,@p) = self_or_default(@_); my(@header); return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], 'STATUS',['COOKIE','COOKIES','SET-COOKIE'],'TARGET', 'EXPIRES','NPH','CHARSET', 'ATTACHMENT','P3P'],@p); # Since $cookie and $p3p may be array references, # we must stringify them before CR escaping is done. my @cookie; for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) { my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; push(@cookie,$cs) if defined $cs and $cs ne ''; } $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY'; # CR escaping for values, per RFC 822 for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) { if (defined $header) { # From RFC 822: # Unfolding is accomplished by regarding CRLF immediately # followed by a LWSP-char as equivalent to the LWSP-char. $header =~ s/$CRLF(\s)/$1/g; # All other uses of newlines are invalid input. if ($header =~ m/$CRLF|\015|\012/) { # shorten very long values in the diagnostic $header = substr($header,0,72).'...' if (length $header > 72); die "Invalid header value contains a newline not followed by whitespace: $header"; } } } $nph ||= $NPH; $type ||= 'text/html' unless defined($type); # sets if $charset is given, gets if not $charset = $self->charset( $charset ); # rearrange() was designed for the HTML portion, so we # need to fix it up a little. for (@other) { # Don't use \s because of perl bug 21951 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s; ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e; } $type .= "; charset=$charset" if $type ne '' and $type !~ /\bcharset\b/ and defined $charset and $charset ne ''; # Maybe future compatibility. Maybe not. my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; push(@header,"Server: " . &server_software()) if $nph; push(@header,"Status: $status") if $status; push(@header,"Window-Target: $target") if $target; push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p; # push all the cookies -- there may be several push(@header,map {"Set-Cookie: $_"} @cookie); # if the user indicates an expiration time, then we need # both an Expires and a Date header (so that the browser is # uses OUR clock) push(@header,"Expires: " . expires($expires,'http')) if $expires; push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; push(@header,"Pragma: no-cache") if $self->cache(); push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; push(@header,map {ucfirst $_} @other); push(@header,"Content-Type: $type") if $type ne ''; my $header = join($CRLF,@header)."${CRLF}${CRLF}"; if (($MOD_PERL >= 1) && !$nph) { $self->r->send_cgi_header($header); return ''; } return $header; } #### Method: cache # Control whether header() will produce the no-cache # Pragma directive. #### sub cache { my($self,$new_value) = self_or_default(@_); $new_value = '' unless $new_value; if ($new_value ne '') { $self->{'cache'} = $new_value; } return $self->{'cache'}; } #### Method: redirect # Return a Location: style header # #### sub redirect { my($self,@p) = self_or_default(@_); my($url,$target,$status,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES','SET-COOKIE'],NPH],@p); $status = '302 Found' unless defined $status; $url ||= $self->self_url; my(@o); for (@other) { tr/\"//d; push(@o,split("=",$_,2)); } unshift(@o, '-Status' => $status, '-Location'=> $url, '-nph' => $nph); unshift(@o,'-Target'=>$target) if $target; unshift(@o,'-Type'=>''); my @unescaped; unshift(@unescaped,'-Cookie'=>$cookie) if $cookie; return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped); } #### Method: start_html # Canned HTML header # # Parameters: # $title -> (optional) The title for this HTML document (-title) # $author -> (optional) e-mail address of the author (-author) # $base -> (optional) if set to true, will enter the BASE address of this document # for resolving relative references (-base) # $xbase -> (optional) alternative base at some remote location (-xbase) # $target -> (optional) target window to load all links into (-target) # $script -> (option) Javascript code (-script) # $no_script -> (option) Javascript <noscript> tag (-noscript) # $meta -> (optional) Meta information tags # $head -> (optional) any other elements you'd like to incorporate into the <head> tag # (a scalar or array ref) # $style -> (optional) reference to an external style sheet # @other -> (optional) any other named parameters you'd like to incorporate into # the <body> tag. #### sub start_html { my($self,@p) = &self_or_default(@_); my($title,$author,$base,$xbase,$script,$noscript, $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) = rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET, META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p); $self->element_id(0); $self->element_tab(0); $encoding = lc($self->charset) unless defined $encoding; # Need to sort out the DTD before it's okay to call escapeHTML(). my(@result,$xml_dtd); if ($dtd) { if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) { $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|; } else { $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|; } } else { $dtd = $XHTML ? $_XHTML_DTD : $DEFAULT_DTD; } $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i; $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i; push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml; if (ref($dtd) && ref($dtd) eq 'ARRAY') { push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">)); $DTD_PUBLIC_IDENTIFIER = $dtd->[0]; } else { push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">)); $DTD_PUBLIC_IDENTIFIER = $dtd; } # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to # call escapeHTML(). Strangely enough, the title needs to be escaped as # HTML while the author needs to be escaped as a URL. $title = $self->_maybe_escapeHTML($title || 'Untitled Document'); $author = $self->escape($author); if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2|4\.01?)/i) { $lang = "" unless defined $lang; $XHTML = 0; } else { $lang = 'en-US' unless defined $lang; } my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : ''; my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />) if $XHTML && $encoding && !$declare_xml; push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>) : ($lang ? qq(<html lang="$lang">) : "<html>") . "<head><title>$title</title>"); if (defined $author) { push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />" : "<link rev=\"made\" href=\"mailto:$author\">"); } if ($base || $xbase || $target) { my $href = $xbase || $self->url('-path'=>1); my $t = $target ? qq/ target="$target"/ : ''; push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>)); } if ($meta && ref($meta) && (ref($meta) eq 'HASH')) { for (sort keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />) : qq(<meta name="$_" content="$meta->{$_}">)); } } my $meta_bits_set = 0; if( $head ) { if( ref $head ) { push @result, @$head; $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head; } else { push @result, $head; $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i; } } # handle the infrequently-used -style and -script parameters push(@result,$self->_style($style)) if defined $style; push(@result,$self->_script($script)) if defined $script; push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set; # handle -noscript parameter push(@result,<<END) if $noscript; <noscript> $noscript </noscript> END ; my($other) = @other ? " @other" : ''; push(@result,"</head>\n<body$other>\n"); return join("\n",@result); } ### Method: _style # internal method for generating a CSS style section #### sub _style { my ($self,$style) = @_; my (@result); my $type = 'text/css'; my $rel = 'stylesheet'; my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- "; my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n"; my @s = ref($style) eq 'ARRAY' ? @$style : $style; my $other = ''; for my $s (@s) { if (ref($s)) { my($src,$code,$verbatim,$stype,$alternate,$foo,@other) = rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)], ('-foo'=>'bar', ref($s) eq 'ARRAY' ? @$s : %$s)); my $type = defined $stype ? $stype : 'text/css'; my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet'; $other = "@other" if @other; if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference { # If it is, push a LINK tag for each one for $src (@$src) { push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src; } } else { # Otherwise, push the single -src, if it exists. push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) : qq(<link rel="$rel" type="$type" href="$src"$other>) ) if $src; } if ($verbatim) { my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim; push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v; } if ($code) { my @c = ref($code) eq 'ARRAY' ? @$code : $code; push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c; } } else { my $src = $s; push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) : qq(<link rel="$rel" type="$type" href="$src"$other>)); } } @result; } sub _script { my ($self,$script) = @_; my (@result); my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script); for $script (@scripts) { my($src,$code,$language,$charset); if (ref($script)) { # script is a hash ($src,$code,$type,$charset) = rearrange(['SRC','CODE',['LANGUAGE','TYPE'],'CHARSET'], '-foo'=>'bar', # a trick to allow the '-' to be omitted ref($script) eq 'ARRAY' ? @$script : %$script); $type ||= 'text/javascript'; unless ($type =~ m!\w+/\w+!) { $type =~ s/[\d.]+$//; $type = "text/$type"; } } else { ($src,$code,$type,$charset) = ('',$script, 'text/javascript', ''); } my $comment = '//'; # javascript by default $comment = '#' if $type=~/perl|tcl/i; $comment = "'" if $type=~/vbscript/i; my ($cdata_start,$cdata_end); if ($XHTML) { $cdata_start = "$comment<![CDATA[\n"; $cdata_end .= "\n$comment]]>"; } else { $cdata_start = "\n<!-- Hide script\n"; $cdata_end = $comment; $cdata_end .= " End script hiding -->\n"; } my(@satts); push(@satts,'src'=>$src) if $src; push(@satts,'type'=>$type); push(@satts,'charset'=>$charset) if ($src && $charset); $code = $cdata_start . $code . $cdata_end if defined $code; push(@result,$self->script({@satts},$code || '')); } @result; } #### Method: end_html # End an HTML document. # Trivial method for completeness. Just returns "</body>" #### sub end_html { return "\n</body>\n</html>"; } ################################ # METHODS USED IN BUILDING FORMS ################################ #### Method: isindex # Just prints out the isindex tag. # Parameters: # $action -> optional URL of script to run # Returns: # A string containing a <isindex> tag sub isindex { my($self,@p) = self_or_default(@_); my($action,@other) = rearrange([ACTION],@p); $action = qq/ action="$action"/ if $action; my($other) = @other ? " @other" : ''; return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>"; } #### Method: start_form # Start a form # Parameters: # $method -> optional submission method to use (GET or POST) # $action -> optional URL of script to run # $enctype ->encoding to use (URL_ENCODED or MULTIPART) sub start_form { my($self,@p) = self_or_default(@_); my($method,$action,$enctype,@other) = rearrange([METHOD,ACTION,ENCTYPE],@p); $method = $self->_maybe_escapeHTML(lc($method || 'post')); if( $XHTML ){ $enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART); }else{ $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED); } if (defined $action) { $action = $self->_maybe_escapeHTML($action); } else { $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url); } $action = qq(action="$action"); my($other) = @other ? " @other" : ''; $self->{'.parametersToAdd'}={}; return qq/<form method="$method" $action enctype="$enctype"$other>/; } #### Method: start_multipart_form sub start_multipart_form { my($self,@p) = self_or_default(@_); if (defined($p[0]) && substr($p[0],0,1) eq '-') { return $self->start_form(-enctype=>&MULTIPART,@p); } else { my($method,$action,@other) = rearrange([METHOD,ACTION],@p); return $self->start_form($method,$action,&MULTIPART,@other); } } #### Method: end_form # End a form # Note: This repeated below under the older name. sub end_form { my($self,@p) = self_or_default(@_); if ( $NOSTICKY ) { return wantarray ? ("</form>") : "\n</form>"; } else { if (my @fields = $self->get_fields) { return wantarray ? ("<div>",@fields,"</div>","</form>") : "<div>".(join '',@fields)."</div>\n</form>"; } else { return "</form>"; } } } #### Method: end_multipart_form # end a multipart form sub end_multipart_form { &end_form; } sub _textfield { my($self,$tag,@p) = self_or_default(@_); my($name,$default,$size,$maxlength,$override,$tabindex,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p); my $current = $override ? $default : (defined($self->param($name)) ? $self->param($name) : $default); $current = defined($current) ? $self->_maybe_escapeHTML($current,1) : ''; $name = defined($name) ? $self->_maybe_escapeHTML($name) : ''; my($s) = defined($size) ? qq/ size="$size"/ : ''; my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : ''; my($other) = @other ? " @other" : ''; # this entered at cristy's request to fix problems with file upload fields # and WebTV -- not sure it won't break stuff my($value) = $current ne '' ? qq(value="$current") : ''; $tabindex = $self->element_tab($tabindex); return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />) : qq(<input type="$tag" name="$name" $value$s$m$other>); } #### Method: textfield # Parameters: # $name -> Name of the text field # $default -> Optional default value of the field if not # already defined. # $size -> Optional width of field in characaters. # $maxlength -> Optional maximum number of characters. # Returns: # A string containing a <input type="text"> field # sub textfield { my($self,@p) = self_or_default(@_); $self->_textfield('text',@p); } #### Method: filefield # Parameters: # $name -> Name of the file upload field # $size -> Optional width of field in characaters. # $maxlength -> Optional maximum number of characters. # Returns: # A string containing a <input type="file"> field # sub filefield { my($self,@p) = self_or_default(@_); $self->_textfield('file',@p); } #### Method: password # Create a "secret password" entry field # Parameters: # $name -> Name of the field # $default -> Optional default value of the field if not # already defined. # $size -> Optional width of field in characters. # $maxlength -> Optional maximum characters that can be entered. # Returns: # A string containing a <input type="password"> field # sub password_field { my ($self,@p) = self_or_default(@_); $self->_textfield('password',@p); } #### Method: textarea # Parameters: # $name -> Name of the text field # $default -> Optional default value of the field if not # already defined. # $rows -> Optional number of rows in text area # $columns -> Optional number of columns in text area # Returns: # A string containing a <textarea></textarea> tag # sub textarea { my($self,@p) = self_or_default(@_); my($name,$default,$rows,$cols,$override,$tabindex,@other) = rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p); my($current)= $override ? $default : (defined($self->param($name)) ? $self->param($name) : $default); $name = defined($name) ? $self->_maybe_escapeHTML($name) : ''; $current = defined($current) ? $self->_maybe_escapeHTML($current) : ''; my($r) = $rows ? qq/ rows="$rows"/ : ''; my($c) = $cols ? qq/ cols="$cols"/ : ''; my($other) = @other ? " @other" : ''; $tabindex = $self->element_tab($tabindex); return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>}; } #### Method: button # Create a javascript button. # Parameters: # $name -> (optional) Name for the button. (-name) # $value -> (optional) Value of the button when selected (and visible name) (-value) # $onclick -> (optional) Text of the JavaScript to run when the button is # clicked. # Returns: # A string containing a <input type="button"> tag #### sub button { my($self,@p) = self_or_default(@_); my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL], [ONCLICK,SCRIPT],TABINDEX],@p); $label=$self->_maybe_escapeHTML($label); $value=$self->_maybe_escapeHTML($value,1); $script=$self->_maybe_escapeHTML($script); $script ||= ''; my($name) = ''; $name = qq/ name="$label"/ if $label; $value = $value || $label; my($val) = ''; $val = qq/ value="$value"/ if $value; $script = qq/ onclick="$script"/ if $script; my($other) = @other ? " @other" : ''; $tabindex = $self->element_tab($tabindex); return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />) : qq(<input type="button"$name$val$script$other>); } #### Method: submit # Create a "submit query" button. # Parameters: # $name -> (optional) Name for the button. # $value -> (optional) Value of the button when selected (also doubles as label). # $label -> (optional) Label printed on the button(also doubles as the value). # Returns: # A string containing a <input type="submit"> tag #### sub submit { my($self,@p) = self_or_default(@_); my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p); $label=$self->_maybe_escapeHTML($label); $value=$self->_maybe_escapeHTML($value,1); my $name = $NOSTICKY ? '' : 'name=".submit" '; $name = qq/name="$label" / if defined($label); $value = defined($value) ? $value : $label; my $val = ''; $val = qq/value="$value" / if defined($value); $tabindex = $self->element_tab($tabindex); my($other) = @other ? "@other " : ''; return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>) : qq(<input type="submit" $name$val$other>); } #### Method: reset # Create a "reset" button. # Parameters: # $name -> (optional) Name for the button. # Returns: # A string containing a <input type="reset"> tag #### sub reset { my($self,@p) = self_or_default(@_); my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p); $label=$self->_maybe_escapeHTML($label); $value=$self->_maybe_escapeHTML($value,1); my ($name) = ' name=".reset"'; $name = qq/ name="$label"/ if defined($label); $value = defined($value) ? $value : $label; my($val) = ''; $val = qq/ value="$value"/ if defined($value); my($other) = @other ? " @other" : ''; $tabindex = $self->element_tab($tabindex); return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />) : qq(<input type="reset"$name$val$other>); } #### Method: defaults # Create a "defaults" button. # Parameters: # $name -> (optional) Name for the button. # Returns: # A string containing a <input type="submit" name=".defaults"> tag # # Note: this button has a special meaning to the initialization script, # and tells it to ERASE the current query string so that your defaults # are used again! #### sub defaults { my($self,@p) = self_or_default(@_); my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p); $label=$self->_maybe_escapeHTML($label,1); $label = $label || "Defaults"; my($value) = qq/ value="$label"/; my($other) = @other ? " @other" : ''; $tabindex = $self->element_tab($tabindex); return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />) : qq/<input type="submit" NAME=".defaults"$value$other>/; } #### Method: comment # Create an HTML <!-- comment --> # Parameters: a string sub comment { my($self,@p) = self_or_CGI(@_); return "<!-- @p -->"; } #### Method: checkbox # Create a checkbox that is not logically linked to any others. # The field value is "on" when the button is checked. # Parameters: # $name -> Name of the checkbox # $checked -> (optional) turned on by default if true # $value -> (optional) value of the checkbox, 'on' by default # $label -> (optional) a user-readable label printed next to the box. # Otherwise the checkbox name is used. # Returns: # A string containing a <input type="checkbox"> field #### sub checkbox { my($self,@p) = self_or_default(@_); my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) = rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES, [OVERRIDE,FORCE],TABINDEX],@p); $value = defined $value ? $value : 'on'; if (!$override && ($self->{'.fieldnames'}->{$name} || defined $self->param($name))) { $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : ''; } else { $checked = $self->_checked($checked); } my($the_label) = defined $label ? $label : $name; $name = $self->_maybe_escapeHTML($name); $value = $self->_maybe_escapeHTML($value,1); $the_label = $self->_maybe_escapeHTML($the_label); my($other) = @other ? "@other " : ''; $tabindex = $self->element_tab($tabindex); $self->register_parameter($name); return $XHTML ? CGI::label($labelattributes, qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label}) : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label}; } # Escape HTML sub escapeHTML { require HTML::Entities; # hack to work around earlier hacks push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); return undef unless defined($toencode); my $encode_entities = $ENCODE_ENTITIES; $encode_entities .= "\012\015" if ( $encode_entities && $newlinestoo ); return HTML::Entities::encode_entities($toencode,$encode_entities); } # unescape HTML -- used internally sub unescapeHTML { require HTML::Entities; # hack to work around earlier hacks push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; my ($self,$string) = CGI::self_or_default(@_); return undef unless defined($string); return HTML::Entities::decode_entities($string); } # Internal procedure - don't use sub _tableize { my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; my @rowheaders = $rowheaders ? @$rowheaders : (); my @colheaders = $colheaders ? @$colheaders : (); my($result); if (defined($columns)) { $rows = int(0.99 + @elements/$columns) unless defined($rows); } if (defined($rows)) { $columns = int(0.99 + @elements/$rows) unless defined($columns); } # rearrange into a pretty table $result = "<table>"; my($row,$column); unshift(@colheaders,'') if @colheaders && @rowheaders; $result .= "<tr>" if @colheaders; for (@colheaders) { $result .= "<th>$_</th>"; } for ($row=0;$row<$rows;$row++) { $result .= "<tr>"; $result .= "<th>$rowheaders[$row]</th>" if @rowheaders; for ($column=0;$column<$columns;$column++) { $result .= "<td>" . $elements[$column*$rows + $row] . "</td>" if defined($elements[$column*$rows + $row]); } $result .= "</tr>"; } $result .= "</table>"; return $result; } #### Method: radio_group # Create a list of logically-linked radio buttons. # Parameters: # $name -> Common name for all the buttons. # $values -> A pointer to a regular array containing the # values for each button in the group. # $default -> (optional) Value of the button to turn on by default. Pass '-' # to turn _nothing_ on. # $linebreak -> (optional) Set to true to place linebreaks # between the buttons. # $labels -> (optional) # A pointer to a hash of labels to print next to each checkbox # in the form $label{'value'}="Long explanatory label". # Otherwise the provided values are used as the labels. # Returns: # An ARRAY containing a series of <input type="radio"> fields #### sub radio_group { my($self,@p) = self_or_default(@_); $self->_box_group('radio',@p); } #### Method: checkbox_group # Create a list of logically-linked checkboxes. # Parameters: # $name -> Common name for all the check boxes # $values -> A pointer to a regular array containing the # values for each checkbox in the group. # $defaults -> (optional) # 1. If a pointer to a regular array of checkbox values, # then this will be used to decide which # checkboxes to turn on by default. # 2. If a scalar, will be assumed to hold the # value of a single checkbox in the group to turn on. # $linebreak -> (optional) Set to true to place linebreaks # between the buttons. # $labels -> (optional) # A pointer to a hash of labels to print next to each checkbox # in the form $label{'value'}="Long explanatory label". # Otherwise the provided values are used as the labels. # Returns: # An ARRAY containing a series of <input type="checkbox"> fields #### sub checkbox_group { my($self,@p) = self_or_default(@_); $self->_box_group('checkbox',@p); } sub _box_group { my $self = shift; my $box_type = shift; my($name,$values,$defaults,$linebreak,$labels,$labelattributes, $attributes,$rows,$columns,$rowheaders,$colheaders, $override,$nolabels,$tabindex,$disabled,@other) = rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES, ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER], [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED ],@_); my($result,$checked,@elements,@values); @values = $self->_set_values_and_labels($values,\$labels,$name); my %checked = $self->previous_or_default($name,$defaults,$override); # If no check array is specified, check the first by default $checked{$values[0]}++ if $box_type eq 'radio' && !%checked; $name=$self->_maybe_escapeHTML($name); my %tabs = (); if ($TABINDEX && $tabindex) { if (!ref $tabindex) { $self->element_tab($tabindex); } elsif (ref $tabindex eq 'ARRAY') { %tabs = map {$_=>$self->element_tab} @$tabindex; } elsif (ref $tabindex eq 'HASH') { %tabs = %$tabindex; } } %tabs = map {$_=>$self->element_tab} @values unless %tabs; my $other = @other ? "@other " : ''; my $radio_checked; # for disabling groups of radio/checkbox buttons my %disabled; for (@{$disabled}) { $disabled{$_}=1; } for (@values) { my $disable=""; if ($disabled{$_}) { $disable="disabled='1'"; } my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++) : $checked{$_}); my($break); if ($linebreak) { $break = $XHTML ? "<br />" : "<br>"; } else { $break = ''; } my($label)=''; unless (defined($nolabels) && $nolabels) { $label = $_; $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); $label = $self->_maybe_escapeHTML($label,1); $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_}; } my $attribs = $self->_set_attributes($_, $attributes); my $tab = $tabs{$_}; $_=$self->_maybe_escapeHTML($_); if ($XHTML) { push @elements, CGI::label($labelattributes, qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break}; } else { push(@elements,qq/<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable>${label}${break}/); } } $self->register_parameter($name); return wantarray ? @elements : "@elements" unless defined($columns) || defined($rows); return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); } #### Method: popup_menu # Create a popup menu. # Parameters: # $name -> Name for all the menu # $values -> A pointer to a regular array containing the # text of each menu item. # $default -> (optional) Default item to display # $labels -> (optional) # A pointer to a hash of labels to print next to each checkbox # in the form $label{'value'}="Long explanatory label". # Otherwise the provided values are used as the labels. # Returns: # A string containing the definition of a popup menu. #### sub popup_menu { my($self,@p) = self_or_default(@_); my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) = rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); my($result,%selected); if (!$override && defined($self->param($name))) { $selected{$self->param($name)}++; } elsif (defined $default) { %selected = map {$_=>1} ref($default) eq 'ARRAY' ? @$default : $default; } $name=$self->_maybe_escapeHTML($name); # RT #30057 - ignore -multiple, if you need this # then use scrolling_list @other = grep { $_ !~ /^multiple=/i } @other; my($other) = @other ? " @other" : ''; my(@values); @values = $self->_set_values_and_labels($values,\$labels,$name); $tabindex = $self->element_tab($tabindex); $name = q{} if ! defined $name; $result = qq/<select name="$name" $tabindex$other>\n/; for (@values) { if (/<optgroup/) { for my $v (split(/\n/)) { my $selectit = $XHTML ? 'selected="selected"' : 'selected'; for my $selected (sort keys %selected) { $v =~ s/(value="\Q$selected\E")/$selectit $1/; } $result .= "$v\n"; } } else { my $attribs = $self->_set_attributes($_, $attributes); my($selectit) = $self->_selected($selected{$_}); my($label) = $_; $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); my($value) = $self->_maybe_escapeHTML($_); $label = $self->_maybe_escapeHTML($label,1); $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n"; } } $result .= "</select>"; return $result; } #### Method: optgroup # Create a optgroup. # Parameters: # $name -> Label for the group # $values -> A pointer to a regular array containing the # values for each option line in the group. # $labels -> (optional) # A pointer to a hash of labels to print next to each item # in the form $label{'value'}="Long explanatory label". # Otherwise the provided values are used as the labels. # $labeled -> (optional) # A true value indicates the value should be used as the label attribute # in the option elements. # The label attribute specifies the option label presented to the user. # This defaults to the content of the <option> element, but the label # attribute allows authors to more easily use optgroup without sacrificing # compatibility with browsers that do not support option groups. # $novals -> (optional) # A true value indicates to suppress the val attribute in the option elements # Returns: # A string containing the definition of an option group. #### sub optgroup { my($self,@p) = self_or_default(@_); my($name,$values,$attributes,$labeled,$noval,$labels,@other) = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p); my($result,@values); @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals); my($other) = @other ? " @other" : ''; $name = $self->_maybe_escapeHTML($name) || q{}; $result = qq/<optgroup label="$name"$other>\n/; for (@values) { if (/<optgroup/) { for (split(/\n/)) { my $selectit = $XHTML ? 'selected="selected"' : 'selected'; s/(value="$selected")/$selectit $1/ if defined $selected; $result .= "$_\n"; } } else { my $attribs = $self->_set_attributes($_, $attributes); my($label) = $_; $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); $label=$self->_maybe_escapeHTML($label); my($value)=$self->_maybe_escapeHTML($_,1); $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n" : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n" : $novals ? "<option$attribs>$label</option>\n" : "<option$attribs value=\"$value\">$label</option>\n"; } } $result .= "</optgroup>"; return $result; } #### Method: scrolling_list # Create a scrolling list. # Parameters: # $name -> name for the list # $values -> A pointer to a regular array containing the # values for each option line in the list. # $defaults -> (optional) # 1. If a pointer to a regular array of options, # then this will be used to decide which # lines to turn on by default. # 2. Otherwise holds the value of the single line to turn on. # $size -> (optional) Size of the list. # $multiple -> (optional) If set, allow multiple selections. # $labels -> (optional) # A pointer to a hash of labels to print next to each checkbox # in the form $label{'value'}="Long explanatory label". # Otherwise the provided values are used as the labels. # Returns: # A string containing the definition of a scrolling list. #### sub scrolling_list { my($self,@p) = self_or_default(@_); my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other) = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); my($result,@values); @values = $self->_set_values_and_labels($values,\$labels,$name); $size = $size || scalar(@values); my(%selected) = $self->previous_or_default($name,$defaults,$override); my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : ''; my($has_size) = $size ? qq/ size="$size"/: ''; my($other) = @other ? " @other" : ''; $name=$self->_maybe_escapeHTML($name); $tabindex = $self->element_tab($tabindex); $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/; for (@values) { if (/<optgroup/) { for my $v (split(/\n/)) { my $selectit = $XHTML ? 'selected="selected"' : 'selected'; for my $selected (sort keys %selected) { $v =~ s/(value="$selected")/$selectit $1/; } $result .= "$v\n"; } } else { my $attribs = $self->_set_attributes($_, $attributes); my($selectit) = $self->_selected($selected{$_}); my($label) = $_; $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); my($value) = $self->_maybe_escapeHTML($_); $label = $self->_maybe_escapeHTML($label,1); $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n"; } } $result .= "</select>"; $self->register_parameter($name); return $result; } #### Method: hidden # Parameters: # $name -> Name of the hidden field # @default -> (optional) Initial values of field (may be an array) # or # $default->[initial values of field] # Returns: # A string containing a <input type="hidden" name="name" value="value"> #### sub hidden { my($self,@p) = self_or_default(@_); # this is the one place where we departed from our standard # calling scheme, so we have to special-case (darn) my(@result,@value); my($name,$default,$override,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); my $do_override = 0; if ( ref($p[0]) || substr($p[0],0,1) eq '-') { @value = ref($default) ? @{$default} : $default; $do_override = $override; } else { for ($default,$override,@other) { push(@value,$_) if defined($_); } undef @other; } # use previous values if override is not set my @prev = $self->param($name); @value = @prev if !$do_override && @prev; $name=$self->_maybe_escapeHTML($name); for (@value) { $_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : ''; push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />) : qq(<input type="hidden" name="$name" value="$_" @other>); } return wantarray ? @result : join('',@result); } #### Method: image_button # Parameters: # $name -> Name of the button # $src -> URL of the image source # $align -> Alignment style (TOP, BOTTOM or MIDDLE) # Returns: # A string containing a <input type="image" name="name" src="url" align="alignment"> #### sub image_button { my($self,@p) = self_or_default(@_); my($name,$src,$alignment,@other) = rearrange([NAME,SRC,ALIGN],@p); my($align) = $alignment ? " align=\L\"$alignment\"" : ''; my($other) = @other ? " @other" : ''; $name=$self->_maybe_escapeHTML($name); return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />) : qq/<input type="image" name="$name" src="$src"$align$other>/; } #### Method: self_url # Returns a URL containing the current script and all its # param/value pairs arranged as a query. You can use this # to create a link that, when selected, will reinvoke the # script with all its state information preserved. #### sub self_url { my($self,@p) = self_or_default(@_); return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p); } # This is provided as a synonym to self_url() for people unfortunate # enough to have incorporated it into their programs already! sub state { &self_url; } #### Method: url # Like self_url, but doesn't return the query string part of # the URL. #### sub url { my($self,@p) = self_or_default(@_); my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) = rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p); my $url = ''; $full++ if $base || !($relative || $absolute); $rewrite++ unless defined $rewrite; my $path = $self->path_info; my $script_name = $self->script_name; my $request_uri = $self->request_uri || ''; my $query_str = $query ? $self->query_string : ''; $script_name =~ s/\?.*$//s; # remove query string $request_uri =~ s/\?.*$//s; # remove query string $request_uri = unescape($request_uri); my $uri = $rewrite && $request_uri ? $request_uri : $script_name; if ( defined( $ENV{PATH_INFO} ) ) { # IIS sometimes sets PATH_INFO to the same value as SCRIPT_NAME so only sub it out # if SCRIPT_NAME isn't defined or isn't the same value as PATH_INFO $uri =~ s/\Q$ENV{PATH_INFO}\E$// if ( ! defined( $ENV{SCRIPT_NAME} ) or $ENV{PATH_INFO} ne $ENV{SCRIPT_NAME} ); # if we're not IIS then keep to spec, the relevant info is here: # https://tools.ietf.org/html/rfc3875#section-4.1.13, namely # "No PATH_INFO segment (see section 4.1.5) is included in the # SCRIPT_NAME value." (see GH #126, GH #152, GH #176) if ( ! $IIS ) { $uri =~ s/\Q$ENV{PATH_INFO}\E$//; } } if ($full) { my $protocol = $self->protocol(); $url = "$protocol://"; my $vh = http('x_forwarded_host') || http('host') || ''; $vh =~ s/^.*,\s*//; # x_forwarded_host may be a comma-separated list (e.g. when the request has # passed through multiple reverse proxies. Take the last one. $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it. $url .= $vh || server_name(); my $port = $self->virtual_port; # add the port to the url unless it's the protocol's default port $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80) or (lc($protocol) eq 'https' && $port == 443); return $url if $base; $url .= $uri; } elsif ($relative) { ($url) = $uri =~ m!([^/]+)$!; } elsif ($absolute) { $url = $uri; } $url .= $path if $path_info and defined $path; $url .= "?$query_str" if $query and $query_str ne ''; $url ||= ''; $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; return $url; } #### Method: cookie # Set or read a cookie from the specified name. # Cookie can then be passed to header(). # Usual rules apply to the stickiness of -value. # Parameters: # -name -> name for this cookie (optional) # -value -> value of this cookie (scalar, array or hash) # -path -> paths for which this cookie is valid (optional) # -domain -> internet domain in which this cookie is valid (optional) # -secure -> if true, cookie only passed through secure channel (optional) # -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) #### sub cookie { my($self,@p) = self_or_default(@_); my($name,$value,$path,$domain,$secure,$expires,$httponly,$max_age,$samesite) = rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY,'MAX-AGE',SAMESITE],@p); require CGI::Cookie; # if no value is supplied, then we retrieve the # value of the cookie, if any. For efficiency, we cache the parsed # cookies in our state variables. unless ( defined($value) ) { $self->{'.cookies'} = CGI::Cookie->fetch unless $COOKIE_CACHE && exists $self->{'.cookies'}; # If no name is supplied, then retrieve the names of all our cookies. return () unless $self->{'.cookies'}; return keys %{$self->{'.cookies'}} unless $name; return () unless $self->{'.cookies'}->{$name}; return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne ''; } # If we get here, we're creating a new cookie return undef unless defined($name) && $name ne ''; # this is an error my @param; push(@param,'-name'=>$name); push(@param,'-value'=>$value); push(@param,'-domain'=>$domain) if $domain; push(@param,'-path'=>$path) if $path; push(@param,'-expires'=>$expires) if $expires; push(@param,'-secure'=>$secure) if $secure; push(@param,'-httponly'=>$httponly) if $httponly; push(@param,'-max-age'=>$max_age) if $max_age; push(@param,'-samesite'=>$samesite) if $samesite; return CGI::Cookie->new(@param); } sub parse_keywordlist { my($self,$tosplit) = @_; $tosplit = unescape($tosplit); # unescape the keywords $tosplit=~tr/+/ /; # pluses to spaces my(@keywords) = split(/\s+/,$tosplit); return @keywords; } sub param_fetch { my($self,@p) = self_or_default(@_); my($name) = rearrange([NAME],@p); return [] unless defined $name; unless (exists($self->{param}{$name})) { $self->add_parameter($name); $self->{param}{$name} = []; } return $self->{param}{$name}; } ############################################### # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT ############################################### #### Method: path_info # Return the extra virtual path information provided # after the URL (if any) #### sub path_info { my ($self,$info) = self_or_default(@_); if (defined($info)) { $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; $self->{'.path_info'} = $info; } elsif (! defined($self->{'.path_info'}) ) { my (undef,$path_info) = $self->_name_and_path_from_env; $self->{'.path_info'} = $path_info || ''; } return $self->{'.path_info'}; } # This function returns a potentially modified version of SCRIPT_NAME # and PATH_INFO. Some HTTP servers do sanitise the paths in those # variables. It is the case of at least Apache 2. If for instance the # user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set: # REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y # SCRIPT_NAME=/path/to/env.cgi # PATH_INFO=/x/y/x # # This is all fine except that some bogus CGI scripts expect # PATH_INFO=/http://foo when the user requests # http://xxx/script.cgi/http://foo # # Old versions of this module used to accomodate with those scripts, so # this is why we do this here to keep those scripts backward compatible. # Basically, we accomodate with those scripts but within limits, that is # we only try to preserve the number of / that were provided by the user # if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number # of consecutive /. # # So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a # script_name of /x//y/script.cgi and a path_info of /a//b, but in: # http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions # possibly sanitised by the HTTP server, so in the case of Apache 2: # script_name == /foo/x/z/script.cgi and path_info == /b/c. # # Future versions of this module may no longer do that, so one should # avoid relying on the browser, proxy, server, and CGI.pm preserving the # number of consecutive slashes as no guarantee can be made there. sub _name_and_path_from_env { my $self = shift; my $script_name = $ENV{SCRIPT_NAME} || ''; my $path_info = $ENV{PATH_INFO} || ''; my $uri = $self->request_uri || ''; $uri =~ s/\?.*//s; $uri = unescape($uri); if ( $IIS ) { # IIS doesn't set $ENV{PATH_INFO} correctly. It sets it to # $ENV{SCRIPT_NAME}path_info # IIS also doesn't set $ENV{REQUEST_URI} so we don't want to do # the test below, hence this comes first $path_info =~ s/^\Q$script_name\E(.*)/$1/; } elsif ($uri ne "$script_name$path_info") { my $script_name_pattern = quotemeta($script_name); my $path_info_pattern = quotemeta($path_info); $script_name_pattern =~ s{(?:\\/)+}{/+}g; $path_info_pattern =~ s{(?:\\/)+}{/+}g; if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) { # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the # numer of consecutive slashes, so we can extract the info from # REQUEST_URI: ($script_name, $path_info) = ($1, $2); } } return ($script_name,$path_info); } #### Method: request_method # Returns 'POST', 'GET', 'PUT', 'PATCH' or 'HEAD' #### sub request_method { return (defined $ENV{'REQUEST_METHOD'}) ? $ENV{'REQUEST_METHOD'} : undef; } #### Method: content_type # Returns the content_type string #### sub content_type { return (defined $ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : undef; } #### Method: path_translated # Return the physical path information provided # by the URL (if any) #### sub path_translated { return (defined $ENV{'PATH_TRANSLATED'}) ? $ENV{'PATH_TRANSLATED'} : undef; } #### Method: request_uri # Return the literal request URI #### sub request_uri { return (defined $ENV{'REQUEST_URI'}) ? $ENV{'REQUEST_URI'} : undef; } #### Method: query_string # Synthesize a query string from our current # parameters #### sub query_string { my($self) = self_or_default(@_); my($param,$value,@pairs); for $param ($self->param) { my($eparam) = escape($param); for $value ($self->param($param)) { $value = escape($value); next unless defined $value; push(@pairs,"$eparam=$value"); } } for (sort keys %{$self->{'.fieldnames'}}) { push(@pairs,".cgifields=".escape("$_")); } return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); } sub env_query_string { return (defined $ENV{'QUERY_STRING'}) ? $ENV{'QUERY_STRING'} : undef; } #### Method: accept # Without parameters, returns an array of the # MIME types the browser accepts. # With a single parameter equal to a MIME # type, will return undef if the browser won't # accept it, 1 if the browser accepts it but # doesn't give a preference, or a floating point # value between 0.0 and 1.0 if the browser # declares a quantitative score for it. # This handles MIME type globs correctly. #### sub Accept { my($self,$search) = self_or_CGI(@_); my(%prefs,$type,$pref,$pat); my(@accept) = defined $self->http('accept') ? split(',',$self->http('accept')) : (); for (@accept) { ($pref) = /q=(\d\.\d+|\d+)/; ($type) = m#(\S+/[^;]+)#; next unless $type; $prefs{$type}=$pref || 1; } return keys %prefs unless $search; # if a search type is provided, we may need to # perform a pattern matching operation. # The MIME types use a glob mechanism, which # is easily translated into a perl pattern match # First return the preference for directly supported # types: return $prefs{$search} if $prefs{$search}; # Didn't get it, so try pattern matching. for (sort keys %prefs) { next unless /\*/; # not a pattern match ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters $pat =~ s/\*/.*/g; # turn it into a pattern return $prefs{$_} if $search=~/$pat/; } } #### Method: user_agent # If called with no parameters, returns the user agent. # If called with one parameter, does a pattern match (case # insensitive) on the user agent. #### sub user_agent { my($self,$match)=self_or_CGI(@_); my $user_agent = $self->http('user_agent'); return $user_agent unless defined $match && $match && $user_agent; return $user_agent =~ /$match/i; } #### Method: raw_cookie # Returns the magic cookies for the session. # The cookies are not parsed or altered in any way, i.e. # cookies are returned exactly as given in the HTTP # headers. If a cookie name is given, only that cookie's # value is returned, otherwise the entire raw cookie # is returned. #### sub raw_cookie { my($self,$key) = self_or_CGI(@_); require CGI::Cookie; if (defined($key)) { $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch unless $self->{'.raw_cookies'}; return () unless $self->{'.raw_cookies'}; return () unless $self->{'.raw_cookies'}->{$key}; return $self->{'.raw_cookies'}->{$key}; } return $self->http('cookie') || $ENV{'COOKIE'} || ''; } #### Method: virtual_host # Return the name of the virtual_host, which # is not always the same as the server ###### sub virtual_host { my $vh = http('x_forwarded_host') || http('host') || server_name(); $vh =~ s/:\d+$//; # get rid of port number return $vh; } #### Method: remote_host # Return the name of the remote host, or its IP # address if unavailable. If this variable isn't # defined, it returns "localhost" for debugging # purposes. #### sub remote_host { return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} || 'localhost'; } #### Method: remote_addr # Return the IP addr of the remote host. #### sub remote_addr { return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; } #### Method: script_name # Return the partial URL to this script for # self-referencing scripts. Also see # self_url(), which returns a URL with all state information # preserved. #### sub script_name { my ($self,@p) = self_or_default(@_); if (@p) { $self->{'.script_name'} = shift @p; } elsif (!exists $self->{'.script_name'}) { my ($script_name,$path_info) = $self->_name_and_path_from_env(); $self->{'.script_name'} = $script_name; } return $self->{'.script_name'}; } #### Method: referer # Return the HTTP_REFERER: useful for generating # a GO BACK button. #### sub referer { my($self) = self_or_CGI(@_); return $self->http('referer'); } #### Method: server_name # Return the name of the server #### sub server_name { return $ENV{'SERVER_NAME'} || 'localhost'; } #### Method: server_software # Return the name of the server software #### sub server_software { return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; } #### Method: virtual_port # Return the server port, taking virtual hosts into account #### sub virtual_port { my($self) = self_or_default(@_); my $vh = $self->http('x_forwarded_host') || $self->http('host'); my $protocol = $self->protocol; if ($vh) { return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80); } else { return $self->server_port(); } } #### Method: server_port # Return the tcp/ip port the server is running on #### sub server_port { return $ENV{'SERVER_PORT'} || 80; # for debugging } #### Method: server_protocol # Return the protocol (usually HTTP/1.0) #### sub server_protocol { return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging } #### Method: http # Return the value of an HTTP variable, or # the list of variables if none provided #### sub http { my ($self,$parameter) = self_or_CGI(@_); if ( defined($parameter) ) { $parameter =~ tr/-a-z/_A-Z/; if ( $parameter =~ /^HTTP(?:_|$)/ ) { return $ENV{$parameter}; } return $ENV{"HTTP_$parameter"}; } return grep { /^HTTP(?:_|$)/ } sort keys %ENV; } #### Method: https # Return the value of HTTPS, or # the value of an HTTPS variable, or # the list of variables #### sub https { my ($self,$parameter) = self_or_CGI(@_); if ( defined($parameter) ) { $parameter =~ tr/-a-z/_A-Z/; if ( $parameter =~ /^HTTPS(?:_|$)/ ) { return $ENV{$parameter}; } return $ENV{"HTTPS_$parameter"}; } return wantarray ? grep { /^HTTPS(?:_|$)/ } sort keys %ENV : $ENV{'HTTPS'}; } #### Method: protocol # Return the protocol (http or https currently) #### sub protocol { local($^W)=0; my $self = shift; return 'https' if uc($self->https()) eq 'ON'; return 'https' if $self->server_port == 443; my $prot = $self->server_protocol; my($protocol,$version) = split('/',$prot); return "\L$protocol\E"; } #### Method: remote_ident # Return the identity of the remote user # (but only if his host is running identd) #### sub remote_ident { return (defined $ENV{'REMOTE_IDENT'}) ? $ENV{'REMOTE_IDENT'} : undef; } #### Method: auth_type # Return the type of use verification/authorization in use, if any. #### sub auth_type { return (defined $ENV{'AUTH_TYPE'}) ? $ENV{'AUTH_TYPE'} : undef; } #### Method: remote_user # Return the authorization name used for user # verification. #### sub remote_user { return (defined $ENV{'REMOTE_USER'}) ? $ENV{'REMOTE_USER'} : undef; } #### Method: user_name # Try to return the remote user's name by hook or by # crook #### sub user_name { my ($self) = self_or_CGI(@_); return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; } #### Method: nosticky # Set or return the NOSTICKY global flag #### sub nosticky { my ($self,$param) = self_or_CGI(@_); $CGI::NOSTICKY = $param if defined($param); return $CGI::NOSTICKY; } #### Method: nph # Set or return the NPH global flag #### sub nph { my ($self,$param) = self_or_CGI(@_); $CGI::NPH = $param if defined($param); return $CGI::NPH; } #### Method: private_tempfiles # Set or return the private_tempfiles global flag #### sub private_tempfiles { warn "private_tempfiles has been deprecated"; return 0; } #### Method: close_upload_files # Set or return the close_upload_files global flag #### sub close_upload_files { my ($self,$param) = self_or_CGI(@_); $CGI::CLOSE_UPLOAD_FILES = $param if defined($param); return $CGI::CLOSE_UPLOAD_FILES; } #### Method: default_dtd # Set or return the default_dtd global #### sub default_dtd { my ($self,$param,$param2) = self_or_CGI(@_); if (defined $param2 && defined $param) { $CGI::DEFAULT_DTD = [ $param, $param2 ]; } elsif (defined $param) { $CGI::DEFAULT_DTD = $param; } return $CGI::DEFAULT_DTD; } # -------------- really private subroutines ----------------- sub _maybe_escapeHTML { # hack to work around earlier hacks push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); return undef unless defined($toencode); return $toencode if ref($self) && !$self->{'escape'}; return $self->escapeHTML($toencode, $newlinestoo); } sub previous_or_default { my($self,$name,$defaults,$override) = @_; my(%selected); if (!$override && ($self->{'.fieldnames'}->{$name} || defined($self->param($name)) ) ) { $selected{$_}++ for $self->param($name); } elsif (defined($defaults) && ref($defaults) && (ref($defaults) eq 'ARRAY')) { $selected{$_}++ for @{$defaults}; } else { $selected{$defaults}++ if defined($defaults); } return %selected; } sub register_parameter { my($self,$param) = @_; $self->{'.parametersToAdd'}->{$param}++; } sub get_fields { my($self) = @_; return $self->CGI::hidden('-name'=>'.cgifields', '-values'=>[sort keys %{$self->{'.parametersToAdd'}}], '-override'=>1); } sub read_from_cmdline { my($input,@words); my($query_string); my($subpath); if ($DEBUG && @ARGV) { @words = @ARGV; } elsif ($DEBUG > 1) { require Text::ParseWords; print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n"; chomp(@lines = <STDIN>); # remove newlines $input = join(" ",@lines); @words = &Text::ParseWords::old_shellwords($input); } for (@words) { s/\\=/%3D/g; s/\\&/%26/g; } if ("@words"=~/=/) { $query_string = join('&',@words); } else { $query_string = join('+',@words); } if ($query_string =~ /^(.*?)\?(.*)$/) { $query_string = $2; $subpath = $1; } return { 'query_string' => $query_string, 'subpath' => $subpath }; } ##### # subroutine: read_multipart # # Read multipart data and store it into our parameters. # An interesting feature is that if any of the parts is a file, we # create a temporary file and open up a filehandle on it so that the # caller can read from it if necessary. ##### sub read_multipart { my($self,$boundary,$length) = @_; my($buffer) = $self->new_MultipartBuffer($boundary,$length); return unless $buffer; my(%header,$body); my $filenumber = 0; while (!$buffer->eof) { %header = $buffer->readHeader; unless (%header) { $self->cgi_error("400 Bad request (malformed multipart POST)"); return; } $header{'Content-Disposition'} ||= ''; # quench uninit variable warning my $param = _mp_value_parse( $header{'Content-Disposition'},'name' ); $param .= $TAINTED; # See RFC 1867, 2183, 2045 # NB: File content will be loaded into memory should # content-disposition parsing fail. my ($filename) = $header{'Content-Disposition'} =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i; $filename ||= ''; # quench uninit variable warning $filename =~ s/^"([^"]*)"$/$1/; # Test for Opera's multiple upload feature my($multipart) = ( defined( $header{'Content-Type'} ) && $header{'Content-Type'} =~ /multipart\/mixed/ ) ? 1 : 0; # add this parameter to our list $self->add_parameter($param); # If no filename specified, then just read the data and assign it # to our parameter list. if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) { my($value) = $buffer->readBody; $value .= $TAINTED; push(@{$self->{param}{$param}},$value); next; } UPLOADS: { # If we get here, then we are dealing with a potentially large # uploaded form. Save the data to a temporary file, then open # the file for reading. # skip the file if uploads disabled if ($DISABLE_UPLOADS) { while (defined($data = $buffer->read)) { } last UPLOADS; } # set the filename to some recognizable value if ( ( !defined($filename) || $filename eq '' ) && $multipart ) { $filename = "multipart/mixed"; } my $tmp_dir = $CGI::OS eq 'WINDOWS' ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) : undef; # File::Temp defaults to TMPDIR require CGI::File::Temp; my $filehandle = CGI::File::Temp->new( UNLINK => $UNLINK_TMP_FILES, DIR => $tmp_dir, ); $filehandle->_mp_filename( $filename ); $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode && defined fileno($filehandle); # if this is an multipart/mixed attachment, save the header # together with the body for later parsing with an external # MIME parser module if ( $multipart ) { for ( sort keys %header ) { print $filehandle "$_: $header{$_}${CRLF}"; } print $filehandle "${CRLF}"; } my ($data); local($\) = ''; my $totalbytes = 0; while (defined($data = $buffer->read)) { if (defined $self->{'.upload_hook'}) { $totalbytes += length($data); &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'}); } print $filehandle $data if ($self->{'use_tempfile'}); } # back up to beginning of file seek($filehandle,0,0); ## Close the filehandle if requested this allows a multipart MIME ## upload to contain many files, and we won't die due to too many ## open file handles. The user can access the files using the hash ## below. close $filehandle if $CLOSE_UPLOAD_FILES; $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; # Save some information about the uploaded file where we can get # at it later. # Use the typeglob + filename as the key, as this is guaranteed to be # unique for each filehandle. Don't use the file descriptor as # this will be re-used for each filehandle if the # close_upload_files feature is used. $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { hndl => $filehandle, name => $filehandle->filename, info => {%header}, }; push(@{$self->{param}{$param}},$filehandle); } } } sub _mp_value_parse { my ( $string,$field ) = @_; my $is_quoted = $string =~/[\s;]$field="/ ? 1 : 0; my $param; if ( $is_quoted ) { # a quoted token cannot contain anything but an unescaped quote ($param) = $string =~/[\s;]$field="((?:\\"|[^"])*)"/; } else { # a plain token cannot contain any reserved characters # https://tools.ietf.org/html/rfc2616#section-2.2 # separators = "(" | ")" | "<" | ">" | "@" # | "," | ";" | ":" | "\" | <"> # | "/" | "[" | "]" | "?" | "=" # | "{" | "}" | SP | HT ($param) = $string =~/[\s;]$field=([^\(\)<>\@,;:\\"\/\[\]\?=\{\} \015\n\t]*)/; } return $param; } ##### # subroutine: read_multipart_related # # Read multipart/related data and store it into our parameters. The # first parameter sets the start of the data. The part identified by # this Content-ID will not be stored as a file upload, but will be # returned by this method. All other parts will be available as file # uploads accessible by their Content-ID ##### sub read_multipart_related { my($self,$start,$boundary,$length) = @_; my($buffer) = $self->new_MultipartBuffer($boundary,$length); return unless $buffer; my(%header,$body); my $filenumber = 0; my $returnvalue; while (!$buffer->eof) { %header = $buffer->readHeader; unless (%header) { $self->cgi_error("400 Bad request (malformed multipart POST)"); return; } my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/; $param .= $TAINTED; # If this is the start part, then just read the data and assign it # to our return variable. if ( $param eq $start ) { $returnvalue = $buffer->readBody; $returnvalue .= $TAINTED; next; } # add this parameter to our list $self->add_parameter($param); UPLOADS: { # If we get here, then we are dealing with a potentially large # uploaded form. Save the data to a temporary file, then open # the file for reading. # skip the file if uploads disabled if ($DISABLE_UPLOADS) { while (defined($data = $buffer->read)) { } last UPLOADS; } my $tmp_dir = $CGI::OS eq 'WINDOWS' ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) : undef; # File::Temp defaults to TMPDIR require CGI::File::Temp; my $filehandle = CGI::File::Temp->new( UNLINK => $UNLINK_TMP_FILES, DIR => $tmp_dir, ); $filehandle->_mp_filename( $filehandle->filename ); $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode && defined fileno($filehandle); my ($data); local($\) = ''; my $totalbytes; while (defined($data = $buffer->read)) { if (defined $self->{'.upload_hook'}) { $totalbytes += length($data); &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'}); } print $filehandle $data if ($self->{'use_tempfile'}); } # back up to beginning of file seek($filehandle,0,0); ## Close the filehandle if requested this allows a multipart MIME ## upload to contain many files, and we won't die due to too many ## open file handles. The user can access the files using the hash ## below. close $filehandle if $CLOSE_UPLOAD_FILES; $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; # Save some information about the uploaded file where we can get # at it later. # Use the typeglob + filename as the key, as this is guaranteed to be # unique for each filehandle. Don't use the file descriptor as # this will be re-used for each filehandle if the # close_upload_files feature is used. $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { hndl => $filehandle, name => $filehandle->filename, info => {%header}, }; push(@{$self->{param}{$param}},$filehandle); } } return $returnvalue; } sub upload { my($self,$param_name) = self_or_default(@_); my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name); return unless @param; return wantarray ? @param : $param[0]; } sub tmpFileName { my($self,$filename) = self_or_default(@_); # preferred calling convention: $filename came directly from param or upload if (ref $filename) { return $self->{'.tmpfiles'}->{$$filename . $filename}->{name} || ''; } # backwards compatible with older versions: $filename is merely equal to # one of our filenames when compared as strings foreach my $param_name ($self->param) { foreach my $filehandle ($self->multi_param($param_name)) { if ($filehandle eq $filename) { return $self->{'.tmpfiles'}->{$$filehandle . $filehandle}->{name} || ''; } } } return ''; } sub uploadInfo { my($self,$filename) = self_or_default(@_); return if ! defined $$filename; return $self->{'.tmpfiles'}->{$$filename . $filename}->{info}; } # internal routine, don't use sub _set_values_and_labels { my $self = shift; my ($v,$l,$n) = @_; $$l = $v if ref($v) eq 'HASH' && !ref($$l); return $self->param($n) if !defined($v); return $v if !ref($v); return ref($v) eq 'HASH' ? sort keys %$v : @$v; } # internal routine, don't use sub _set_attributes { my $self = shift; my($element, $attributes) = @_; return '' unless defined($attributes->{$element}); $attribs = ' '; for my $attrib (sort keys %{$attributes->{$element}}) { (my $clean_attrib = $attrib) =~ s/^-//; $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" "; } $attribs =~ s/ $//; return $attribs; } ######################################################### # Globals and stubs for other packages that we use. ######################################################### ######################## CGI::MultipartBuffer #################### package CGI::MultipartBuffer; $_DEBUG = 0; # how many bytes to read at a time. We use # a 4K buffer by default. $MultipartBuffer::INITIAL_FILLUNIT ||= 1024 * 4; $MultipartBuffer::TIMEOUT ||= 240*60; # 4 hour timeout for big files $MultipartBuffer::SPIN_LOOP_MAX ||= 2000; # bug fix for some Netscape servers $MultipartBuffer::CRLF ||= $CGI::CRLF; $INITIAL_FILLUNIT = $MultipartBuffer::INITIAL_FILLUNIT; $TIMEOUT = $MultipartBuffer::TIMEOUT; $SPIN_LOOP_MAX = $MultipartBuffer::SPIN_LOOP_MAX; $CRLF = $MultipartBuffer::CRLF; sub new { my($package,$interface,$boundary,$length) = @_; $FILLUNIT = $INITIAL_FILLUNIT; $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always # If the user types garbage into the file upload field, # then Netscape passes NOTHING to the server (not good). # We may hang on this read in that case. So we implement # a read timeout. If nothing is ready to read # by then, we return. # Netscape seems to be a little bit unreliable # about providing boundary strings. my $boundary_read = 0; if ($boundary) { # Under the MIME spec, the boundary consists of the # characters "--" PLUS the Boundary string # BUG: IE 3.01 on the Macintosh uses just the boundary -- not # the two extra hyphens. We do a special case here on the user-agent!!!! $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport'); } else { # otherwise we find it ourselves my($old); ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl $length -= length($boundary); chomp($boundary); # remove the CRLF $/ = $old; # restore old line separator $boundary_read++; } my $self = {LENGTH=>$length, CHUNKED=>!$length, BOUNDARY=>$boundary, INTERFACE=>$interface, BUFFER=>'', }; $FILLUNIT = length($boundary) if length($boundary) > $FILLUNIT; my $retval = bless $self,ref $package || $package; # Read the preamble and the topmost (boundary) line plus the CRLF. unless ($boundary_read) { while ($self->read(0)) { } } die "Malformed multipart POST: data truncated\n" if $self->eof; return $retval; } sub readHeader { my($self) = @_; my($end); my($ok) = 0; my($bad) = 0; local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; do { $self->fillBuffer($FILLUNIT); $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; $ok++ if $self->{BUFFER} eq ''; $bad++ if !$ok && $self->{LENGTH} <= 0; # this was a bad idea # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; } until $ok || $bad; return () if $bad; #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines! my($header) = substr($self->{BUFFER},0,$end+2); substr($self->{BUFFER},0,$end+4) = ''; my %return; if ($CGI::EBCDIC) { warn "untranslated header=$header\n" if $_DEBUG; $header = CGI::Util::ascii2ebcdic($header); warn "translated header=$header\n" if $_DEBUG; } # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 # (Folding Long Header Fields), 3.4.3 (Comments) # and 3.4.5 (Quoted-Strings). my $token = '[-\w!\#$%&\'*+.^_\`|{}~]'; $header=~s/$CRLF\s+/ /og; # merge continuation lines while ($header=~/($token+):\s+([^$CRLF]*)/mgox) { my ($field_name,$field_value) = ($1,$2); $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize $return{$field_name}=$field_value; } return %return; } # This reads and returns the body as a single scalar value. sub readBody { my($self) = @_; my($data); my($returnval)=''; #EBCDIC NOTE: want to translate returnval into EBCDIC HERE while (defined($data = $self->read)) { $returnval .= $data; } if ($CGI::EBCDIC) { warn "untranslated body=$returnval\n" if $_DEBUG; $returnval = CGI::Util::ascii2ebcdic($returnval); warn "translated body=$returnval\n" if $_DEBUG; } return $returnval; } # This will read $bytes or until the boundary is hit, whichever happens # first. After the boundary is hit, we return undef. The next read will # skip over the boundary and begin reading again; sub read { my($self,$bytes) = @_; # default number of bytes to read $bytes = $bytes || $FILLUNIT; # Fill up our internal buffer in such a way that the boundary # is never split between reads. $self->fillBuffer($bytes); my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY}; my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--'; # Find the boundary in the buffer (it may not be there). my $start = index($self->{BUFFER},$boundary_start); warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if $_DEBUG; # protect against malformed multipart POST operations die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0); #EBCDIC NOTE: want to translate boundary search into ASCII here. # If the boundary begins the data, then skip past it # and return undef. if ($start == 0) { # clear us out completely if we've hit the last boundary. if (index($self->{BUFFER},$boundary_end)==0) { $self->{BUFFER}=''; $self->{LENGTH}=0; return undef; } # just remove the boundary. substr($self->{BUFFER},0,length($boundary_start))=''; $self->{BUFFER} =~ s/^\012\015?//; return undef; } my $bytesToReturn; if ($start > 0) { # read up to the boundary $bytesToReturn = $start-2 > $bytes ? $bytes : $start; } else { # read the requested number of bytes # leave enough bytes in the buffer to allow us to read # the boundary. Thanks to Kevin Hendrick for finding # this one. $bytesToReturn = $bytes - (length($boundary_start)+1); } my $returnval=substr($self->{BUFFER},0,$bytesToReturn); substr($self->{BUFFER},0,$bytesToReturn)=''; # If we hit the boundary, remove the CRLF from the end. return ($bytesToReturn==$start) ? substr($returnval,0,-2) : $returnval; } # This fills up our internal buffer in such a way that the # boundary is never split between reads sub fillBuffer { my($self,$bytes) = @_; return unless $self->{CHUNKED} || $self->{LENGTH}; my($boundaryLength) = length($self->{BOUNDARY}); my($bufferLength) = length($self->{BUFFER}); my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead; # Try to read some data. We may hang here if the browser is screwed up. my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER}, $bytesToRead, $bufferLength); warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if $_DEBUG; $self->{BUFFER} = '' unless defined $self->{BUFFER}; # An apparent bug in the Apache server causes the read() # to return zero bytes repeatedly without blocking if the # remote user aborts during a file transfer. I don't know how # they manage this, but the workaround is to abort if we get # more than SPIN_LOOP_MAX consecutive zero reads. if ($bytesRead <= 0) { die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); } else { $self->{ZERO_LOOP_COUNTER}=0; } $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead; } # Return true when we've finished reading sub eof { my($self) = @_; return 1 if (length($self->{BUFFER}) == 0) && ($self->{LENGTH} <= 0); undef; } 1; package CGI; # We get a whole bunch of warnings about "possibly uninitialized variables" # when running with the -w switch. Touch them all once to get rid of the # warnings. This is ugly and I hate it. if ($^W) { $CGI::CGI = ''; $CGI::CGI=<<EOF; $CGI::VERSION; $CGI::MultipartBuffer::SPIN_LOOP_MAX; $CGI::MultipartBuffer::CRLF; $CGI::MultipartBuffer::TIMEOUT; $CGI::MultipartBuffer::INITIAL_FILLUNIT; EOF ; } 1; PK ! �*I�P� P� JSON.pmnu �[��� package JSON; use strict; use Carp (); use Exporter; BEGIN { @JSON::ISA = 'Exporter' } @JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json); BEGIN { $JSON::VERSION = '4.04'; $JSON::DEBUG = 0 unless (defined $JSON::DEBUG); $JSON::DEBUG = $ENV{ PERL_JSON_DEBUG } if exists $ENV{ PERL_JSON_DEBUG }; } my %RequiredVersion = ( 'JSON::PP' => '2.27203', 'JSON::XS' => '2.34', ); # XS and PP common methods my @PublicMethods = qw/ ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref allow_blessed convert_blessed filter_json_object filter_json_single_key_object shrink max_depth max_size encode decode decode_prefix allow_unknown /; my @Properties = qw/ ascii latin1 utf8 indent space_before space_after relaxed canonical allow_nonref allow_blessed convert_blessed shrink max_depth max_size allow_unknown /; my @XSOnlyMethods = qw//; # Currently nothing my @PublicMethodsSince4_0 = qw/allow_tags/; my @PropertiesSince4_0 = qw/allow_tags/; my @PPOnlyMethods = qw/ indent_length sort_by allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed /; # JSON::PP specific # used in _load_xs and _load_pp ($INSTALL_ONLY is not used currently) my $_INSTALL_DONT_DIE = 1; # When _load_xs fails to load XS, don't die. my $_ALLOW_UNSUPPORTED = 0; my $_UNIV_CONV_BLESSED = 0; # Check the environment variable to decide worker module. unless ($JSON::Backend) { $JSON::DEBUG and Carp::carp("Check used worker module..."); my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1; if ($backend eq '1') { $backend = 'JSON::XS,JSON::PP'; } elsif ($backend eq '0') { $backend = 'JSON::PP'; } elsif ($backend eq '2') { $backend = 'JSON::XS'; } $backend =~ s/\s+//g; my @backend_modules = split /,/, $backend; while(my $module = shift @backend_modules) { if ($module =~ /JSON::XS/) { _load_xs($module, @backend_modules ? $_INSTALL_DONT_DIE : 0); } elsif ($module =~ /JSON::PP/) { _load_pp($module); } elsif ($module =~ /JSON::backportPP/) { _load_pp($module); } else { Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid."; } last if $JSON::Backend; } } sub import { my $pkg = shift; my @what_to_export; my $no_export; for my $tag (@_) { if ($tag eq '-support_by_pp') { if (!$_ALLOW_UNSUPPORTED++) { JSON::Backend::XS ->support_by_pp(@PPOnlyMethods) if ($JSON::Backend->is_xs); } next; } elsif ($tag eq '-no_export') { $no_export++, next; } elsif ( $tag eq '-convert_blessed_universally' ) { my $org_encode = $JSON::Backend->can('encode'); eval q| require B; local $^W; no strict 'refs'; *{"${JSON::Backend}\::encode"} = sub { # only works with Perl 5.18+ local *UNIVERSAL::TO_JSON = sub { my $b_obj = B::svref_2object( $_[0] ); return $b_obj->isa('B::HV') ? { %{ $_[0] } } : $b_obj->isa('B::AV') ? [ @{ $_[0] } ] : undef ; }; $org_encode->(@_); }; | if ( !$_UNIV_CONV_BLESSED++ ); next; } push @what_to_export, $tag; } return if ($no_export); __PACKAGE__->export_to_level(1, $pkg, @what_to_export); } # OBSOLETED sub jsonToObj { my $alternative = 'from_json'; if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) { shift @_; $alternative = 'decode'; } Carp::carp "'jsonToObj' will be obsoleted. Please use '$alternative' instead."; return JSON::from_json(@_); }; sub objToJson { my $alternative = 'to_json'; if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) { shift @_; $alternative = 'encode'; } Carp::carp "'objToJson' will be obsoleted. Please use '$alternative' instead."; JSON::to_json(@_); }; # INTERFACES sub to_json ($@) { if ( ref($_[0]) eq 'JSON' or (@_ > 2 and $_[0] eq 'JSON') ) { Carp::croak "to_json should not be called as a method."; } my $json = JSON->new; if (@_ == 2 and ref $_[1] eq 'HASH') { my $opt = $_[1]; for my $method (keys %$opt) { $json->$method( $opt->{$method} ); } } $json->encode($_[0]); } sub from_json ($@) { if ( ref($_[0]) eq 'JSON' or $_[0] eq 'JSON' ) { Carp::croak "from_json should not be called as a method."; } my $json = JSON->new; if (@_ == 2 and ref $_[1] eq 'HASH') { my $opt = $_[1]; for my $method (keys %$opt) { $json->$method( $opt->{$method} ); } } return $json->decode( $_[0] ); } sub true { $JSON::true } sub false { $JSON::false } sub boolean { # might be called as method or as function, so pop() to get the last arg instead of shift() to get the first pop() ? $JSON::true : $JSON::false } sub null { undef; } sub require_xs_version { $RequiredVersion{'JSON::XS'}; } sub backend { my $proto = shift; $JSON::Backend; } #*module = *backend; sub is_xs { return $_[0]->backend->is_xs; } sub is_pp { return $_[0]->backend->is_pp; } sub pureperl_only_methods { @PPOnlyMethods; } sub property { my ($self, $name, $value) = @_; if (@_ == 1) { my %props; for $name (@Properties) { my $method = 'get_' . $name; if ($name eq 'max_size') { my $value = $self->$method(); $props{$name} = $value == 1 ? 0 : $value; next; } $props{$name} = $self->$method(); } return \%props; } elsif (@_ > 3) { Carp::croak('property() can take only the option within 2 arguments.'); } elsif (@_ == 2) { if ( my $method = $self->can('get_' . $name) ) { if ($name eq 'max_size') { my $value = $self->$method(); return $value == 1 ? 0 : $value; } $self->$method(); } } else { $self->$name($value); } } # INTERNAL sub __load_xs { my ($module, $opt) = @_; $JSON::DEBUG and Carp::carp "Load $module."; my $required_version = $RequiredVersion{$module} || ''; eval qq| use $module $required_version (); |; if ($@) { if (defined $opt and $opt & $_INSTALL_DONT_DIE) { $JSON::DEBUG and Carp::carp "Can't load $module...($@)"; return 0; } Carp::croak $@; } $JSON::BackendModuleXS = $module; return 1; } sub _load_xs { my ($module, $opt) = @_; __load_xs($module, $opt) or return; my $data = join("", <DATA>); # this code is from Jcode 2.xx. close(DATA); eval $data; JSON::Backend::XS->init($module); return 1; }; sub __load_pp { my ($module, $opt) = @_; $JSON::DEBUG and Carp::carp "Load $module."; my $required_version = $RequiredVersion{$module} || ''; eval qq| use $module $required_version () |; if ($@) { if ( $module eq 'JSON::PP' ) { $JSON::DEBUG and Carp::carp "Can't load $module ($@), so try to load JSON::backportPP"; $module = 'JSON::backportPP'; local $^W; # if PP installed but invalid version, backportPP redefines methods. eval qq| require $module |; } Carp::croak $@ if $@; } $JSON::BackendModulePP = $module; return 1; } sub _load_pp { my ($module, $opt) = @_; __load_pp($module, $opt); JSON::Backend::PP->init($module); }; # # Helper classes for Backend Module (PP) # package JSON::Backend::PP; sub init { my ($class, $module) = @_; # name may vary, but the module should (always) be a JSON::PP local $^W; no strict qw(refs); # this routine may be called after JSON::Backend::XS init was called. *{"JSON::decode_json"} = \&{"JSON::PP::decode_json"}; *{"JSON::encode_json"} = \&{"JSON::PP::encode_json"}; *{"JSON::is_bool"} = \&{"JSON::PP::is_bool"}; $JSON::true = ${"JSON::PP::true"}; $JSON::false = ${"JSON::PP::false"}; push @JSON::Backend::PP::ISA, 'JSON::PP'; push @JSON::ISA, $class; $JSON::Backend = $class; $JSON::BackendModule = $module; my $version = ${"$class\::VERSION"} = $module->VERSION; $version =~ s/_//; if ($version < 3.99) { push @XSOnlyMethods, qw/allow_tags get_allow_tags/; } else { push @Properties, 'allow_tags'; } for my $method (@XSOnlyMethods) { *{"JSON::$method"} = sub { Carp::carp("$method is not supported by $module $version."); $_[0]; }; } return 1; } sub is_xs { 0 }; sub is_pp { 1 }; # # To save memory, the below lines are read only when XS backend is used. # package JSON; 1; __DATA__ # # Helper classes for Backend Module (XS) # package JSON::Backend::XS; sub init { my ($class, $module) = @_; local $^W; no strict qw(refs); *{"JSON::decode_json"} = \&{"$module\::decode_json"}; *{"JSON::encode_json"} = \&{"$module\::encode_json"}; *{"JSON::is_bool"} = \&{"$module\::is_bool"}; $JSON::true = ${"$module\::true"}; $JSON::false = ${"$module\::false"}; push @JSON::Backend::XS::ISA, $module; push @JSON::ISA, $class; $JSON::Backend = $class; $JSON::BackendModule = $module; ${"$class\::VERSION"} = $module->VERSION; if ( $module->VERSION < 3 ) { eval 'package JSON::PP::Boolean'; push @{"$module\::Boolean::ISA"}, qw(JSON::PP::Boolean); } for my $method (@PPOnlyMethods) { *{"JSON::$method"} = sub { Carp::carp("$method is not supported by $module."); $_[0]; }; } return 1; } sub is_xs { 1 }; sub is_pp { 0 }; sub support_by_pp { my ($class, @methods) = @_; JSON::__load_pp('JSON::PP'); local $^W; no strict qw(refs); for my $method (@methods) { my $pp_method = JSON::PP->can($method) or next; *{"JSON::$method"} = sub { if (!$_[0]->isa('JSON::PP')) { my $xs_self = $_[0]; my $pp_self = JSON::PP->new; for (@Properties) { my $getter = "get_$_"; $pp_self->$_($xs_self->$getter); } $_[0] = $pp_self; } $pp_method->(@_); }; } $JSON::DEBUG and Carp::carp("set -support_by_pp mode."); } 1; __END__ =head1 NAME JSON - JSON (JavaScript Object Notation) encoder/decoder =head1 SYNOPSIS use JSON; # imports encode_json, decode_json, to_json and from_json. # simple and fast interfaces (expect/generate UTF-8) $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; # OO-interface $json = JSON->new->allow_nonref; $json_text = $json->encode( $perl_scalar ); $perl_scalar = $json->decode( $json_text ); $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing =head1 VERSION 4.02 =head1 DESCRIPTION This module is a thin wrapper for L<JSON::XS>-compatible modules with a few additional features. All the backend modules convert a Perl data structure to a JSON text and vice versa. This module uses L<JSON::XS> by default, and when JSON::XS is not available, falls back on L<JSON::PP>, which is in the Perl core since 5.14. If JSON::PP is not available either, this module then falls back on JSON::backportPP (which is actually JSON::PP in a different .pm file) bundled in the same distribution as this module. You can also explicitly specify to use L<Cpanel::JSON::XS>, a fork of JSON::XS by Reini Urban. All these backend modules have slight incompatibilities between them, including extra features that other modules don't support, but as long as you use only common features (most important ones are described below), migration from backend to backend should be reasonably easy. For details, see each backend module you use. =head1 CHOOSING BACKEND This module respects an environmental variable called C<PERL_JSON_BACKEND> when it decides a backend module to use. If this environmental variable is not set, it tries to load JSON::XS, and if JSON::XS is not available, it falls back on JSON::PP, and then JSON::backportPP if JSON::PP is not available either. If you always don't want it to fall back on pure perl modules, set the variable like this (C<export> may be C<setenv>, C<set> and the likes, depending on your environment): > export PERL_JSON_BACKEND=JSON::XS If you prefer Cpanel::JSON::XS to JSON::XS, then: > export PERL_JSON_BACKEND=Cpanel::JSON::XS,JSON::XS,JSON::PP You may also want to set this variable at the top of your test files, in order not to be bothered with incompatibilities between backends (you need to wrap this in C<BEGIN>, and set before actually C<use>-ing JSON module, as it decides its backend as soon as it's loaded): BEGIN { $ENV{PERL_JSON_BACKEND}='JSON::backportPP'; } use JSON; =head1 USING OPTIONAL FEATURES There are a few options you can set when you C<use> this module. These historical options are only kept for backward compatibility, and should not be used in a new application. =over =item -support_by_pp BEGIN { $ENV{PERL_JSON_BACKEND} = 'JSON::XS' } use JSON -support_by_pp; my $json = JSON->new; # escape_slash is for JSON::PP only. $json->allow_nonref->escape_slash->encode("/"); With this option, this module loads its pure perl backend along with its XS backend (if available), and lets the XS backend to watch if you set a flag only JSON::PP supports. When you do, the internal JSON::XS object is replaced with a newly created JSON::PP object with the setting copied from the XS object, so that you can use JSON::PP flags (and its slower C<decode>/C<encode> methods) from then on. In other words, this is not something that allows you to hook JSON::XS to change its behavior while keeping its speed. JSON::XS and JSON::PP objects are quite different (JSON::XS object is a blessed scalar reference, while JSON::PP object is a blessed hash reference), and can't share their internals. To avoid needless overhead (by copying settings), you are advised not to use this option and just to use JSON::PP explicitly when you need JSON::PP features. =item -convert_blessed_universally use JSON -convert_blessed_universally; my $json = JSON->new->allow_nonref->convert_blessed; my $object = bless {foo => 'bar'}, 'Foo'; $json->encode($object); # => {"foo":"bar"} JSON::XS-compatible backend modules don't encode blessed objects by default (except for their boolean values, which are typically blessed JSON::PP::Boolean objects). If you need to encode a data structure that may contain objects, you usually need to look into the structure and replace objects with alternative non-blessed values, or enable C<convert_blessed> and provide a C<TO_JSON> method for each object's (base) class that may be found in the structure, in order to let the methods replace the objects with whatever scalar values the methods return. If you need to serialise data structures that may contain arbitrary objects, it's probably better to use other serialisers (such as L<Sereal> or L<Storable> for example), but if you do want to use this module for that purpose, C<-convert_blessed_universally> option may help, which tweaks C<encode> method of the backend to install C<UNIVERSAL::TO_JSON> method (locally) before encoding, so that all the objects that don't have their own C<TO_JSON> method can fall back on the method in the C<UNIVERSAL> namespace. Note that you still need to enable C<convert_blessed> flag to actually encode objects in a data structure, and C<UNIVERSAL::TO_JSON> method installed by this option only converts blessed hash/array references into their unblessed clone (including private keys/values that are not supposed to be exposed). Other blessed references will be converted into null. This feature is experimental and may be removed in the future. =item -no_export When you don't want to import functional interfaces from a module, you usually supply C<()> to its C<use> statement. use JSON (); # no functional interfaces If you don't want to import functional interfaces, but you also want to use any of the above options, add C<-no_export> to the option list. # no functional interfaces, while JSON::PP support is enabled. use JSON -support_by_pp, -no_export; =back =head1 FUNCTIONAL INTERFACE This section is taken from JSON::XS. C<encode_json> and C<decode_json> are exported by default. This module also exports C<to_json> and C<from_json> for backward compatibility. These are slower, and may expect/generate different stuff from what C<encode_json> and C<decode_json> do, depending on their options. It's better just to use Object-Oriented interfaces than using these two functions. =head2 encode_json $json_text = encode_json $perl_scalar Converts the given Perl data structure to a UTF-8 encoded, binary string (that is, the string contains octets only). Croaks on error. This function call is functionally identical to: $json_text = JSON->new->utf8->encode($perl_scalar) Except being faster. =head2 decode_json $perl_scalar = decode_json $json_text The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries to parse that as an UTF-8 encoded JSON text, returning the resulting reference. Croaks on error. This function call is functionally identical to: $perl_scalar = JSON->new->utf8->decode($json_text) Except being faster. =head2 to_json $json_text = to_json($perl_scalar[, $optional_hashref]) Converts the given Perl data structure to a Unicode string by default. Croaks on error. Basically, this function call is functionally identical to: $json_text = JSON->new->encode($perl_scalar) Except being slower. You can pass an optional hash reference to modify its behavior, but that may change what C<to_json> expects/generates (see C<ENCODING/CODESET FLAG NOTES> for details). $json_text = to_json($perl_scalar, {utf8 => 1, pretty => 1}) # => JSON->new->utf8(1)->pretty(1)->encode($perl_scalar) =head2 from_json $perl_scalar = from_json($json_text[, $optional_hashref]) The opposite of C<to_json>: expects a Unicode string and tries to parse it, returning the resulting reference. Croaks on error. Basically, this function call is functionally identical to: $perl_scalar = JSON->new->decode($json_text) You can pass an optional hash reference to modify its behavior, but that may change what C<from_json> expects/generates (see C<ENCODING/CODESET FLAG NOTES> for details). $perl_scalar = from_json($json_text, {utf8 => 1}) # => JSON->new->utf8(1)->decode($json_text) =head2 JSON::is_bool $is_boolean = JSON::is_bool($scalar) Returns true if the passed scalar represents either JSON::true or JSON::false, two constants that act like C<1> and C<0> respectively and are also used to represent JSON C<true> and C<false> in Perl strings. See L<MAPPING>, below, for more information on how JSON values are mapped to Perl. =head1 COMMON OBJECT-ORIENTED INTERFACE This section is also taken from JSON::XS. The object oriented interface lets you configure your own encoding or decoding style, within the limits of supported formats. =head2 new $json = JSON->new Creates a new JSON::XS-compatible backend object that can be used to de/encode JSON strings. All boolean flags described below are by default I<disabled> (with the exception of C<allow_nonref>, which defaults to I<enabled> since version C<4.0>). The mutators for flags all return the backend object again and thus calls can be chained: my $json = JSON->new->utf8->space_after->encode({a => [1,2]}) => {"a": [1, 2]} =head2 ascii $json = $json->ascii([$enable]) $enabled = $json->get_ascii If C<$enable> is true (or missing), then the C<encode> method will not generate characters outside the code range C<0..127> (which is ASCII). Any Unicode characters outside that range will be escaped using either a single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. The resulting encoded JSON text can be treated as a native Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string, or any other superset of ASCII. If C<$enable> is false, then the C<encode> method will not escape Unicode characters unless required by the JSON syntax or other flags. This results in a faster and more compact format. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. The main use for this flag is to produce JSON texts that can be transmitted over a 7-bit channel, as the encoded JSON texts will not contain any 8 bit characters. JSON->new->ascii(1)->encode([chr 0x10401]) => ["\ud801\udc01"] =head2 latin1 $json = $json->latin1([$enable]) $enabled = $json->get_latin1 If C<$enable> is true (or missing), then the C<encode> method will encode the resulting JSON text as latin1 (or iso-8859-1), escaping any characters outside the code range C<0..255>. The resulting string can be treated as a latin1-encoded JSON text or a native Unicode string. The C<decode> method will not be affected in any way by this flag, as C<decode> by default expects Unicode, which is a strict superset of latin1. If C<$enable> is false, then the C<encode> method will not escape Unicode characters unless required by the JSON syntax or other flags. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. The main use for this flag is efficiently encoding binary data as JSON text, as most octets will not be escaped, resulting in a smaller encoded size. The disadvantage is that the resulting JSON text is encoded in latin1 (and must correctly be treated as such when storing and transferring), a rare encoding for JSON. It is therefore most useful when you want to store data structures known to contain binary data efficiently in files or databases, not when talking to other JSON encoders/decoders. JSON->new->latin1->encode (["\x{89}\x{abc}"] => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) =head2 utf8 $json = $json->utf8([$enable]) $enabled = $json->get_utf8 If C<$enable> is true (or missing), then the C<encode> method will encode the JSON result into UTF-8, as required by many protocols, while the C<decode> method expects to be handled an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any characters outside the range C<0..255>, they are thus useful for bytewise/binary I/O. In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 encoding families, as described in RFC4627. If C<$enable> is false, then the C<encode> method will return the JSON string as a (non-encoded) Unicode string, while C<decode> expects thus a Unicode string. Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. Example, output UTF-16BE-encoded JSON: use Encode; $jsontext = encode "UTF-16BE", JSON->new->encode ($object); Example, decode UTF-32LE-encoded JSON: use Encode; $object = JSON->new->decode (decode "UTF-32LE", $jsontext); =head2 pretty $json = $json->pretty([$enable]) This enables (or disables) all of the C<indent>, C<space_before> and C<space_after> (and in the future possibly more) flags in one call to generate the most readable (or most compact) form possible. =head2 indent $json = $json->indent([$enable]) $enabled = $json->get_indent If C<$enable> is true (or missing), then the C<encode> method will use a multiline format as output, putting every array member or object/hash key-value pair into its own line, indenting them properly. If C<$enable> is false, no newlines or indenting will be produced, and the resulting JSON text is guaranteed not to contain any C<newlines>. This setting has no effect when decoding JSON texts. =head2 space_before $json = $json->space_before([$enable]) $enabled = $json->get_space_before If C<$enable> is true (or missing), then the C<encode> method will add an extra optional space before the C<:> separating keys from values in JSON objects. If C<$enable> is false, then the C<encode> method will not add any extra space at those places. This setting has no effect when decoding JSON texts. You will also most likely combine this setting with C<space_after>. Example, space_before enabled, space_after and indent disabled: {"key" :"value"} =head2 space_after $json = $json->space_after([$enable]) $enabled = $json->get_space_after If C<$enable> is true (or missing), then the C<encode> method will add an extra optional space after the C<:> separating keys from values in JSON objects and extra whitespace after the C<,> separating key-value pairs and array members. If C<$enable> is false, then the C<encode> method will not add any extra space at those places. This setting has no effect when decoding JSON texts. Example, space_before and indent disabled, space_after enabled: {"key": "value"} =head2 relaxed $json = $json->relaxed([$enable]) $enabled = $json->get_relaxed If C<$enable> is true (or missing), then C<decode> will accept some extensions to normal JSON syntax (see below). C<encode> will not be affected in any way. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. Currently accepted extensions are: =over 4 =item * list items can have an end-comma JSON I<separates> array elements and key-value pairs with commas. This can be annoying if you write JSON texts manually and want to be able to quickly append elements, so this extension accepts comma at the end of such items not just between them: [ 1, 2, <- this comma not normally allowed ] { "k1": "v1", "k2": "v2", <- this comma not normally allowed } =item * shell-style '#'-comments Whenever JSON allows whitespace, shell-style comments are additionally allowed. They are terminated by the first carriage-return or line-feed character, after which more white-space and comments are allowed. [ 1, # this comment not allowed in JSON # neither this one... ] =back =head2 canonical $json = $json->canonical([$enable]) $enabled = $json->get_canonical If C<$enable> is true (or missing), then the C<encode> method will output JSON objects by sorting their keys. This is adding a comparatively high overhead. If C<$enable> is false, then the C<encode> method will output key-value pairs in the order Perl stores them (which will likely change between runs of the same script, and can change even within the same run from 5.18 onwards). This option is useful if you want the same data structure to be encoded as the same JSON text (given the same overall settings). If it is disabled, the same hash might be encoded differently even if contains the same data, as key-value pairs have no inherent ordering in Perl. This setting has no effect when decoding JSON texts. This setting has currently no effect on tied hashes. =head2 allow_nonref $json = $json->allow_nonref([$enable]) $enabled = $json->get_allow_nonref Unlike other boolean options, this option is enabled by default beginning with version C<4.0>. If C<$enable> is true (or missing), then the C<encode> method can convert a non-reference into its corresponding string, number or null JSON value, which is an extension to RFC4627. Likewise, C<decode> will accept those JSON values instead of croaking. If C<$enable> is false, then the C<encode> method will croak if it isn't passed an arrayref or hashref, as JSON texts must either be an object or array. Likewise, C<decode> will croak if given something that is not a JSON object or array. Example, encode a Perl scalar as JSON value with enabled C<allow_nonref>, resulting in an invalid JSON text: JSON->new->allow_nonref->encode ("Hello, World!") => "Hello, World!" =head2 allow_unknown $json = $json->allow_unknown ([$enable]) $enabled = $json->get_allow_unknown If C<$enable> is true (or missing), then C<encode> will I<not> throw an exception when it encounters values it cannot represent in JSON (for example, filehandles) but instead will encode a JSON C<null> value. Note that blessed objects are not included here and are handled separately by c<allow_blessed>. If C<$enable> is false (the default), then C<encode> will throw an exception when it encounters anything it cannot encode as JSON. This option does not affect C<decode> in any way, and it is recommended to leave it off unless you know your communications partner. =head2 allow_blessed $json = $json->allow_blessed([$enable]) $enabled = $json->get_allow_blessed See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then the C<encode> method will not barf when it encounters a blessed reference that it cannot convert otherwise. Instead, a JSON C<null> value is encoded instead of the object. If C<$enable> is false (the default), then C<encode> will throw an exception when it encounters a blessed object that it cannot convert otherwise. This setting has no effect on C<decode>. =head2 convert_blessed $json = $json->convert_blessed([$enable]) $enabled = $json->get_convert_blessed See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then C<encode>, upon encountering a blessed object, will check for the availability of the C<TO_JSON> method on the object's class. If found, it will be called in scalar context and the resulting scalar will be encoded instead of the object. The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON> returns other blessed objects, those will be handled in the same way. C<TO_JSON> must take care of not causing an endless recursion cycle (== crash) in this case. The name of C<TO_JSON> was chosen because other methods called by the Perl core (== not by the user of the object) are usually in upper case letters and to avoid collisions with any C<to_json> function or method. If C<$enable> is false (the default), then C<encode> will not consider this type of conversion. This setting has no effect on C<decode>. =head2 allow_tags (since version 3.0) $json = $json->allow_tags([$enable]) $enabled = $json->get_allow_tags See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then C<encode>, upon encountering a blessed object, will check for the availability of the C<FREEZE> method on the object's class. If found, it will be used to serialise the object into a nonstandard tagged JSON value (that JSON decoders cannot decode). It also causes C<decode> to parse such tagged JSON values and deserialise them via a call to the C<THAW> method. If C<$enable> is false (the default), then C<encode> will not consider this type of conversion, and tagged JSON values will cause a parse error in C<decode>, as if tags were not part of the grammar. =head2 boolean_values (since version 4.0) $json->boolean_values([$false, $true]) ($false, $true) = $json->get_boolean_values By default, JSON booleans will be decoded as overloaded C<$JSON::false> and C<$JSON::true> objects. With this method you can specify your own boolean values for decoding - on decode, JSON C<false> will be decoded as a copy of C<$false>, and JSON C<true> will be decoded as C<$true> ("copy" here is the same thing as assigning a value to another variable, i.e. C<$copy = $false>). This is useful when you want to pass a decoded data structure directly to other serialisers like YAML, Data::MessagePack and so on. Note that this works only when you C<decode>. You can set incompatible boolean objects (like L<boolean>), but when you C<encode> a data structure with such boolean objects, you still need to enable C<convert_blessed> (and add a C<TO_JSON> method if necessary). Calling this method without any arguments will reset the booleans to their default values. C<get_boolean_values> will return both C<$false> and C<$true> values, or the empty list when they are set to the default. =head2 filter_json_object $json = $json->filter_json_object([$coderef]) When C<$coderef> is specified, it will be called from C<decode> each time it decodes a JSON object. The only argument is a reference to the newly-created hash. If the code references returns a single scalar (which need not be a reference), this value (or rather a copy of it) is inserted into the deserialised data structure. If it returns an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised hash will be inserted. This setting can slow down decoding considerably. When C<$coderef> is omitted or undefined, any existing callback will be removed and C<decode> will not change the deserialised hash in any way. Example, convert all JSON objects into the integer 5: my $js = JSON->new->filter_json_object(sub { 5 }); # returns [5] $js->decode('[{}]'); # returns 5 $js->decode('{"a":1, "b":2}'); =head2 filter_json_single_key_object $json = $json->filter_json_single_key_object($key [=> $coderef]) Works remotely similar to C<filter_json_object>, but is only called for JSON objects having a single key named C<$key>. This C<$coderef> is called before the one specified via C<filter_json_object>, if any. It gets passed the single value in the JSON object. If it returns a single value, it will be inserted into the data structure. If it returns nothing (not even C<undef> but the empty list), the callback from C<filter_json_object> will be called next, as if no single-key callback were specified. If C<$coderef> is omitted or undefined, the corresponding callback will be disabled. There can only ever be one callback for a given key. As this callback gets called less often then the C<filter_json_object> one, decoding speed will not usually suffer as much. Therefore, single-key objects make excellent targets to serialise Perl objects into, especially as single-key JSON objects are as close to the type-tagged value concept as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not support this in any way, so you need to make sure your data never looks like a serialised Perl hash. Typical names for the single object key are C<__class_whatever__>, or C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even things like C<__class_md5sum(classname)__>, to reduce the risk of clashing with real hashes. Example, decode JSON objects of the form C<< { "__widget__" => <id> } >> into the corresponding C<< $WIDGET{<id>} >> object: # return whatever is in $WIDGET{5}: JSON ->new ->filter_json_single_key_object (__widget__ => sub { $WIDGET{ $_[0] } }) ->decode ('{"__widget__": 5') # this can be used with a TO_JSON method in some "widget" class # for serialisation to json: sub WidgetBase::TO_JSON { my ($self) = @_; unless ($self->{id}) { $self->{id} = ..get..some..id..; $WIDGET{$self->{id}} = $self; } { __widget__ => $self->{id} } } =head2 max_depth $json = $json->max_depth([$maximum_nesting_depth]) $max_depth = $json->get_max_depth Sets the maximum nesting level (default C<512>) accepted while encoding or decoding. If a higher nesting level is detected in JSON text or a Perl data structure, then the encoder and decoder will stop and croak at that point. Nesting level is defined by number of hash- or arrayrefs that the encoder needs to traverse to reach a given point or the number of C<{> or C<[> characters without their matching closing parenthesis crossed to reach a given character in a string. Setting the maximum depth to one disallows any nesting, so that ensures that the object is only a single hash/object or array. If no argument is given, the highest possible setting will be used, which is rarely useful. See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful. =head2 max_size $json = $json->max_size([$maximum_string_size]) $max_size = $json->get_max_size Set the maximum length a JSON text may have (in bytes) where decoding is being attempted. The default is C<0>, meaning no limit. When C<decode> is called on a string that is longer then this many bytes, it will not attempt to decode the string but throw an exception. This setting has no effect on C<encode> (yet). If no argument is given, the limit check will be deactivated (same as when C<0> is specified). See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful. =head2 encode $json_text = $json->encode($perl_scalar) Converts the given Perl value or data structure to its JSON representation. Croaks on error. =head2 decode $perl_scalar = $json->decode($json_text) The opposite of C<encode>: expects a JSON text and tries to parse it, returning the resulting simple scalar or reference. Croaks on error. =head2 decode_prefix ($perl_scalar, $characters) = $json->decode_prefix($json_text) This works like the C<decode> method, but instead of raising an exception when there is trailing garbage after the first JSON object, it will silently stop parsing there and return the number of characters consumed so far. This is useful if your JSON texts are not delimited by an outer protocol and you need to know where the JSON text ends. JSON->new->decode_prefix ("[1] the tail") => ([1], 3) =head1 ADDITIONAL METHODS The following methods are for this module only. =head2 backend $backend = $json->backend Since 2.92, C<backend> method returns an abstract backend module used currently, which should be JSON::Backend::XS (which inherits JSON::XS or Cpanel::JSON::XS), or JSON::Backend::PP (which inherits JSON::PP), not to monkey-patch the actual backend module globally. If you need to know what is used actually, use C<isa>, instead of string comparison. =head2 is_xs $boolean = $json->is_xs Returns true if the backend inherits JSON::XS or Cpanel::JSON::XS. =head2 is_pp $boolean = $json->is_pp Returns true if the backend inherits JSON::PP. =head2 property $settings = $json->property() Returns a reference to a hash that holds all the common flag settings. $json = $json->property('utf8' => 1) $value = $json->property('utf8') # 1 You can use this to get/set a value of a particular flag. =head2 boolean $boolean_object = JSON->boolean($scalar) Returns $JSON::true if $scalar contains a true value, $JSON::false otherwise. You can use this as a full-qualified function (C<JSON::boolean($scalar)>). =head1 INCREMENTAL PARSING This section is also taken from JSON::XS. In some cases, there is the need for incremental parsing of JSON texts. While this module always has to keep both JSON text and resulting Perl data structure in memory at one time, it does allow you to parse a JSON stream incrementally. It does so by accumulating text until it has a full JSON object, which it then can decode. This process is similar to using C<decode_prefix> to see if a full JSON object is available, but is much more efficient (and can be implemented with a minimum of method calls). This module will only attempt to parse the JSON text once it is sure it has enough text to get a decisive result, using a very simple but truly incremental parser. This means that it sometimes won't stop as early as the full parser, for example, it doesn't detect mismatched parentheses. The only thing it guarantees is that it starts decoding as soon as a syntactically valid JSON text has been seen. This means you need to set resource limits (e.g. C<max_size>) to ensure the parser will stop parsing in the presence if syntax errors. The following methods implement this incremental parser. =head2 incr_parse $json->incr_parse( [$string] ) # void context $obj_or_undef = $json->incr_parse( [$string] ) # scalar context @obj_or_empty = $json->incr_parse( [$string] ) # list context This is the central parsing function. It can both append new text and extract objects from the stream accumulated so far (both of these functions are optional). If C<$string> is given, then this string is appended to the already existing JSON fragment stored in the C<$json> object. After that, if the function is called in void context, it will simply return without doing anything further. This can be used to add more text in as many chunks as you want. If the method is called in scalar context, then it will try to extract exactly I<one> JSON object. If that is successful, it will return this object, otherwise it will return C<undef>. If there is a parse error, this method will croak just as C<decode> would do (one can then use C<incr_skip> to skip the erroneous part). This is the most common way of using the method. And finally, in list context, it will try to extract as many objects from the stream as it can find and return them, or the empty list otherwise. For this to work, there must be no separators (other than whitespace) between the JSON objects or arrays, instead they must be concatenated back-to-back. If an error occurs, an exception will be raised as in the scalar context case. Note that in this case, any previously-parsed JSON texts will be lost. Example: Parse some JSON arrays/objects in a given string and return them. my @objs = JSON->new->incr_parse ("[5][7][1,2]"); =head2 incr_text $lvalue_string = $json->incr_text This method returns the currently stored JSON fragment as an lvalue, that is, you can manipulate it. This I<only> works when a preceding call to C<incr_parse> in I<scalar context> successfully returned an object. Under all other circumstances you must not call this function (I mean it. although in simple tests it might actually work, it I<will> fail under real world conditions). As a special exception, you can also call this method before having parsed anything. That means you can only use this function to look at or manipulate text before or after complete JSON objects, not while the parser is in the middle of parsing a JSON object. This function is useful in two cases: a) finding the trailing text after a JSON object or b) parsing multiple JSON objects separated by non-JSON text (such as commas). =head2 incr_skip $json->incr_skip This will reset the state of the incremental parser and will remove the parsed text from the input buffer so far. This is useful after C<incr_parse> died, in which case the input buffer and incremental parser state is left unchanged, to skip the text parsed so far and to reset the parse state. The difference to C<incr_reset> is that only text until the parse error occurred is removed. =head2 incr_reset $json->incr_reset This completely resets the incremental parser, that is, after this call, it will be as if the parser had never parsed anything. This is useful if you want to repeatedly parse JSON objects and want to ignore any trailing data, which means you have to reset the parser after each successful decode. =head1 MAPPING Most of this section is also taken from JSON::XS. This section describes how the backend modules map Perl values to JSON values and vice versa. These mappings are designed to "do the right thing" in most circumstances automatically, preserving round-tripping characteristics (what you put in comes out as something equivalent). For the more enlightened: note that in the following descriptions, lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl> refers to the abstract Perl language itself. =head2 JSON -> PERL =over 4 =item object A JSON object becomes a reference to a hash in Perl. No ordering of object keys is preserved (JSON does not preserver object key ordering itself). =item array A JSON array becomes a reference to an array in Perl. =item string A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON are represented by the same codepoints in the Perl string, so no manual decoding is necessary. =item number A JSON number becomes either an integer, numeric (floating point) or string scalar in perl, depending on its range and any fractional parts. On the Perl level, there is no difference between those as Perl handles all the conversion details, but an integer may take slightly less memory and might represent more values exactly than floating point numbers. If the number consists of digits only, this module will try to represent it as an integer value. If that fails, it will try to represent it as a numeric (floating point) value if that is possible without loss of precision. Otherwise it will preserve the number as a string value (in which case you lose roundtripping ability, as the JSON number will be re-encoded to a JSON string). Numbers containing a fractional or exponential part will always be represented as numeric (floating point) values, possibly at a loss of precision (in which case you might lose perfect roundtripping ability, but the JSON number will still be re-encoded as a JSON number). Note that precision is not accuracy - binary floating point values cannot represent most decimal fractions exactly, and when converting from and to floating point, this module only guarantees precision up to but not including the least significant bit. =item true, false These JSON atoms become C<JSON::true> and C<JSON::false>, respectively. They are overloaded to act almost exactly like the numbers C<1> and C<0>. You can check whether a scalar is a JSON boolean by using the C<JSON::is_bool> function. =item null A JSON null atom becomes C<undef> in Perl. =item shell-style comments (C<< # I<text> >>) As a nonstandard extension to the JSON syntax that is enabled by the C<relaxed> setting, shell-style comments are allowed. They can start anywhere outside strings and go till the end of the line. =item tagged values (C<< (I<tag>)I<value> >>). Another nonstandard extension to the JSON syntax, enabled with the C<allow_tags> setting, are tagged values. In this implementation, the I<tag> must be a perl package/class name encoded as a JSON string, and the I<value> must be a JSON array encoding optional constructor arguments. See L<OBJECT SERIALISATION>, below, for details. =back =head2 PERL -> JSON The mapping from Perl to JSON is slightly more difficult, as Perl is a truly typeless language, so we can only guess which JSON type is meant by a Perl value. =over 4 =item hash references Perl hash references become JSON objects. As there is no inherent ordering in hash keys (or JSON objects), they will usually be encoded in a pseudo-random order. This module can optionally sort the hash keys (determined by the I<canonical> flag), so the same data structure will serialise to the same JSON text (given same settings and version of the same backend), but this incurs a runtime overhead and is only rarely useful, e.g. when you want to compare some JSON text against another for equality. =item array references Perl array references become JSON arrays. =item other references Other unblessed references are generally not allowed and will cause an exception to be thrown, except for references to the integers C<0> and C<1>, which get turned into C<false> and C<true> atoms in JSON. You can also use C<JSON::false> and C<JSON::true> to improve readability. encode_json [\0,JSON::true] # yields [false,true] =item JSON::true, JSON::false, JSON::null These special values become JSON true and JSON false values, respectively. You can also use C<\1> and C<\0> directly if you want. =item blessed objects Blessed objects are not directly representable in JSON, but C<JSON::XS> allows various ways of handling objects. See L<OBJECT SERIALISATION>, below, for details. =item simple scalars Simple Perl scalars (any scalar that is not a reference) are the most difficult objects to encode: this module will encode undefined scalars as JSON C<null> values, scalars that have last been used in a string context before encoding as JSON strings, and anything else as number value: # dump as number encode_json [2] # yields [2] encode_json [-3.0e17] # yields [-3e+17] my $value = 5; encode_json [$value] # yields [5] # used as string, so dump as string print $value; encode_json [$value] # yields ["5"] # undef becomes null encode_json [undef] # yields [null] You can force the type to be a string by stringifying it: my $x = 3.1; # some variable containing a number "$x"; # stringified $x .= ""; # another, more awkward way to stringify print $x; # perl does it for you, too, quite often You can force the type to be a number by numifying it: my $x = "3"; # some variable containing a string $x += 0; # numify it, ensuring it will be dumped as a number $x *= 1; # same thing, the choice is yours. You can not currently force the type in other, less obscure, ways. Tell me if you need this capability (but don't forget to explain why it's needed :). Since version 2.91_01, JSON::PP uses a different number detection logic that converts a scalar that is possible to turn into a number safely. The new logic is slightly faster, and tends to help people who use older perl or who want to encode complicated data structure. However, this may results in a different JSON text from the one JSON::XS encodes (and thus may break tests that compare entire JSON texts). If you do need the previous behavior for better compatibility or for finer control, set PERL_JSON_PP_USE_B environmental variable to true before you C<use> JSON. Note that numerical precision has the same meaning as under Perl (so binary to decimal conversion follows the same rules as in Perl, which can differ to other languages). Also, your perl interpreter might expose extensions to the floating point numbers of your platform, such as infinities or NaN's - these cannot be represented in JSON, and it is an error to pass those in. JSON.pm backend modules trust what you pass to C<encode> method (or C<encode_json> function) is a clean, validated data structure with values that can be represented as valid JSON values only, because it's not from an external data source (as opposed to JSON texts you pass to C<decode> or C<decode_json>, which JSON backends consider tainted and don't trust). As JSON backends don't know exactly what you and consumers of your JSON texts want the unexpected values to be (you may want to convert them into null, or to stringify them with or without normalisation (string representation of infinities/NaN may vary depending on platforms), or to croak without conversion), you're advised to do what you and your consumers need before you encode, and also not to numify values that may start with values that look like a number (including infinities/NaN), without validating. =back =head2 OBJECT SERIALISATION As JSON cannot directly represent Perl objects, you have to choose between a pure JSON representation (without the ability to deserialise the object automatically again), and a nonstandard extension to the JSON syntax, tagged values. =head3 SERIALISATION What happens when this module encounters a Perl object depends on the C<allow_blessed>, C<convert_blessed> and C<allow_tags> settings, which are used in this order: =over 4 =item 1. C<allow_tags> is enabled and the object has a C<FREEZE> method. In this case, C<JSON> creates a tagged JSON value, using a nonstandard extension to the JSON syntax. This works by invoking the C<FREEZE> method on the object, with the first argument being the object to serialise, and the second argument being the constant string C<JSON> to distinguish it from other serialisers. The C<FREEZE> method can return any number of values (i.e. zero or more). These values and the package/classname of the object will then be encoded as a tagged JSON value in the following format: ("classname")[FREEZE return values...] e.g.: ("URI")["http://www.google.com/"] ("MyDate")[2013,10,29] ("ImageData::JPEG")["Z3...VlCg=="] For example, the hypothetical C<My::Object> C<FREEZE> method might use the objects C<type> and C<id> members to encode the object: sub My::Object::FREEZE { my ($self, $serialiser) = @_; ($self->{type}, $self->{id}) } =item 2. C<convert_blessed> is enabled and the object has a C<TO_JSON> method. In this case, the C<TO_JSON> method of the object is invoked in scalar context. It must return a single scalar that can be directly encoded into JSON. This scalar replaces the object in the JSON text. For example, the following C<TO_JSON> method will convert all L<URI> objects to JSON strings when serialised. The fact that these values originally were L<URI> objects is lost. sub URI::TO_JSON { my ($uri) = @_; $uri->as_string } =item 3. C<allow_blessed> is enabled. The object will be serialised as a JSON null value. =item 4. none of the above If none of the settings are enabled or the respective methods are missing, this module throws an exception. =back =head3 DESERIALISATION For deserialisation there are only two cases to consider: either nonstandard tagging was used, in which case C<allow_tags> decides, or objects cannot be automatically be deserialised, in which case you can use postprocessing or the C<filter_json_object> or C<filter_json_single_key_object> callbacks to get some real objects our of your JSON. This section only considers the tagged value case: a tagged JSON object is encountered during decoding and C<allow_tags> is disabled, a parse error will result (as if tagged values were not part of the grammar). If C<allow_tags> is enabled, this module will look up the C<THAW> method of the package/classname used during serialisation (it will not attempt to load the package as a Perl module). If there is no such method, the decoding will fail with an error. Otherwise, the C<THAW> method is invoked with the classname as first argument, the constant string C<JSON> as second argument, and all the values from the JSON array (the values originally returned by the C<FREEZE> method) as remaining arguments. The method must then return the object. While technically you can return any Perl scalar, you might have to enable the C<allow_nonref> setting to make that work in all cases, so better return an actual blessed reference. As an example, let's implement a C<THAW> function that regenerates the C<My::Object> from the C<FREEZE> example earlier: sub My::Object::THAW { my ($class, $serialiser, $type, $id) = @_; $class->new (type => $type, id => $id) } =head1 ENCODING/CODESET FLAG NOTES This section is taken from JSON::XS. The interested reader might have seen a number of flags that signify encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be some confusion on what these do, so here is a short comparison: C<utf8> controls whether the JSON text created by C<encode> (and expected by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only control whether C<encode> escapes character values outside their respective codeset range. Neither of these flags conflict with each other, although some combinations make less sense than others. Care has been taken to make all flags symmetrical with respect to C<encode> and C<decode>, that is, texts encoded with any combination of these flag values will be correctly decoded when the same flags are used - in general, if you use different flag settings while encoding vs. when decoding you likely have a bug somewhere. Below comes a verbose discussion of these flags. Note that a "codeset" is simply an abstract set of character-codepoint pairs, while an encoding takes those codepoint numbers and I<encodes> them, in our case into octets. Unicode is (among other things) a codeset, UTF-8 is an encoding, and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at the same time, which can be confusing. =over 4 =item C<utf8> flag disabled When C<utf8> is disabled (the default), then C<encode>/C<decode> generate and expect Unicode strings, that is, characters with high ordinal Unicode values (> 255) will be encoded as such characters, and likewise such characters are decoded as-is, no changes to them will be done, except "(re-)interpreting" them as Unicode codepoints or Unicode characters, respectively (to Perl, these are the same thing in strings unless you do funny/weird/dumb stuff). This is useful when you want to do the encoding yourself (e.g. when you want to have UTF-16 encoded JSON texts) or when some other layer does the encoding for you (for example, when printing to a terminal using a filehandle that transparently encodes to UTF-8 you certainly do NOT want to UTF-8 encode your data first and have Perl encode it another time). =item C<utf8> flag enabled If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all characters using the corresponding UTF-8 multi-byte sequence, and will expect your input strings to be encoded as UTF-8, that is, no "character" of the input string must have any value > 255, as UTF-8 does not allow that. The C<utf8> flag therefore switches between two modes: disabled means you will get a Unicode string in Perl, enabled means you get an UTF-8 encoded octet/binary string in Perl. =item C<latin1> or C<ascii> flags enabled With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining characters as specified by the C<utf8> flag. If C<utf8> is disabled, then the result is also correctly encoded in those character sets (as both are proper subsets of Unicode, meaning that a Unicode string with all character values < 256 is the same thing as a ISO-8859-1 string, and a Unicode string with all character values < 128 is the same thing as an ASCII string in Perl). If C<utf8> is enabled, you still get a correct UTF-8-encoded string, regardless of these flags, just some more characters will be escaped using C<\uXXXX> then before. Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8 encoding, while ASCII-encoded strings are. That is because the ISO-8859-1 encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being a subset of Unicode), while ASCII is. Surprisingly, C<decode> will ignore these flags and so treat all input values as governed by the C<utf8> flag. If it is disabled, this allows you to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings. So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag - they only govern when the JSON output engine escapes a character or not. The main use for C<latin1> is to relatively efficiently store binary data as JSON, at the expense of breaking compatibility with most JSON decoders. The main use for C<ascii> is to force the output to not contain characters with values > 127, which means you can interpret the resulting string as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and 8-bit-encoding, and still get the same data structure back. This is useful when your channel for JSON transfer is not 8-bit clean or the encoding might be mangled in between (e.g. in mail), and works because ASCII is a proper subset of most 8-bit and multibyte encodings in use in the world. =back =head1 BACKWARD INCOMPATIBILITY Since version 2.90, stringification (and string comparison) for C<JSON::true> and C<JSON::false> has not been overloaded. It shouldn't matter as long as you treat them as boolean values, but a code that expects they are stringified as "true" or "false" doesn't work as you have expected any more. if (JSON::true eq 'true') { # now fails print "The result is $JSON::true now."; # => The result is 1 now. And now these boolean values don't inherit JSON::Boolean, either. When you need to test a value is a JSON boolean value or not, use C<JSON::is_bool> function, instead of testing the value inherits a particular boolean class or not. =head1 BUGS Please report bugs on backend selection and additional features this module provides to RT or GitHub issues for this module: L<https://rt.cpan.org/Public/Dist/Display.html?Queue=JSON> L<https://github.com/makamaka/JSON/issues> As for bugs on a specific behavior, please report to the author of the backend module you are using. As for new features and requests to change common behaviors, please ask the author of JSON::XS (Marc Lehmann, E<lt>schmorp[at]schmorp.deE<gt>) first, by email (important!), to keep compatibility among JSON.pm backends. =head1 SEE ALSO L<JSON::XS>, L<Cpanel::JSON::XS>, L<JSON::PP> for backends. L<JSON::MaybeXS>, an alternative that prefers Cpanel::JSON::XS. C<RFC4627>(L<http://www.ietf.org/rfc/rfc4627.txt>) RFC7159 (L<http://www.ietf.org/rfc/rfc7159.txt>) RFC8259 (L<http://www.ietf.org/rfc/rfc8259.txt>) =head1 AUTHOR Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> JSON::XS was written by Marc Lehmann E<lt>schmorp[at]schmorp.deE<gt> The release of this new version owes to the courtesy of Marc Lehmann. =head1 CURRENT MAINTAINER Kenichi Ishigaki, E<lt>ishigaki[at]cpan.orgE<gt> =head1 COPYRIGHT AND LICENSE Copyright 2005-2013 by Makamaka Hannyaharamitu Most of the documentation is taken from JSON::XS by Marc Lehmann This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! x��Uv v CGI.podnu �[��� =head1 NAME CGI - Handle Common Gateway Interface requests and responses =for html <a href='https://travis-ci.org/leejo/CGI.pm?branch=master'><img src='https://travis-ci.org/leejo/CGI.pm.svg?branch=master' alt='Build Status' /></a> <a href='https://coveralls.io/r/leejo/CGI.pm'><img src='https://coveralls.io/repos/leejo/CGI.pm/badge.png?branch=master' alt='Coverage Status' /></a> =head1 SYNOPSIS use strict; use warnings; use CGI; # create a CGI object (query) for use my $q = CGI->new; # Process an HTTP request my @values = $q->multi_param('form_field'); my $value = $q->param('param_name'); my $fh = $q->upload('file_field'); my $riddle = $q->cookie('riddle_name'); my %answers = $q->cookie('answers'); # Prepare various HTTP responses print $q->header(); print $q->header('application/json'); my $cookie1 = $q->cookie( -name => 'riddle_name', -value => "The Sphynx's Question" ); my $cookie2 = $q->cookie( -name => 'answers', -value => \%answers ); print $q->header( -type => 'image/gif', -expires => '+3d', -cookie => [ $cookie1,$cookie2 ] ); print $q->redirect('http://somewhere.else/in/movie/land'); =head1 DESCRIPTION CGI.pm is a stable, complete and mature solution for processing and preparing HTTP requests and responses. Major features including processing form submissions, file uploads, reading and writing cookies, query string generation and manipulation, and processing and preparing HTTP headers. CGI.pm performs very well in a vanilla CGI.pm environment and also comes with built-in support for mod_perl and mod_perl2 as well as FastCGI. It has the benefit of having developed and refined over 20 years with input from dozens of contributors and being deployed on thousands of websites. CGI.pm was included in the perl distribution from perl v5.4 to v5.20, however is has now been removed from the perl core... =head1 CGI.pm HAS BEEN REMOVED FROM THE PERL CORE L<http://perl5.git.perl.org/perl.git/commitdiff/e9fa5a80> If you upgrade to a new version of perl or if you rely on a system or vendor perl and get an updated version of perl through a system update, then you will have to install CGI.pm yourself with cpan/cpanm/a vendor package/manually. To make this a little easier the L<CGI::Fast> module has been split into its own distribution, meaning you do not need access to a compiler to install CGI.pm The rationale for this decision is that CGI.pm is no longer considered good practice for developing web applications, B<including> quick prototyping and small web scripts. There are far better, cleaner, quicker, easier, safer, more scalable, more extensible, more modern alternatives available at this point in time. These will be documented with L<CGI::Alternatives>. For more discussion on the removal of CGI.pm from core please see: L<http://www.nntp.perl.org/group/perl.perl5.porters/2013/05/msg202130.html> Note that the v4 releases of CGI.pm will retain back compatibility B<as much> B<as possible>, however you may need to make some minor changes to your code if you are using deprecated methods or some of the more obscure features of the module. If you plan to upgrade to v4.00 and beyond you should read the Changes file for more information and B<test your code> against CGI.pm before deploying it. =head1 HTML Generation functions should no longer be used B<All> HTML generation functions within CGI.pm are no longer being maintained. Any issues, bugs, or patches will be rejected unless they relate to fundamentally broken page rendering. The rationale for this is that the HTML generation functions of CGI.pm are an obfuscation at best and a maintenance nightmare at worst. You should be using a template engine for better separation of concerns. See L<CGI::Alternatives> for an example of using CGI.pm with the L<Template::Toolkit> module. These functions, and perldoc for them, are considered deprecated, they are no longer being maintained and no fixes or features for them will be accepted. They will, however, continue to exist in CGI.pm without any deprecation warnings ("soft" deprecation) so you can continue to use them if you really want to. All documentation for these functions has been moved to L<CGI::HTML::Functions>. =head1 Programming style There are two styles of programming with CGI.pm, an object-oriented (OO) style and a function-oriented style. You are recommended to use the OO style as CGI.pm will create an internal default object when the functions are called procedurally and you will not have to worry about method names clashing with perl builtins. In the object-oriented style you create one or more CGI objects and then use object methods to create the various elements of the page. Each CGI object starts out with the list of named parameters that were passed to your CGI script by the server. You can modify the objects, save them to a file or database and recreate them. Because each object corresponds to the "state" of the CGI script, and because each object's parameter list is independent of the others, this allows you to save the state of the script and restore it later. For example, using the object oriented style: #!/usr/bin/env perl use strict; use warnings; use CGI; # load CGI routines my $q = CGI->new; # create new CGI object print $q->header; # create the HTTP header In the function-oriented style, there is one default CGI object that you rarely deal with directly. Instead you just call functions to retrieve CGI parameters, manage cookies, and so on. The following example is identical to above, in terms of output, but uses the function-oriented interface. The main differences are that we now need to import a set of functions into our name space (usually the "standard" functions), and we don't need to create the CGI object. #!/usr/bin/env perl use strict; use warnings; use CGI qw/:standard/; # load standard CGI routines print header(); # create the HTTP header The examples in this document mainly use the object-oriented style. See HOW TO IMPORT FUNCTIONS for important information on function-oriented programming in CGI.pm =head2 Calling CGI.pm routines Most CGI.pm routines accept several arguments, sometimes as many as 20 optional ones! To simplify this interface, all routines use a named argument calling style that looks like this: print $q->header( -type => 'image/gif', -expires => '+3d', ); Each argument name is preceded by a dash. Neither case nor order matters in the argument list: -type, -Type, and -TYPE are all acceptable. In fact, only the first argument needs to begin with a dash. If a dash is present in the first argument CGI.pm assumes dashes for the subsequent ones. Several routines are commonly called with just one argument. In the case of these routines you can provide the single argument without an argument name. header() happens to be one of these routines. In this case, the single argument is the document type. print $q->header('text/html'); Other such routines are documented below. Sometimes named arguments expect a scalar, sometimes a reference to an array, and sometimes a reference to a hash. Often, you can pass any type of argument and the routine will do whatever is most appropriate. For example, the param() routine is used to set a CGI parameter to a single or a multi-valued value. The two cases are shown below: $q->param( -name => 'veggie', -value => 'tomato', ); $q->param( -name => 'veggie', -value => [ qw/tomato tomahto potato potahto/ ], ); Many routines will do something useful with a named argument that it doesn't recognize. For example, you can produce non-standard HTTP header fields by providing them as named arguments: print $q->header( -type => 'text/html', -cost => 'Three smackers', -annoyance_level => 'high', -complaints_to => 'bit bucket', ); This will produce the following nonstandard HTTP header: HTTP/1.0 200 OK Cost: Three smackers Annoyance-level: high Complaints-to: bit bucket Content-type: text/html Notice the way that underscores are translated automatically into hyphens. =head2 Creating a new query object (object-oriented style) my $q = CGI->new; This will parse the input (from POST, GET and DELETE methods) and store it into a perl5 object called $q. Note that because the input parsing happens at object instantiation you have to set any CGI package variables that control parsing B<before> you call CGI->new. Any filehandles from file uploads will have their position reset to the beginning of the file. =head2 Creating a new query object from an input file my $q = CGI->new( $input_filehandle ); If you provide a file handle to the new() method, it will read parameters from the file (or STDIN, or whatever). The file can be in any of the forms describing below under debugging (i.e. a series of newline delimited TAG=VALUE pairs will work). Conveniently, this type of file is created by the save() method (see below). Multiple records can be saved and restored. Perl purists will be pleased to know that this syntax accepts references to file handles, or even references to filehandle globs, which is the "official" way to pass a filehandle. You can also initialize the CGI object with a FileHandle or IO::File object. If you are using the function-oriented interface and want to initialize CGI state from a file handle, the way to do this is with B<restore_parameters()>. This will (re)initialize the default CGI object from the indicated file handle. open( my $in_fh,'<',"test.in") || die "Couldn't open test.in for read: $!"; restore_parameters( $in_fh ); close( $in_fh ); You can also initialize the query object from a hash reference: my $q = CGI->new( { 'dinosaur' => 'barney', 'song' => 'I love you', 'friends' => [ qw/ Jessica George Nancy / ] } ); or from a properly formatted, URL-escaped query string: my $q = CGI->new('dinosaur=barney&color=purple'); or from a previously existing CGI object (currently this clones the parameter list, but none of the other object-specific fields, such as autoescaping): my $old_query = CGI->new; my $new_query = CGI->new($old_query); To create an empty query, initialize it from an empty string or hash: my $empty_query = CGI->new(""); -or- my $empty_query = CGI->new({}); =head2 Fetching a list of keywords from the query my @keywords = $q->keywords If the script was invoked as the result of an ISINDEX search, the parsed keywords can be obtained as an array using the keywords() method. =head2 Fetching the names of all the parameters passed to your script my @names = $q->multi_param my @names = $q->param If the script was invoked with a parameter list (e.g. "name1=value1&name2=value2&name3=value3"), the param() / multi_param() methods will return the parameter names as a list. If the script was invoked as an ISINDEX script and contains a string without ampersands (e.g. "value1+value2+value3"), there will be a single parameter named "keywords" containing the "+"-delimited keywords. The array of parameter names returned will be in the same order as they were submitted by the browser. Usually this order is the same as the order in which the parameters are defined in the form (however, this isn't part of the spec, and so isn't guaranteed). =head2 Fetching the value or values of a single named parameter my @values = $q->multi_param('foo'); -or- my $value = $q->param('foo'); -or- my @values = $q->param('foo'); # list context, discouraged and will raise # a warning (use ->multi_param instead) Pass the param() / multi_param() method a single argument to fetch the value of the named parameter. When calling param() If the parameter is multivalued (e.g. from multiple selections in a scrolling list), you can ask to receive an array. Otherwise the method will return the B<first> value. B<Warning> - calling param() in list context can lead to vulnerabilities if you do not sanitise user input as it is possible to inject other param keys and values into your code. This is why the multi_param() method exists, to make it clear that a list is being returned, note that param() can still be called in list context and will return a list for back compatibility. The following code is an example of a vulnerability as the call to param will be evaluated in list context and thus possibly inject extra keys and values into the hash: my %user_info = ( id => 1, name => $q->param('name'), ); The fix for the above is to force scalar context on the call to ->param by prefixing it with "scalar" name => scalar $q->param('name'), If you call param() in list context with an argument a warning will be raised by CGI.pm, you can disable this warning by setting $CGI::LIST_CONTEXT_WARN to 0 or by using the multi_param() method instead If a value is not given in the query string, as in the queries "name1=&name2=", it will be returned as an empty string. If the parameter does not exist at all, then param() will return undef in scalar context, and the empty list in a list context. =head2 Setting the value(s) of a named parameter $q->param('foo','an','array','of','values'); This sets the value for the named parameter 'foo' to an array of values. This is one way to change the value of a field AFTER the script has been invoked once before. param() also recognizes a named parameter style of calling described in more detail later: $q->param( -name => 'foo', -values => ['an','array','of','values'], ); -or- $q->param( -name => 'foo', -value => 'the value', ); =head2 Appending additional values to a named parameter $q->append( -name =>'foo', -values =>['yet','more','values'], ); This adds a value or list of values to the named parameter. The values are appended to the end of the parameter if it already exists. Otherwise the parameter is created. Note that this method only recognizes the named argument calling syntax. =head2 Importing all parameters into a namespace $q->import_names('R'); This creates a series of variables in the 'R' namespace. For example, $R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear. If no namespace is given, this method will assume 'Q'. B<WARNING>: don't import anything into 'main'; this is a major security risk! NOTE 1: Variable names are transformed as necessary into legal perl variable names. All non-legal characters are transformed into underscores. If you need to keep the original names, you should use the param() method instead to access CGI variables by name. In fact, you should probably not use this method at all given the above caveats and security risks. =head2 Deleting a parameter completely $q->delete('foo','bar','baz'); This completely clears a list of parameters. It sometimes useful for resetting parameters that you don't want passed down between script invocations. If you are using the function call interface, use "Delete()" instead to avoid conflicts with perl's built-in delete operator. =head2 Deleting all parameters $q->delete_all(); This clears the CGI object completely. It might be useful to ensure that all the defaults are taken when you create a fill-out form. Use Delete_all() instead if you are using the function call interface. =head2 Handling non-urlencoded arguments If POSTed data is not of type application/x-www-form-urlencoded or multipart/form-data, then the POSTed data will not be processed, but instead be returned as-is in a parameter named POSTDATA. To retrieve it, use code like this: my $data = $q->param('POSTDATA'); Likewise if PUTed and PATCHed data can be retrieved with code like this: my $data = $q->param('PUTDATA'); my $data = $q->param('PATCHDATA'); (If you don't know what the preceding means, worry not. It only affects people trying to use CGI for XML processing and other specialized tasks) PUTDATA/POSTDATA/PATCHDATA are also available via L<upload_hook|/Progress bars for file uploads and avoiding temp files>, and as L<file uploads|/Processing a file upload field> via L</-putdata_upload> option. =head2 Direct access to the parameter list $q->param_fetch('address')->[1] = '1313 Mockingbird Lane'; unshift @{$q->param_fetch(-name=>'address')},'George Munster'; If you need access to the parameter list in a way that isn't covered by the methods given in the previous sections, you can obtain a direct reference to it by calling the B<param_fetch()> method with the name of the parameter. This will return an array reference to the named parameter, which you then can manipulate in any way you like. You can also use a named argument style using the B<-name> argument. =head2 Fetching the parameter list as a hash my $params = $q->Vars; print $params->{'address'}; my @foo = split("\0",$params->{'foo'}); my %params = $q->Vars; use CGI ':cgi-lib'; my $params = Vars(); Many people want to fetch the entire parameter list as a hash in which the keys are the names of the CGI parameters, and the values are the parameters' values. The Vars() method does this. Called in a scalar context, it returns the parameter list as a tied hash reference. Changing a key changes the value of the parameter in the underlying CGI parameter list. Called in a list context, it returns the parameter list as an ordinary hash. This allows you to read the contents of the parameter list, but not to change it. When using this, the thing you must watch out for are multivalued CGI parameters. Because a hash cannot distinguish between scalar and list context, multivalued parameters will be returned as a packed string, separated by the "\0" (null) character. You must split this packed string in order to get at the individual values. This is the convention introduced long ago by Steve Brenner in his cgi-lib.pl module for perl version 4, and may be replaced in future versions with array references. If you wish to use Vars() as a function, import the I<:cgi-lib> set of function calls (also see the section on CGI-LIB compatibility). =head2 Saving the state of the script to a file $q->save(\*FILEHANDLE) This will write the current state of the form to the provided filehandle. You can read it back in by providing a filehandle to the new() method. Note that the filehandle can be a file, a pipe, or whatever. The format of the saved file is: NAME1=VALUE1 NAME1=VALUE1' NAME2=VALUE2 NAME3=VALUE3 = Both name and value are URL escaped. Multi-valued CGI parameters are represented as repeated names. A session record is delimited by a single = symbol. You can write out multiple records and read them back in with several calls to B<new>. You can do this across several sessions by opening the file in append mode, allowing you to create primitive guest books, or to keep a history of users' queries. Here's a short example of creating multiple session records: use strict; use warnings; use CGI; open (my $out_fh,'>>','test.out') || die "Can't open test.out: $!"; my $records = 5; for ( 0 .. $records ) { my $q = CGI->new; $q->param( -name => 'counter',-value => $_ ); $q->save( $out_fh ); } close( $out_fh ); # reopen for reading open (my $in_fh,'<','test.out') || die "Can't open test.out: $!"; while (!eof($in_fh)) { my $q = CGI->new($in_fh); print $q->param('counter'),"\n"; } The file format used for save/restore is identical to that used by the Whitehead Genome Center's data exchange format "Boulderio", and can be manipulated and even databased using Boulderio utilities. See L<Boulder> for further details. If you wish to use this method from the function-oriented (non-OO) interface, the exported name for this method is B<save_parameters()>. =head2 Retrieving cgi errors Errors can occur while processing user input, particularly when processing uploaded files. When these errors occur, CGI will stop processing and return an empty parameter list. You can test for the existence and nature of errors using the I<cgi_error()> function. The error messages are formatted as HTTP status codes. You can either incorporate the error text into a page, or use it as the value of the HTTP status: if ( my $error = $q->cgi_error ) { print $q->header( -status => $error ); print "Error: $error"; exit 0; } When using the function-oriented interface (see the next section), errors may only occur the first time you call I<param()>. Be ready for this! =head2 Using the function-oriented interface To use the function-oriented interface, you must specify which CGI.pm routines or sets of routines to import into your script's namespace. There is a small overhead associated with this importation, but it isn't much. use strict; use warnings; use CGI qw/ list of methods /; The listed methods will be imported into the current package; you can call them directly without creating a CGI object first. This example shows how to import the B<param()> and B<header()> methods, and then use them directly: use strict; use warnings; use CGI qw/ param header /; print header('text/plain'); my $zipcode = param('zipcode'); More frequently, you'll import common sets of functions by referring to the groups by name. All function sets are preceded with a ":" character as in ":cgi" (for CGI protocol handling methods). Here is a list of the function sets you can import: =over 4 =item B<:cgi> Import all CGI-handling methods, such as B<param()>, B<path_info()> and the like. =item B<:all> Import all the available methods. For the full list, see the CGI.pm code, where the variable %EXPORT_TAGS is defined. (N.B. the :cgi-lib imports will B<not> be included in the :all import, you will have to import :cgi-lib to get those) =back Note that in the interests of execution speed CGI.pm does B<not> use the standard L<Exporter> syntax for specifying load symbols. This may change in the future. =head2 Pragmas In addition to the function sets, there are a number of pragmas that you can import. Pragmas, which are always preceded by a hyphen, change the way that CGI.pm functions in various ways. Pragmas, function sets, and individual functions can all be imported in the same use() line. For example, the following use statement imports the cgi set of functions and enables debugging mode (pragma -debug): use strict; use warninigs; use CGI qw/ :cgi -debug /; The current list of pragmas is as follows: =over 4 =item -no_undef_params This keeps CGI.pm from including undef params in the parameter list. =item -utf8 This makes CGI.pm treat all parameters as text strings rather than binary strings (see L<perlunitut> for the distinction), assuming UTF-8 for the encoding. CGI.pm does the decoding from the UTF-8 encoded input data, restricting this decoding to input text as distinct from binary upload data which are left untouched. Therefore, a ':utf8' layer must B<not> be used on STDIN. If you do not use this option you can manually select which fields are expected to return utf-8 strings and convert them using code like this: use strict; use warnings; use CGI; use Encode qw/ decode /; my $cgi = CGI->new; my $param = $cgi->param('foo'); $param = decode( 'UTF-8',$param ); =item -putdata_upload / -postdata_upload / -patchdata_upload Makes C<<< $cgi->param('PUTDATA'); >>>, C<<< $cgi->param('PATCHDATA'); >>>, and C<<< $cgi->param('POSTDATA'); >>> act like file uploads named PUTDATA, PATCHDATA, and POSTDATA. See L</Handling non-urlencoded arguments> and L</Processing a file upload field> PUTDATA/POSTDATA/PATCHDATA are also available via L<upload_hook|/Progress bars for file uploads and avoiding temp files>. =item -nph This makes CGI.pm produce a header appropriate for an NPH (no parsed header) script. You may need to do other things as well to tell the server that the script is NPH. See the discussion of NPH scripts below. =item -newstyle_urls Separate the name=value pairs in CGI parameter query strings with semicolons rather than ampersands. For example: ?name=fred;age=24;favorite_color=3 Semicolon-delimited query strings are always accepted, and will be emitted by self_url() and query_string(). newstyle_urls became the default in version 2.64. =item -oldstyle_urls Separate the name=value pairs in CGI parameter query strings with ampersands rather than semicolons. This is no longer the default. =item -no_debug This turns off the command-line processing features. If you want to run a CGI.pm script from the command line, and you don't want it to read CGI parameters from the command line or STDIN, then use this pragma: use CGI qw/ -no_debug :standard /; =item -debug This turns on full debugging. In addition to reading CGI arguments from the command-line processing, CGI.pm will pause and try to read arguments from STDIN, producing the message "(offline mode: enter name=value pairs on standard input)" features. See the section on debugging for more details. =back =head1 GENERATING DYNAMIC DOCUMENTS Most of CGI.pm's functions deal with creating documents on the fly. Generally you will produce the HTTP header first, followed by the document itself. CGI.pm provides functions for generating HTTP headers of various types. Each of these functions produces a fragment of HTTP which you can print out directly so that it is processed by the browser, appended to a string, or saved to a file for later use. =head2 Creating a standard http header Normally the first thing you will do in any CGI script is print out an HTTP header. This tells the browser what type of document to expect, and gives other optional information, such as the language, expiration date, and whether to cache the document. The header can also be manipulated for special purposes, such as server push and pay per view pages. use strict; use warnings; use CGI; my $cgi = CGI->new; print $cgi->header; -or- print $cgi->header('image/gif'); -or- print $cgi->header('text/html','204 No response'); -or- print $cgi->header( -type => 'image/gif', -nph => 1, -status => '402 Payment required', -expires => '+3d', -cookie => $cookie, -charset => 'utf-8', -attachment => 'foo.gif', -Cost => '$2.00' ); header() returns the Content-type: header. You can provide your own MIME type if you choose, otherwise it defaults to text/html. An optional second parameter specifies the status code and a human-readable message. For example, you can specify 204, "No response" to create a script that tells the browser to do nothing at all. Note that RFC 2616 expects the human-readable phase to be there as well as the numeric status code. The last example shows the named argument style for passing arguments to the CGI methods using named parameters. Recognized parameters are B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named parameters will be stripped of their initial hyphens and turned into header fields, allowing you to specify any HTTP header you desire. Internal underscores will be turned into hyphens: print $cgi->header( -Content_length => 3002 ); Most browsers will not cache the output from CGI scripts. Every time the browser reloads the page, the script is invoked anew. You can change this behavior with the B<-expires> parameter. When you specify an absolute or relative expiration interval with this parameter, some browsers and proxy servers will cache the script's output until the indicated expiration date. The following forms are all valid for the -expires field: +30s 30 seconds from now +10m ten minutes from now +1h one hour from now -1d yesterday (i.e. "ASAP!") now immediately +3M in three months +10y in ten years time Thursday, 25-Apr-2018 00:40:33 GMT at the indicated time & date The B<-cookie> parameter generates a header that tells the browser to provide a "magic cookie" during all subsequent transactions with your script. Some cookies have a special format that includes interesting attributes such as expiration time. Use the cookie() method to create and retrieve session cookies. The B<-nph> parameter, if set to a true value, will issue the correct headers to work with a NPH (no-parse-header) script. This is important to use with certain servers that expect all their scripts to be NPH. The B<-charset> parameter can be used to control the character set sent to the browser. If not provided, defaults to ISO-8859-1. As a side effect, this sets the charset() method as well. B<Note> that the default being ISO-8859-1 may not make sense for all content types, e.g.: Content-Type: image/gif; charset=ISO-8859-1 In the above case you need to pass -charset => '' to prevent the default being used. The B<-attachment> parameter can be used to turn the page into an attachment. Instead of displaying the page, some browsers will prompt the user to save it to disk. The value of the argument is the suggested name for the saved file. In order for this to work, you may have to set the B<-type> to "application/octet-stream". The B<-p3p> parameter will add a P3P tag to the outgoing header. The parameter can be an arrayref or a space-delimited string of P3P tags. For example: print $cgi->header( -p3p => [ qw/ CAO DSP LAW CURa / ] ); print $cgi->header( -p3p => 'CAO DSP LAW CURa' ); In either case, the outgoing header will be formatted as: P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa" CGI.pm will accept valid multi-line headers when each line is separated with a CRLF value ("\r\n" on most platforms) followed by at least one space. For example: print $cgi->header( -ingredients => "ham\r\n\seggs\r\n\sbacon" ); Invalid multi-line header input will trigger in an exception. When multi-line headers are received, CGI.pm will always output them back as a single line, according to the folding rules of RFC 2616: the newlines will be removed, while the white space remains. =head2 Generating a redirection header print $q->redirect( 'http://somewhere.else/in/movie/land' ); Sometimes you don't want to produce a document yourself, but simply redirect the browser elsewhere, perhaps choosing a URL based on the time of day or the identity of the user. The redirect() method redirects the browser to a different URL. If you use redirection like this, you should B<not> print out a header as well. You are advised to use full URLs (absolute with respect to current URL or even including the http: or ftp: part) in redirection requests as relative URLs are resolved by the user agent of the client so may not do what you want or expect them to do. You can also use named arguments: print $q->redirect( -uri => 'http://somewhere.else/in/movie/land', -nph => 1, -status => '301 Moved Permanently' ); All names arguments recognized by header() are also recognized by redirect(). However, most HTTP headers, including those generated by -cookie and -target, are ignored by the browser. The B<-nph> parameter, if set to a true value, will issue the correct headers to work with a NPH (no-parse-header) script. This is important to use with certain servers, such as Microsoft IIS, which expect all their scripts to be NPH. The B<-status> parameter will set the status of the redirect. HTTP defines several different possible redirection status codes, and the default if not specified is 302, which means "moved temporarily." You may change the status to another status code if you wish. Note that the human-readable phrase is also expected to be present to conform with RFC 2616, section 6.1. =head2 Creating a self-referencing url that preserves state information my $myself = $q->self_url; print qq(<a href="$myself">I'm talking to myself.</a>); self_url() will return a URL, that, when selected, will re-invoke this script with all its state information intact. This is most useful when you want to jump around within the document using internal anchors but you don't want to disrupt the current contents of the form(s). Something like this will do the trick: my $myself = $q->self_url; print "<a href=\"$myself#table1\">See table 1</a>"; print "<a href=\"$myself#table2\">See table 2</a>"; print "<a href=\"$myself#yourself\">See for yourself</a>"; If you want more control over what's returned, using the B<url()> method instead. You can also retrieve a query string representation of the current object state with query_string(): my $the_string = $q->query_string(); The behavior of calling query_string is currently undefined when the HTTP method is something other than GET. If you want to retrieved the query string as set in the webserver, namely the environment variable, you can call env_query_string() =head2 Obtaining the script's url my $full_url = url(); my $full_url = url( -full =>1 ); # alternative syntax my $relative_url = url( -relative => 1 ); my $absolute_url = url( -absolute =>1 ); my $url_with_path = url( -path_info => 1 ); my $url_path_qry = url( -path_info => 1, -query =>1 ); my $netloc = url( -base => 1 ); B<url()> returns the script's URL in a variety of formats. Called without any arguments, it returns the full form of the URL, including host name and port number http://your.host.com/path/to/script.cgi You can modify this format with the following named arguments: =over 4 =item B<-absolute> If true, produce an absolute URL, e.g. /path/to/script.cgi =item B<-relative> Produce a relative URL. This is useful if you want to re-invoke your script with different parameters. For example: script.cgi =item B<-full> Produce the full URL, exactly as if called without any arguments. This overrides the -relative and -absolute arguments. =item B<-path> (B<-path_info>) Append the additional path information to the URL. This can be combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info> is provided as a synonym. =item B<-query> (B<-query_string>) Append the query string to the URL. This can be combined with B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided as a synonym. =item B<-base> Generate just the protocol and net location, as in http://www.foo.com:8000 =item B<-rewrite> If Apache's mod_rewrite is turned on, then the script name and path info probably won't match the request that the user sent. Set -rewrite => 1 (default) to return URLs that match what the user sent (the original request URI). Set -rewrite => 0 to return URLs that match the URL after the mod_rewrite rules have run. =back =head2 Mixing post and url parameters my $color = url_param('color'); It is possible for a script to receive CGI parameters in the URL as well as in the fill-out form by creating a form that POSTs to a URL containing a query string (a "?" mark followed by arguments). The B<param()> method will always return the contents of the POSTed fill-out form, ignoring the URL's query string. To retrieve URL parameters, call the B<url_param()> method. Use it in the same way as B<param()>. The main difference is that it allows you to read the parameters, but not set them. Under no circumstances will the contents of the URL query string interfere with similarly-named CGI parameters in POSTed forms. If you try to mix a URL query string with a form submitted with the GET method, the results will not be what you expect. If running from the command line, C<url_param> will not pick up any parameters given on the command line. =head2 Processing a file upload field =head3 Basics When the form is processed, you can retrieve an L<IO::File> compatible handle for a file upload field like this: use autodie; # undef may be returned if it's not a valid file handle if ( my $io_handle = $q->upload('field_name') ) { open ( my $out_file,'>>','/usr/local/web/users/feedback' ); while ( my $bytesread = $io_handle->read($buffer,1024) ) { print $out_file $buffer; } } In a list context, upload() will return an array of filehandles. This makes it possible to process forms that use the same name for multiple upload fields. If you want the entered file name for the file, you can just call param(): my $filename = $q->param('field_name'); Different browsers will return slightly different things for the name. Some browsers return the filename only. Others return the full path to the file, using the path conventions of the user's machine. Regardless, the name returned is always the name of the file on the I<user's> machine, and is unrelated to the name of the temporary file that CGI.pm creates during upload spooling (see below). When a file is uploaded the browser usually sends along some information along with it in the format of headers. The information usually includes the MIME content type. To retrieve this information, call uploadInfo(). It returns a reference to a hash containing all the document headers. my $filehandle = $q->upload( 'uploaded_file' ); my $type = $q->uploadInfo( $filehandle )->{'Content-Type'}; if ( $type ne 'text/html' ) { die "HTML FILES ONLY!"; } Note that you must use ->upload or ->param to get the file-handle to pass into uploadInfo as internally this is represented as a File::Temp object (which is what will be returned by ->upload or ->param). When using ->Vars you will get the literal filename rather than the File::Temp object, which will not return anything when passed to uploadInfo. So don't use ->Vars. If you are using a machine that recognizes "text" and "binary" data modes, be sure to understand when and how to use them (see the Camel book). Otherwise you may find that binary files are corrupted during file uploads. =head3 Accessing the temp files directly When processing an uploaded file, CGI.pm creates a temporary file on your hard disk and passes you a file handle to that file. After you are finished with the file handle, CGI.pm unlinks (deletes) the temporary file. If you need to you can access the temporary file directly. You can access the temp file for a file upload by passing the file name to the tmpFileName() method: my $filehandle = $q->upload( 'uploaded_file' ); my $tmpfilename = $q->tmpFileName( $filehandle ); As with ->uploadInfo, using the reference returned by ->upload or ->param is preferred, although unlike ->uploadInfo, plain filenames also work if possible for backwards compatibility. The temporary file will be deleted automatically when your program exits unless you manually rename it or set $CGI::UNLINK_TMP_FILES to 0. On some operating systems (such as Windows NT), you will need to close the temporary file's filehandle before your program exits. Otherwise the attempt to delete the temporary file will fail. =head3 Changes in temporary file handling (v4.05+) CGI.pm had its temporary file handling significantly refactored, this logic is now all deferred to File::Temp (which is wrapped in a compatibility object, CGI::File::Temp - B<DO NOT USE THIS PACKAGE DIRECTLY>). As a consequence the PRIVATE_TEMPFILES variable has been removed along with deprecation of the private_tempfiles routine and B<complete> removal of the CGITempFile package. The $CGITempFile::TMPDIRECTORY is no longer used to set the temp directory, refer to the perldoc for File::Temp if you want to override the default settings in that package (the TMPDIR env variable is still available on some platforms). For Windows platforms the temporary directory order remains as before: TEMP > TMP > WINDIR ( > TMPDIR ) so if you have any of these in use in existing scripts they should still work. The Fh package still exists but does nothing, the CGI::File::Temp class is a subclass of both File::Temp and the empty Fh package, so if you have any code that checks that the filehandle isa Fh this should still work. When you get the internal file handle you will receive a File::Temp object, this should be transparent as File::Temp isa IO::Handle and isa IO::Seekable meaning it behaves as previously. If you are doing anything out of the ordinary with regards to temp files you should test your code before deploying this update and refer to the File::Temp documentation for more information. =head3 Handling interrupted file uploads There are occasionally problems involving parsing the uploaded file. This usually happens when the user presses "Stop" before the upload is finished. In this case, CGI.pm will return undef for the name of the uploaded file and set I<cgi_error()> to the string "400 Bad request (malformed multipart POST)". This error message is designed so that you can incorporate it into a status code to be sent to the browser. Example: my $file = $q->upload( 'uploaded_file' ); if ( !$file && $q->cgi_error ) { print $q->header( -status => $q->cgi_error ); exit 0; } =head3 Progress bars for file uploads and avoiding temp files CGI.pm gives you low-level access to file upload management through a file upload hook. You can use this feature to completely turn off the temp file storage of file uploads, or potentially write your own file upload progress meter. This is much like the UPLOAD_HOOK facility available in L<Apache::Request>, with the exception that the first argument to the callback is an L<Apache::Upload> object, here it's the remote filename. my $q = CGI->new( \&hook [,$data [,$use_tempfile]] ); sub hook { my ( $filename, $buffer, $bytes_read, $data ) = @_; print "Read $bytes_read bytes of $filename\n"; } The C<< $data >> field is optional; it lets you pass configuration information (e.g. a database handle) to your hook callback. The C<< $use_tempfile >> field is a flag that lets you turn on and off CGI.pm's use of a temporary disk-based file during file upload. If you set this to a FALSE value (default true) then $q->param('uploaded_file') will no longer work, and the only way to get at the uploaded data is via the hook you provide. If using the function-oriented interface, call the CGI::upload_hook() method before calling param() or any other CGI functions: CGI::upload_hook( \&hook [,$data [,$use_tempfile]] ); This method is not exported by default. You will have to import it explicitly if you wish to use it without the CGI:: prefix. =head3 Troubleshooting file uploads on Windows If you are using CGI.pm on a Windows platform and find that binary files get slightly larger when uploaded but that text files remain the same, then you have forgotten to activate binary mode on the output filehandle. Be sure to call binmode() on any handle that you create to write the uploaded file to disk. =head3 Older ways to process file uploads This section is here for completeness. if you are building a new application with CGI.pm, you can skip it. The original way to process file uploads with CGI.pm was to use param(). The value it returns has a dual nature as both a file name and a lightweight filehandle. This dual nature is problematic if you following the recommended practice of having C<use strict> in your code. perl will complain when you try to use a string as a filehandle. More seriously, it is possible for the remote user to type garbage into the upload field, in which case what you get from param() is not a filehandle at all, but a string. To solve this problem the upload() method was added, which always returns a lightweight filehandle. This generally works well, but will have trouble interoperating with some other modules because the file handle is not derived from L<IO::File>. So that brings us to current recommendation given above, which is to call the handle() method on the file handle returned by upload(). That upgrades the handle to an IO::File. It's a big win for compatibility for a small penalty of loading IO::File the first time you call it. =head1 HTTP COOKIES CGI.pm has several methods that support cookies. A cookie is a name=value pair much like the named parameters in a CGI query string. CGI scripts create one or more cookies and send them to the browser in the HTTP header. The browser maintains a list of cookies that belong to a particular Web server, and returns them to the CGI script during subsequent interactions. In addition to the required name=value pair, each cookie has several optional attributes: =over 4 =item 1. an expiration time This is a time/date string (in a special GMT format) that indicates when a cookie expires. The cookie will be saved and returned to your script until this expiration date is reached if the user exits the browser and restarts it. If an expiration date isn't specified, the cookie will remain active until the user quits the browser. =item 2. a domain This is a partial or complete domain name for which the cookie is valid. The browser will return the cookie to any host that matches the partial domain name. For example, if you specify a domain name of ".capricorn.com", then the browser will return the cookie to Web servers running on any of the machines "www.capricorn.com", "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names must contain at least two periods to prevent attempts to match on top level domains like ".edu". If no domain is specified, then the browser will only return the cookie to servers on the host the cookie originated from. =item 3. a path If you provide a cookie path attribute, the browser will check it against your script's URL before returning the cookie. For example, if you specify the path "/cgi-bin", then the cookie will be returned to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and "/cgi-bin/customer_service/complain.pl", but not to the script "/cgi-private/site_admin.pl". By default, path is set to "/", which causes the cookie to be sent to any CGI script on your site. =item 4. a "secure" flag If the "secure" attribute is set, the cookie will only be sent to your script if the CGI request is occurring on a secure channel, such as SSL. =back The interface to HTTP cookies is the B<cookie()> method: my $cookie = $q->cookie( -name => 'sessionID', -value => 'xyzzy', -expires => '+1h', -path => '/cgi-bin/database', -domain => '.capricorn.org', -secure => 1 ); print $q->header( -cookie => $cookie ); B<cookie()> creates a new cookie. Its parameters include: =over 4 =item B<-name> The name of the cookie (required). This can be any string at all. Although browsers limit their cookie names to non-whitespace alphanumeric characters, CGI.pm removes this restriction by escaping and unescaping cookies behind the scenes. =item B<-value> The value of the cookie. This can be any scalar value, array reference, or even hash reference. For example, you can store an entire hash into a cookie this way: my $cookie = $q->cookie( -name => 'family information', -value => \%childrens_ages ); =item B<-path> The optional partial path for which this cookie will be valid, as described above. =item B<-domain> The optional partial domain for which this cookie will be valid, as described above. =item B<-expires> The optional expiration date for this cookie. The format is as described in the section on the B<header()> method: "+1h" one hour from now =item B<-secure> If set to true, this cookie will only be used within a secure SSL session. =back The cookie created by cookie() must be incorporated into the HTTP header within the string returned by the header() method: use strict; use warnings; use CGI; my $q = CGI->new; my $cookie = ... print $q->header( -cookie => $cookie ); To create multiple cookies, give header() an array reference: my $cookie1 = $q->cookie( -name => 'riddle_name', -value => "The Sphynx's Question" ); my $cookie2 = $q->cookie( -name => 'answers', -value => \%answers ); print $q->header( -cookie => [ $cookie1,$cookie2 ] ); To retrieve a cookie, request it by name by calling cookie() method without the B<-value> parameter. This example uses the object-oriented form: my $riddle = $q->cookie('riddle_name'); my %answers = $q->cookie('answers'); Cookies created with a single scalar value, such as the "riddle_name" cookie, will be returned in that form. Cookies with array and hash values can also be retrieved. The cookie and CGI namespaces are separate. If you have a parameter named 'answers' and a cookie named 'answers', the values retrieved by param() and cookie() are independent of each other. However, it's simple to turn a CGI parameter into a cookie, and vice-versa: # turn a CGI parameter into a cookie my $c = cookie( -name => 'answers',-value => [$q->param('answers')] ); # vice-versa $q->param( -name => 'answers',-value => [ $q->cookie('answers')] ); If you call cookie() without any parameters, it will return a list of the names of all cookies passed to your script: my @cookies = $q->cookie(); See the B<cookie.cgi> example script for some ideas on how to use cookies effectively. =over 4 =item B<$CGI::COOKIE_CACHE> If set to a non-negative integer, this variable will cause CGI.pm to use the cached cookie details from the previous call to cookie(). By default this cache is off to retain backwards compatibility. =back =head1 DEBUGGING If you are running the script from the command line or in the perl debugger, you can pass the script a list of keywords or parameter=value pairs on the command line or from standard input (you don't have to worry about tricking your script into reading from environment variables). You can pass keywords like this: your_script.pl keyword1 keyword2 keyword3 or this: your_script.pl keyword1+keyword2+keyword3 or this: your_script.pl name1=value1 name2=value2 or this: your_script.pl name1=value1&name2=value2 To turn off this feature, use the -no_debug pragma. To test the POST method, you may enable full debugging with the -debug pragma. This will allow you to feed newline-delimited name=value pairs to the script on standard input. When debugging, you can use quotes and backslashes to escape characters in the familiar shell manner, letting you place spaces and other funny characters in your parameter=value pairs: your_script.pl "name1='I am a long value'" "name2=two\ words" Finally, you can set the path info for the script by prefixing the first name/value parameter with the path followed by a question mark (?): your_script.pl /your/path/here?name1=value1&name2=value2 =head1 FETCHING ENVIRONMENT VARIABLES Some of the more useful environment variables can be fetched through this interface. The methods are as follows: =over 4 =item B<Accept()> Return a list of MIME types that the remote browser accepts. If you give this method a single argument corresponding to a MIME type, as in Accept('text/html'), it will return a floating point value corresponding to the browser's preference for this type from 0.0 (don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept list are handled correctly. Note that the capitalization changed between version 2.43 and 2.44 in order to avoid conflict with perl's accept() function. =item B<raw_cookie()> Returns the HTTP_COOKIE variable. Cookies have a special format, and this method call just returns the raw form (?cookie dough). See cookie() for ways of setting and retrieving cooked cookies. Called with no parameters, raw_cookie() returns the packed cookie structure. You can separate it into individual cookies by splitting on the character sequence "; ". Called with the name of a cookie, retrieves the B<unescaped> form of the cookie. You can use the regular cookie() method to get the names, or use the raw_fetch() method from the CGI::Cookie module. =item B<env_query_string()> Returns the QUERY_STRING variable, note that this is the original value as set in the environment by the webserver and (possibly) not the same value as returned by query_string(), which represents the object state =item B<user_agent()> Returns the HTTP_USER_AGENT variable. If you give this method a single argument, it will attempt to pattern match on it, allowing you to do something like user_agent(Mozilla); =item B<path_info()> Returns additional path information from the script URL. E.G. fetching /cgi-bin/your_script/additional/stuff will result in path_info() returning "/additional/stuff". NOTE: The Microsoft Internet Information Server is broken with respect to additional path information. If you use the perl DLL library, the IIS server will attempt to execute the additional path information as a perl script. If you use the ordinary file associations mapping, the path information will be present in the environment, but incorrect. The best thing to do is to avoid using additional path information in CGI scripts destined for use with IIS. A best attempt has been made to make CGI.pm do the right thing. =item B<path_translated()> As per path_info() but returns the additional path information translated into a physical path, e.g. "/usr/local/etc/httpd/htdocs/additional/stuff". The Microsoft IIS is broken with respect to the translated path as well. =item B<remote_host()> Returns either the remote host name or IP address if the former is unavailable. =item B<remote_ident()> Returns the name of the remote user (as returned by identd) or undef if not set =item B<remote_addr()> Returns the remote host IP address, or 127.0.0.1 if the address is unavailable. =item B<request_uri()> Returns the interpreted pathname of the requested document or CGI (relative to the document root). Or undef if not set. =item B<script_name()> Return the script name as a partial URL, for self-referring scripts. =item B<referer()> Return the URL of the page the browser was viewing prior to fetching your script. =item B<auth_type()> Return the authorization/verification method in use for this script, if any. =item B<server_name()> Returns the name of the server, usually the machine's host name. =item B<virtual_host()> When using virtual hosts, returns the name of the host that the browser attempted to contact =item B<server_port()> Return the port that the server is listening on. =item B<server_protocol()> Returns the protocol and revision of the incoming request, or defaults to HTTP/1.0 if this is not set =item B<virtual_port()> Like server_port() except that it takes virtual hosts into account. Use this when running with virtual hosts. =item B<server_software()> Returns the server software and version number. =item B<remote_user()> Return the authorization/verification name used for user verification, if this script is protected. =item B<user_name()> Attempt to obtain the remote user's name, using a variety of different techniques. May not work in all browsers. =item B<request_method()> Returns the method used to access your script, usually one of 'POST', 'GET' or 'HEAD'. If running from the command line it will be undef. =item B<content_type()> Returns the content_type of data submitted in a POST, generally multipart/form-data or application/x-www-form-urlencoded =item B<http()> Called with no arguments returns the list of HTTP environment variables, including such things as HTTP_USER_AGENT, HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the like-named HTTP header fields in the request. Called with the name of an HTTP header field, returns its value. Capitalization and the use of hyphens versus underscores are not significant. For example, all three of these examples are equivalent: my $requested_language = $q->http('Accept-language'); my $requested_language = $q->http('Accept_language'); my $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE'); =item B<https()> The same as I<http()>, but operates on the HTTPS environment variables present when the SSL protocol is in effect. Can be used to determine whether SSL is turned on. =back =head1 USING NPH SCRIPTS NPH, or "no-parsed-header", scripts bypass the server completely by sending the complete HTTP header directly to the browser. This has slight performance benefits, but is of most use for taking advantage of HTTP extensions that are not directly supported by your server, such as server push and PICS headers. Servers use a variety of conventions for designating CGI scripts as NPH. Many Unix servers look at the beginning of the script's name for the prefix "nph-". The Macintosh WebSTAR server and Microsoft's Internet Information Server, in contrast, try to decide whether a program is an NPH script by examining the first line of script output. CGI.pm supports NPH scripts with a special NPH mode. When in this mode, CGI.pm will output the necessary extra header information when the header() and redirect() methods are called. The Microsoft Internet Information Server requires NPH mode. As of version 2.30, CGI.pm will automatically detect when the script is running under IIS and put itself into this mode. You do not need to do this manually, although it won't hurt anything if you do. =over 4 =item In the B<use> statement Simply add the "-nph" pragma to the list of symbols to be imported into your script: use CGI qw(:standard -nph) =item By calling the B<nph()> method: Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program. CGI->nph(1) =item By using B<-nph> parameters in the B<header()> and B<redirect()> statements: print header(-nph=>1); =back =head1 SERVER PUSH CGI.pm provides four simple functions for producing multipart documents of the type needed to implement server push. These functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To import these into your namespace, you must import the ":push" set. You are also advised to put the script into NPH mode and to set $| to 1 to avoid buffering problems. Here is a simple script that demonstrates server push: #!/usr/bin/env perl use strict; use warnings; use CGI qw/:push -nph/; $| = 1; print multipart_init( -boundary=>'----here we go!' ); for (0 .. 4) { print multipart_start( -type=>'text/plain' ), "The current time is ",scalar( localtime ),"\n"; if ($_ < 4) { print multipart_end(); } else { print multipart_final(); } sleep 1; } This script initializes server push by calling B<multipart_init()>. It then enters a loop in which it begins a new multipart section by calling B<multipart_start()>, prints the current local time, and ends a multipart section with B<multipart_end()>. It then sleeps a second, and begins again. On the final iteration, it ends the multipart section with B<multipart_final()> rather than with B<multipart_end()>. =over 4 =item multipart_init() multipart_init( -boundary => $boundary, -charset => $charset ); Initialize the multipart system. The -boundary argument specifies what MIME boundary string to use to separate parts of the document. If not provided, CGI.pm chooses a reasonable boundary for you. The -charset provides the character set, if not provided this will default to ISO-8859-1 =item multipart_start() multipart_start( -type => $type, -charset => $charset ); Start a new part of the multipart document using the specified MIME type and charset. If not specified, text/html ISO-8859-1 is assumed. =item multipart_end() multipart_end() End a part. You must remember to call multipart_end() once for each multipart_start(), except at the end of the last part of the multipart document when multipart_final() should be called instead of multipart_end(). =item multipart_final() multipart_final() End all parts. You should call multipart_final() rather than multipart_end() at the end of the last part of the multipart document. =back Users interested in server push applications should also have a look at the CGI::Push module. =head1 AVOIDING DENIAL OF SERVICE ATTACKS A potential problem with CGI.pm is that, by default, it attempts to process form POSTings no matter how large they are. A wily hacker could attack your site by sending a CGI script a huge POST of many gigabytes. CGI.pm will attempt to read the entire POST into a variable, growing hugely in size until it runs out of memory. While the script attempts to allocate the memory the system may slow down dramatically. This is a form of denial of service attack. Another possible attack is for the remote user to force CGI.pm to accept a huge file upload. CGI.pm will accept the upload and store it in a temporary directory even if your script doesn't expect to receive an uploaded file. CGI.pm will delete the file automatically when it terminates, but in the meantime the remote user may have filled up the server's disk space, causing problems for other programs. The best way to avoid denial of service attacks is to limit the amount of memory, CPU time and disk space that CGI scripts can use. Some Web servers come with built-in facilities to accomplish this. In other cases, you can use the shell I<limit> or I<ulimit> commands to put ceilings on CGI resource usage. CGI.pm also has some simple built-in protections against denial of service attacks, but you must activate them before you can use them. These take the form of two global variables in the CGI name space: =over 4 =item B<$CGI::POST_MAX> If set to a non-negative integer, this variable puts a ceiling on the size of POSTings, in bytes. If CGI.pm detects a POST that is greater than the ceiling, it will immediately exit with an error message. This value will affect both ordinary POSTs and multipart POSTs, meaning that it limits the maximum size of file uploads as well. You should set this to a reasonably high value, such as 10 megabytes. =item B<$CGI::DISABLE_UPLOADS> If set to a non-zero value, this will disable file uploads completely. Other fill-out form values will work as usual. =back To use these variables, set the variable at the top of the script, right after the "use" statement: #!/usr/bin/env perl use strict; use warnings; use CGI; $CGI::POST_MAX = 1024 * 1024 * 10; # max 10MB posts $CGI::DISABLE_UPLOADS = 1; # no uploads An attempt to send a POST larger than $POST_MAX bytes will cause I<param()> to return an empty CGI parameter list. You can test for this event by checking I<cgi_error()>, either after you create the CGI object or, if you are using the function-oriented interface, call <param()> for the first time. If the POST was intercepted, then cgi_error() will return the message "413 POST too large". This error message is actually defined by the HTTP protocol, and is designed to be returned to the browser as the CGI script's status code. For example: my $uploaded_file = $q->param('upload'); if ( !$uploaded_file && $q->cgi_error() ) { print $q->header( -status => $q->cgi_error() ); exit 0; } However it isn't clear that any browser currently knows what to do with this status code. It might be better just to create a page that warns the user of the problem. =head1 MODULE FLAGS There are a number of global module flags which affect how CGI.pm operates. =over 4 =item B<$CGI::APPEND_QUERY_STRING> If set to a non-zero value, this will add query string parameters to a POST forms parameters hence allowing I<param()> to return values from the query string as well as from the decoded POST request instead of having to use I<url_param> instead. This makes it easier to get the value of a parameter when you don't know the source. =back =head1 COMPATIBILITY WITH CGI-LIB.PL To make it easier to port existing programs that use cgi-lib.pl the compatibility routine "ReadParse" is provided. Porting is simple: OLD VERSION require "cgi-lib.pl"; &ReadParse; print "The value of the antique is $in{antique}.\n"; NEW VERSION use CGI; CGI::ReadParse(); print "The value of the antique is $in{antique}.\n"; CGI.pm's ReadParse() routine creates a tied variable named %in, which can be accessed to obtain the query variables. Like ReadParse, you can also provide your own variable. Infrequently used features of ReadParse, such as the creation of @in and $in variables, are not supported. Once you use ReadParse, you can retrieve the query object itself this way: my $q = $in{CGI}; This allows you to start using the more interesting features of CGI.pm without rewriting your old scripts from scratch. An even simpler way to mix cgi-lib calls with CGI.pm calls is to import both the C<:cgi-lib> and C<:standard> method: use CGI qw(:cgi-lib :standard); &ReadParse; print "The price of your purchase is $in{price}.\n"; print textfield(-name=>'price', -default=>'$1.99'); =head2 Cgi-lib functions that are available in CGI.pm In compatibility mode, the following cgi-lib.pl functions are available for your use: ReadParse() PrintHeader() SplitParam() MethGet() MethPost() =head1 LICENSE The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is distributed under the Artistic License 2.0. It is currently maintained by Lee Johnson (LEEJO) with help from many contributors. =head1 CREDITS Thanks very much to: =over 4 =item Mark Stosberg (mark@stosberg.com) =item Matt Heffron (heffron@falstaff.css.beckman.com) =item James Taylor (james.taylor@srs.gov) =item Scott Anguish (sanguish@digifix.com) =item Mike Jewell (mlj3u@virginia.edu) =item Timothy Shimmin (tes@kbs.citri.edu.au) =item Joergen Haegg (jh@axis.se) =item Laurent Delfosse (delfosse@delfosse.com) =item Richard Resnick (applepi1@aol.com) =item Craig Bishop (csb@barwonwater.vic.gov.au) =item Tony Curtis (tc@vcpc.univie.ac.at) =item Tim Bunce (Tim.Bunce@ig.co.uk) =item Tom Christiansen (tchrist@convex.com) =item Andreas Koenig (k@franz.ww.TU-Berlin.DE) =item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au) =item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu) =item Stephen Dahmen (joyfire@inxpress.net) =item Ed Jordan (ed@fidalgo.net) =item David Alan Pisoni (david@cnation.com) =item Doug MacEachern (dougm@opengroup.org) =item Robin Houston (robin@oneworld.org) =item ...and many many more... for suggestions and bug fixes. =back =head1 BUGS Address bug reports and comments to: L<https://github.com/leejo/CGI.pm/issues> See the L<https://github.com/leejo/CGI.pm/blob/master/CONTRIBUTING.md> file for information on raising issues and contributing The original bug tracker can be found at: L<https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm> =head1 SEE ALSO L<CGI::Carp> - provides L<Carp> implementation tailored to the CGI environment. L<CGI::Fast> - supports running CGI applications under FastCGI =cut PK ! �Wy�� � Types/Serialiser/Error.pmnu �[��� =head1 NAME Types::Serialiser::Error - dummy module for Types::Serialiser =head1 SYNOPSIS # do not "use" yourself =head1 DESCRIPTION This module exists only to provide overload resolution for Storable and similar modules that assume that class name equals module name. See L<Types::Serialiser> for more info about this class. =cut use Types::Serialiser (); =head1 AUTHOR Marc Lehmann <schmorp@schmorp.de> http://home.schmorp.de/ =cut 1 PK ! ?��# �# Types/Serialiser.pmnu �[��� =head1 NAME Types::Serialiser - simple data types for common serialisation formats =encoding utf-8 =head1 SYNOPSIS =head1 DESCRIPTION This module provides some extra datatypes that are used by common serialisation formats such as JSON or CBOR. The idea is to have a repository of simple/small constants and containers that can be shared by different implementations so they become interoperable between each other. =cut package Types::Serialiser; use common::sense; # required to suppress annoying warnings our $VERSION = '1.01'; =head1 SIMPLE SCALAR CONSTANTS Simple scalar constants are values that are overloaded to act like simple Perl values, but have (class) type to differentiate them from normal Perl scalars. This is necessary because these have different representations in the serialisation formats. In the following, functions with zero or one arguments have a prototype of C<()> and C<($)>, respectively, so act as constants and unary operators. =head2 BOOLEANS (Types::Serialiser::Boolean class) This type has only two instances, true and false. A natural representation for these in Perl is C<1> and C<0>, but serialisation formats need to be able to differentiate between them and mere numbers. =over 4 =item $Types::Serialiser::true, Types::Serialiser::true This value represents the "true" value. In most contexts is acts like the number C<1>. It is up to you whether you use the variable form (C<$Types::Serialiser::true>) or the constant form (C<Types::Serialiser::true>). The constant is represented as a reference to a scalar containing C<1> - implementations are allowed to directly test for this. =item $Types::Serialiser::false, Types::Serialiser::false This value represents the "false" value. In most contexts is acts like the number C<0>. It is up to you whether you use the variable form (C<$Types::Serialiser::false>) or the constant form (C<Types::Serialiser::false>). The constant is represented as a reference to a scalar containing C<0> - implementations are allowed to directly test for this. =item Types::Serialiser::as_bool $value Converts a Perl scalar into a boolean, which is useful syntactic sugar. Strictly equivalent to: $value ? $Types::Serialiser::true : $Types::Serialiser::false =item $is_bool = Types::Serialiser::is_bool $value Returns true iff the C<$value> is either C<$Types::Serialiser::true> or C<$Types::Serialiser::false>. For example, you could differentiate between a perl true value and a C<Types::Serialiser::true> by using this: $value && Types::Serialiser::is_bool $value =item $is_true = Types::Serialiser::is_true $value Returns true iff C<$value> is C<$Types::Serialiser::true>. =item $is_false = Types::Serialiser::is_false $value Returns false iff C<$value> is C<$Types::Serialiser::false>. =back =head2 ERROR (Types::Serialiser::Error class) This class has only a single instance, C<error>. It is used to signal an encoding or decoding error. In CBOR for example, and object that couldn't be encoded will be represented by a CBOR undefined value, which is represented by the error value in Perl. =over 4 =item $Types::Serialiser::error, Types::Serialiser::error This value represents the "error" value. Accessing values of this type will throw an exception. The constant is represented as a reference to a scalar containing C<undef> - implementations are allowed to directly test for this. =item $is_error = Types::Serialiser::is_error $value Returns false iff C<$value> is C<$Types::Serialiser::error>. =back =cut BEGIN { # for historical reasons, and to avoid extra dependencies in JSON::PP, # we alias *Types::Serialiser::Boolean with JSON::PP::Boolean. package JSON::PP::Boolean; *Types::Serialiser::Boolean:: = *JSON::PP::Boolean::; } { # this must done before blessing to work around bugs # in perl < 5.18 (it seems to be fixed in 5.18). package Types::Serialiser::BooleanBase; use overload "0+" => sub { ${$_[0]} }, "++" => sub { $_[0] = ${$_[0]} + 1 }, "--" => sub { $_[0] = ${$_[0]} - 1 }, fallback => 1; @Types::Serialiser::Boolean::ISA = Types::Serialiser::BooleanBase::; } our $true = do { bless \(my $dummy = 1), Types::Serialiser::Boolean:: }; our $false = do { bless \(my $dummy = 0), Types::Serialiser::Boolean:: }; our $error = do { bless \(my $dummy ), Types::Serialiser::Error:: }; sub true () { $true } sub false () { $false } sub error () { $error } sub as_bool($) { $_[0] ? $true : $false } sub is_bool ($) { UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: } sub is_true ($) { $_[0] && UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: } sub is_false ($) { !$_[0] && UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: } sub is_error ($) { UNIVERSAL::isa $_[0], Types::Serialiser::Error:: } package Types::Serialiser::Error; sub error { require Carp; Carp::croak ("caught attempt to use the Types::Serialiser::error value"); }; use overload "0+" => \&error, "++" => \&error, "--" => \&error, fallback => 1; =head1 NOTES FOR XS USERS The recommended way to detect whether a scalar is one of these objects is to check whether the stash is the C<Types::Serialiser::Boolean> or C<Types::Serialiser::Error> stash, and then follow the scalar reference to see if it's C<1> (true), C<0> (false) or C<undef> (error). While it is possible to use an isa test, directly comparing stash pointers is faster and guaranteed to work. For historical reasons, the C<Types::Serialiser::Boolean> stash is just an alias for C<JSON::PP::Boolean>. When printed, the classname with usually be C<JSON::PP::Boolean>, but isa tests and stash pointer comparison will normally work correctly (i.e. Types::Serialiser::true ISA JSON::PP::Boolean, but also ISA Types::Serialiser::Boolean). =head1 A GENERIC OBJECT SERIALIATION PROTOCOL This section explains the object serialisation protocol used by L<CBOR::XS>. It is meant to be generic enough to support any kind of generic object serialiser. This protocol is called "the Types::Serialiser object serialisation protocol". =head2 ENCODING When the encoder encounters an object that it cannot otherwise encode (for example, L<CBOR::XS> can encode a few special types itself, and will first attempt to use the special C<TO_CBOR> serialisation protocol), it will look up the C<FREEZE> method on the object. Note that the C<FREEZE> method will normally be called I<during> encoding, and I<MUST NOT> change the data structure that is being encoded in any way, or it might cause memory corruption or worse. If it exists, it will call it with two arguments: the object to serialise, and a constant string that indicates the name of the data model. For example L<CBOR::XS> uses C<CBOR>, and the L<JSON> and L<JSON::XS> modules (or any other JSON serialiser), would use C<JSON> as second argument. The C<FREEZE> method can then return zero or more values to identify the object instance. The serialiser is then supposed to encode the class name and all of these return values (which must be encodable in the format) using the relevant form for Perl objects. In CBOR for example, there is a registered tag number for encoded perl objects. The values that C<FREEZE> returns must be serialisable with the serialiser that calls it. Therefore, it is recommended to use simple types such as strings and numbers, and maybe array references and hashes (basically, the JSON data model). You can always use a more complex format for a specific data model by checking the second argument, the data model. The "data model" is not the same as the "data format" - the data model indicates what types and kinds of return values can be returned from C<FREEZE>. For example, in C<CBOR> it is permissible to return tagged CBOR values, while JSON does not support these at all, so C<JSON> would be a valid (but too limited) data model name for C<CBOR::XS>. similarly, a serialising format that supports more or less the same data model as JSON could use C<JSON> as data model without losing anything. =head2 DECODING When the decoder then encounters such an encoded perl object, it should look up the C<THAW> method on the stored classname, and invoke it with the classname, the constant string to identify the data model/data format, and all the return values returned by C<FREEZE>. =head2 EXAMPLES See the C<OBJECT SERIALISATION> section in the L<CBOR::XS> manpage for more details, an example implementation, and code examples. Here is an example C<FREEZE>/C<THAW> method pair: sub My::Object::FREEZE { my ($self, $model) = @_; ($self->{type}, $self->{id}, $self->{variant}) } sub My::Object::THAW { my ($class, $model, $type, $id, $variant) = @_; $class->new (type => $type, id => $id, variant => $variant) } =head1 BUGS The use of L<overload> makes this module much heavier than it should be (on my system, this module: 4kB RSS, overload: 260kB RSS). =head1 SEE ALSO Currently, L<JSON::XS> and L<CBOR::XS> use these types. =head1 AUTHOR Marc Lehmann <schmorp@schmorp.de> http://home.schmorp.de/ =cut 1 PK ! ӣ !& !& URI/file.pmnu �[��� package URI::file; use strict; use warnings; use parent 'URI::_generic'; our $VERSION = '5.10'; use URI::Escape qw(uri_unescape); our $DEFAULT_AUTHORITY = ""; # Map from $^O values to implementation classes. The Unix # class is the default. our %OS_CLASS = ( os2 => "OS2", mac => "Mac", MacOS => "Mac", MSWin32 => "Win32", win32 => "Win32", msdos => "FAT", dos => "FAT", qnx => "QNX", ); sub os_class { my($OS) = shift || $^O; my $class = "URI::file::" . ($OS_CLASS{$OS} || "Unix"); no strict 'refs'; unless (%{"$class\::"}) { eval "require $class"; die $@ if $@; } $class; } sub host { uri_unescape(shift->authority(@_)) } sub new { my($class, $path, $os) = @_; os_class($os)->new($path); } sub new_abs { my $class = shift; my $file = $class->new(@_); return $file->abs($class->cwd) unless $$file =~ /^file:/; $file; } sub cwd { my $class = shift; require Cwd; my $cwd = Cwd::cwd(); $cwd = VMS::Filespec::unixpath($cwd) if $^O eq 'VMS'; $cwd = $class->new($cwd); $cwd .= "/" unless substr($cwd, -1, 1) eq "/"; $cwd; } sub canonical { my $self = shift; my $other = $self->SUPER::canonical; my $scheme = $other->scheme; my $auth = $other->authority; return $other if !defined($scheme) && !defined($auth); # relative if (!defined($auth) || $auth eq "" || lc($auth) eq "localhost" || (defined($DEFAULT_AUTHORITY) && lc($auth) eq lc($DEFAULT_AUTHORITY)) ) { # avoid cloning if $auth already match if ((defined($auth) || defined($DEFAULT_AUTHORITY)) && (!defined($auth) || !defined($DEFAULT_AUTHORITY) || $auth ne $DEFAULT_AUTHORITY) ) { $other = $other->clone if $self == $other; $other->authority($DEFAULT_AUTHORITY); } } $other; } sub file { my($self, $os) = @_; os_class($os)->file($self); } sub dir { my($self, $os) = @_; os_class($os)->dir($self); } 1; __END__ =head1 NAME URI::file - URI that maps to local file names =head1 SYNOPSIS use URI::file; $u1 = URI->new("file:/foo/bar"); $u2 = URI->new("foo/bar", "file"); $u3 = URI::file->new($path); $u4 = URI::file->new("c:\\windows\\", "win32"); $u1->file; $u1->file("mac"); =head1 DESCRIPTION The C<URI::file> class supports C<URI> objects belonging to the I<file> URI scheme. This scheme allows us to map the conventional file names found on various computer systems to the URI name space. An old specification of the I<file> URI scheme is found in RFC 1738. Some older background information is also in RFC 1630. There are no newer specifications as far as I know. If you simply want to construct I<file> URI objects from URI strings, use the normal C<URI> constructor. If you want to construct I<file> URI objects from the actual file names used by various systems, then use one of the following C<URI::file> constructors: =over 4 =item $u = URI::file->new( $filename, [$os] ) Maps a file name to the I<file:> URI name space, creates a URI object and returns it. The $filename is interpreted as belonging to the indicated operating system ($os), which defaults to the value of the $^O variable. The $filename can be either absolute or relative, and the corresponding type of URI object for $os is returned. =item $u = URI::file->new_abs( $filename, [$os] ) Same as URI::file->new, but makes sure that the URI returned represents an absolute file name. If the $filename argument is relative, then the name is resolved relative to the current directory, i.e. this constructor is really the same as: URI::file->new($filename)->abs(URI::file->cwd); =item $u = URI::file->cwd Returns a I<file> URI that represents the current working directory. See L<Cwd>. =back The following methods are supported for I<file> URI (in addition to the common and generic methods described in L<URI>): =over 4 =item $u->file( [$os] ) Returns a file name. It maps from the URI name space to the file name space of the indicated operating system. It might return C<undef> if the name can not be represented in the indicated file system. =item $u->dir( [$os] ) Some systems use a different form for names of directories than for plain files. Use this method if you know you want to use the name for a directory. =back The C<URI::file> module can be used to map generic file names to names suitable for the current system. As such, it can work as a nice replacement for the C<File::Spec> module. For instance, the following code translates the UNIX-style file name F<Foo/Bar.pm> to a name suitable for the local system: $file = URI::file->new("Foo/Bar.pm", "unix")->file; die "Can't map filename Foo/Bar.pm for $^O" unless defined $file; open(FILE, $file) || die "Can't open '$file': $!"; # do something with FILE =head1 MAPPING NOTES Most computer systems today have hierarchically organized file systems. Mapping the names used in these systems to the generic URI syntax allows us to work with relative file URIs that behave as they should when resolved using the generic algorithm for URIs (specified in RFC 2396). Mapping a file name to the generic URI syntax involves mapping the path separator character to "/" and encoding any reserved characters that appear in the path segments of the file name. If path segments consisting of the strings "." or ".." have a different meaning than what is specified for generic URIs, then these must be encoded as well. If the file system has device, volume or drive specifications as the root of the name space, then it makes sense to map them to the authority field of the generic URI syntax. This makes sure that relative URIs can not be resolved "above" them, i.e. generally how relative file names work in those systems. Another common use of the authority field is to encode the host on which this file name is valid. The host name "localhost" is special and generally has the same meaning as a missing or empty authority field. This use is in conflict with using it as a device specification, but can often be resolved for device specifications having characters not legal in plain host names. File name to URI mapping in normally not one-to-one. There are usually many URIs that map to any given file name. For instance, an authority of "localhost" maps the same as a URI with a missing or empty authority. Example 1: The Mac classic (Mac OS 9 and earlier) used ":" as path separator, but not in the same way as a generic URI. ":foo" was a relative name. "foo:bar" was an absolute name. Also, path segments could contain the "/" character as well as the literal "." or "..". So the mapping looks like this: Mac classic URI ---------- ------------------- :foo:bar <==> foo/bar : <==> ./ ::foo:bar <==> ../foo/bar ::: <==> ../../ foo:bar <==> file:/foo/bar foo:bar: <==> file:/foo/bar/ .. <==> %2E%2E <undef> <== / foo/ <== file:/foo%2F ./foo.txt <== file:/.%2Ffoo.txt Note that if you want a relative URL, you *must* begin the path with a :. Any path that begins with [^:] is treated as absolute. Example 2: The UNIX file system is easy to map, as it uses the same path separator as URIs, has a single root, and segments of "." and ".." have the same meaning. URIs that have the character "\0" or "/" as part of any path segment can not be turned into valid UNIX file names. UNIX URI ---------- ------------------ foo/bar <==> foo/bar /foo/bar <==> file:/foo/bar /foo/bar <== file://localhost/foo/bar file: ==> ./file: <undef> <== file:/fo%00/bar / <==> file:/ =cut RFC 1630 [...] There is clearly a danger of confusion that a link made to a local file should be followed by someone on a different system, with unexpected and possibly harmful results. Therefore, the convention is that even a "file" URL is provided with a host part. This allows a client on another system to know that it cannot access the file system, or perhaps to use some other local mechanism to access the file. The special value "localhost" is used in the host field to indicate that the filename should really be used on whatever host one is. This for example allows links to be made to files which are distributed on many machines, or to "your unix local password file" subject of course to consistency across the users of the data. A void host field is equivalent to "localhost". =head1 CONFIGURATION VARIABLES The following configuration variables influence how the class and its methods behave: =over =item %URI::file::OS_CLASS This hash maps OS identifiers to implementation classes. You might want to add or modify this if you want to plug in your own file handler class. Normally the keys should match the $^O values in use. If there is no mapping then the "Unix" implementation is used. =item $URI::file::DEFAULT_AUTHORITY This determine what "authority" string to include in absolute file URIs. It defaults to "". If you prefer verbose URIs you might set it to be "localhost". Setting this value to C<undef> force behaviour compatible to URI v1.31 and earlier. In this mode host names in UNC paths and drive letters are mapped to the authority component on Windows, while we produce authority-less URIs on Unix. =back =head1 SEE ALSO L<URI>, L<File::Spec>, L<perlport> =head1 COPYRIGHT Copyright 1995-1998,2004 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! � LT� � URI/http.pmnu �[��� package URI::http; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::_server'; sub default_port { 80 } sub canonical { my $self = shift; my $other = $self->SUPER::canonical; my $slash_path = defined($other->authority) && !length($other->path) && !defined($other->query); if ($slash_path) { $other = $other->clone if $other == $self; $other->path("/"); } $other; } 1; PK ! ���9� � URI/_punycode.pmnu �[��� package URI::_punycode; use strict; use warnings; our $VERSION = '5.10'; use Exporter 'import'; our @EXPORT = qw(encode_punycode decode_punycode); use integer; our $DEBUG = 0; use constant BASE => 36; use constant TMIN => 1; use constant TMAX => 26; use constant SKEW => 38; use constant DAMP => 700; use constant INITIAL_BIAS => 72; use constant INITIAL_N => 128; my $Delimiter = chr 0x2D; my $BasicRE = qr/[\x00-\x7f]/; sub _croak { require Carp; Carp::croak(@_); } sub digit_value { my $code = shift; return ord($code) - ord("A") if $code =~ /[A-Z]/; return ord($code) - ord("a") if $code =~ /[a-z]/; return ord($code) - ord("0") + 26 if $code =~ /[0-9]/; return; } sub code_point { my $digit = shift; return $digit + ord('a') if 0 <= $digit && $digit <= 25; return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36; die 'NOT COME HERE'; } sub adapt { my($delta, $numpoints, $firsttime) = @_; $delta = $firsttime ? $delta / DAMP : $delta / 2; $delta += $delta / $numpoints; my $k = 0; while ($delta > ((BASE - TMIN) * TMAX) / 2) { $delta /= BASE - TMIN; $k += BASE; } return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW)); } sub decode_punycode { my $code = shift; my $n = INITIAL_N; my $i = 0; my $bias = INITIAL_BIAS; my @output; if ($code =~ s/(.*)$Delimiter//o) { push @output, map ord, split //, $1; return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o; } while ($code) { my $oldi = $i; my $w = 1; LOOP: for (my $k = BASE; 1; $k += BASE) { my $cp = substr($code, 0, 1, ''); my $digit = digit_value($cp); defined $digit or return _croak("invalid punycode input"); $i += $digit * $w; my $t = ($k <= $bias) ? TMIN : ($k >= $bias + TMAX) ? TMAX : $k - $bias; last LOOP if $digit < $t; $w *= (BASE - $t); } $bias = adapt($i - $oldi, @output + 1, $oldi == 0); warn "bias becomes $bias" if $DEBUG; $n += $i / (@output + 1); $i = $i % (@output + 1); splice(@output, $i, 0, $n); warn join " ", map sprintf('%04x', $_), @output if $DEBUG; $i++; } return join '', map chr, @output; } sub encode_punycode { my $input = shift; my @input = split //, $input; my $n = INITIAL_N; my $delta = 0; my $bias = INITIAL_BIAS; my @output; my @basic = grep /$BasicRE/, @input; my $h = my $b = @basic; push @output, @basic; push @output, $Delimiter if $b && $h < @input; warn "basic codepoints: (@output)" if $DEBUG; while ($h < @input) { my $m = min(grep { $_ >= $n } map ord, @input); warn sprintf "next code point to insert is %04x", $m if $DEBUG; $delta += ($m - $n) * ($h + 1); $n = $m; for my $i (@input) { my $c = ord($i); $delta++ if $c < $n; if ($c == $n) { my $q = $delta; LOOP: for (my $k = BASE; 1; $k += BASE) { my $t = ($k <= $bias) ? TMIN : ($k >= $bias + TMAX) ? TMAX : $k - $bias; last LOOP if $q < $t; my $cp = code_point($t + (($q - $t) % (BASE - $t))); push @output, chr($cp); $q = ($q - $t) / (BASE - $t); } push @output, chr(code_point($q)); $bias = adapt($delta, $h + 1, $h == $b); warn "bias becomes $bias" if $DEBUG; $delta = 0; $h++; } } $delta++; $n++; } return join '', @output; } sub min { my $min = shift; for (@_) { $min = $_ if $_ <= $min } return $min; } 1; __END__ =encoding utf8 =head1 NAME URI::_punycode - encodes Unicode string in Punycode =head1 SYNOPSIS use strict; use warnings; use utf8; use URI::_punycode qw(encode_punycode decode_punycode); # encode a unicode string my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g $punycode = encode_punycode('bücher'); # bcher-kva $punycode = encode_punycode('他们为什么不说中文'); # ihqwcrb4cv8a8dqg056pqjye # decode a punycode string back into a unicode string my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net $unicode = decode_punycode('bcher-kva'); # bücher $unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文 =head1 DESCRIPTION L<URI::_punycode> is a module to encode / decode Unicode strings into L<Punycode|https://tools.ietf.org/html/rfc3492>, an efficient encoding of Unicode for use with L<IDNA|https://tools.ietf.org/html/rfc5890>. =head1 FUNCTIONS All functions throw exceptions on failure. You can C<catch> them with L<Syntax::Keyword::Try> or L<Try::Tiny>. The following functions are exported by default. =head2 encode_punycode my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g $punycode = encode_punycode('bücher'); # bcher-kva $punycode = encode_punycode('他们为什么不说中文') # ihqwcrb4cv8a8dqg056pqjye Takes a Unicode string (UTF8-flagged variable) and returns a Punycode encoding for it. =head2 decode_punycode my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net $unicode = decode_punycode('bcher-kva'); # bücher $unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文 Takes a Punycode encoding and returns original Unicode string. =head1 AUTHOR Tatsuhiko Miyagawa <F<miyagawa@bulknews.net>> is the author of L<IDNA::Punycode> which was the basis for this module. =head1 SEE ALSO L<IDNA::Punycode>, L<RFC 3492|https://tools.ietf.org/html/rfc3492>, L<RFC 5891|https://tools.ietf.org/html/rfc5891> =head1 COPYRIGHT AND LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! J�2t� � URI/ldapi.pmnu �[��� package URI::ldapi; use strict; use warnings; our $VERSION = '5.10'; use parent qw(URI::_ldap URI::_generic); use URI::Escape (); sub un_path { my $self = shift; my $old = URI::Escape::uri_unescape($self->authority); if (@_) { my $p = shift; $p =~ s/:/%3A/g; $p =~ s/\@/%40/g; $self->authority($p); } return $old; } sub _nonldap_canonical { my $self = shift; $self->URI::_generic::canonical(@_); } 1; PK ! hV�� � URI/sips.pmnu �[��� package URI::sips; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::sip'; sub default_port { 5061 } sub secure { 1 } 1; PK ! �l�� � URI/telnet.pmnu �[��� package URI::telnet; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::_login'; sub default_port { 23 } 1; PK ! �� � URI/pop.pmnu �[��� package URI::pop; # RFC 2384 use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::_server'; use URI::Escape qw(uri_unescape); sub default_port { 110 } #pop://<user>;auth=<auth>@<host>:<port> sub user { my $self = shift; my $old = $self->userinfo; if (@_) { my $new_info = $old; $new_info = "" unless defined $new_info; $new_info =~ s/^[^;]*//; my $new = shift; if (!defined($new) && !length($new_info)) { $self->userinfo(undef); } else { $new = "" unless defined $new; $new =~ s/%/%25/g; $new =~ s/;/%3B/g; $self->userinfo("$new$new_info"); } } return undef unless defined $old; $old =~ s/;.*//; return uri_unescape($old); } sub auth { my $self = shift; my $old = $self->userinfo; if (@_) { my $new = $old; $new = "" unless defined $new; $new =~ s/(^[^;]*)//; my $user = $1; $new =~ s/;auth=[^;]*//i; my $auth = shift; if (defined $auth) { $auth =~ s/%/%25/g; $auth =~ s/;/%3B/g; $new = ";AUTH=$auth$new"; } $self->userinfo("$user$new"); } return undef unless defined $old; $old =~ s/^[^;]*//; return uri_unescape($1) if $old =~ /;auth=(.*)/i; return; } 1; PK ! h-�� � URI/file/FAT.pmnu �[��� package URI::file::FAT; use strict; use warnings; use parent 'URI::file::Win32'; our $VERSION = '5.10'; sub fix_path { shift; # class for (@_) { # turn it into 8.3 names my @p = map uc, split(/\./, $_, -1); return if @p > 2; # more than 1 dot is not allowed @p = ("") unless @p; # split bug? (returns nothing when splitting "") $_ = substr($p[0], 0, 8); if (@p > 1) { my $ext = substr($p[1], 0, 3); $_ .= ".$ext" if length $ext; } } 1; # ok } 1; PK ! �JL� � URI/file/Unix.pmnu �[��� package URI::file::Unix; use strict; use warnings; use parent 'URI::file::Base'; use URI::Escape qw(uri_unescape); our $VERSION = '5.10'; sub _file_extract_path { my($class, $path) = @_; # tidy path $path =~ s,//+,/,g; $path =~ s,(/\.)+/,/,g; $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:" return $path; } sub _file_is_absolute { my($class, $path) = @_; return $path =~ m,^/,; } sub file { my $class = shift; my $uri = shift; my @path; my $auth = $uri->authority; if (defined($auth)) { if (lc($auth) ne "localhost" && $auth ne "") { $auth = uri_unescape($auth); unless ($class->_file_is_localhost($auth)) { push(@path, "", "", $auth); } } } my @ps = $uri->path_segments; shift @ps if @path; push(@path, @ps); for (@path) { # Unix file/directory names are not allowed to contain '\0' or '/' return undef if /\0/; return undef if /\//; # should we really? } return join("/", @path); } 1; PK ! <��(� � URI/file/Mac.pmnu �[��� package URI::file::Mac; use strict; use warnings; use parent 'URI::file::Base'; use URI::Escape qw(uri_unescape); our $VERSION = '5.10'; sub _file_extract_path { my $class = shift; my $path = shift; my @pre; if ($path =~ s/^(:+)//) { if (length($1) == 1) { @pre = (".") unless length($path); } else { @pre = ("..") x (length($1) - 1); } } else { #absolute $pre[0] = ""; } my $isdir = ($path =~ s/:$//); $path =~ s,([%/;]), URI::Escape::escape_char($1),eg; my @path = split(/:/, $path, -1); for (@path) { if ($_ eq "." || $_ eq "..") { $_ = "%2E" x length($_); } $_ = ".." unless length($_); } push (@path,"") if $isdir; (join("/", @pre, @path), 1); } sub file { my $class = shift; my $uri = shift; my @path; my $auth = $uri->authority; if (defined $auth) { if (lc($auth) ne "localhost" && $auth ne "") { my $u_auth = uri_unescape($auth); if (!$class->_file_is_localhost($u_auth)) { # some other host (use it as volume name) @path = ("", $auth); # XXX or just return to make it illegal; } } } my @ps = split("/", $uri->path, -1); shift @ps if @path; push(@path, @ps); my $pre = ""; if (!@path) { return; # empty path; XXX return ":" instead? } elsif ($path[0] eq "") { # absolute shift(@path); if (@path == 1) { return if $path[0] eq ""; # not root directory push(@path, ""); # volume only, effectively append ":" } @ps = @path; @path = (); my $part; for (@ps) { #fix up "." and "..", including interior, in relatives next if $_ eq "."; $part = $_ eq ".." ? "" : $_; push(@path,$part); } if ($ps[-1] eq "..") { #if this happens, we need another : push(@path,""); } } else { $pre = ":"; @ps = @path; @path = (); my $part; for (@ps) { #fix up "." and "..", including interior, in relatives next if $_ eq "."; $part = $_ eq ".." ? "" : $_; push(@path,$part); } if ($ps[-1] eq "..") { #if this happens, we need another : push(@path,""); } } return unless $pre || @path; for (@path) { s/;.*//; # get rid of parameters #return unless length; # XXX $_ = uri_unescape($_); return if /\0/; return if /:/; # Should we? } $pre . join(":", @path); } sub dir { my $class = shift; my $path = $class->file(@_); return unless defined $path; $path .= ":" unless $path =~ /:$/; $path; } 1; PK ! �{{�1 1 URI/file/OS2.pmnu �[��� package URI::file::OS2; use strict; use warnings; use parent 'URI::file::Win32'; our $VERSION = '5.10'; # The Win32 version translates k:/foo to file://k:/foo (?!) # We add an empty host sub _file_extract_authority { my $class = shift; return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too? if ($_[0] =~ m#^[a-zA-Z]{1,2}:#) { # allow for ab: drives return ""; } return; } sub file { my $p = &URI::file::Win32::file; return unless defined $p; $p =~ s,\\,/,g; $p; } 1; PK ! C �2� � URI/file/Base.pmnu �[��� package URI::file::Base; use strict; use warnings; use URI::Escape (); our $VERSION = '5.10'; sub new { my $class = shift; my $path = shift; $path = "" unless defined $path; my($auth, $escaped_auth, $escaped_path); ($auth, $escaped_auth) = $class->_file_extract_authority($path); ($path, $escaped_path) = $class->_file_extract_path($path); if (defined $auth) { $auth =~ s,%,%25,g unless $escaped_auth; $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg; $auth = "//$auth"; if (defined $path) { $path = "/$path" unless substr($path, 0, 1) eq "/"; } else { $path = ""; } } else { return undef unless defined $path; $auth = ""; } $path =~ s,([%;?]), URI::Escape::escape_char($1),eg unless $escaped_path; $path =~ s/\#/%23/g; my $uri = $auth . $path; $uri = "file:$uri" if substr($uri, 0, 1) eq "/"; URI->new($uri, "file"); } sub _file_extract_authority { my($class, $path) = @_; return undef unless $class->_file_is_absolute($path); return $URI::file::DEFAULT_AUTHORITY; } sub _file_extract_path { return undef; } sub _file_is_absolute { return 0; } sub _file_is_localhost { shift; # class my $host = lc(shift); return 1 if $host eq "localhost"; eval { require Net::Domain; lc(Net::Domain::hostfqdn() || '') eq $host || lc(Net::Domain::hostname() || '') eq $host; }; } sub file { undef; } sub dir { my $self = shift; $self->file(@_); } 1; PK ! �!�M� � URI/file/Win32.pmnu �[��� package URI::file::Win32; use strict; use warnings; use parent 'URI::file::Base'; use URI::Escape qw(uri_unescape); our $VERSION = '5.10'; sub _file_extract_authority { my $class = shift; return $class->SUPER::_file_extract_authority($_[0]) if defined $URI::file::DEFAULT_AUTHORITY; return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too? if ($_[0] =~ s,^([a-zA-Z]:),,) { my $auth = $1; $auth .= "relative" if $_[0] !~ m,^[\\/],; return $auth; } return undef; } sub _file_extract_path { my($class, $path) = @_; $path =~ s,\\,/,g; #$path =~ s,//+,/,g; $path =~ s,(/\.)+/,/,g; if (defined $URI::file::DEFAULT_AUTHORITY) { $path =~ s,^([a-zA-Z]:),/$1,; } return $path; } sub _file_is_absolute { my($class, $path) = @_; return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],; } sub file { my $class = shift; my $uri = shift; my $auth = $uri->authority; my $rel; # is filename relative to drive specified in authority if (defined $auth) { $auth = uri_unescape($auth); if ($auth =~ /^([a-zA-Z])[:|](relative)?/) { $auth = uc($1) . ":"; $rel++ if $2; } elsif (lc($auth) eq "localhost") { $auth = ""; } elsif (length $auth) { $auth = "\\\\" . $auth; # UNC } } else { $auth = ""; } my @path = $uri->path_segments; for (@path) { return undef if /\0/; return undef if /\//; #return undef if /\\/; # URLs with "\" is not uncommon } return undef unless $class->fix_path(@path); my $path = join("\\", @path); $path =~ s/^\\// if $rel; $path = $auth . $path; $path =~ s,^\\([a-zA-Z])[:|],\u$1:,; return $path; } sub fix_path { 1; } 1; PK ! �y��Q Q URI/file/QNX.pmnu �[��� package URI::file::QNX; use strict; use warnings; use parent 'URI::file::Unix'; our $VERSION = '5.10'; sub _file_extract_path { my($class, $path) = @_; # tidy path $path =~ s,(.)//+,$1/,g; # ^// is correct $path =~ s,(/\.)+/,/,g; $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:" $path; } 1; PK ! T?�k� � URI/rsync.pmnu �[��� package URI::rsync; # http://rsync.samba.org/ # rsync://[USER@]HOST[:PORT]/SRC use strict; use warnings; our $VERSION = '5.10'; use parent qw(URI::_server URI::_userpass); sub default_port { 873 } 1; PK ! ���� � URI/urn/isbn.pmnu �[��� package URI::urn::isbn; # RFC 3187 use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::urn'; use Carp qw(carp); BEGIN { require Business::ISBN; local $^W = 0; # don't warn about dev versions, perl5.004 style warn "Using Business::ISBN version " . Business::ISBN->VERSION . " which is deprecated.\nUpgrade to Business::ISBN version 3.005\n" if Business::ISBN->VERSION < 3.005; } sub _isbn { my $nss = shift; $nss = $nss->nss if ref($nss); my $isbn = Business::ISBN->new($nss); $isbn = undef if $isbn && !$isbn->is_valid; return $isbn; } sub _nss_isbn { my $self = shift; my $nss = $self->nss(@_); my $isbn = _isbn($nss); $isbn = $isbn->as_string if $isbn; return($nss, $isbn); } sub isbn { my $self = shift; my $isbn; (undef, $isbn) = $self->_nss_isbn(@_); return $isbn; } sub isbn_publisher_code { my $isbn = shift->_isbn || return undef; return $isbn->publisher_code; } BEGIN { my $group_method = do { local $^W = 0; # don't warn about dev versions, perl5.004 style Business::ISBN->VERSION >= 2 ? 'group_code' : 'country_code'; }; sub isbn_group_code { my $isbn = shift->_isbn || return undef; return $isbn->$group_method; } } sub isbn_country_code { my $name = (caller(0))[3]; $name =~ s/.*:://; carp "$name is DEPRECATED. Use isbn_group_code instead"; no strict 'refs'; &isbn_group_code; } BEGIN { my $isbn13_method = do { local $^W = 0; # don't warn about dev versions, perl5.004 style Business::ISBN->VERSION >= 2 ? 'as_isbn13' : 'as_ean'; }; sub isbn13 { my $isbn = shift->_isbn || return undef; # Business::ISBN 1.x didn't put hyphens in the EAN, and it was just a string # Business::ISBN 2.0 doesn't do EAN, but it does ISBN-13 objects # and it uses the hyphens, so call as_string with an empty anon array # or, adjust the test and features to say that it comes out with hyphens. my $thingy = $isbn->$isbn13_method; return eval { $thingy->can( 'as_string' ) } ? $thingy->as_string([]) : $thingy; } } sub isbn_as_ean { my $name = (caller(0))[3]; $name =~ s/.*:://; carp "$name is DEPRECATED. Use isbn13 instead"; no strict 'refs'; &isbn13; } sub canonical { my $self = shift; my($nss, $isbn) = $self->_nss_isbn; my $new = $self->SUPER::canonical; return $new unless $nss && $isbn && $nss ne $isbn; $new = $new->clone if $new == $self; $new->nss($isbn); return $new; } 1; PK ! ΄�� URI/urn/oid.pmnu �[��� package URI::urn::oid; # RFC 2061 use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::urn'; sub oid { my $self = shift; my $old = $self->nss; if (@_) { $self->nss(join(".", @_)); } return split(/\./, $old) if wantarray; return $old; } 1; PK ! QV � � URI/QueryParam.pmnu �[��� package URI::QueryParam; use strict; use warnings; our $VERSION = '5.10'; sub URI::_query::query_param { my $self = shift; my @old = $self->query_form; if (@_ == 0) { # get keys my (%seen, $i); return grep !($i++ % 2 || $seen{$_}++), @old; } my $key = shift; my @i = grep $_ % 2 == 0 && $old[$_] eq $key, 0 .. $#old; if (@_) { my @new = @old; my @new_i = @i; my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_; while (@new_i > @vals) { splice @new, pop @new_i, 2; } if (@vals > @new_i) { my $i = @new_i ? $new_i[-1] + 2 : @new; my @splice = splice @vals, @new_i, @vals - @new_i; splice @new, $i, 0, map { $key => $_ } @splice; } if (@vals) { #print "SET $new_i[0]\n"; @new[ map $_ + 1, @new_i ] = @vals; } $self->query_form(\@new); } return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef; } sub URI::_query::query_param_append { my $self = shift; my $key = shift; my @vals = map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_; $self->query_form($self->query_form, $key => \@vals); # XXX return; } sub URI::_query::query_param_delete { my $self = shift; my $key = shift; my @old = $self->query_form; my @vals; for (my $i = @old - 2; $i >= 0; $i -= 2) { next if $old[$i] ne $key; push(@vals, (splice(@old, $i, 2))[1]); } $self->query_form(\@old) if @vals; return wantarray ? reverse @vals : $vals[-1]; } sub URI::_query::query_form_hash { my $self = shift; my @old = $self->query_form; if (@_) { $self->query_form(@_ == 1 ? %{shift(@_)} : @_); } my %hash; while (my($k, $v) = splice(@old, 0, 2)) { if (exists $hash{$k}) { for ($hash{$k}) { $_ = [$_] unless ref($_) eq "ARRAY"; push(@$_, $v); } } else { $hash{$k} = $v; } } return \%hash; } 1; __END__ =head1 NAME URI::QueryParam - Additional query methods for URIs =head1 SYNOPSIS use URI; use URI::QueryParam; $u = URI->new("", "http"); $u->query_param(foo => 1, 2, 3); print $u->query; # prints foo=1&foo=2&foo=3 for my $key ($u->query_param) { print "$key: ", join(", ", $u->query_param($key)), "\n"; } =head1 DESCRIPTION Loading the C<URI::QueryParam> module adds some extra methods to URIs that support query methods. These methods provide an alternative interface to the $u->query_form data. The query_param_* methods have deliberately been made identical to the interface of the corresponding C<CGI.pm> methods. The following additional methods are made available: =over =item @keys = $u->query_param =item @values = $u->query_param( $key ) =item $first_value = $u->query_param( $key ) =item $u->query_param( $key, $value,... ) If $u->query_param is called with no arguments, it returns all the distinct parameter keys of the URI. In a scalar context it returns the number of distinct keys. When a $key argument is given, the method returns the parameter values with the given key. In a scalar context, only the first parameter value is returned. If additional arguments are given, they are used to update successive parameters with the given key. If any of the values provided are array references, then the array is dereferenced to get the actual values. Please note that you can supply multiple values to this method, but you cannot supply multiple keys. Do this: $uri->query_param( widget_id => 1, 5, 9 ); Do NOT do this: $uri->query_param( widget_id => 1, frobnicator_id => 99 ); =item $u->query_param_append($key, $value,...) Adds new parameters with the given key without touching any old parameters with the same key. It can be explained as a more efficient version of: $u->query_param($key, $u->query_param($key), $value,...); One difference is that this expression would return the old values of $key, whereas the query_param_append() method does not. =item @values = $u->query_param_delete($key) =item $first_value = $u->query_param_delete($key) Deletes all key/value pairs with the given key. The old values are returned. In a scalar context, only the first value is returned. Using the query_param_delete() method is slightly more efficient than the equivalent: $u->query_param($key, []); =item $hashref = $u->query_form_hash =item $u->query_form_hash( \%new_form ) Returns a reference to a hash that represents the query form's key/value pairs. If a key occurs multiple times, then the hash value becomes an array reference. Note that sequence information is lost. This means that: $u->query_form_hash($u->query_form_hash); is not necessarily a no-op, as it may reorder the key/value pairs. The values returned by the query_param() method should stay the same though. =back =head1 SEE ALSO L<URI>, L<CGI> =head1 COPYRIGHT Copyright 2002 Gisle Aas. =cut PK ! y��[� � URI/ldaps.pmnu �[��� package URI::ldaps; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::ldap'; sub default_port { 636 } sub secure { 1 } 1; PK ! ��s URI/_idna.pmnu �[��� package URI::_idna; # This module implements the RFCs 3490 (IDNA) and 3491 (Nameprep) # based on Python-2.6.4/Lib/encodings/idna.py use strict; use warnings; use URI::_punycode qw(decode_punycode encode_punycode); use Carp qw(croak); our $VERSION = '5.10'; BEGIN { *URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS = "$]" < 5.008_003 ? sub () { 1 } : sub () { 0 } ; } my $ASCII = qr/^[\x00-\x7F]*\z/; sub encode { my $idomain = shift; my @labels = split(/\./, $idomain, -1); my @last_empty; push(@last_empty, pop @labels) if @labels > 1 && $labels[-1] eq ""; for (@labels) { $_ = ToASCII($_); } return eval 'join(".", @labels, @last_empty)' if URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS; return join(".", @labels, @last_empty); } sub decode { my $domain = shift; return join(".", map ToUnicode($_), split(/\./, $domain, -1)) } sub nameprep { # XXX real implementation missing my $label = shift; $label = lc($label); return $label; } sub check_size { my $label = shift; croak "Label empty" if $label eq ""; croak "Label too long" if length($label) > 63; return $label; } sub ToASCII { my $label = shift; return check_size($label) if $label =~ $ASCII; # Step 2: nameprep $label = nameprep($label); # Step 3: UseSTD3ASCIIRules is false # Step 4: try ASCII again return check_size($label) if $label =~ $ASCII; # Step 5: Check ACE prefix if ($label =~ /^xn--/) { croak "Label starts with ACE prefix"; } # Step 6: Encode with PUNYCODE $label = encode_punycode($label); # Step 7: Prepend ACE prefix $label = "xn--$label"; # Step 8: Check size return check_size($label); } sub ToUnicode { my $label = shift; $label = nameprep($label) unless $label =~ $ASCII; return $label unless $label =~ /^xn--/; my $result = decode_punycode(substr($label, 4)); my $label2 = ToASCII($result); if (lc($label) ne $label2) { croak "IDNA does not round-trip: '\L$label\E' vs '$label2'"; } return $result; } 1; PK ! �{�l l URI/ldap.pmnu �[��� # Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package URI::ldap; use strict; use warnings; our $VERSION = '5.10'; use parent qw(URI::_ldap URI::_server); sub default_port { 389 } sub _nonldap_canonical { my $self = shift; $self->URI::_server::canonical(@_); } 1; __END__ =head1 NAME URI::ldap - LDAP Uniform Resource Locators =head1 SYNOPSIS use URI; $uri = URI->new("ldap:$uri_string"); $dn = $uri->dn; $filter = $uri->filter; @attr = $uri->attributes; $scope = $uri->scope; %extn = $uri->extensions; $uri = URI->new("ldap:"); # start empty $uri->host("ldap.itd.umich.edu"); $uri->dn("o=University of Michigan,c=US"); $uri->attributes(qw(postalAddress)); $uri->scope('sub'); $uri->filter('(cn=Babs Jensen)'); print $uri->as_string,"\n"; =head1 DESCRIPTION C<URI::ldap> provides an interface to parse an LDAP URI into its constituent parts and also to build a URI as described in RFC 2255. =head1 METHODS C<URI::ldap> supports all the generic and server methods defined by L<URI>, plus the following. Each of the following methods can be used to set or get the value in the URI. The values are passed in unescaped form. None of these return undefined values, but elements without a default can be empty. If arguments are given, then a new value is set for the given part of the URI. =over 4 =item $uri->dn( [$new_dn] ) Sets or gets the I<Distinguished Name> part of the URI. The DN identifies the base object of the LDAP search. =item $uri->attributes( [@new_attrs] ) Sets or gets the list of attribute names which are returned by the search. =item $uri->scope( [$new_scope] ) Sets or gets the scope to be used by the search. The value can be one of C<"base">, C<"one"> or C<"sub">. If none is given in the URI then the return value defaults to C<"base">. =item $uri->_scope( [$new_scope] ) Same as scope(), but does not default to anything. =item $uri->filter( [$new_filter] ) Sets or gets the filter to be used by the search. If none is given in the URI then the return value defaults to C<"(objectClass=*)">. =item $uri->_filter( [$new_filter] ) Same as filter(), but does not default to anything. =item $uri->extensions( [$etype => $evalue,...] ) Sets or gets the extensions used for the search. The list passed should be in the form etype1 => evalue1, etype2 => evalue2,... This is also the form of list that is returned. =back =head1 SEE ALSO L<http://tools.ietf.org/html/rfc2255> =head1 AUTHOR Graham Barr E<lt>F<gbarr@pobox.com>E<gt> Slightly modified by Gisle Aas to fit into the URI distribution. =head1 COPYRIGHT Copyright (c) 1998 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! ϝ<� URI/nntp.pmnu �[��� package URI::nntp; # draft-gilman-news-url-01 use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::news'; 1; PK ! ��I� � URI/news.pmnu �[��� package URI::news; # draft-gilman-news-url-01 use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::_server'; use URI::Escape qw(uri_unescape); use Carp (); sub default_port { 119 } # newsURL = scheme ":" [ news-server ] [ refbygroup | message ] # scheme = "news" | "snews" | "nntp" # news-server = "//" server "/" # refbygroup = group [ "/" messageno [ "-" messageno ] ] # message = local-part "@" domain sub _group { my $self = shift; my $old = $self->path; if (@_) { my($group,$from,$to) = @_; if ($group =~ /\@/) { $group =~ s/^<(.*)>$/$1/; # "<" and ">" should not be part of it } $group =~ s,%,%25,g; $group =~ s,/,%2F,g; my $path = $group; if (defined $from) { $path .= "/$from"; $path .= "-$to" if defined $to; } $self->path($path); } $old =~ s,^/,,; if ($old !~ /\@/ && $old =~ s,/(.*),, && wantarray) { my $extra = $1; return (uri_unescape($old), split(/-/, $extra)); } uri_unescape($old); } sub group { my $self = shift; if (@_) { Carp::croak("Group name can't contain '\@'") if $_[0] =~ /\@/; } my @old = $self->_group(@_); return if $old[0] =~ /\@/; wantarray ? @old : $old[0]; } sub message { my $self = shift; if (@_) { Carp::croak("Message must contain '\@'") unless $_[0] =~ /\@/; } my $old = $self->_group(@_); return undef unless $old =~ /\@/; return $old; } 1; PK ! :ښ_1 1 URI/Split.pmnu �[��� package URI::Split; use strict; use warnings; our $VERSION = '5.10'; use Exporter 5.57 'import'; our @EXPORT_OK = qw(uri_split uri_join); use URI::Escape (); sub uri_split { return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,; } sub uri_join { my($scheme, $auth, $path, $query, $frag) = @_; my $uri = defined($scheme) ? "$scheme:" : ""; $path = "" unless defined $path; if (defined $auth) { $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg; $uri .= "//$auth"; $path = "/$path" if length($path) && $path !~ m,^/,; } elsif ($path =~ m,^//,) { $uri .= "//"; # XXX force empty auth } unless (length $uri) { $path =~ s,(:), URI::Escape::escape_char($1),e while $path =~ m,^[^:/?\#]+:,; } $path =~ s,([?\#]), URI::Escape::escape_char($1),eg; $uri .= $path; if (defined $query) { $query =~ s,(\#), URI::Escape::escape_char($1),eg; $uri .= "?$query"; } $uri .= "#$frag" if defined $frag; $uri; } 1; __END__ =head1 NAME URI::Split - Parse and compose URI strings =head1 SYNOPSIS use URI::Split qw(uri_split uri_join); ($scheme, $auth, $path, $query, $frag) = uri_split($uri); $uri = uri_join($scheme, $auth, $path, $query, $frag); =head1 DESCRIPTION Provides functions to parse and compose URI strings. The following functions are provided: =over =item ($scheme, $auth, $path, $query, $frag) = uri_split($uri) Breaks up a URI string into its component parts. An C<undef> value is returned for those parts that are not present. The $path part is always present (but can be the empty string) and is thus never returned as C<undef>. No sensible value is returned if this function is called in a scalar context. =item $uri = uri_join($scheme, $auth, $path, $query, $frag) Puts together a URI string from its parts. Missing parts are signaled by passing C<undef> for the corresponding argument. Minimal escaping is applied to parts that contain reserved chars that would confuse a parser. For instance, any occurrence of '?' or '#' in $path is always escaped, as it would otherwise be parsed back as a query or fragment. =back =head1 SEE ALSO L<URI>, L<URI::Escape> =head1 COPYRIGHT Copyright 2003, Gisle Aas This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! ���~� � URI/https.pmnu �[��� package URI::https; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::http'; sub default_port { 443 } sub secure { 1 } 1; PK ! >�\�� � URI/Escape.pmnu �[��� package URI::Escape; use strict; use warnings; =head1 NAME URI::Escape - Percent-encode and percent-decode unsafe characters =head1 SYNOPSIS use URI::Escape; $safe = uri_escape("10% is enough\n"); $verysafe = uri_escape("foo", "\0-\377"); $str = uri_unescape($safe); =head1 DESCRIPTION This module provides functions to percent-encode and percent-decode URI strings as defined by RFC 3986. Percent-encoding URI's is informally called "URI escaping". This is the terminology used by this module, which predates the formalization of the terms by the RFC by several years. A URI consists of a restricted set of characters. The restricted set of characters consists of digits, letters, and a few graphic symbols chosen from those common to most of the character encodings and input facilities available to Internet users. They are made up of the "unreserved" and "reserved" character sets as defined in RFC 3986. unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" reserved = ":" / "/" / "?" / "#" / "[" / "]" / "@" "!" / "$" / "&" / "'" / "(" / ")" / "*" / "+" / "," / ";" / "=" In addition, any byte (octet) can be represented in a URI by an escape sequence: a triplet consisting of the character "%" followed by two hexadecimal digits. A byte can also be represented directly by a character, using the US-ASCII character for that octet. Some of the characters are I<reserved> for use as delimiters or as part of certain URI components. These must be escaped if they are to be treated as ordinary data. Read RFC 3986 for further details. The functions provided (and exported by default) from this module are: =over 4 =item uri_escape( $string ) =item uri_escape( $string, $unsafe ) Replaces each unsafe character in the $string with the corresponding escape sequence and returns the result. The $string argument should be a string of bytes. The uri_escape() function will croak if given a characters with code above 255. Use uri_escape_utf8() if you know you have such chars or/and want chars in the 128 .. 255 range treated as UTF-8. The uri_escape() function takes an optional second argument that overrides the set of characters that are to be escaped. The set is specified as a string that can be used in a regular expression character class (between [ ]). E.g.: "\x00-\x1f\x7f-\xff" # all control and hi-bit characters "a-z" # all lower case characters "^A-Za-z" # everything not a letter The default set of characters to be escaped is all those which are I<not> part of the C<unreserved> character class shown above as well as the reserved characters. I.e. the default is: "^A-Za-z0-9\-\._~" =item uri_escape_utf8( $string ) =item uri_escape_utf8( $string, $unsafe ) Works like uri_escape(), but will encode chars as UTF-8 before escaping them. This makes this function able to deal with characters with code above 255 in $string. Note that chars in the 128 .. 255 range will be escaped differently by this function compared to what uri_escape() would. For chars in the 0 .. 127 range there is no difference. Equivalent to: utf8::encode($string); my $uri = uri_escape($string); Note: JavaScript has a function called escape() that produces the sequence "%uXXXX" for chars in the 256 .. 65535 range. This function has really nothing to do with URI escaping but some folks got confused since it "does the right thing" in the 0 .. 255 range. Because of this you sometimes see "URIs" with these kind of escapes. The JavaScript encodeURIComponent() function is similar to uri_escape_utf8(). =item uri_unescape($string,...) Returns a string with each %XX sequence replaced with the actual byte (octet). This does the same as: $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; but does not modify the string in-place as this RE would. Using the uri_unescape() function instead of the RE might make the code look cleaner and is a few characters less to type. In a simple benchmark test I did, calling the function (instead of the inline RE above) if a few chars were unescaped was something like 40% slower, and something like 700% slower if none were. If you are going to unescape a lot of times it might be a good idea to inline the RE. If the uri_unescape() function is passed multiple strings, then each one is returned unescaped. =back The module can also export the C<%escapes> hash, which contains the mapping from all 256 bytes to the corresponding escape codes. Lookup in this hash is faster than evaluating C<sprintf("%%%02X", ord($byte))> each time. =head1 SEE ALSO L<URI> =head1 COPYRIGHT Copyright 1995-2004 Gisle Aas. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use Exporter 5.57 'import'; our %escapes; our @EXPORT = qw(uri_escape uri_unescape uri_escape_utf8); our @EXPORT_OK = qw(%escapes); our $VERSION = '5.10'; use Carp (); # Build a char->hex map for (0..255) { $escapes{chr($_)} = sprintf("%%%02X", $_); } my %subst; # compiled patterns my %Unsafe = ( RFC2732 => qr/[^A-Za-z0-9\-_.!~*'()]/, RFC3986 => qr/[^A-Za-z0-9\-\._~]/, ); sub uri_escape { my($text, $patn) = @_; return undef unless defined $text; if (defined $patn){ unless (exists $subst{$patn}) { # Because we can't compile the regex we fake it with a cached sub (my $tmp = $patn) =~ s,/,\\/,g; eval "\$subst{\$patn} = sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1} || _fail_hi(\$1)/ge; }"; Carp::croak("uri_escape: $@") if $@; } &{$subst{$patn}}($text); } else { $text =~ s/($Unsafe{RFC3986})/$escapes{$1} || _fail_hi($1)/ge; } $text; } sub _fail_hi { my $chr = shift; Carp::croak(sprintf "Can't escape \\x{%04X}, try uri_escape_utf8() instead", ord($chr)); } sub uri_escape_utf8 { my $text = shift; return undef unless defined $text; utf8::encode($text); return uri_escape($text, @_); } sub uri_unescape { # Note from RFC1630: "Sequences which start with a percent sign # but are not followed by two hexadecimal characters are reserved # for future extension" my $str = shift; if (@_ && wantarray) { # not executed for the common case of a single argument my @str = ($str, @_); # need to copy for (@str) { s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; } return @str; } $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str; $str; } # XXX FIXME escape_char is buggy as it assigns meaning to the string's storage format. sub escape_char { # Old versions of utf8::is_utf8() didn't properly handle magical vars (e.g. $1). # The following forces a fetch to occur beforehand. my $dummy = substr($_[0], 0, 0); if (utf8::is_utf8($_[0])) { my $s = shift; utf8::encode($s); unshift(@_, $s); } return join '', @URI::Escape::escapes{split //, $_[0]}; } 1; PK ! �F� � � URI/sip.pmnu �[��� # # Written by Ryan Kereliuk <ryker@ryker.org>. This file may be # distributed under the same terms as Perl itself. # # The RFC 3261 sip URI is <scheme>:<authority>;<params>?<query>. # package URI::sip; use strict; use warnings; use parent qw(URI::_server URI::_userpass); use URI::Escape (); our $VERSION = '5.10'; sub default_port { 5060 } sub authority { my $self = shift; $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die; my $old = $2; if (@_) { my $auth = shift; $$self = defined($1) ? $1 : ""; my $rest = $3; if (defined $auth) { $auth =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; $$self .= "$auth"; } $$self .= $rest; } $old; } sub params_form { my $self = shift; $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die; my $paramstr = $3; if (@_) { my @args = @_; $$self = $1 . $2; my $rest = $4; my @new; for (my $i=0; $i < @args; $i += 2) { push(@new, "$args[$i]=$args[$i+1]"); } $paramstr = join(";", @new); $$self .= ";" . $paramstr . $rest; } $paramstr =~ s/^;//o; return split(/[;=]/, $paramstr); } sub params { my $self = shift; $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die; my $paramstr = $3; if (@_) { my $new = shift; $$self = $1 . $2; my $rest = $4; $$self .= $paramstr . $rest; } $paramstr =~ s/^;//o; return $paramstr; } # Inherited methods that make no sense for a SIP URI. sub path {} sub path_query {} sub path_segments {} sub abs { shift } sub rel { shift } sub query_keywords {} 1; PK ! hj\�k k URI/_foreign.pmnu �[��� package URI::_foreign; use strict; use warnings; use parent 'URI::_generic'; our $VERSION = '5.10'; 1; PK ! ( �Rb b URI/sftp.pmnu �[��� package URI::sftp; use strict; use warnings; use parent 'URI::ssh'; our $VERSION = '5.10'; 1; PK ! ��-�o o URI/URL.pmnu �[��� package URI::URL; use strict; use warnings; use parent 'URI::WithBase'; our $VERSION = '5.10'; # Provide as much as possible of the old URI::URL interface for backwards # compatibility... use Exporter 5.57 'import'; our @EXPORT = qw(url); # Easy to use constructor sub url ($;$) { URI::URL->new(@_); } use URI::Escape qw(uri_unescape); sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->[0] = $self->[0]->canonical; $self; } sub newlocal { my $class = shift; require URI::file; bless [URI::file->new_abs(shift)], $class; } {package URI::_foreign; sub _init # hope it is not defined { my $class = shift; die "Unknown URI::URL scheme $_[1]:" if $URI::URL::STRICT; $class->SUPER::_init(@_); } } sub strict { my $old = $URI::URL::STRICT; $URI::URL::STRICT = shift if @_; $old; } sub print_on { my $self = shift; require Data::Dumper; print STDERR Data::Dumper::Dumper($self); } sub _try { my $self = shift; my $method = shift; scalar(eval { $self->$method(@_) }); } sub crack { # should be overridden by subclasses my $self = shift; (scalar($self->scheme), $self->_try("user"), $self->_try("password"), $self->_try("host"), $self->_try("port"), $self->_try("path"), $self->_try("params"), $self->_try("query"), scalar($self->fragment), ) } sub full_path { my $self = shift; my $path = $self->path_query; $path = "/" unless length $path; $path; } sub netloc { shift->authority(@_); } sub epath { my $path = shift->SUPER::path(@_); $path =~ s/;.*//; $path; } sub eparams { my $self = shift; my @p = $self->path_segments; return undef unless ref($p[-1]); @p = @{$p[-1]}; shift @p; join(";", @p); } sub params { shift->eparams(@_); } sub path { my $self = shift; my $old = $self->epath(@_); return unless defined wantarray; return '/' if !defined($old) || !length($old); Carp::croak("Path components contain '/' (you must call epath)") if $old =~ /%2[fF]/ and !@_; $old = "/$old" if $old !~ m|^/| && defined $self->netloc; return uri_unescape($old); } sub path_components { shift->path_segments(@_); } sub query { my $self = shift; my $old = $self->equery(@_); if (defined(wantarray) && defined($old)) { if ($old =~ /%(?:26|2[bB]|3[dD])/) { # contains escaped '=' '&' or '+' my $mess; for ($old) { $mess = "Query contains both '+' and '%2B'" if /\+/ && /%2[bB]/; $mess = "Form query contains escaped '=' or '&'" if /=/ && /%(?:3[dD]|26)/; } if ($mess) { Carp::croak("$mess (you must call equery)"); } } # Now it should be safe to unescape the string without losing # information return uri_unescape($old); } undef; } sub abs { my $self = shift; my $base = shift; my $allow_scheme = shift; $allow_scheme = $URI::URL::ABS_ALLOW_RELATIVE_SCHEME unless defined $allow_scheme; local $URI::ABS_ALLOW_RELATIVE_SCHEME = $allow_scheme; local $URI::ABS_REMOTE_LEADING_DOTS = $URI::URL::ABS_REMOTE_LEADING_DOTS; $self->SUPER::abs($base); } sub frag { shift->fragment(@_); } sub keywords { shift->query_keywords(@_); } # file: sub local_path { shift->file; } sub unix_path { shift->file("unix"); } sub dos_path { shift->file("dos"); } sub mac_path { shift->file("mac"); } sub vms_path { shift->file("vms"); } # mailto: sub address { shift->to(@_); } sub encoded822addr { shift->to(@_); } sub URI::mailto::authority { shift->to(@_); } # make 'netloc' method work # news: sub groupart { shift->_group(@_); } sub article { shift->message(@_); } 1; __END__ =head1 NAME URI::URL - Uniform Resource Locators =head1 SYNOPSIS $u1 = URI::URL->new($str, $base); $u2 = $u1->abs; =head1 DESCRIPTION This module is provided for backwards compatibility with modules that depend on the interface provided by the C<URI::URL> class that used to be distributed with the libwww-perl library. The following differences exist compared to the C<URI> class interface: =over 3 =item * The URI::URL module exports the url() function as an alternate constructor interface. =item * The constructor takes an optional $base argument. The C<URI::URL> class is a subclass of C<URI::WithBase>. =item * The URI::URL->newlocal class method is the same as URI::file->new_abs. =item * URI::URL::strict(1) =item * $url->print_on method =item * $url->crack method =item * $url->full_path: same as ($uri->abs_path || "/") =item * $url->netloc: same as $uri->authority =item * $url->epath, $url->equery: same as $uri->path, $uri->query =item * $url->path and $url->query pass unescaped strings. =item * $url->path_components: same as $uri->path_segments (if you don't consider path segment parameters) =item * $url->params and $url->eparams methods =item * $url->base method. See L<URI::WithBase>. =item * $url->abs and $url->rel have an optional $base argument. See L<URI::WithBase>. =item * $url->frag: same as $uri->fragment =item * $url->keywords: same as $uri->query_keywords =item * $url->localpath and friends map to $uri->file. =item * $url->address and $url->encoded822addr: same as $uri->to for mailto URI =item * $url->groupart method for news URI =item * $url->article: same as $uri->message =back =head1 SEE ALSO L<URI>, L<URI::WithBase> =head1 COPYRIGHT Copyright 1998-2000 Gisle Aas. =cut PK ! �u� URI/Heuristic.pmnu �[��� package URI::Heuristic; =head1 NAME URI::Heuristic - Expand URI using heuristics =head1 SYNOPSIS use URI::Heuristic qw(uf_uristr); $u = uf_uristr("example"); # http://www.example.com $u = uf_uristr("www.sol.no/sol"); # http://www.sol.no/sol $u = uf_uristr("aas"); # http://www.aas.no $u = uf_uristr("ftp.funet.fi"); # ftp://ftp.funet.fi $u = uf_uristr("/etc/passwd"); # file:/etc/passwd =head1 DESCRIPTION This module provides functions that expand strings into real absolute URIs using some built-in heuristics. Strings that already represent absolute URIs (i.e. that start with a C<scheme:> part) are never modified and are returned unchanged. The main use of these functions is to allow abbreviated URIs similar to what many web browsers allow for URIs typed in by the user. The following functions are provided: =over 4 =item uf_uristr($str) Tries to make the argument string into a proper absolute URI string. The "uf_" prefix stands for "User Friendly". Under MacOS, it assumes that any string with a common URL scheme (http, ftp, etc.) is a URL rather than a local path. So don't name your volumes after common URL schemes and expect uf_uristr() to construct valid file: URL's on those volumes for you, because it won't. =item uf_uri($str) Works the same way as uf_uristr() but returns a C<URI> object. =back =head1 ENVIRONMENT If the hostname portion of a URI does not contain any dots, then certain qualified guesses are made. These guesses are governed by the following environment variables: =over 10 =item COUNTRY The two-letter country code (ISO 3166) for your location. If the domain name of your host ends with two letters, then it is taken to be the default country. See also L<Locale::Country>. =item HTTP_ACCEPT_LANGUAGE, LC_ALL, LANG If COUNTRY is not set, these standard environment variables are examined and country (not language) information possibly found in them is used as the default country. =item URL_GUESS_PATTERN Contains a space-separated list of URL patterns to try. The string "ACME" is for some reason used as a placeholder for the host name in the URL provided. Example: URL_GUESS_PATTERN="www.ACME.no www.ACME.se www.ACME.com" export URL_GUESS_PATTERN Specifying URL_GUESS_PATTERN disables any guessing rules based on country. An empty URL_GUESS_PATTERN disables any guessing that involves host name lookups. =back =head1 COPYRIGHT Copyright 1997-1998, Gisle Aas This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use warnings; use Exporter 5.57 'import'; our @EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr); our $VERSION = '5.10'; our ($MY_COUNTRY, $DEBUG); sub MY_COUNTRY() { for ($MY_COUNTRY) { return $_ if defined; # First try the environment. $_ = $ENV{COUNTRY}; return $_ if defined; # Try the country part of LC_ALL and LANG from environment my @srcs = ($ENV{LC_ALL}, $ENV{LANG}); # ...and HTTP_ACCEPT_LANGUAGE before those if present if (my $httplang = $ENV{HTTP_ACCEPT_LANGUAGE}) { # TODO: q-value processing/ordering for $httplang (split(/\s*,\s*/, $httplang)) { if ($httplang =~ /^\s*([a-zA-Z]+)[_-]([a-zA-Z]{2})\s*$/) { unshift(@srcs, "${1}_${2}"); last; } } } for (@srcs) { next unless defined; return lc($1) if /^[a-zA-Z]+_([a-zA-Z]{2})(?:[.@]|$)/; } # Last bit of domain name. This may access the network. require Net::Domain; my $fqdn = Net::Domain::hostfqdn(); $_ = lc($1) if $fqdn =~ /\.([a-zA-Z]{2})$/; return $_ if defined; # Give up. Defined but false. return ($_ = 0); } } our %LOCAL_GUESSING = ( 'us' => [qw(www.ACME.gov www.ACME.mil)], 'gb' => [qw(www.ACME.co.uk www.ACME.org.uk www.ACME.ac.uk)], 'au' => [qw(www.ACME.com.au www.ACME.org.au www.ACME.edu.au)], 'il' => [qw(www.ACME.co.il www.ACME.org.il www.ACME.net.il)], # send corrections and new entries to <gisle@aas.no> ); # Backwards compatibility; uk != United Kingdom in ISO 3166 $LOCAL_GUESSING{uk} = $LOCAL_GUESSING{gb}; sub uf_uristr ($) { local($_) = @_; print STDERR "uf_uristr: resolving $_\n" if $DEBUG; return unless defined; s/^\s+//; s/\s+$//; if (/^(www|web|home)[a-z0-9-]*(?:\.|$)/i) { $_ = "http://$_"; } elsif (/^(ftp|gopher|news|wais|https|http)[a-z0-9-]*(?:\.|$)/i) { $_ = lc($1) . "://$_"; } elsif ($^O ne "MacOS" && (m,^/, || # absolute file name m,^\.\.?/, || # relative file name m,^[a-zA-Z]:[/\\],) # dosish file name ) { $_ = "file:$_"; } elsif ($^O eq "MacOS" && m/:/) { # potential MacOS file name unless (m/^(ftp|gopher|news|wais|http|https|mailto):/) { require URI::file; my $a = URI::file->new($_)->as_string; $_ = ($a =~ m/^file:/) ? $a : "file:$a"; } } elsif (/^\w+([\.\-]\w+)*\@(\w+\.)+\w{2,3}$/) { $_ = "mailto:$_"; } elsif (!/^[a-zA-Z][a-zA-Z0-9.+\-]*:/) { # no scheme specified if (s/^([-\w]+(?:\.[-\w]+)*)([\/:\?\#]|$)/$2/) { my $host = $1; my $scheme = "http"; if (/^:(\d+)\b/) { # Some more or less well known ports if ($1 =~ /^[56789]?443$/) { $scheme = "https"; } elsif ($1 eq "21") { $scheme = "ftp"; } } if ($host !~ /\./ && $host ne "localhost") { my @guess; if (exists $ENV{URL_GUESS_PATTERN}) { @guess = map { s/\bACME\b/$host/; $_ } split(' ', $ENV{URL_GUESS_PATTERN}); } else { if (MY_COUNTRY()) { my $special = $LOCAL_GUESSING{MY_COUNTRY()}; if ($special) { my @special = @$special; push(@guess, map { s/\bACME\b/$host/; $_ } @special); } else { push(@guess, "www.$host." . MY_COUNTRY()); } } push(@guess, map "www.$host.$_", "com", "org", "net", "edu", "int"); } my $guess; for $guess (@guess) { print STDERR "uf_uristr: gethostbyname('$guess.')..." if $DEBUG; if (gethostbyname("$guess.")) { print STDERR "yes\n" if $DEBUG; $host = $guess; last; } print STDERR "no\n" if $DEBUG; } } $_ = "$scheme://$host$_"; } else { # pure junk, just return it unchanged... } } print STDERR "uf_uristr: ==> $_\n" if $DEBUG; $_; } sub uf_uri ($) { require URI; URI->new(uf_uristr($_[0])); } # legacy *uf_urlstr = \*uf_uristr; sub uf_url ($) { require URI::URL; URI::URL->new(uf_uristr($_[0])); } 1; PK ! kc̥~ ~ URI/rtspu.pmnu �[��� package URI::rtspu; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::rtsp'; sub default_port { 554 } 1; PK ! �綧� � URI/nntps.pmnu �[��� package URI::nntps; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::nntp'; sub default_port { 563 } sub secure { 1 } 1; PK ! �'y y URI/mailto.pmnu �[��� package URI::mailto; # RFC 2368 use strict; use warnings; our $VERSION = '5.10'; use parent qw(URI URI::_query); sub to { my $self = shift; my @old = $self->headers; if (@_) { my @new = @old; # get rid of any other to: fields for (my $i = 0; $i < @new; $i += 2) { if (lc($new[$i] || '') eq "to") { splice(@new, $i, 2); redo; } } my $to = shift; $to = "" unless defined $to; unshift(@new, "to" => $to); $self->headers(@new); } return unless defined wantarray; my @to; while (@old) { my $h = shift @old; my $v = shift @old; push(@to, $v) if lc($h) eq "to"; } join(",", @to); } sub headers { my $self = shift; # The trick is to just treat everything as the query string... my $opaque = "to=" . $self->opaque; $opaque =~ s/\?/&/; if (@_) { my @new = @_; # strip out any "to" fields my @to; for (my $i=0; $i < @new; $i += 2) { if (lc($new[$i] || '') eq "to") { push(@to, (splice(@new, $i, 2))[1]); # remove header redo; } } my $new = join(",",@to); $new =~ s/%/%25/g; $new =~ s/\?/%3F/g; $self->opaque($new); $self->query_form(@new) if @new; } return unless defined wantarray; # I am lazy today... URI->new("mailto:?$opaque")->query_form; } # https://datatracker.ietf.org/doc/html/rfc6068#section-5 requires # plus signs (+) not to be turned into spaces sub query_form { my $self = shift; my @fields = $self->SUPER::query_form(@_); for ( my $i = 0 ; $i < @fields ; $i += 2 ) { if ( $fields[0] eq 'to' ) { $fields[1] =~ s/ /+/g; last; } } return @fields; } 1; PK ! 1��! URI/urn.pmnu �[��� package URI::urn; # RFC 2141 use strict; use warnings; our $VERSION = '5.10'; use parent 'URI'; use Carp qw(carp); my %implementor; my %require_attempted; sub _init { my $class = shift; my $self = $class->SUPER::_init(@_); my $nid = $self->nid; my $impclass = $implementor{$nid}; return $impclass->_urn_init($self, $nid) if $impclass; $impclass = "URI::urn"; if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) { my $id = $nid; # make it a legal perl identifier $id =~ s/-/_/g; $id = "_$id" if $id =~ /^\d/; $impclass = "URI::urn::$id"; no strict 'refs'; unless (@{"${impclass}::ISA"}) { if (not exists $require_attempted{$impclass}) { # Try to load it my $_old_error = $@; eval "require $impclass"; die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; $@ = $_old_error; } $impclass = "URI::urn" unless @{"${impclass}::ISA"}; } } else { carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W; } $implementor{$nid} = $impclass; return $impclass->_urn_init($self, $nid); } sub _urn_init { my($class, $self, $nid) = @_; bless $self, $class; } sub _nid { my $self = shift; my $opaque = $self->opaque; if (@_) { my $v = $opaque; my $new = shift; $v =~ s/[^:]*/$new/; $self->opaque($v); # XXX possible rebless } $opaque =~ s/:.*//s; return $opaque; } sub nid { # namespace identifier my $self = shift; my $nid = $self->_nid(@_); $nid = lc($nid) if defined($nid); return $nid; } sub nss { # namespace specific string my $self = shift; my $opaque = $self->opaque; if (@_) { my $v = $opaque; my $new = shift; if (defined $new) { $v =~ s/(:|\z).*/:$new/; } else { $v =~ s/:.*//s; } $self->opaque($v); } return undef unless $opaque =~ s/^[^:]*://; return $opaque; } sub canonical { my $self = shift; my $nid = $self->_nid; my $new = $self->SUPER::canonical; return $new if $nid !~ /[A-Z]/ || $nid =~ /%/; $new = $new->clone if $new == $self; $new->nid(lc($nid)); return $new; } 1; PK ! �y� � � URI/_server.pmnu �[��� package URI::_server; use strict; use warnings; use parent 'URI::_generic'; use URI::Escape qw(uri_unescape); our $VERSION = '5.10'; sub _uric_escape { my($class, $str) = @_; if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) { my($scheme, $host, $rest) = ($1, $2, $3); my $ui = $host =~ s/(.*@)// ? $1 : ""; my $port = $host =~ s/(:\d+)\z// ? $1 : ""; if (_host_escape($host)) { $str = "$scheme//$ui$host$port$rest"; } } return $class->SUPER::_uric_escape($str); } sub _host_escape { return unless $_[0] =~ /[^$URI::uric]/; eval { require URI::_idna; $_[0] = URI::_idna::encode($_[0]); }; return 0 if $@; return 1; } sub as_iri { my $self = shift; my $str = $self->SUPER::as_iri; if ($str =~ /\bxn--/) { if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) { my($scheme, $host, $rest) = ($1, $2, $3); my $ui = $host =~ s/(.*@)// ? $1 : ""; my $port = $host =~ s/(:\d+)\z// ? $1 : ""; require URI::_idna; $host = URI::_idna::decode($host); $str = "$scheme//$ui$host$port$rest"; } } return $str; } sub userinfo { my $self = shift; my $old = $self->authority; if (@_) { my $new = $old; $new = "" unless defined $new; $new =~ s/.*@//; # remove old stuff my $ui = shift; if (defined $ui) { $ui =~ s/@/%40/g; # protect @ $new = "$ui\@$new"; } $self->authority($new); } return undef if !defined($old) || $old !~ /(.*)@/; return $1; } sub host { my $self = shift; my $old = $self->authority; if (@_) { my $tmp = $old; $tmp = "" unless defined $tmp; my $ui = ($tmp =~ /(.*@)/) ? $1 : ""; my $port = ($tmp =~ /(:\d+)$/) ? $1 : ""; my $new = shift; $new = "" unless defined $new; if (length $new) { $new =~ s/[@]/%40/g; # protect @ if ($new =~ /^[^:]*:\d*\z/ || $new =~ /]:\d*\z/) { $new =~ s/(:\d*)\z// || die "Assert"; $port = $1; } $new = "[$new]" if $new =~ /:/ && $new !~ /^\[/; # IPv6 address _host_escape($new); } $self->authority("$ui$new$port"); } return undef unless defined $old; $old =~ s/.*@//; $old =~ s/:\d+$//; # remove the port $old =~ s{^\[(.*)\]$}{$1}; # remove brackets around IPv6 (RFC 3986 3.2.2) return uri_unescape($old); } sub ihost { my $self = shift; my $old = $self->host(@_); if ($old =~ /(^|\.)xn--/) { require URI::_idna; $old = URI::_idna::decode($old); } return $old; } sub _port { my $self = shift; my $old = $self->authority; if (@_) { my $new = $old; $new =~ s/:\d*$//; my $port = shift; $new .= ":$port" if defined $port; $self->authority($new); } return $1 if defined($old) && $old =~ /:(\d*)$/; return; } sub port { my $self = shift; my $port = $self->_port(@_); $port = $self->default_port if !defined($port) || $port eq ""; $port; } sub host_port { my $self = shift; my $old = $self->authority; $self->host(shift) if @_; return undef unless defined $old; $old =~ s/.*@//; # zap userinfo $old =~ s/:$//; # empty port should be treated the same a no port $old .= ":" . $self->port unless $old =~ /:\d+$/; $old; } sub default_port { undef } sub canonical { my $self = shift; my $other = $self->SUPER::canonical; my $host = $other->host || ""; my $port = $other->_port; my $uc_host = $host =~ /[A-Z]/; my $def_port = defined($port) && ($port eq "" || $port == $self->default_port); if ($uc_host || $def_port) { $other = $other->clone if $other == $self; $other->host(lc $host) if $uc_host; $other->port(undef) if $def_port; } $other; } 1; PK ! �j�5� � URI/ssh.pmnu �[��� package URI::ssh; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::_login'; # ssh://[USER@]HOST[:PORT]/SRC sub default_port { 22 } sub secure { 1 } 1; PK ! x�=�� � URI/_generic.pmnu �[��� package URI::_generic; use strict; use warnings; use parent qw(URI URI::_query); use URI::Escape qw(uri_unescape); use Carp (); our $VERSION = '5.10'; my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g; my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g; sub _no_scheme_ok { 1 } sub authority { my $self = shift; $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die; if (@_) { my $auth = shift; $$self = $1; my $rest = $3; if (defined $auth) { $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego; utf8::downgrade($auth); $$self .= "//$auth"; } _check_path($rest, $$self); $$self .= $rest; } $2; } sub path { my $self = shift; $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die; if (@_) { $$self = $1; my $rest = $3; my $new_path = shift; $new_path = "" unless defined $new_path; $new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego; utf8::downgrade($new_path); _check_path($new_path, $$self); $$self .= $new_path . $rest; } $2; } sub path_query { my $self = shift; $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die; if (@_) { $$self = $1; my $rest = $3; my $new_path = shift; $new_path = "" unless defined $new_path; $new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; utf8::downgrade($new_path); _check_path($new_path, $$self); $$self .= $new_path . $rest; } $2; } sub _check_path { my($path, $pre) = @_; my $prefix; if ($pre =~ m,/,) { # authority present $prefix = "/" if length($path) && $path !~ m,^[/?\#],; } else { if ($path =~ m,^//,) { Carp::carp("Path starting with double slash is confusing") if $^W; } elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) { Carp::carp("Path might look like scheme, './' prepended") if $^W; $prefix = "./"; } } substr($_[0], 0, 0) = $prefix if defined $prefix; } sub path_segments { my $self = shift; my $path = $self->path; if (@_) { my @arg = @_; # make a copy for (@arg) { if (ref($_)) { my @seg = @$_; $seg[0] =~ s/%/%25/g; for (@seg) { s/;/%3B/g; } $_ = join(";", @seg); } else { s/%/%25/g; s/;/%3B/g; } s,/,%2F,g; } $self->path(join("/", @arg)); } return $path unless wantarray; map {/;/ ? $self->_split_segment($_) : uri_unescape($_) } split('/', $path, -1); } sub _split_segment { my $self = shift; require URI::_segment; URI::_segment->new(@_); } sub abs { my $self = shift; my $base = shift || Carp::croak("Missing base argument"); if (my $scheme = $self->scheme) { return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME; $base = URI->new($base) unless ref $base; return $self unless $scheme eq $base->scheme; } $base = URI->new($base) unless ref $base; my $abs = $self->clone; $abs->scheme($base->scheme); return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o; $abs->authority($base->authority); my $path = $self->path; return $abs if $path =~ m,^/,; if (!length($path)) { my $abs = $base->clone; my $query = $self->query; $abs->query($query) if defined $query; my $fragment = $self->fragment; $abs->fragment($fragment) if defined $fragment; return $abs; } my $p = $base->path; $p =~ s,[^/]+$,,; $p .= $path; my @p = split('/', $p, -1); shift(@p) if @p && !length($p[0]); my $i = 1; while ($i < @p) { #print "$i ", join("/", @p), " ($p[$i])\n"; if ($p[$i-1] eq ".") { splice(@p, $i-1, 1); $i-- if $i > 1; } elsif ($p[$i] eq ".." && $p[$i-1] ne "..") { splice(@p, $i-1, 2); if ($i > 1) { $i--; push(@p, "") if $i == @p; } } else { $i++; } } $p[-1] = "" if @p && $p[-1] eq "."; # trailing "/." if ($URI::ABS_REMOTE_LEADING_DOTS) { shift @p while @p && $p[0] =~ /^\.\.?$/; } $abs->path("/" . join("/", @p)); $abs; } # The opposite of $url->abs. Return a URI which is as relative as possible sub rel { my $self = shift; my $base = shift || Carp::croak("Missing base argument"); my $rel = $self->clone; $base = URI->new($base) unless ref $base; #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)}; my $scheme = $rel->scheme; my $auth = $rel->canonical->authority; my $path = $rel->path; if (!defined($scheme) && !defined($auth)) { # it is already relative return $rel; } #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)}; my $bscheme = $base->scheme; my $bauth = $base->canonical->authority; my $bpath = $base->path; for ($bscheme, $bauth, $auth) { $_ = '' unless defined } unless ($scheme eq $bscheme && $auth eq $bauth) { # different location, can't make it relative return $rel; } for ($path, $bpath) { $_ = "/$_" unless m,^/,; } # Make it relative by eliminating scheme and authority $rel->scheme(undef); $rel->authority(undef); # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>. # First we calculate common initial path components length ($li). my $li = 1; while (1) { my $i = index($path, '/', $li); last if $i < 0 || $i != index($bpath, '/', $li) || substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li); $li=$i+1; } # then we nuke it from both paths substr($path, 0,$li) = ''; substr($bpath,0,$li) = ''; if ($path eq $bpath && defined($rel->fragment) && !defined($rel->query)) { $rel->path(""); } else { # Add one "../" for each path component left in the base path $path = ('../' x $bpath =~ tr|/|/|) . $path; $path = "./" if $path eq ""; $rel->path($path); } $rel; } 1; PK ! M�[> > URI/data.pmnu �[��� package URI::data; # RFC 2397 use strict; use warnings; use parent 'URI'; our $VERSION = '5.10'; use MIME::Base64 qw(decode_base64 encode_base64); use URI::Escape qw(uri_unescape); sub media_type { my $self = shift; my $opaque = $self->opaque; $opaque =~ /^([^,]*),?/ or die; my $old = $1; my $base64; $base64 = $1 if $old =~ s/(;base64)$//i; if (@_) { my $new = shift; $new = "" unless defined $new; $new =~ s/%/%25/g; $new =~ s/,/%2C/g; $base64 = "" unless defined $base64; $opaque =~ s/^[^,]*,?/$new$base64,/; $self->opaque($opaque); } return uri_unescape($old) if $old; # media_type can't really be "0" "text/plain;charset=US-ASCII"; # default type } sub data { my $self = shift; my($enc, $data) = split(",", $self->opaque, 2); unless (defined $data) { $data = ""; $enc = "" unless defined $enc; } my $base64 = ($enc =~ /;base64$/i); if (@_) { $enc =~ s/;base64$//i if $base64; my $new = shift; $new = "" unless defined $new; my $uric_count = _uric_count($new); my $urienc_len = $uric_count + (length($new) - $uric_count) * 3; my $base64_len = int((length($new)+2) / 3) * 4; $base64_len += 7; # because of ";base64" marker if ($base64_len < $urienc_len || $_[0]) { $enc .= ";base64"; $new = encode_base64($new, ""); } else { $new =~ s/%/%25/g; } $self->opaque("$enc,$new"); } return unless defined wantarray; $data = uri_unescape($data); return $base64 ? decode_base64($data) : $data; } # I could not find a better way to interpolate the tr/// chars from # a variable. my $ENC = $URI::uric; $ENC =~ s/%//; eval <<EOT; die $@ if $@; sub _uric_count { \$_[0] =~ tr/$ENC//; } EOT 1; __END__ =head1 NAME URI::data - URI that contains immediate data =head1 SYNOPSIS use URI; $u = URI->new("data:"); $u->media_type("image/gif"); $u->data(scalar(`cat camel.gif`)); print "$u\n"; open(XV, "|xv -") and print XV $u->data; =head1 DESCRIPTION The C<URI::data> class supports C<URI> objects belonging to the I<data> URI scheme. The I<data> URI scheme is specified in RFC 2397. It allows inclusion of small data items as "immediate" data, as if it had been included externally. Examples: data:,Perl%20is%20good data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs= C<URI> objects belonging to the data scheme support the common methods (described in L<URI>) and the following two scheme-specific methods: =over 4 =item $uri->media_type( [$new_media_type] ) Can be used to get or set the media type specified in the URI. If no media type is specified, then the default C<"text/plain;charset=US-ASCII"> is returned. =item $uri->data( [$new_data] ) Can be used to get or set the data contained in the URI. The data is passed unescaped (in binary form). The decision about whether to base64 encode the data in the URI is taken automatically, based on the encoding that produces the shorter URI string. =back =head1 SEE ALSO L<URI> =head1 COPYRIGHT Copyright 1995-1998 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! O-�� � URI/_query.pmnu �[��� package URI::_query; use strict; use warnings; use URI (); use URI::Escape qw(uri_unescape); our $VERSION = '5.10'; sub query { my $self = shift; $$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die; if (@_) { my $q = shift; $$self = $1; if (defined $q) { $q =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; utf8::downgrade($q); $$self .= "?$q"; } $$self .= $3; } $2; } # Handle ...?foo=bar&bar=foo type of query sub query_form { my $self = shift; my $old = $self->query; if (@_) { # Try to set query string my $delim; my $r = $_[0]; if (ref($r) eq "ARRAY") { $delim = $_[1]; @_ = @$r; } elsif (ref($r) eq "HASH") { $delim = $_[1]; @_ = map { $_ => $r->{$_} } sort keys %$r; } $delim = pop if @_ % 2; my @query; while (my($key,$vals) = splice(@_, 0, 2)) { $key = '' unless defined $key; $key =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; $key =~ s/ /+/g; $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals]; for my $val (@$vals) { $val = '' unless defined $val; $val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; $val =~ s/ /+/g; push(@query, "$key=$val"); } } if (@query) { unless ($delim) { $delim = $1 if $old && $old =~ /([&;])/; $delim ||= $URI::DEFAULT_QUERY_FORM_DELIMITER || "&"; } $self->query(join($delim, @query)); } else { $self->query(undef); } } return if !defined($old) || !length($old) || !defined(wantarray); return unless $old =~ /=/; # not a form map { s/\+/ /g; uri_unescape($_) } map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old); } # Handle ...?dog+bones type of query sub query_keywords { my $self = shift; my $old = $self->query; if (@_) { # Try to set query string my @copy = @_; @copy = @{$copy[0]} if @copy == 1 && ref($copy[0]) eq "ARRAY"; for (@copy) { s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; } $self->query(@copy ? join('+', @copy) : undef); } return if !defined($old) || !defined(wantarray); return if $old =~ /=/; # not keywords, but a form map { uri_unescape($_) } split(/\+/, $old, -1); } # Some URI::URL compatibility stuff sub equery { goto &query } 1; PK ! E.�% URI/WithBase.pmnu �[��� package URI::WithBase; use strict; use warnings; use URI (); use Scalar::Util qw(blessed); our $VERSION = '5.10'; use overload '""' => "as_string", fallback => 1; sub as_string; # help overload find it sub new { my($class, $uri, $base) = @_; my $ibase = $base; if ($base && blessed($base) && $base->isa(__PACKAGE__)) { $base = $base->abs; $ibase = $base->[0]; } bless [URI->new($uri, $ibase), $base], $class; } sub new_abs { my $class = shift; my $self = $class->new(@_); $self->abs; } sub _init { my $class = shift; my($str, $scheme) = @_; bless [URI->new($str, $scheme), undef], $class; } sub eq { my($self, $other) = @_; $other = $other->[0] if blessed($other) and $other->isa(__PACKAGE__); $self->[0]->eq($other); } our $AUTOLOAD; sub AUTOLOAD { my $self = shift; my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); return if $method eq "DESTROY"; $self->[0]->$method(@_); } sub can { # override UNIVERSAL::can my $self = shift; $self->SUPER::can(@_) || ( ref($self) ? $self->[0]->can(@_) : undef ) } sub base { my $self = shift; my $base = $self->[1]; if (@_) { # set my $new_base = shift; # ensure absoluteness $new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__); $self->[1] = $new_base; } return unless defined wantarray; # The base attribute supports 'lazy' conversion from URL strings # to URL objects. Strings may be stored but when a string is # fetched it will automatically be converted to a URL object. # The main benefit is to make it much cheaper to say: # URI::WithBase->new($random_url_string, 'http:') if (defined($base) && !ref($base)) { $base = ref($self)->new($base); $self->[1] = $base unless @_; } $base; } sub clone { my $self = shift; my $base = $self->[1]; $base = $base->clone if ref($base); bless [$self->[0]->clone, $base], ref($self); } sub abs { my $self = shift; my $base = shift || $self->base || return $self->clone; $base = $base->as_string if ref($base); bless [$self->[0]->abs($base, @_), $base], ref($self); } sub rel { my $self = shift; my $base = shift || $self->base || return $self->clone; $base = $base->as_string if ref($base); bless [$self->[0]->rel($base, @_), $base], ref($self); } 1; __END__ =head1 NAME URI::WithBase - URIs which remember their base =head1 SYNOPSIS $u1 = URI::WithBase->new($str, $base); $u2 = $u1->abs; $base = $u1->base; $u1->base( $new_base ) =head1 DESCRIPTION This module provides the C<URI::WithBase> class. Objects of this class are like C<URI> objects, but can keep their base too. The base represents the context where this URI was found and can be used to absolutize or relativize the URI. All the methods described in L<URI> are supported for C<URI::WithBase> objects. The methods provided in addition to or modified from those of C<URI> are: =over 4 =item $uri = URI::WithBase->new($str, [$base]) The constructor takes an optional base URI as the second argument. If provided, this argument initializes the base attribute. =item $uri->base( [$new_base] ) Can be used to get or set the value of the base attribute. The return value, which is the old value, is a URI object or C<undef>. =item $uri->abs( [$base_uri] ) The $base_uri argument is now made optional as the object carries its base with it. A new object is returned even if $uri is already absolute (while plain URI objects simply return themselves in that case). =item $uri->rel( [$base_uri] ) The $base_uri argument is now made optional as the object carries its base with it. A new object is always returned. =back =head1 SEE ALSO L<URI> =head1 COPYRIGHT Copyright 1998-2002 Gisle Aas. =cut PK ! ]�: URI/ftp.pmnu �[��� package URI::ftp; use strict; use warnings; our $VERSION = '5.10'; use parent qw(URI::_server URI::_userpass); sub default_port { 21 } sub path { shift->path_query(@_) } # XXX sub _user { shift->SUPER::user(@_); } sub _password { shift->SUPER::password(@_); } sub user { my $self = shift; my $user = $self->_user(@_); $user = "anonymous" unless defined $user; $user; } sub password { my $self = shift; my $pass = $self->_password(@_); unless (defined $pass) { my $user = $self->user; if ($user eq 'anonymous' || $user eq 'ftp') { # anonymous ftp login password # If there is no ftp anonymous password specified # then we'll just use 'anonymous@' # We don't try to send the read e-mail address because: # - We want to remain anonymous # - We want to stop SPAM # - We don't want to let ftp sites to discriminate by the user, # host, country or ftp client being used. $pass = 'anonymous@'; } } $pass; } 1; PK ! ����| | URI/gopher.pmnu �[��� package URI::gopher; # <draft-murali-url-gopher>, Dec 4, 1996 use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::_server'; use URI::Escape qw(uri_unescape); # A Gopher URL follows the common internet scheme syntax as defined in # section 4.3 of [RFC-URL-SYNTAX]: # # gopher://<host>[:<port>]/<gopher-path> # # where # # <gopher-path> := <gopher-type><selector> | # <gopher-type><selector>%09<search> | # <gopher-type><selector>%09<search>%09<gopher+_string> # # <gopher-type> := '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' # '8' | '9' | '+' | 'I' | 'g' | 'T' # # <selector> := *pchar Refer to RFC 1808 [4] # <search> := *pchar # <gopher+_string> := *uchar Refer to RFC 1738 [3] # # If the optional port is omitted, the port defaults to 70. sub default_port { 70 } sub _gopher_type { my $self = shift; my $path = $self->path_query; $path =~ s,^/,,; my $gtype = $1 if $path =~ s/^(.)//s; if (@_) { my $new_type = shift; if (defined($new_type)) { Carp::croak("Bad gopher type '$new_type'") unless length($new_type) == 1; substr($path, 0, 0) = $new_type; $self->path_query($path); } else { Carp::croak("Can't delete gopher type when selector is present") if length($path); $self->path_query(undef); } } return $gtype; } sub gopher_type { my $self = shift; my $gtype = $self->_gopher_type(@_); $gtype = "1" unless defined $gtype; $gtype; } sub gtype { goto &gopher_type } # URI::URL compatibility sub selector { shift->_gfield(0, @_) } sub search { shift->_gfield(1, @_) } sub string { shift->_gfield(2, @_) } sub _gfield { my $self = shift; my $fno = shift; my $path = $self->path_query; # not according to spec., but many popular browsers accept # gopher URLs with a '?' before the search string. $path =~ s/\?/\t/; $path = uri_unescape($path); $path =~ s,^/,,; my $gtype = $1 if $path =~ s,^(.),,s; my @path = split(/\t/, $path, 3); if (@_) { # modify my $new = shift; $path[$fno] = $new; pop(@path) while @path && !defined($path[-1]); for (@path) { $_="" unless defined } $path = $gtype; $path = "1" unless defined $path; $path .= join("\t", @path); $self->path_query($path); } $path[$fno]; } 1; PK ! `;z�� � URI/_login.pmnu �[��� package URI::_login; use strict; use warnings; use parent qw(URI::_server URI::_userpass); our $VERSION = '5.10'; # Generic terminal logins. This is used as a base class for 'telnet', # 'tn3270', and 'rlogin' URL schemes. 1; PK ! [�� URI/_userpass.pmnu �[��� package URI::_userpass; use strict; use warnings; use URI::Escape qw(uri_unescape); our $VERSION = '5.10'; sub user { my $self = shift; my $info = $self->userinfo; if (@_) { my $new = shift; my $pass = defined($info) ? $info : ""; $pass =~ s/^[^:]*//; if (!defined($new) && !length($pass)) { $self->userinfo(undef); } else { $new = "" unless defined($new); $new =~ s/%/%25/g; $new =~ s/:/%3A/g; $self->userinfo("$new$pass"); } } return undef unless defined $info; $info =~ s/:.*//; uri_unescape($info); } sub password { my $self = shift; my $info = $self->userinfo; if (@_) { my $new = shift; my $user = defined($info) ? $info : ""; $user =~ s/:.*//; if (!defined($new) && !length($user)) { $self->userinfo(undef); } else { $new = "" unless defined($new); $new =~ s/%/%25/g; $self->userinfo("$user:$new"); } } return undef unless defined $info; return undef unless $info =~ s/^[^:]*://; uri_unescape($info); } 1; PK ! ޜ} } URI/mms.pmnu �[��� package URI::mms; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::http'; sub default_port { 1755 } 1; PK ! r�� � URI/tn3270.pmnu �[��� package URI::tn3270; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::_login'; sub default_port { 23 } 1; PK ! WT�} } URI/rtsp.pmnu �[��� package URI::rtsp; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::http'; sub default_port { 554 } 1; PK ! ѻ�F URI/IRI.pmnu �[��� package URI::IRI; # Experimental use strict; use warnings; use URI (); use overload '""' => sub { shift->as_string }; our $VERSION = '5.10'; sub new { my($class, $uri, $scheme) = @_; utf8::upgrade($uri); return bless { uri => URI->new($uri, $scheme), }, $class; } sub clone { my $self = shift; return bless { uri => $self->{uri}->clone, }, ref($self); } sub as_string { my $self = shift; return $self->{uri}->as_iri; } our $AUTOLOAD; sub AUTOLOAD { my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); # We create the function here so that it will not need to be # autoloaded the next time. no strict 'refs'; *$method = sub { shift->{uri}->$method(@_) }; goto &$method; } sub DESTROY {} # avoid AUTOLOADing it 1; PK ! ��� � URI/_ldap.pmnu �[��� # Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package URI::_ldap; use strict; use warnings; our $VERSION = '5.10'; use URI::Escape qw(uri_unescape); sub _ldap_elem { my $self = shift; my $elem = shift; my $query = $self->query; my @bits = (split(/\?/,defined($query) ? $query : ""),("")x4); my $old = $bits[$elem]; if (@_) { my $new = shift; $new =~ s/\?/%3F/g; $bits[$elem] = $new; $query = join("?",@bits); $query =~ s/\?+$//; $query = undef unless length($query); $self->query($query); } $old; } sub dn { my $old = shift->path(@_); $old =~ s:^/::; uri_unescape($old); } sub attributes { my $self = shift; my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ()); return $old unless wantarray; map { uri_unescape($_) } split(/,/,$old); } sub _scope { my $self = shift; my $old = _ldap_elem($self,1, @_); return undef unless defined wantarray && defined $old; uri_unescape($old); } sub scope { my $old = &_scope; $old = "base" unless length $old; $old; } sub _filter { my $self = shift; my $old = _ldap_elem($self,2, @_); return undef unless defined wantarray && defined $old; uri_unescape($old); # || "(objectClass=*)"; } sub filter { my $old = &_filter; $old = "(objectClass=*)" unless length $old; $old; } sub extensions { my $self = shift; my @ext; while (@_) { my $key = shift; my $value = shift; push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value)); } @ext = join(",", @ext) if @ext; my $old = _ldap_elem($self,3, @ext); return $old unless wantarray; map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old); } sub canonical { my $self = shift; my $other = $self->_nonldap_canonical; # The stuff below is not as efficient as one might hope... $other = $other->clone if $other == $self; $other->dn(_normalize_dn($other->dn)); # Should really know about mixed case "postalAddress", etc... $other->attributes(map lc, $other->attributes); # Lowercase scope, remove default my $old_scope = $other->scope; my $new_scope = lc($old_scope); $new_scope = "" if $new_scope eq "base"; $other->scope($new_scope) if $new_scope ne $old_scope; # Remove filter if default my $old_filter = $other->filter; $other->filter("") if lc($old_filter) eq "(objectclass=*)" || lc($old_filter) eq "objectclass=*"; # Lowercase extensions types and deal with known extension values my @ext = $other->extensions; for (my $i = 0; $i < @ext; $i += 2) { my $etype = $ext[$i] = lc($ext[$i]); if ($etype =~ /^!?bindname$/) { $ext[$i+1] = _normalize_dn($ext[$i+1]); } } $other->extensions(@ext) if @ext; $other; } sub _normalize_dn # RFC 2253 { my $dn = shift; return $dn; # The code below will fail if the "+" or "," is embedding in a quoted # string or simply escaped... my @dn = split(/([+,])/, $dn); for (@dn) { s/^([a-zA-Z]+=)/lc($1)/e; } join("", @dn); } 1; PK ! ��g� � URI/snews.pmnu �[��� package URI::snews; # draft-gilman-news-url-01 use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::news'; sub default_port { 563 } sub secure { 1 } 1; PK ! �m�2� � URI/rlogin.pmnu �[��� package URI::rlogin; use strict; use warnings; our $VERSION = '5.10'; use parent 'URI::_login'; sub default_port { 513 } 1; PK ! ���� � URI/_segment.pmnu �[��� package URI::_segment; # Represents a generic path_segment so that it can be treated as # a string too. use strict; use warnings; use URI::Escape qw(uri_unescape); use overload '""' => sub { $_[0]->[0] }, fallback => 1; our $VERSION = '5.10'; sub new { my $class = shift; my @segment = split(';', shift, -1); $segment[0] = uri_unescape($segment[0]); bless \@segment, $class; } 1; PK ! � ��'& '& CGI/Fast.pmnu �[��� package CGI::Fast; use strict; use warnings; use if $] >= 5.019, 'deprecate'; $CGI::Fast::VERSION='2.15'; use CGI; use CGI::Carp; use FCGI; # use vars works like "our", but is compatible with older Perls. use vars qw( @ISA $ignore ); @ISA = ('CGI'); # workaround for known bug in libfcgi while (($ignore) = each %ENV) { } # override the initialization behavior so that # state is NOT maintained between invocations sub save_request { # no-op } # If ENV{FCGI_SOCKET_PATH} is specified, we maintain a FCGI Request handle # in this package variable. use vars qw($Ext_Request $socket $socket_perm $queue); sub import { my ($package,@import) = @_; # check imports for this class then pass on # imports to SUPER class for (my $i = 0; $i < scalar( @import ); $i++) { if ( $import[$i] eq 'socket_path' ) { $socket = $import[$i+1]; } elsif ( $import[$i] eq 'socket_perm' ) { $socket_perm = $import[$i+1]; } elsif ( $import[$i] eq 'listen_queue' ) { $queue = $import[$i+1]; } } $package->SUPER::import(@import); } sub _create_fcgi_request { my ( $in_fh,$out_fh,$err_fh ) = @_; # If we have a socket set, explicitly open it if ($ENV{FCGI_SOCKET_PATH} or $socket) { my $path = $ENV{FCGI_SOCKET_PATH} || $socket; my $perm = $ENV{FCGI_SOCKET_PERM} || $socket_perm; my $backlog = $ENV{FCGI_LISTEN_QUEUE} || $queue || 100; my $socket = FCGI::OpenSocket( $path, $backlog ); if ($path !~ /^:/ && defined $perm) { chmod $perm, $path or croak( "Couldn't chmod($path): $!" ); } return FCGI::Request( ( $in_fh || \*STDIN ), ( $out_fh || \*STDOUT ), ( $err_fh || \*STDERR ), \%ENV, $socket, 1 ); } else { return FCGI::Request( ( $in_fh || \*STDIN ), ( $out_fh || \*STDOUT ), ( $err_fh || \*STDERR ), ); } } { my ( $in_fh,$out_fh,$err_fh ); sub file_handles { my ($self, $handles) = @_; if ( ref( $handles ) eq 'HASH' ) { $in_fh = delete( $handles->{fcgi_input_file_handle} ); $out_fh = delete( $handles->{fcgi_output_file_handle} ); $err_fh = delete( $handles->{fcgi_error_file_handle} ); } } sub new { # # the interface to the ->new method is unfortunately somewhat # overloaded as it can be passed: # # nothing # an upload hook, "something", 0 # an initializer, an upload hook, "something", 0 # # these then get passed through to the SUPER class (CGI.pm) that # also has a constructor that can take various order of args # my ($self, @args) = @_; if ( ! $args[0] || ( ref( $args[0] ) && UNIVERSAL::isa( $args[0],'CODE' ) && ! $args[3] ) ) { $Ext_Request ||= _create_fcgi_request( $in_fh,$out_fh,$err_fh ); my $accept = $Ext_Request->Accept; return undef unless ( defined $accept && $accept >= 0 ); } CGI->_reset_globals; $self->_setup_symbols(@CGI::SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS; return $CGI::Q = $self->SUPER::new(@args); } } 1; =head1 NAME CGI::Fast - CGI Interface for Fast CGI =for html <a href='https://travis-ci.org/leejo/cgi-fast?branch=master'><img src='https://travis-ci.org/leejo/cgi-fast.svg?branch=master' alt='Build Status' /></a> <a href='https://coveralls.io/r/leejo/cgi-fast?branch=master'><img src='https://coveralls.io/repos/leejo/cgi-fast/badge.png?branch=master' alt='Coverage Status' /></a> =head1 SYNOPSIS use CGI::Fast socket_path => '9000', socket_perm => 0777, listen_queue => 50; use CGI qw/ :standard /; $COUNTER = 0; # optional, will default to STDOUT, STDERR CGI::Fast->file_handles({ fcgi_output_file_handle => IO::Handle->new, fcgi_error_file_handle => IO::Handle->new, }); while ($q = CGI::Fast->new) { process_request($q); } =head1 DESCRIPTION CGI::Fast is a subclass of the CGI object created by CGI.pm. It is specialized to work with the FCGI module, which greatly speeds up CGI scripts by turning them into persistently running server processes. Scripts that perform time-consuming initialization processes, such as loading large modules or opening persistent database connections, will see large performance improvements. Note that as CGI::Fast is based on CGI.pm it is no longer advised as a way to write Perl web apps. See L<https://metacpan.org/pod/CGI#CGI.pm-HAS-BEEN-REMOVED-FROM-THE-PERL-CORE> for more information about this =head1 OTHER PIECES OF THE PUZZLE In order to use CGI::Fast you'll need the FCGI module. See http://www.cpan.org/ for details. =head1 WRITING FASTCGI PERL SCRIPTS FastCGI scripts are persistent: one or more copies of the script are started up when the server initializes, and stay around until the server exits or they die a natural death. After performing whatever one-time initialization it needs, the script enters a loop waiting for incoming connections, processing the request, and waiting some more. A typical FastCGI script will look like this: #!perl use CGI::Fast; do_some_initialization(); while ($q = CGI::Fast->new) { process_request($q); } Each time there's a new request, CGI::Fast returns a CGI object to your loop. The rest of the time your script waits in the call to new(). When the server requests that your script be terminated, new() will return undef. You can of course exit earlier if you choose. A new version of the script will be respawned to take its place (this may be necessary in order to avoid Perl memory leaks in long-running scripts). CGI.pm's default CGI object mode also works. Just modify the loop this way: while (CGI::Fast->new) { process_request(); } Calls to header(), start_form(), etc. will all operate on the current request. =head1 INSTALLING FASTCGI SCRIPTS See the FastCGI developer's kit documentation for full details. On the Apache server, the following line must be added to srm.conf: AddType application/x-httpd-fcgi .fcgi FastCGI scripts must end in the extension .fcgi. For each script you install, you must add something like the following to srm.conf: FastCgiServer /usr/lib/cgi-bin/file_upload.fcgi -processes 2 This instructs Apache to launch two copies of file_upload.fcgi at startup time. =head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS Any script that works correctly as a FastCGI script will also work correctly when installed as a vanilla CGI script. However it will not see any performance benefit. =head1 EXTERNAL FASTCGI SERVER INVOCATION FastCGI supports a TCP/IP transport mechanism which allows FastCGI scripts to run external to the webserver, perhaps on a remote machine. To configure the webserver to connect to an external FastCGI server, you would add the following to your srm.conf: FastCgiExternalServer /usr/lib/cgi-bin/file_upload.fcgi -host sputnik:8888 Two environment variables affect how the C<CGI::Fast> object is created, allowing C<CGI::Fast> to be used as an external FastCGI server. (See C<FCGI> documentation for C<FCGI::OpenSocket> for more information.) You can set these as ENV variables or imports in the use CGI::Fast statement. If the ENV variables are set then these will be favoured so you can override the import statements on the command line, etc. =over =item FCGI_SOCKET_PATH / socket_path The address (TCP/IP) or path (UNIX Domain) of the socket the external FastCGI script to which bind an listen for incoming connections from the web server. =item FCGI_SOCKET_PERM / socket_perm Permissions for UNIX Domain socket. =item FCGI_LISTEN_QUEUE / listen_queue Maximum length of the queue of pending connections, defaults to 100. =back For example: use CGI::Fast socket_path => "sputnik:8888", listen_queue => "50" ; use CGI qw/ :standard /; do_some_initialization(); while ($q = CGI::Fast->new) { process_request($q); } Or: use CGI::Fast; use CGI qw/ :standard /; do_some_initialization(); $ENV{FCGI_SOCKET_PATH} = "sputnik:8888"; $ENV{FCGI_LISTEN_QUEUE} = 50; while ($q = CGI::Fast->new) { process_request($q); } Note the importance of having use CGI after use CGI::Fast as this will prevent any CGI import pragmas being overwritten by CGI::Fast. You can use CGI::Fast as a drop in replacement like so: use CGI::Fast qw/ :standard / =head1 FILE HANDLES FCGI defaults to using STDOUT and STDERR as its output filehandles - this may lead to unexpected redirect of output if you migrate scripts from CGI.pm to CGI::Fast. To get around this you can use the file_handles method, which you must do B<before> the first call to CGI::Fast->new. For example using IO::Handle: CGI::Fast->file_handles({ fcgi_output_file_handle => IO::Handle->new, fcgi_error_file_handle => IO::Handle->new, }); while (CGI::Fast->new) { .. } Overriding STDIN using the C<fcgi_input_file_handle> key is also possible, however doing so is likely to break at least POST requests. =head1 CAVEATS I haven't tested this very much. =head1 LICENSE Copyright 1996-1998, Lincoln D. Stein. All rights reserved. Currently maintained by Lee Johnson This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Address bug reports and comments to: https://github.com/leejo/cgi-fast =head1 BUGS This section intentionally left blank. =head1 SEE ALSO L<CGI::Carp>, L<CGI> =cut PK ! ZP��� � CGI/Pretty.pmnu �[��� package CGI::Pretty; use strict; use warnings; use CGI (); $CGI::Pretty::VERSION = '4.54'; $CGI::DefaultClass = __PACKAGE__; @CGI::Pretty::ISA = qw( CGI ); sub new { my $class = shift; my $this = $class->SUPER::new( @_ ); return bless $this, $class; } sub import { warn "CGI::Pretty is DEPRECATED and will be removed in a future release. Please see https://github.com/leejo/CGI.pm/issues/162 for more information"; my $self = shift; no strict 'refs'; # This causes modules to clash. undef %CGI::EXPORT; undef %CGI::EXPORT; $self->_setup_symbols(@_); my ($callpack, $callfile, $callline) = caller; # To allow overriding, search through the packages # Till we find one in which the correct subroutine is defined. my @packages = ($self,@{"$self\:\:ISA"}); foreach my $sym (keys %CGI::EXPORT) { my $pck; my $def = $CGI::DefaultClass; foreach $pck (@packages) { if (defined(&{"$pck\:\:$sym"})) { $def = $pck; last; } } *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; } } 1; =head1 NAME CGI::Pretty - module to produce nicely formatted HTML code =head1 CGI::Pretty IS DEPRECATED It will be removed from the CGI distribution in a future release, so you should no longer use it and remove it from any code that currently uses it. For now it has been reduced to a shell to prevent your code breaking, but the "pretty" functions will no longer output "pretty" HTML. =head1 Alternatives L<HTML::HTML5::Parser> + L<HTML::HTML5::Writer> + L<XML::LibXML::PrettyPrint>: print HTML::HTML5::Writer->new( start_tags => 'force', end_tags => 'force', )->document( XML::LibXML::PrettyPrint->new_for_html( indent_string => "\t" ) ->pretty_print( HTML::HTML5::Parser->new->parse_string( $html_string ) ) ); L<Marpa::R2::HTML> (see the html_fmt script for examples) L<HTML::Tidy> L<HTML::Parser> =cut PK ! P+��- �- CGI/Util.pmnu �[��� package CGI::Util; use parent 'Exporter'; require 5.008001; use strict; our @EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); our $VERSION = '4.54'; our $_EBCDIC = "\t" ne "\011"; my $appease_cpants_kwalitee = q/ use strict; use warnings; #/; # (ord('^') == 95) for codepage 1047 as on os390, vmesa our @A2E = ( 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97, 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109, 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7, 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255, 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188, 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171, 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119, 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89, 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87, 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223 ); our @E2A = ( 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15, 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31, 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7, 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26, 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124, 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94, 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63, 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34, 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177, 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164, 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174, 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215, 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245, 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255, 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159 ); if ($_EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74; $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95; $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186; $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173; $A2E[249] = 192; $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168; $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172; $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166; $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125; $E2A[255] = 126; } elsif ($_EBCDIC && ord('^') == 176) { # as in codepage 037 on os400 $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176; $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173; $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221; $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168; } # Smart rearrangement of parameters to allow named parameter # calling. We do the rearrangement if: # the first parameter begins with a - sub rearrange { my ($order,@param) = @_; my ($result, $leftover) = _rearrange_params( $order, @param ); push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 ) if keys %$leftover; @$result; } sub rearrange_header { my ($order,@param) = @_; my ($result,$leftover) = _rearrange_params( $order, @param ); push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover; @$result; } sub _rearrange_params { my($order,@param) = @_; return [] unless @param; if (ref($param[0]) eq 'HASH') { @param = %{$param[0]}; } else { return \@param unless (defined($param[0]) && substr($param[0],0,1) eq '-'); } # map parameters into positional indices my ($i,%pos); $i = 0; foreach (@$order) { foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; } $i++; } my %params_as_hash = ( @param ); my (@result,%leftover); $#result = $#$order; # preextend foreach my $k ( # sort keys alphabetically but favour certain keys before others # specifically for the case where there could be several options # for a param key, but one should be preferred (see GH #155) sort { if ( $a =~ /content/i ) { return 1 } elsif ( $b =~ /content/i ) { return -1 } else { $a cmp $b } } keys( %params_as_hash ) ) { my $key = lc($k); $key =~ s/^\-//; if (exists $pos{$key}) { $result[$pos{$key}] = $params_as_hash{$k}; } else { $leftover{$key} = $params_as_hash{$k}; } } return \@result, \%leftover; } sub make_attributes { my $attr = shift; return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; my $escape = shift || 0; my $do_not_quote = shift; my $quote = $do_not_quote ? '' : '"'; my @attr_keys= sort keys %$attr; my(@att); foreach (@attr_keys) { my($key) = $_; $key=~s/^\-//; # get rid of initial - if present # old way: breaks EBCDIC! # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_}; push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/); } return sort @att; } sub simple_escape { return unless defined(my $toencode = shift); $toencode =~ s{&}{&}gso; $toencode =~ s{<}{<}gso; $toencode =~ s{>}{>}gso; $toencode =~ s{\"}{"}gso; # Doesn't work. Can't work. forget it. # $toencode =~ s{\x8b}{‹}gso; # $toencode =~ s{\x9b}{›}gso; $toencode; } sub utf8_chr { my $c = shift(@_); my $u = chr($c); utf8::encode($u); # drop utf8 flag return $u; } # unescape URL-encoded data sub unescape { shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); my $todecode = shift; return undef unless defined($todecode); $todecode =~ tr/+/ /; # pluses become spaces if ($_EBCDIC) { $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge; } else { # handle surrogate pairs first -- dankogai. Ref: http://unicode.org/faq/utf_bom.html#utf16-2 $todecode =~ s{ %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo }{ utf8_chr( 0x10000 + (hex($1) - 0xD800) * 0x400 + (hex($2) - 0xDC00) ) }gex; $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/ defined($1)? chr hex($1) : utf8_chr(hex($2))/ge; } return $todecode; } # URL-encode data # # We cannot use the %u escapes, they were rejected by W3C, so the official # way is %XX-escaped utf-8 encoding. # Naturally, Unicode strings have to be converted to their utf-8 byte # representation. # Byte strings were traditionally used directly as a sequence of octets. # This worked if they actually represented binary data (i.e. in CGI::Compress). # This also worked if these byte strings were actually utf-8 encoded; e.g., # when the source file used utf-8 without the appropriate "use utf8;". # This fails if the byte string is actually a Latin 1 encoded string, but it # was always so and cannot be fixed without breaking the binary data case. # -- Stepan Kasal <skasal@redhat.com> # sub escape { # If we being called in an OO-context, discard the first argument. shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); my $toencode = shift; return undef unless defined($toencode); utf8::encode($toencode) if utf8::is_utf8($toencode); if ($_EBCDIC) { $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg; } else { $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg; } return $toencode; } # This internal routine creates date strings suitable for use in # cookies and HTTP headers. (They differ, unfortunately.) # Thanks to Mark Fisher for this. sub expires { my($time,$format) = @_; $format ||= 'http'; my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; # pass through preformatted dates for the sake of expire_calc() $time = expire_calc($time); return $time unless $time =~ /^\d+$/; # make HTTP/cookie date string from GMT'ed time # (cookies use '-' as date separator, HTTP uses ' ') my($sc) = ' '; $sc = '-' if $format eq "cookie"; my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); $year += 1900; return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); } # This internal routine creates an expires time exactly some number of # hours from the current time. It incorporates modifications from # Mark Fisher. sub expire_calc { my($time) = @_; my(%mult) = ('s'=>1, 'm'=>60, 'h'=>60*60, 'd'=>60*60*24, 'M'=>60*60*24*30, 'y'=>60*60*24*365); # format for time can be in any of the forms... # "now" -- expire immediately # "+180s" -- in 180 seconds # "+2m" -- in 2 minutes # "+12h" -- in 12 hours # "+1d" -- in 1 day # "+3M" -- in 3 months # "+2y" -- in 2 years # "-3m" -- 3 minutes ago(!) # If you don't supply one of these forms, we assume you are # specifying the date yourself my($offset); if (!$time || (lc($time) eq 'now')) { $offset = 0; } elsif ($time=~/^\d+/) { return $time; } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) { $offset = ($mult{$2} || 1)*$1; } else { return $time; } my $cur_time = time; return ($cur_time+$offset); } sub ebcdic2ascii { my $data = shift; $data =~ s/(.)/chr $E2A[ord($1)]/ge; $data; } sub ascii2ebcdic { my $data = shift; $data =~ s/(.)/chr $A2E[ord($1)]/ge; $data; } 1; __END__ =head1 NAME CGI::Util - Internal utilities used by CGI module =head1 SYNOPSIS none =head1 DESCRIPTION no public subroutines =head1 AUTHOR INFORMATION The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is distributed under the Artistic License 2.0. It is currently maintained by Lee Johnson with help from many contributors. Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm When sending bug reports, please provide the version of CGI.pm, the version of Perl, the name and version of your Web server, and the name and version of the operating system you are using. If the problem is even remotely browser dependent, please provide information about the affected browsers as well. =head1 SEE ALSO L<CGI> =cut PK ! �=�[D [D CGI/Cookie.pmnu �[��� package CGI::Cookie; use strict; use warnings; our $VERSION='4.54'; use CGI::Util qw(rearrange unescape escape); use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback' => 1; my $PERLEX = 0; # Turn on special checking for ActiveState's PerlEx $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; # Turn on special checking for mod_perl # PerlEx::DBI tries to fool DBI by setting MOD_PERL my $MOD_PERL = 0; if (exists $ENV{MOD_PERL} && ! $PERLEX) { if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { $MOD_PERL = 2; require Apache2::RequestUtil; require APR::Table; } else { $MOD_PERL = 1; require Apache; } } # fetch a list of cookies from the environment and # return as a hash. the cookies are parsed as normal # escaped URL data. sub fetch { my $class = shift; my $raw_cookie = get_raw_cookie(@_) or return; return $class->parse($raw_cookie); } # Fetch a list of cookies from the environment or the incoming headers and # return as a hash. The cookie values are not unescaped or altered in any way. sub raw_fetch { my $class = shift; my $raw_cookie = get_raw_cookie(@_) or return; my %results; my($key,$value); my @pairs = split("[;,] ?",$raw_cookie); for my $pair ( @pairs ) { $pair =~ s/^\s+|\s+$//g; # trim leading trailing whitespace my ( $key, $value ) = split "=", $pair; $value = defined $value ? $value : ''; $results{$key} = $value; } return wantarray ? %results : \%results; } sub get_raw_cookie { my $r = shift; $r ||= eval { $MOD_PERL == 2 ? Apache2::RequestUtil->request() : Apache->request } if $MOD_PERL; return $r->headers_in->{'Cookie'} if $r; die "Run $r->subprocess_env; before calling fetch()" if $MOD_PERL and !exists $ENV{REQUEST_METHOD}; return $ENV{HTTP_COOKIE} || $ENV{COOKIE}; } sub parse { my ($self,$raw_cookie) = @_; return wantarray ? () : {} unless $raw_cookie; my %results; my @pairs = split("[;,] ?",$raw_cookie); for (@pairs) { s/^\s+//; s/\s+$//; my($key,$value) = split("=",$_,2); # Some foreign cookies are not in name=value format, so ignore # them. next if !defined($value); my @values = (); if ($value ne '') { @values = map unescape($_),split(/[&;]/,$value.'&dmy'); pop @values; } $key = unescape($key); # A bug in Netscape can cause several cookies with same name to # appear. The FIRST one in HTTP_COOKIE is the most recent version. $results{$key} ||= $self->new(-name=>$key,-value=>\@values); } return wantarray ? %results : \%results; } sub new { my ( $class, @params ) = @_; $class = ref( $class ) || $class; # Ignore mod_perl request object--compatibility with Apache::Cookie. shift if ref $params[0] && eval { $params[0]->isa('Apache::Request::Req') || $params[0]->isa('Apache') }; my ( $name, $value, $path, $domain, $secure, $expires, $max_age, $httponly, $samesite ) = rearrange( [ 'NAME', [ 'VALUE', 'VALUES' ], 'PATH', 'DOMAIN', 'SECURE', 'EXPIRES', 'MAX-AGE','HTTPONLY','SAMESITE' ], @params ); return undef unless defined $name and defined $value; my $self = {}; bless $self, $class; $self->name( $name ); $self->value( $value ); $path ||= "/"; $self->path( $path ) if defined $path; $self->domain( $domain ) if defined $domain; $self->secure( $secure ) if defined $secure; $self->expires( $expires ) if defined $expires; $self->max_age( $max_age ) if defined $max_age; $self->httponly( $httponly ) if defined $httponly; $self->samesite( $samesite ) if defined $samesite; return $self; } sub as_string { my $self = shift; return "" unless $self->name; no warnings; # some things may be undefined, that's OK. my $name = escape( $self->name ); my $value = join "&", map { escape($_) } $self->value; my @cookie = ( "$name=$value" ); push @cookie,"domain=".$self->domain if $self->domain; push @cookie,"path=".$self->path if $self->path; push @cookie,"expires=".$self->expires if $self->expires; push @cookie,"max-age=".$self->max_age if $self->max_age; push @cookie,"secure" if $self->secure; push @cookie,"HttpOnly" if $self->httponly; push @cookie,"SameSite=".$self->samesite if $self->samesite; return join "; ", @cookie; } sub compare { my ( $self, $value ) = @_; return "$self" cmp $value; } sub bake { my ($self, $r) = @_; $r ||= eval { $MOD_PERL == 2 ? Apache2::RequestUtil->request() : Apache->request } if $MOD_PERL; if ($r) { $r->err_headers_out->add('Set-Cookie' => $self->as_string); } else { require CGI; print CGI::header(-cookie => $self); } } # accessors sub name { my ( $self, $name ) = @_; $self->{'name'} = $name if defined $name; return $self->{'name'}; } sub value { my ( $self, $value ) = @_; if ( defined $value ) { my @values = ref $value eq 'ARRAY' ? @$value : ref $value eq 'HASH' ? %$value : ( $value ); $self->{'value'} = [@values]; } return wantarray ? @{ $self->{'value'} } : $self->{'value'}->[0]; } sub domain { my ( $self, $domain ) = @_; $self->{'domain'} = lc $domain if defined $domain; return $self->{'domain'}; } sub secure { my ( $self, $secure ) = @_; $self->{'secure'} = $secure if defined $secure; return $self->{'secure'}; } sub expires { my ( $self, $expires ) = @_; $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires; return $self->{'expires'}; } sub max_age { my ( $self, $max_age ) = @_; $self->{'max-age'} = CGI::Util::expire_calc($max_age)-time() if defined $max_age; return $self->{'max-age'}; } sub path { my ( $self, $path ) = @_; $self->{'path'} = $path if defined $path; return $self->{'path'}; } sub httponly { # HttpOnly my ( $self, $httponly ) = @_; $self->{'httponly'} = $httponly if defined $httponly; return $self->{'httponly'}; } my %_legal_samesite = ( Strict => 1, Lax => 1, None => 1 ); sub samesite { # SameSite my $self = shift; my $samesite = ucfirst lc +shift if @_; # Normalize casing. $self->{'samesite'} = $samesite if $samesite and $_legal_samesite{$samesite}; return $self->{'samesite'}; } 1; =head1 NAME CGI::Cookie - Interface to HTTP Cookies =head1 SYNOPSIS use CGI qw/:standard/; use CGI::Cookie; # Create new cookies and send them $cookie1 = CGI::Cookie->new(-name=>'ID',-value=>123456); $cookie2 = CGI::Cookie->new(-name=>'preferences', -value=>{ font => Helvetica, size => 12 } ); print header(-cookie=>[$cookie1,$cookie2]); # fetch existing cookies %cookies = CGI::Cookie->fetch; $id = $cookies{'ID'}->value; # create cookies returned from an external source %cookies = CGI::Cookie->parse($ENV{COOKIE}); =head1 DESCRIPTION CGI::Cookie is an interface to HTTP/1.1 cookies, a mechanism that allows Web servers to store persistent information on the browser's side of the connection. Although CGI::Cookie is intended to be used in conjunction with CGI.pm (and is in fact used by it internally), you can use this module independently. For full information on cookies see https://tools.ietf.org/html/rfc6265 =head1 USING CGI::Cookie CGI::Cookie is object oriented. Each cookie object has a name and a value. The name is any scalar value. The value is any scalar or array value (associative arrays are also allowed). Cookies also have several optional attributes, including: =over 4 =item B<1. expiration date> The expiration date tells the browser how long to hang on to the cookie. If the cookie specifies an expiration date in the future, the browser will store the cookie information in a disk file and return it to the server every time the user reconnects (until the expiration date is reached). If the cookie species an expiration date in the past, the browser will remove the cookie from the disk file. If the expiration date is not specified, the cookie will persist only until the user quits the browser. =item B<2. domain> This is a partial or complete domain name for which the cookie is valid. The browser will return the cookie to any host that matches the partial domain name. For example, if you specify a domain name of ".capricorn.com", then the browser will return the cookie to Web servers running on any of the machines "www.capricorn.com", "ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names must contain at least two periods to prevent attempts to match on top level domains like ".edu". If no domain is specified, then the browser will only return the cookie to servers on the host the cookie originated from. =item B<3. path> If you provide a cookie path attribute, the browser will check it against your script's URL before returning the cookie. For example, if you specify the path "/cgi-bin", then the cookie will be returned to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and "/cgi-bin/customer_service/complain.pl", but not to the script "/cgi-private/site_admin.pl". By default, the path is set to "/", so that all scripts at your site will receive the cookie. =item B<4. secure flag> If the "secure" attribute is set, the cookie will only be sent to your script if the CGI request is occurring on a secure channel, such as SSL. =item B<5. httponly flag> If the "httponly" attribute is set, the cookie will only be accessible through HTTP Requests. This cookie will be inaccessible via JavaScript (to prevent XSS attacks). This feature is supported by nearly all modern browsers. See these URLs for more information: http://msdn.microsoft.com/en-us/library/ms533046.aspx http://www.browserscope.org/?category=security&v=top =item B<6. samesite flag> Allowed settings are C<Strict>, C<Lax> and C<None>. As of June 2016, support is limited to recent releases of Chrome and Opera. L<https://tools.ietf.org/html/draft-west-first-party-cookies-07> =back =head2 Creating New Cookies my $c = CGI::Cookie->new(-name => 'foo', -value => 'bar', -expires => '+3M', '-max-age' => '+3M', -domain => '.capricorn.com', -path => '/cgi-bin/database', -secure => 1, -samesite=> "Lax" ); Create cookies from scratch with the B<new> method. The B<-name> and B<-value> parameters are required. The name must be a scalar value. The value can be a scalar, an array reference, or a hash reference. (At some point in the future cookies will support one of the Perl object serialization protocols for full generality). B<-expires> accepts any of the relative or absolute date formats recognized by CGI.pm, for example "+3M" for three months in the future. See CGI.pm's documentation for details. B<-max-age> accepts the same data formats as B<< -expires >>, but sets a relative value instead of an absolute like B<< -expires >>. This is intended to be more secure since a clock could be changed to fake an absolute time. In practice, as of 2011, C<< -max-age >> still does not enjoy the widespread support that C<< -expires >> has. You can set both, and browsers that support C<< -max-age >> should ignore the C<< Expires >> header. The drawback to this approach is the bit of bandwidth for sending an extra header on each cookie. B<-domain> points to a domain name or to a fully qualified host name. If not specified, the cookie will be returned only to the Web server that created it. B<-path> points to a partial URL on the current server. The cookie will be returned to all URLs beginning with the specified path. If not specified, it defaults to '/', which returns the cookie to all pages at your site. B<-secure> if set to a true value instructs the browser to return the cookie only when a cryptographic protocol is in use. B<-httponly> if set to a true value, the cookie will not be accessible via JavaScript. B<-samesite> may be C<Lax>, C<Strict>, or C<None> and is an evolving part of the standards for cookies. Please refer to current documentation regarding it. For compatibility with Apache::Cookie, you may optionally pass in a mod_perl request object as the first argument to C<new()>. It will simply be ignored: my $c = CGI::Cookie->new($r, -name => 'foo', -value => ['bar','baz']); =head2 Sending the Cookie to the Browser The simplest way to send a cookie to the browser is by calling the bake() method: $c->bake; This will print the Set-Cookie HTTP header to STDOUT using CGI.pm. CGI.pm will be loaded for this purpose if it is not already. Otherwise CGI.pm is not required or used by this module. Under mod_perl, pass in an Apache request object: $c->bake($r); If you want to set the cookie yourself, Within a CGI script you can send a cookie to the browser by creating one or more Set-Cookie: fields in the HTTP header. Here is a typical sequence: my $c = CGI::Cookie->new(-name => 'foo', -value => ['bar','baz'], -expires => '+3M'); print "Set-Cookie: $c\n"; print "Content-Type: text/html\n\n"; To send more than one cookie, create several Set-Cookie: fields. If you are using CGI.pm, you send cookies by providing a -cookie argument to the header() method: print header(-cookie=>$c); Mod_perl users can set cookies using the request object's header_out() method: $r->err_headers_out->add('Set-Cookie' => $c); Internally, Cookie overloads the "" operator to call its as_string() method when incorporated into the HTTP header. as_string() turns the Cookie's internal representation into an RFC-compliant text representation. You may call as_string() yourself if you prefer: print "Set-Cookie: ",$c->as_string,"\n"; =head2 Recovering Previous Cookies %cookies = CGI::Cookie->fetch; B<fetch> returns an associative array consisting of all cookies returned by the browser. The keys of the array are the cookie names. You can iterate through the cookies this way: %cookies = CGI::Cookie->fetch; for (keys %cookies) { do_something($cookies{$_}); } In a scalar context, fetch() returns a hash reference, which may be more efficient if you are manipulating multiple cookies. CGI.pm uses the URL escaping methods to save and restore reserved characters in its cookies. If you are trying to retrieve a cookie set by a foreign server, this escaping method may trip you up. Use raw_fetch() instead, which has the same semantics as fetch(), but performs no unescaping. You may also retrieve cookies that were stored in some external form using the parse() class method: $COOKIES = `cat /usr/tmp/Cookie_stash`; %cookies = CGI::Cookie->parse($COOKIES); If you are in a mod_perl environment, you can save some overhead by passing the request object to fetch() like this: CGI::Cookie->fetch($r); If the value passed to parse() is undefined, an empty array will returned in list context, and an empty hashref will be returned in scalar context. =head2 Manipulating Cookies Cookie objects have a series of accessor methods to get and set cookie attributes. Each accessor has a similar syntax. Called without arguments, the accessor returns the current value of the attribute. Called with an argument, the accessor changes the attribute and returns its new value. =over 4 =item B<name()> Get or set the cookie's name. Example: $name = $c->name; $new_name = $c->name('fred'); =item B<value()> Get or set the cookie's value. Example: $value = $c->value; @new_value = $c->value(['a','b','c','d']); B<value()> is context sensitive. In a list context it will return the current value of the cookie as an array. In a scalar context it will return the B<first> value of a multivalued cookie. =item B<domain()> Get or set the cookie's domain. =item B<path()> Get or set the cookie's path. =item B<expires()> Get or set the cookie's expiration time. =item B<max_age()> Get or set the cookie's max_age value. =back =head1 AUTHOR INFORMATION The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is distributed under the Artistic License 2.0. It is currently maintained by Lee Johnson with help from many contributors. Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm When sending bug reports, please provide the version of CGI.pm, the version of Perl, the name and version of your Web server, and the name and version of the operating system you are using. If the problem is even remotely browser dependent, please provide information about the affected browsers as well. =head1 BUGS This section intentionally left blank. =head1 SEE ALSO L<CGI::Carp>, L<CGI> L<RFC 2109|http://www.ietf.org/rfc/rfc2109.txt>, L<RFC 2695|http://www.ietf.org/rfc/rfc2965.txt> =cut PK ! ��� � CGI/File/Temp.pmnu �[��� # this is a back compatibility wrapper around File::Temp. DO NOT # use this package outside of CGI, i won't provide any help if # you use it directly and your code breaks horribly. package CGI::File::Temp; $CGI::File::Temp::VERSION = '4.54'; use parent File::Temp; use parent Fh; my $appease_cpants_kwalitee = q/ use strict; use warnings; #/; use overload '""' => \&asString, 'cmp' => \&compare, 'fallback'=>1; # back compatibility method since we now return a File::Temp object # as the filehandle (which isa IO::Handle) so calling ->handle on # it will fail. FIXME: deprecate this method in v5+ sub handle { return shift; }; sub compare { my ( $self,$value ) = @_; return "$self" cmp $value; } sub _mp_filename { my ( $self,$filename ) = @_; ${*$self}->{ _mp_filename } = $filename if $filename; return ${*$self}->{_mp_filename}; } sub asString { my ( $self ) = @_; return $self->_mp_filename; } 1; PK ! 9e �SJ SJ CGI/Carp.pmnu �[��� package CGI::Carp; my $appease_cpants_kwalitee = q/ use strict; use warnings; #/; =head1 NAME B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log =head1 SYNOPSIS use CGI::Carp; croak "We're outta here!"; confess "It was my fault: $!"; carp "It was your fault!"; warn "I'm confused"; die "I'm dying.\n"; use CGI::Carp qw(cluck); cluck "I wouldn't do that if I were you"; use CGI::Carp qw(fatalsToBrowser); die "Fatal error messages are now sent to browser"; =head1 DESCRIPTION CGI scripts have a nasty habit of leaving warning messages in the error logs that are neither time stamped nor fully identified. Tracking down the script that caused the error is a pain. This fixes that. Replace the usual use Carp; with use CGI::Carp The standard warn(), die (), croak(), confess() and carp() calls will be replaced with functions that write time-stamped messages to the HTTP server error log. For example: [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3. [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied. [Fri Nov 17 21:40:43 1995] test.pl: I'm dying. =head1 REDIRECTING ERROR MESSAGES By default, error messages are sent to STDERR. Most HTTPD servers direct STDERR to the server's error log. Some applications may wish to keep private error logs, distinct from the server's error log, or they may wish to direct error messages to STDOUT so that the browser will receive them. The C<carpout()> function is provided for this purpose. Since carpout() is not exported by default, you must import it explicitly by saying use CGI::Carp qw(carpout); The carpout() function requires one argument, a reference to an open filehandle for writing errors. It should be called in a C<BEGIN> block at the top of the CGI application so that compiler errors will be caught. Example: BEGIN { use CGI::Carp qw(carpout); open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or die("Unable to open mycgi-log: $!\n"); carpout(LOG); } carpout() does not handle file locking on the log for you at this point. Also, note that carpout() does not work with in-memory file handles, although a patch would be welcome to address that. The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. Some servers, when dealing with CGI scripts, close their connection to the browser when the script closes STDOUT and STDERR. CGI::Carp::SAVEERR is there to prevent this from happening prematurely. You can pass filehandles to carpout() in a variety of ways. The "correct" way according to Tom Christiansen is to pass a reference to a filehandle GLOB: carpout(\*LOG); This looks weird to mere mortals however, so the following syntaxes are accepted as well: carpout(LOG); carpout(main::LOG); carpout(main'LOG); carpout(\LOG); carpout(\'main::LOG'); ... and so on FileHandle and other objects work as well. Use of carpout() is not great for performance, so it is recommended for debugging purposes or for moderate-use applications. A future version of this module may delay redirecting STDERR until one of the CGI::Carp methods is called to prevent the performance hit. =head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW If you want to send fatal (die, confess) errors to the browser, import the special "fatalsToBrowser" subroutine: use CGI::Carp qw(fatalsToBrowser); die "Bad error here"; Fatal errors will now be echoed to the browser as well as to the log. CGI::Carp arranges to send a minimal HTTP header to the browser so that even errors that occur in the early compile phase will be seen. Nonfatal errors will still be directed to the log file only (unless redirected with carpout). Note that fatalsToBrowser may B<not> work well with mod_perl version 2.0 and higher. =head2 Changing the default message By default, the software error message is followed by a note to contact the Webmaster by e-mail with the time and date of the error. If this message is not to your liking, you can change it using the set_message() routine. This is not imported by default; you should import it on the use() line: use CGI::Carp qw(fatalsToBrowser set_message); set_message("It's not a bug, it's a feature!"); You may also pass in a code reference in order to create a custom error message. At run time, your code will be called with the text of the error message that caused the script to die. Example: use CGI::Carp qw(fatalsToBrowser set_message); BEGIN { sub handle_errors { my $msg = shift; print "<h1>Oh gosh</h1>"; print "<p>Got an error: $msg</p>"; } set_message(\&handle_errors); } In order to correctly intercept compile-time errors, you should call set_message() from within a BEGIN{} block. =head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS If fatalsToBrowser in conjunction with set_message does not provide you with all of the functionality you need, you can go one step further by specifying a function to be executed any time a script calls "die", has a syntax error, or dies unexpectedly at runtime with a line like "undef->explode();". use CGI::Carp qw(set_die_handler); BEGIN { sub handle_errors { my $msg = shift; print "content-type: text/html\n\n"; print "<h1>Oh gosh</h1>"; print "<p>Got an error: $msg</p>"; #proceed to send an email to a system administrator, #write a detailed message to the browser and/or a log, #etc.... } set_die_handler(\&handle_errors); } Notice that if you use set_die_handler(), you must handle sending HTML headers to the browser yourself if you are printing a message. If you use set_die_handler(), you will most likely interfere with the behavior of fatalsToBrowser, so you must use this or that, not both. Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser), and there is only one SIG{__DIE__}. This means that if you are attempting to set SIG{__DIE__} yourself, you may interfere with this module's functionality, or this module may interfere with your module's functionality. =head1 SUPPRESSING PERL ERRORS APPEARING IN THE BROWSER WINDOW A problem sometimes encountered when using fatalsToBrowser is when a C<die()> is done inside an C<eval> body or expression. Even though the fatalsToBrower support takes precautions to avoid this, you still may get the error message printed to STDOUT. This may have some undesirable effects when the purpose of doing the eval is to determine which of several algorithms is to be used. By setting C<$CGI::Carp::TO_BROWSER> to 0 you can suppress printing the C<die> messages but without all of the complexity of using C<set_die_handler>. You can localize this effect to inside C<eval> bodies if this is desirable: For example: eval { local $CGI::Carp::TO_BROWSER = 0; die "Fatal error messages not sent browser" } # $@ will contain error message =head1 MAKING WARNINGS APPEAR AS HTML COMMENTS It is also possible to make non-fatal errors appear as HTML comments embedded in the output of your program. To enable this feature, export the new "warningsToBrowser" subroutine. Since sending warnings to the browser before the HTTP headers have been sent would cause an error, any warnings are stored in an internal buffer until you call the warningsToBrowser() subroutine with a true argument: use CGI::Carp qw(fatalsToBrowser warningsToBrowser); use CGI qw(:standard); print header(); warningsToBrowser(1); You may also give a false argument to warningsToBrowser() to prevent warnings from being sent to the browser while you are printing some content where HTML comments are not allowed: warningsToBrowser(0); # disable warnings print "<script type=\"text/javascript\"><!--\n"; print_some_javascript_code(); print "//--></script>\n"; warningsToBrowser(1); # re-enable warnings Note: In this respect warningsToBrowser() differs fundamentally from fatalsToBrowser(), which you should never call yourself! =head1 OVERRIDING THE NAME OF THE PROGRAM CGI::Carp includes the name of the program that generated the error or warning in the messages written to the log and the browser window. Sometimes, Perl can get confused about what the actual name of the executed program was. In these cases, you can override the program name that CGI::Carp will use for all messages. The quick way to do that is to tell CGI::Carp the name of the program in its use statement. You can do that by adding "name=cgi_carp_log_name" to your "use" statement. For example: use CGI::Carp qw(name=cgi_carp_log_name); . If you want to change the program name partway through the program, you can use the C<set_progname()> function instead. It is not exported by default, you must import it explicitly by saying use CGI::Carp qw(set_progname); Once you've done that, you can change the logged name of the program at any time by calling set_progname(new_program_name); You can set the program back to the default by calling set_progname(undef); Note that this override doesn't happen until after the program has compiled, so any compile-time errors will still show up with the non-overridden program name =head1 TURNING OFF TIMESTAMPS IN MESSAGES If your web server automatically adds a timestamp to each log line, you may not need CGI::Carp to add its own. You can disable timestamping by importing "noTimestamp": use CGI::Carp qw(noTimestamp); Alternatively you can set C<$CGI::Carp::NO_TIMESTAMP> to 1. Note that the name of the program is still automatically included in the message. =head1 GETTING THE FULL PATH OF THE SCRIPT IN MESSAGES Set C<$CGI::Carp::FULL_PATH> to 1. =head1 AUTHOR INFORMATION The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is distributed under the Artistic License 2.0. It is currently maintained by Lee Johnson with help from many contributors. Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm When sending bug reports, please provide the version of CGI.pm, the version of Perl, the name and version of your Web server, and the name and version of the operating system you are using. If the problem is even remotely browser dependent, please provide information about the affected browsers as well. =head1 SEE ALSO L<Carp>, L<CGI::Base>, L<CGI::BasePlus>, L<CGI::Request>, L<CGI::MiniSvr>, L<CGI::Form>, L<CGI::Response>. =cut require 5.000; use Exporter; #use Carp; BEGIN { require Carp; *CORE::GLOBAL::die = \&CGI::Carp::die; } use File::Spec; @ISA = qw(Exporter); @EXPORT = qw(confess croak carp); @EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap noTimestamp set_message set_die_handler set_progname cluck ^name= die); $main::SIG{__WARN__}=\&CGI::Carp::warn; $CGI::Carp::VERSION = '4.54'; $CGI::Carp::CUSTOM_MSG = undef; $CGI::Carp::DIE_HANDLER = undef; $CGI::Carp::TO_BROWSER = 1; $CGI::Carp::NO_TIMESTAMP= 0; $CGI::Carp::FULL_PATH = 0; # fancy import routine detects and handles 'errorWrap' specially. sub import { my $pkg = shift; my(%routines); my(@name); if (@name=grep(/^name=/,@_)) { my($n) = (split(/=/,$name[0]))[1]; set_progname($n); @_=grep(!/^name=/,@_); } grep($routines{$_}++,@_,@EXPORT); $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; $WARN++ if $routines{'warningsToBrowser'}; my($oldlevel) = $Exporter::ExportLevel; $Exporter::ExportLevel = 1; Exporter::import($pkg,keys %routines); $Exporter::ExportLevel = $oldlevel; $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'}; $CGI::Carp::NO_TIMESTAMP = 1 if $routines{'noTimestamp'}; } # These are the originals sub realwarn { CORE::warn(@_); } sub realdie { CORE::die(@_); } sub id { my $level = shift; my($pack,$file,$line,$sub) = caller($level); my($dev,$dirs,$id) = File::Spec->splitpath($file); return ($file,$line,$id); } sub stamp { my $frame = 0; my ($id,$pack,$file,$dev,$dirs); if (defined($CGI::Carp::PROGNAME)) { $id = $CGI::Carp::PROGNAME; } else { do { $id = $file; ($pack,$file) = caller($frame++); } until !$file; } if (! $CGI::Carp::FULL_PATH) { ($dev,$dirs,$id) = File::Spec->splitpath($id); } return "$id: " if $CGI::Carp::NO_TIMESTAMP; my $time = scalar(localtime); return "[$time] $id: "; } sub set_progname { $CGI::Carp::PROGNAME = shift; return $CGI::Carp::PROGNAME; } sub warn { my $message = shift; my($file,$line,$id) = id(1); $message .= " at $file line $line.\n" unless $message=~/\n$/; _warn($message) if $WARN; my $stamp = stamp; $message=~s/^/$stamp/gm; realwarn $message; } sub _warn { my $msg = shift; if ($EMIT_WARNINGS) { # We need to mangle the message a bit to make it a valid HTML # comment. This is done by substituting similar-looking ISO # 8859-1 characters for <, > and -. This is a hack. $msg =~ tr/<>-/\253\273\255/; chomp $msg; print STDOUT "<!-- warning: $msg -->\n"; } else { push @WARNINGS, $msg; } } # The mod_perl package Apache::Registry loads CGI programs by calling # eval. These evals don't count when looking at the stack backtrace. sub _longmess { my $message = Carp::longmess(); $message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s if exists $ENV{MOD_PERL}; return $message; } sub ineval { (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m } sub die { # if no argument is passed, propagate $@ like # the real die my ($arg,@rest) = @_ ? @_ : $@ ? "$@\t...propagated" : "Died" ; &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER; # the "$arg" is done on purpose! # if called as die( $object, 'string' ), # all is stringified, just like with # the real 'die' $arg = join '' => "$arg", @rest if @rest; my($file,$line,$id) = id(1); $arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/; realdie $arg if ineval(); &fatalsToBrowser($arg) if ($WRAP and $CGI::Carp::TO_BROWSER); $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL}; $arg .= "\n" unless $arg =~ /\n$/; realdie $arg; } sub set_message { $CGI::Carp::CUSTOM_MSG = shift; return $CGI::Carp::CUSTOM_MSG; } sub set_die_handler { my ($handler) = shift; #setting SIG{__DIE__} here is necessary to catch runtime #errors which are not called by literally saying "die", #such as the line "undef->explode();". however, doing this #will interfere with fatalsToBrowser, which also sets #SIG{__DIE__} in the import() function above (or the #import() function above may interfere with this). for #this reason, you should choose to either set the die #handler here, or use fatalsToBrowser, not both. $main::SIG{__DIE__} = $handler; $CGI::Carp::DIE_HANDLER = $handler; return $CGI::Carp::DIE_HANDLER; } sub confess { CGI::Carp::die Carp::longmess @_; } sub croak { CGI::Carp::die Carp::shortmess @_; } sub carp { CGI::Carp::warn Carp::shortmess @_; } sub cluck { CGI::Carp::warn Carp::longmess @_; } # We have to be ready to accept a filehandle as a reference # or a string. sub carpout { my($in) = @_; my($no) = fileno(to_filehandle($in)); realdie("Invalid filehandle $in\n") unless defined $no; open(SAVEERR, ">&STDERR"); open(STDERR, ">&$no") or ( print SAVEERR "Unable to redirect >&$no: $!\n" and exit(1) ); } sub warningsToBrowser { $EMIT_WARNINGS = @_ ? shift : 1; _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS; } # headers sub fatalsToBrowser { my $msg = shift; $msg = "$msg" if ref $msg; $msg=~s/&/&/g; $msg=~s/>/>/g; $msg=~s/</</g; $msg=~s/"/"/g; my($wm) = $ENV{SERVER_ADMIN} ? qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : "this site's webmaster"; my ($outer_message) = <<END; For help, please send mail to $wm, giving this error message and the time and date of the error. END ; my $mod_perl = exists $ENV{MOD_PERL}; if ($CUSTOM_MSG) { if (ref($CUSTOM_MSG) eq 'CODE') { print STDOUT "Content-type: text/html\n\n" unless $mod_perl; eval { &$CUSTOM_MSG($msg); # nicer to perl 5.003 users }; if ($@) { print STDERR qq(error while executing the error handler: $@); } return; } else { $outer_message = $CUSTOM_MSG; } } my $mess = <<END; <h1>Software error:</h1> <pre>$msg</pre> <p> $outer_message </p> END ; if ($mod_perl) { my $r; if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { $mod_perl = 2; require Apache2::RequestRec; require Apache2::RequestIO; require Apache2::RequestUtil; require APR::Pool; require ModPerl::Util; require Apache2::Response; $r = Apache2::RequestUtil->request; } else { $r = Apache->request; } # If bytes have already been sent, then # we print the message out directly. # Otherwise we make a custom error # handler to produce the doc for us. if ($r->bytes_sent) { $r->print($mess); $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit; } else { # MSIE won't display a custom 500 response unless it is >512 bytes! if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) { $mess = "<!-- " . (' ' x 513) . " -->\n$mess"; } $r->custom_response(500,$mess); } } else { my $bytes_written = eval{tell STDOUT}; if (defined $bytes_written && $bytes_written > 0) { print STDOUT $mess; } else { print STDOUT "Status: 500\n"; print STDOUT "Content-type: text/html\n\n"; # MSIE won't display a custom 500 response unless it is >512 bytes! if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) { $mess = "<!-- " . (' ' x 513) . " -->\n$mess"; } print STDOUT $mess; } } warningsToBrowser(1); # emit warnings before dying } # Cut and paste from CGI.pm so that we don't have the overhead of # always loading the entire CGI module. sub to_filehandle { my $thingy = shift; return undef unless $thingy; return $thingy if UNIVERSAL::isa($thingy,'GLOB'); return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); if (!ref($thingy)) { my $caller = 1; while (my $package = caller($caller++)) { my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; return $tmp if defined(fileno($tmp)); } } return undef; } 1; PK ! r��}' }' CGI/Push.pmnu �[��� package CGI::Push; my $appease_cpants_kwalitee = q/ use strict; use warnings; #/; $CGI::Push::VERSION='4.54'; use CGI; use CGI::Util 'rearrange'; @ISA = ('CGI'); $CGI::DefaultClass = 'CGI::Push'; # add do_push() and push_delay() to exported tags push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay'); sub do_push { my ($self,@p) = CGI::self_or_default(@_); # unbuffer output $| = 1; srand; my ($random) = sprintf("%08.0f",rand()*1E8); my ($boundary) = "----=_NeXtPaRt$random"; my (@header); my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,$nph,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); $type = 'text/html' unless $type; $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE'; $delay = 1 unless defined($delay); $self->push_delay($delay); $nph = 1 unless defined($nph); my(@o); foreach (@other) { push(@o,split("=")); } push(@o,'-Target'=>$target) if defined($target); push(@o,'-Cookie'=>$cookie) if defined($cookie); push(@o,'-Type'=>"multipart/x-mixed-replace;boundary=\"$boundary\""); push(@o,'-Server'=>"CGI.pm Push Module") if $nph; push(@o,'-Status'=>'200 OK'); push(@o,'-nph'=>1) if $nph; print $self->header(@o); $boundary = "$CGI::CRLF--$boundary"; print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF"; my (@contents) = &$callback($self,++$COUNTER); # now we enter a little loop while (1) { print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i; print @contents; @contents = &$callback($self,++$COUNTER); if ((@contents) && defined($contents[0])) { print "${boundary}$CGI::CRLF"; do_sleep($self->push_delay()) if $self->push_delay(); } else { if ($last_page && ref($last_page) eq 'CODE') { print "${boundary}$CGI::CRLF"; do_sleep($self->push_delay()) if $self->push_delay(); print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i; print &$last_page($self,$COUNTER); } print "${boundary}--$CGI::CRLF"; last; } } print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.$CGI::CRLF"; } sub simple_counter { my ($self,$count) = @_; return $self->start_html("CGI::Push Default Counter"), $self->h1("CGI::Push Default Counter"), "This page has been updated ",$self->strong($count)," times.", $self->hr(), $self->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'), $self->end_html; } sub do_sleep { my $delay = shift; if ( ($delay >= 1) && ($delay!~/\./) ){ sleep($delay); } else { select(undef,undef,undef,$delay); return $delay; } } sub push_delay { my ($self,$delay) = CGI::self_or_default(@_); return defined($delay) ? $self->{'.delay'} = $delay : $self->{'.delay'}; } 1; =head1 NAME CGI::Push - Simple Interface to Server Push =head1 SYNOPSIS use strict; use warnings; use CGI::Push qw(:standard); do_push( -next_page => \&next_page, -last_page => \&last_page, -delay => 0.5 ); sub next_page { my($q,$counter) = @_; return undef if $counter >= 10; .... } sub last_page { my($q,$counter) = @_; return ... } =head1 DESCRIPTION CGI::Push is a subclass of the CGI object created by CGI.pm. It is specialized for server push operations, which allow you to create animated pages whose content changes at regular intervals. You provide CGI::Push with a pointer to a subroutine that will draw one page. Every time your subroutine is called, it generates a new page. The contents of the page will be transmitted to the browser in such a way that it will replace what was there beforehand. The technique will work with HTML pages as well as with graphics files, allowing you to create animated GIFs. Only Netscape Navigator supports server push. Internet Explorer browsers do not. =head1 USING CGI::Push CGI::Push adds one new method to the standard CGI suite, do_push(). When you call this method, you pass it a reference to a subroutine that is responsible for drawing each new page, an interval delay, and an optional subroutine for drawing the last page. Other optional parameters include most of those recognized by the CGI header() method. You may call do_push() in the object oriented manner or not, as you prefer: use CGI::Push; $q = CGI::Push->new; $q->do_push(-next_page=>\&draw_a_page); -or- use CGI::Push qw(:standard); do_push(-next_page=>\&draw_a_page); Parameters are as follows: =over 4 =item -next_page do_push(-next_page=>\&my_draw_routine); This required parameter points to a reference to a subroutine responsible for drawing each new page. The subroutine should expect two parameters consisting of the CGI object and a counter indicating the number of times the subroutine has been called. It should return the contents of the page as an B<array> of one or more items to print. It can return a false value (or an empty array) in order to abort the redrawing loop and print out the final page (if any) sub my_draw_routine { my($q,$counter) = @_; return undef if $counter > 100; ... } You are of course free to refer to create and use global variables within your draw routine in order to achieve special effects. =item -last_page This optional parameter points to a reference to the subroutine responsible for drawing the last page of the series. It is called after the -next_page routine returns a false value. The subroutine itself should have exactly the same calling conventions as the -next_page routine. =item -type This optional parameter indicates the content type of each page. It defaults to "text/html". Normally the module assumes that each page is of a homogeneous MIME type. However if you provide either of the magic values "heterogeneous" or "dynamic" (the latter provided for the convenience of those who hate long parameter names), you can specify the MIME type -- and other header fields -- on a per-page basis. See "heterogeneous pages" for more details. =item -delay This indicates the delay, in seconds, between frames. Smaller delays refresh the page faster. Fractional values are allowed. B<If not specified, -delay will default to 1 second> =item -cookie, -target, -expires, -nph These have the same meaning as the like-named parameters in CGI::header(). If not specified, -nph will default to 1 (as needed for many servers, see below). =back =head2 Heterogeneous Pages Ordinarily all pages displayed by CGI::Push share a common MIME type. However by providing a value of "heterogeneous" or "dynamic" in the do_push() -type parameter, you can specify the MIME type of each page on a case-by-case basis. If you use this option, you will be responsible for producing the HTTP header for each page. Simply modify your draw routine to look like this: sub my_draw_routine { my($q,$counter) = @_; return header('text/html'), # note we're producing the header here .... } You can add any header fields that you like, but some (cookies and status fields included) may not be interpreted by the browser. One interesting effect is to display a series of pages, then, after the last page, to redirect the browser to a new URL. Because redirect() does b<not> work, the easiest way is with a -refresh header field, as shown below: sub my_draw_routine { my($q,$counter) = @_; return undef if $counter > 10; return header('text/html'), # note we're producing the header here ... } sub my_last_page { return header(-refresh=>'5; URL=http://somewhere.else/finished.html', -type=>'text/html'), ... } =head2 Changing the Page Delay on the Fly If you would like to control the delay between pages on a page-by-page basis, call push_delay() from within your draw routine. push_delay() takes a single numeric argument representing the number of seconds you wish to delay after the current page is displayed and before displaying the next one. The delay may be fractional. Without parameters, push_delay() just returns the current delay. =head1 INSTALLING CGI::Push SCRIPTS Server push scripts must be installed as no-parsed-header (NPH) scripts in order to work correctly on many servers. On Unix systems, this is most often accomplished by prefixing the script's name with "nph-". Recognition of NPH scripts happens automatically with WebSTAR and Microsoft IIS. Users of other servers should see their documentation for help. Apache web server from version 1.3b2 on does not need server push scripts installed as NPH scripts: the -nph parameter to do_push() may be set to a false value to disable the extra headers needed by an NPH script. =head1 AUTHOR INFORMATION The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is distributed under the Artistic License 2.0. It is currently maintained by Lee Johnson with help from many contributors. Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm When sending bug reports, please provide the version of CGI.pm, the version of Perl, the name and version of your Web server, and the name and version of the operating system you are using. If the problem is even remotely browser dependent, please provide information about the affected browsers as well. Copyright 1995-1998, Lincoln D. Stein. All rights reserved. =head1 BUGS This section intentionally left blank. =head1 SEE ALSO L<CGI::Carp>, L<CGI> =cut PK ! ��} } CGI/HTML/Functions.pmnu �[��� package CGI::HTML::Functions; use strict; use warnings; # nothing here yet... may move functions here in the long term 1; PK ! G ":p� p� CGI/HTML/Functions.podnu �[��� =head1 NAME CGI::HTML::Functions - Documentation for CGI.pm Legacy HTML Functionality =head1 SYNOPSIS Nothing here - please do not use this functionality, it is considered to be legacy and essentially deprecated. This documentation exists solely to aid in maintenance and migration of legacy code using this functionality and you are strongly encouraged to migrate away from it. If you are working on new code you should be using a template engine. For more information see L<CGI::Alternatives>. If you really want to continue using the HTML generation functionality of CGI.pm then you should take a look at L<HTML::Tiny> instead, which may give you a migration path away from CGI.pm's html generation functions; i strongly encourage you to move towards template driven page generation for anything involving markup as it will make porting your app to other frameworks much easier in the long run. =head1 DESCRIPTION The documentation here should be considered an addendum to the sections in the L<CGI> documentation - the sections here are named the same as those within the CGI perldoc. =head1 Calling CGI.pm routines HTML tag functions have both attributes (the attribute="value" pairs within the tag itself) and contents (the part between the opening and closing pairs). To distinguish between attributes and contents, CGI.pm uses the convention of passing HTML attributes as a hash reference as the first argument, and the contents, if any, as any subsequent arguments. It works out like this: Code Generated HTML ---- -------------- h1() <h1 /> h1('some','contents'); <h1>some contents</h1> h1({-align=>left}); <h1 align="LEFT"> h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1> Many newcomers to CGI.pm are puzzled by the difference between the calling conventions for the HTML shortcuts, which require curly braces around the HTML tag attributes, and the calling conventions for other routines, which manage to generate attributes without the curly brackets. Don't be confused. As a convenience the curly braces are optional in all but the HTML shortcuts. If you like, you can use curly braces when calling any routine that takes named arguments. For example: print $q->header( { -type => 'image/gif', -expires => '+3d' } ); If you use warnings, you will be warned that some CGI.pm argument names conflict with built-in perl functions. The most frequent of these is the -values argument, used to create multi-valued menus, radio button clusters and the like. To get around this warning, you have several choices: =over 4 =item 1. Use another name for the argument, if one is available. For example, -value is an alias for -values. =item 2. Change the capitalization, e.g. -Values =item 3. Put quotes around the argument name, e.g. '-values' =back =head2 Function-oriented interface HTML exports Here is a list of the HTML related function sets you can import: =over 4 =item B<:form> Import all fill-out form generating methods, such as B<textfield()>. =item B<:html2> Import all methods that generate HTML 2.0 standard elements. =item B<:html3> Import all methods that generate HTML 3.0 elements (such as <table>, <super> and <sub>). =item B<:html4> Import all methods that generate HTML 4 elements (such as <abbrev>, <acronym> and <thead>). =item B<:netscape> Import the <blink>, <fontsize> and <center> tags. =item B<:html> Import all HTML-generating shortcuts (i.e. 'html2', 'html3', 'html4' and 'netscape') =item B<:standard> Import "standard" features, 'html2', 'html3', 'html4', 'ssl', 'form' and 'cgi'. =back If you import any of the state-maintaining CGI or form-generating methods, a default CGI object will be created and initialized automatically the first time you use any of the methods that require one to be present. This includes B<param()>, B<textfield()>, B<submit()> and the like. (If you need direct access to the CGI object, you can find it in the global variable B<$CGI::Q>). =head2 Pragmas Additional HTML generation related pragms: =over 4 =item -nosticky By default the CGI module implements a state-preserving behavior called "sticky" fields. The way this works is that if you are regenerating a form, the methods that generate the form field values will interrogate param() to see if similarly-named parameters are present in the query string. If they find a like-named parameter, they will use it to set their default values. Sometimes this isn't what you want. The B<-nosticky> pragma prevents this behavior. You can also selectively change the sticky behavior in each element that you generate. =item -tabindex Automatically add tab index attributes to each form field. With this option turned off, you can still add tab indexes manually by passing a -tabindex option to each field-generating method. =item -no_xhtml By default, CGI.pm versions 2.69 and higher emit XHTML (http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this feature. If start_html()'s -dtd parameter specifies an HTML 2.0, 3.2, 4.0 or 4.01 DTD, XHTML will automatically be disabled without needing to use this pragma. =back =head2 Special forms for importing HTML-tag functions Many of the methods generate HTML tags. As described below, tag functions automatically generate both the opening and closing tags. For example: print h1('Level 1 Header'); produces <h1>Level 1 Header</h1> There will be some times when you want to produce the start and end tags yourself. In this case, you can use the form start_I<tag_name> and end_I<tag_name>, as in: print start_h1,'Level 1 Header',end_h1; =head2 Creating the HTML document header print start_html( -title => 'Secrets of the Pyramids', -author => 'fred@capricorn.org', -base => 'true', -target => '_blank', -meta => {'keywords'=>'pharaoh secret mummy', 'copyright' => 'copyright 1996 King Tut'}, -style => {'src'=>'/styles/style1.css'}, -BGCOLOR => 'blue' ); The start_html() routine creates the top of the page, along with a lot of optional information that controls the page's appearance and behavior. This method returns a canned HTML header and the opening <body> tag. All parameters are optional. In the named parameter form, recognized parameters are -title, -author, -base, -xbase, -dtd, -lang and -target (see below for the explanation). Any additional parameters you provide, such as the unofficial BGCOLOR attribute, are added to the <body> tag. Additional parameters must be proceeded by a hyphen. The argument B<-xbase> allows you to provide an HREF for the <base> tag different from the current location, as in -xbase => "http://home.mcom.com/" All relative links will be interpreted relative to this tag. The argument B<-target> allows you to provide a default target frame for all the links and fill-out forms on the page. B<This is a non-standard HTTP feature> B<which only works with some browsers!> -target => "answer_window" All relative links will be interpreted relative to this tag. You add arbitrary meta information to the header with the B<-meta> argument. This argument expects a reference to a hash containing name/value pairs of meta information. These will be turned into a series of header <meta> tags that look something like this: <meta name="keywords" content="pharaoh secret mummy"> <meta name="description" content="copyright 1996 King Tut"> To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described below. The B<-style> argument is used to incorporate cascading stylesheets into your code. See the section on CASCADING STYLESHEETS for more information. The B<-lang> argument is used to incorporate a language attribute into the <html> tag. For example: print $q->start_html( -lang => 'fr-CA' ); The default if not specified is "en-US" for US English, unless the -dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the lang attribute is left off. You can force the lang attribute to left off in other cases by passing an empty string (-lang=>''). The B<-encoding> argument can be used to specify the character set for XHTML. It defaults to iso-8859-1 if not specified. The B<-dtd> argument can be used to specify a public DTD identifier string. For example: -dtd => '-//W3C//DTD HTML 4.01 Transitional//EN') Alternatively, it can take public and system DTD identifiers as an array: -dtd => [ '-//W3C//DTD HTML 4.01 Transitional//EN', 'http://www.w3.org/TR/html4/loose.dtd' ] For the public DTD identifier to be considered, it must be valid. Otherwise it will be replaced by the default DTD. If the public DTD contains 'XHTML', CGI.pm will emit XML. The B<-declare_xml> argument, when used in conjunction with XHTML, will put a <?xml> declaration at the top of the HTML header. The sole purpose of this declaration is to declare the character set encoding. In the absence of -declare_xml, the output HTML will contain a <meta> tag that specifies the encoding, allowing the HTML to pass most validators. The default for -declare_xml is false. You can place other arbitrary HTML elements to the <head> section with the B<-head> tag. For example, to place a <link> element in the head section, use this: print start_html( -head => Link({ -rel => 'shortcut icon', -href => 'favicon.ico' }) ); To incorporate multiple HTML elements into the <head> section, just pass an array reference: print start_html( -head => [ Link({ -rel => 'next', -href => 'http://www.capricorn.com/s2.html' }), Link({ -rel => 'previous', -href => 'http://www.capricorn.com/s1.html' }) ] ); And here's how to create an HTTP-EQUIV <meta> tag: print start_html( -head => meta({ -http_equiv => 'Content-Type', -content => 'text/html' }) ); JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>, B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used to add JavaScript calls to your pages. B<-script> should point to a block of text containing JavaScript function definitions. This block will be placed within a <script> block inside the HTML (not HTTP) header. The block is placed in the header in order to give your page a fighting chance of having all its JavaScript functions in place even if the user presses the stop button before the page has loaded completely. CGI.pm attempts to format the script in such a way that JavaScript-naive browsers will not choke on the code: unfortunately there are some browsers that get confused by it nevertheless. The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript code to execute when the page is respectively opened and closed by the browser. Usually these parameters are calls to functions defined in the B<-script> field: $q = CGI->new; print header; $JSCRIPT = <<END; // Ask a silly question function riddle_me_this() { var r = prompt( "What walks on four legs in the morning, " + "two legs in the afternoon, " + "and three legs in the evening?" ); response(r); } // Get a silly answer function response(answer) { if (answer == "man") alert("Right you are!"); else alert("Wrong! Guess again."); } END print start_html( -title => 'The Riddle of the Sphinx', -script => $JSCRIPT ); Use the B<-noScript> parameter to pass some HTML text that will be displayed on browsers that do not have JavaScript (or browsers where JavaScript is turned off). The <script> tag, has several attributes including "type", "charset" and "src". "src" allows you to keep JavaScript code in an external file. To use these attributes pass a HASH reference in the B<-script> parameter containing one or more of -type, -src, or -code: print $q->start_html( -title => 'The Riddle of the Sphinx', -script => { -type => 'JAVASCRIPT', -src => '/javascript/sphinx.js'} ); print $q->( -title => 'The Riddle of the Sphinx', -script => { -type => 'PERLSCRIPT', -code => 'print "hello world!\n;"' } ); A final feature allows you to incorporate multiple <script> sections into the header. Just pass the list of script sections as an array reference. This allows you to specify different source files for different dialects of JavaScript. Example: print $q->start_html( -title => 'The Riddle of the Sphinx', -script => [ { -type => 'text/javascript', -src => '/javascript/utilities10.js' }, { -type => 'text/javascript', -src => '/javascript/utilities11.js' }, { -type => 'text/jscript', -src => '/javascript/utilities12.js' }, { -type => 'text/ecmascript', -src => '/javascript/utilities219.js' } ] ); The option "-language" is a synonym for -type, and is supported for backwards compatibility. The old-style positional parameters are as follows: B<Parameters:> =over 4 =item 1. The title =item 2. The author's e-mail address (will create a <link rev="MADE"> tag if present =item 3. A 'true' flag if you want to include a <base> tag in the header. This helps resolve relative addresses to absolute ones when the document is moved, but makes the document hierarchy non-portable. Use with care! =back Other parameters you want to include in the <body> tag may be appended to these. This is a good place to put HTML extensions, such as colors and wallpaper patterns. =head2 Ending the Html document: print $q->end_html; This ends an HTML document by printing the </body></html> tags. =head1 CREATING STANDARD HTML ELEMENTS: CGI.pm defines general HTML shortcut methods for many HTML tags. HTML shortcuts are named after a single HTML element and return a fragment of HTML text. Example: print $q->blockquote( "Many years ago on the island of", $q->a({href=>"http://crete.org/"},"Crete"), "there lived a Minotaur named", $q->strong("Fred."), ), $q->hr; This results in the following HTML code (extra newlines have been added for readability): <blockquote> Many years ago on the island of <a href="http://crete.org/">Crete</a> there lived a minotaur named <strong>Fred.</strong> </blockquote> <hr> If you find the syntax for calling the HTML shortcuts awkward, you can import them into your namespace and dispense with the object syntax completely (see the next section for more details): use CGI ':standard'; print blockquote( "Many years ago on the island of", a({href=>"http://crete.org/"},"Crete"), "there lived a minotaur named", strong("Fred."), ), hr; =head2 Providing arguments to HTML shortcuts The HTML methods will accept zero, one or multiple arguments. If you provide no arguments, you get a single tag: print hr; # <hr> If you provide one or more string arguments, they are concatenated together with spaces and placed between opening and closing tags: print h1("Chapter","1"); # <h1>Chapter 1</h1>" If the first argument is a hash reference, then the keys and values of the hash become the HTML tag's attributes: print a({-href=>'fred.html',-target=>'_new'}, "Open a new frame"); <a href="fred.html",target="_new">Open a new frame</a> You may dispense with the dashes in front of the attribute names if you prefer: print img {src=>'fred.gif',align=>'LEFT'}; <img align="LEFT" src="fred.gif"> Sometimes an HTML tag attribute has no argument. For example, ordered lists can be marked as COMPACT. The syntax for this is an argument that that points to an undef string: print ol({compact=>undef},li('one'),li('two'),li('three')); Prior to CGI.pm version 2.41, providing an empty ('') string as an attribute argument was the same as providing undef. However, this has changed in order to accommodate those who want to create tags of the form <img alt="">. The difference is shown in these two pieces of code: CODE RESULT img({alt=>undef}) <img alt> img({alt=>''}) <img alt=""> =head2 The distributive property of HTML shortcuts One of the cool features of the HTML shortcuts is that they are distributive. If you give them an argument consisting of a B<reference> to a list, the tag will be distributed across each element of the list. For example, here's one way to make an ordered list: print ul( li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']) ); This example will result in HTML output that looks like this: <ul> <li type="disc">Sneezy</li> <li type="disc">Doc</li> <li type="disc">Sleepy</li> <li type="disc">Happy</li> </ul> This is extremely useful for creating tables. For example: print table({-border=>undef}, caption('When Should You Eat Your Vegetables?'), Tr({-align=>'CENTER',-valign=>'TOP'}, [ th(['Vegetable', 'Breakfast','Lunch','Dinner']), td(['Tomatoes' , 'no', 'yes', 'yes']), td(['Broccoli' , 'no', 'no', 'yes']), td(['Onions' , 'yes','yes', 'yes']) ] ) ); =head2 HTML shortcuts and list interpolation Consider this bit of code: print blockquote(em('Hi'),'mom!')); It will ordinarily return the string that you probably expect, namely: <blockquote><em>Hi</em> mom!</blockquote> Note the space between the element "Hi" and the element "mom!". CGI.pm puts the extra space there using array interpolation, which is controlled by the magic $" variable. Sometimes this extra space is not what you want, for example, when you are trying to align a series of images. In this case, you can simply change the value of $" to an empty string. { local($") = ''; print blockquote(em('Hi'),'mom!')); } I suggest you put the code in a block as shown here. Otherwise the change to $" will affect all subsequent code until you explicitly reset it. =head2 Non-standard HTML shortcuts A few HTML tags don't follow the standard pattern for various reasons. B<comment()> generates an HTML comment (<!-- comment -->). Call it like print comment('here is my comment'); Because of conflicts with built-in perl functions, the following functions begin with initial caps: Select Tr Link Delete Accept Sub In addition, start_html(), end_html(), start_form(), end_form(), start_multipart_form() and all the fill-out form tags are special. See their respective sections. =head2 Autoescaping HTML By default, all HTML that is emitted by the form-generating functions is passed through a function called escapeHTML(): =over 4 =item $escaped_string = escapeHTML("unescaped string"); Escape HTML formatting characters in a string. Internally this calls L<HTML::Entities> (encode_entities) so really you should just use that instead - the default list of chars that will be encoded (passed to the HTML::Entities encode_entities method) is: & < > " \x8b \x9b ' you can control this list by setting the value of $CGI::ENCODE_ENTITIES: # only encode < > $CGI::ENCODE_ENTITIES = q{<>} if you want to encode B<all> entities then undef $CGI::ENCODE_ENTITIES: # encode all entities $CGI::ENCODE_ENTITIES = undef; =back The automatic escaping does not apply to other shortcuts, such as h1(). You should call escapeHTML() yourself on untrusted data in order to protect your pages against nasty tricks that people may enter into guestbooks, etc.. To change the character set, use charset(). To turn autoescaping off completely, use autoEscape(0): =over 4 =item $charset = charset([$charset]); Get or set the current character set. =item $flag = autoEscape([$flag]); Get or set the value of the autoescape flag. =back =head1 CREATING FILL-OUT FORMS: I<General note> The various form-creating methods all return strings to the caller, containing the tag or tags that will create the requested form element. You are responsible for actually printing out these strings. It's set up this way so that you can place formatting tags around the form elements. I<Another note> The default values that you specify for the forms are only used the B<first> time the script is invoked (when there is no query string). On subsequent invocations of the script (when there is a query string), the former values are used even if they are blank. If you want to change the value of a field from its previous value, you have two choices: (1) call the param() method to set it. (2) use the -override (alias -force) parameter (a new feature in version 2.15). This forces the default value to be used, regardless of the previous value: print textfield(-name=>'field_name', -default=>'starting value', -override=>1, -size=>50, -maxlength=>80); I<Yet another note> By default, the text and labels of form elements are escaped according to HTML rules. This means that you can safely use "<CLICK ME>" as the label for a button. However, it also interferes with your ability to incorporate special HTML character sequences, such as Á, into your fields. If you wish to turn off automatic escaping, call the autoEscape() method with a false value immediately after creating the CGI object: $q = CGI->new; $q->autoEscape(0); Note that autoEscape() is exclusively used to effect the behavior of how some CGI.pm HTML generation functions handle escaping. Calling escapeHTML() explicitly will always escape the HTML. I<A Lurking Trap!> Some of the form-element generating methods return multiple tags. In a scalar context, the tags will be concatenated together with spaces, or whatever is the current value of the $" global. In a list context, the methods will return a list of elements, allowing you to modify them if you wish. Usually you will not notice this behavior, but beware of this: printf("%s\n",end_form()) end_form() produces several tags, and only the first of them will be printed because the format only expects one value. <p> =head2 Creating an isindex tag print isindex(-action=>$action); -or- print isindex($action); Prints out an <isindex> tag. Not very exciting. The parameter -action specifies the URL of the script to process the query. The default is to process the query with the current script. =head2 Starting and ending a form print start_form(-method=>$method, -action=>$action, -enctype=>$encoding); <... various form stuff ...> print end_form; -or- print start_form($method,$action,$encoding); <... various form stuff ...> print end_form; start_form() will return a <form> tag with the optional method, action and form encoding that you specify. The defaults are: method: POST action: this script enctype: application/x-www-form-urlencoded for non-XHTML multipart/form-data for XHTML, see multipart/form-data below. end_form() returns the closing </form> tag. start_form()'s enctype argument tells the browser how to package the various fields of the form before sending the form to the server. Two values are possible: =over 4 =item B<application/x-www-form-urlencoded> This is the older type of encoding. It is compatible with many CGI scripts and is suitable for short fields containing text data. For your convenience, CGI.pm stores the name of this encoding type in B<&CGI::URL_ENCODED>. =item B<multipart/form-data> This is the newer type of encoding. It is suitable for forms that contain very large fields or that are intended for transferring binary data. Most importantly, it enables the "file upload" feature. For your convenience, CGI.pm stores the name of this encoding type in B<&CGI::MULTIPART> Forms that use this type of encoding are not easily interpreted by CGI scripts unless they use CGI.pm or another library designed to handle them. If XHTML is activated (the default), then forms will be automatically created using this type of encoding. =back The start_form() method uses the older form of encoding by default unless XHTML is requested. If you want to use the newer form of encoding by default, you can call B<start_multipart_form()> instead of B<start_form()>. The method B<end_multipart_form()> is an alias to B<end_form()>. JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided for use with JavaScript. The -name parameter gives the form a name so that it can be identified and manipulated by JavaScript functions. -onSubmit should point to a JavaScript function that will be executed just before the form is submitted to your server. You can use this opportunity to check the contents of the form for consistency and completeness. If you find something wrong, you can put up an alert box or maybe fix things up yourself. You can abort the submission by returning false from this function. Usually the bulk of JavaScript functions are defined in a <script> block in the HTML header and -onSubmit points to one of these function call. See start_html() for details. =head2 Form elements After starting a form, you will typically create one or more textfields, popup menus, radio groups and other form elements. Each of these elements takes a standard set of named arguments. Some elements also have optional arguments. The standard arguments are as follows: =over 4 =item B<-name> The name of the field. After submission this name can be used to retrieve the field's value using the param() method. =item B<-value>, B<-values> The initial value of the field which will be returned to the script after form submission. Some form elements, such as text fields, take a single scalar -value argument. Others, such as popup menus, take a reference to an array of values. The two arguments are synonyms. =item B<-tabindex> A numeric value that sets the order in which the form element receives focus when the user presses the tab key. Elements with lower values receive focus first. =item B<-id> A string identifier that can be used to identify this element to JavaScript and DHTML. =item B<-override> A boolean, which, if true, forces the element to take on the value specified by B<-value>, overriding the sticky behavior described earlier for the B<-nosticky> pragma. =item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect> These are used to assign JavaScript event handlers. See the JavaScripting section for more details. =back Other common arguments are described in the next section. In addition to these, all attributes described in the HTML specifications are supported. =head2 Creating a text field print textfield(-name=>'field_name', -value=>'starting value', -size=>50, -maxlength=>80); -or- print textfield('field_name','starting value',50,80); textfield() will return a text input field. B<Parameters> =over 4 =item 1. The first parameter is the required name for the field (-name). =item 2. The optional second parameter is the default starting value for the field contents (-value, formerly known as -default). =item 3. The optional third parameter is the size of the field in characters (-size). =item 4. The optional fourth parameter is the maximum number of characters the field will accept (-maxlength). =back As with all these methods, the field will be initialized with its previous contents from earlier invocations of the script. When the form is processed, the value of the text field can be retrieved with: $value = param('foo'); If you want to reset it from its initial value after the script has been called once, you can do so like this: param('foo',"I'm taking over this value!"); =head2 Creating a big text field print textarea(-name=>'foo', -default=>'starting value', -rows=>10, -columns=>50); -or print textarea('foo','starting value',10,50); textarea() is just like textfield, but it allows you to specify rows and columns for a multiline text entry box. You can provide a starting value for the field, which can be long and contain multiple lines. =head2 Creating a password field print password_field(-name=>'secret', -value=>'starting value', -size=>50, -maxlength=>80); -or- print password_field('secret','starting value',50,80); password_field() is identical to textfield(), except that its contents will be starred out on the web page. =head2 Creating a file upload field print filefield(-name=>'uploaded_file', -default=>'starting value', -size=>50, -maxlength=>80); -or- print filefield('uploaded_file','starting value',50,80); filefield() will return a file upload field. In order to take full advantage of this I<you must use the new multipart encoding scheme> for the form. You can do this either by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>, or by calling the new method B<start_multipart_form()> instead of vanilla B<start_form()>. B<Parameters> =over 4 =item 1. The first parameter is the required name for the field (-name). =item 2. The optional second parameter is the starting value for the field contents to be used as the default file name (-default). For security reasons, browsers don't pay any attention to this field, and so the starting value will always be blank. Worse, the field loses its "sticky" behavior and forgets its previous contents. The starting value field is called for in the HTML specification, however, and possibly some browser will eventually provide support for it. =item 3. The optional third parameter is the size of the field in characters (-size). =item 4. The optional fourth parameter is the maximum number of characters the field will accept (-maxlength). =back JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are recognized. See textfield() for details. =head2 Creating a popup menu print popup_menu('menu_name', ['eenie','meenie','minie'], 'meenie'); -or- %labels = ('eenie'=>'your first choice', 'meenie'=>'your second choice', 'minie'=>'your third choice'); %attributes = ('eenie'=>{'class'=>'class of first choice'}); print popup_menu('menu_name', ['eenie','meenie','minie'], 'meenie',\%labels,\%attributes); -or (named parameter style)- print popup_menu(-name=>'menu_name', -values=>['eenie','meenie','minie'], -default=>['meenie','minie'], -labels=>\%labels, -attributes=>\%attributes); popup_menu() creates a menu. Please note that the -multiple option will be ignored if passed - use scrolling_list() if you want to create a menu that supports multiple selections =over 4 =item 1. The required first argument is the menu's name (-name). =item 2. The required second argument (-values) is an array B<reference> containing the list of menu items in the menu. You can pass the method an anonymous array, as shown in the example, or a reference to a named array, such as "\@foo". =item 3. The optional third parameter (-default) is the name of the default menu choice. If not specified, the first item will be the default. The values of the previous choice will be maintained across queries. Pass an array reference to select multiple defaults. =item 4. The optional fourth parameter (-labels) is provided for people who want to use different values for the user-visible label inside the popup menu and the value returned to your script. It's a pointer to an hash relating menu values to user-visible labels. If you leave this parameter blank, the menu values will be displayed by default. (You can also leave a label undefined if you want to). =item 5. The optional fifth parameter (-attributes) is provided to assign any of the common HTML attributes to an individual menu item. It's a pointer to a hash relating menu values to another hash with the attribute's name as the key and the attribute's value as the value. =back When the form is processed, the selected value of the popup menu can be retrieved using: $popup_menu_value = param('menu_name'); =head2 Creating an option group Named parameter style print popup_menu(-name=>'menu_name', -values=>[qw/eenie meenie minie/, optgroup(-name=>'optgroup_name', -values => ['moe','catch'], -attributes=>{'catch'=>{'class'=>'red'}})], -labels=>{'eenie'=>'one', 'meenie'=>'two', 'minie'=>'three'}, -default=>'meenie'); Old style print popup_menu('menu_name', ['eenie','meenie','minie', optgroup('optgroup_name', ['moe', 'catch'], {'catch'=>{'class'=>'red'}})],'meenie', {'eenie'=>'one','meenie'=>'two','minie'=>'three'}); optgroup() creates an option group within a popup menu. =over 4 =item 1. The required first argument (B<-name>) is the label attribute of the optgroup and is B<not> inserted in the parameter list of the query. =item 2. The required second argument (B<-values>) is an array reference containing the list of menu items in the menu. You can pass the method an anonymous array, as shown in the example, or a reference to a named array, such as \@foo. If you pass a HASH reference, the keys will be used for the menu values, and the values will be used for the menu labels (see -labels below). =item 3. The optional third parameter (B<-labels>) allows you to pass a reference to a hash containing user-visible labels for one or more of the menu items. You can use this when you want the user to see one menu string, but have the browser return your program a different one. If you don't specify this, the value string will be used instead ("eenie", "meenie" and "minie" in this example). This is equivalent to using a hash reference for the -values parameter. =item 4. An optional fourth parameter (B<-labeled>) can be set to a true value and indicates that the values should be used as the label attribute for each option element within the optgroup. =item 5. An optional fifth parameter (-novals) can be set to a true value and indicates to suppress the val attribute in each option element within the optgroup. See the discussion on optgroup at W3C (http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP) for details. =item 6. An optional sixth parameter (-attributes) is provided to assign any of the common HTML attributes to an individual menu item. It's a pointer to a hash relating menu values to another hash with the attribute's name as the key and the attribute's value as the value. =back =head2 Creating a scrolling list print scrolling_list('list_name', ['eenie','meenie','minie','moe'], ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}}); -or- print scrolling_list('list_name', ['eenie','meenie','minie','moe'], ['eenie','moe'],5,'true', \%labels,%attributes); -or- print scrolling_list(-name=>'list_name', -values=>['eenie','meenie','minie','moe'], -default=>['eenie','moe'], -size=>5, -multiple=>'true', -labels=>\%labels, -attributes=>\%attributes); scrolling_list() creates a scrolling list. B<Parameters:> =over 4 =item 1. The first and second arguments are the list name (-name) and values (-values). As in the popup menu, the second argument should be an array reference. =item 2. The optional third argument (-default) can be either a reference to a list containing the values to be selected by default, or can be a single value to select. If this argument is missing or undefined, then nothing is selected when the list first appears. In the named parameter version, you can use the synonym "-defaults" for this parameter. =item 3. The optional fourth argument is the size of the list (-size). =item 4. The optional fifth argument can be set to true to allow multiple simultaneous selections (-multiple). Otherwise only one selection will be allowed at a time. =item 5. The optional sixth argument is a pointer to a hash containing long user-visible labels for the list items (-labels). If not provided, the values will be displayed. =item 6. The optional sixth parameter (-attributes) is provided to assign any of the common HTML attributes to an individual menu item. It's a pointer to a hash relating menu values to another hash with the attribute's name as the key and the attribute's value as the value. When this form is processed, all selected list items will be returned as a list under the parameter name 'list_name'. The values of the selected items can be retrieved with: @selected = param('list_name'); =back =head2 Creating a group of related checkboxes print checkbox_group(-name=>'group_name', -values=>['eenie','meenie','minie','moe'], -default=>['eenie','moe'], -linebreak=>'true', -disabled => ['moe'], -labels=>\%labels, -attributes=>\%attributes); print checkbox_group('group_name', ['eenie','meenie','minie','moe'], ['eenie','moe'],'true',\%labels, {'moe'=>{'class'=>'red'}}); HTML3-COMPATIBLE BROWSERS ONLY: print checkbox_group(-name=>'group_name', -values=>['eenie','meenie','minie','moe'], -rows=2,-columns=>2); checkbox_group() creates a list of checkboxes that are related by the same name. B<Parameters:> =over 4 =item 1. The first and second arguments are the checkbox name and values, respectively (-name and -values). As in the popup menu, the second argument should be an array reference. These values are used for the user-readable labels printed next to the checkboxes as well as for the values passed to your script in the query string. =item 2. The optional third argument (-default) can be either a reference to a list containing the values to be checked by default, or can be a single value to checked. If this argument is missing or undefined, then nothing is selected when the list first appears. =item 3. The optional fourth argument (-linebreak) can be set to true to place line breaks between the checkboxes so that they appear as a vertical list. Otherwise, they will be strung together on a horizontal line. =back The optional B<-labels> argument is a pointer to a hash relating the checkbox values to the user-visible labels that will be printed next to them. If not provided, the values will be used as the default. The optional parameters B<-rows>, and B<-columns> cause checkbox_group() to return an HTML3 compatible table containing the checkbox group formatted with the specified number of rows and columns. You can provide just the -columns parameter if you wish; checkbox_group will calculate the correct number of rows for you. The option B<-disabled> takes an array of checkbox values and disables them by greying them out (this may not be supported by all browsers). The optional B<-attributes> argument is provided to assign any of the common HTML attributes to an individual menu item. It's a pointer to a hash relating menu values to another hash with the attribute's name as the key and the attribute's value as the value. The optional B<-tabindex> argument can be used to control the order in which radio buttons receive focus when the user presses the tab button. If passed a scalar numeric value, the first element in the group will receive this tab index and subsequent elements will be incremented by one. If given a reference to an array of radio button values, then the indexes will be jiggered so that the order specified in the array will correspond to the tab order. You can also pass a reference to a hash in which the hash keys are the radio button values and the values are the tab indexes of each button. Examples: -tabindex => 100 # this group starts at index 100 and counts up -tabindex => ['moe','minie','eenie','meenie'] # tab in this order -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order The optional B<-labelattributes> argument will contain attributes attached to the <label> element that surrounds each button. When the form is processed, all checked boxes will be returned as a list under the parameter name 'group_name'. The values of the "on" checkboxes can be retrieved with: @turned_on = param('group_name'); The value returned by checkbox_group() is actually an array of button elements. You can capture them and use them within tables, lists, or in other creative ways: @h = checkbox_group(-name=>'group_name',-values=>\@values); &use_in_creative_way(@h); =head2 Creating a standalone checkbox print checkbox(-name=>'checkbox_name', -checked=>1, -value=>'ON', -label=>'CLICK ME'); -or- print checkbox('checkbox_name','checked','ON','CLICK ME'); checkbox() is used to create an isolated checkbox that isn't logically related to any others. B<Parameters:> =over 4 =item 1. The first parameter is the required name for the checkbox (-name). It will also be used for the user-readable label printed next to the checkbox. =item 2. The optional second parameter (-checked) specifies that the checkbox is turned on by default. Synonyms are -selected and -on. =item 3. The optional third parameter (-value) specifies the value of the checkbox when it is checked. If not provided, the word "on" is assumed. =item 4. The optional fourth parameter (-label) is the user-readable label to be attached to the checkbox. If not provided, the checkbox name is used. =back The value of the checkbox can be retrieved using: $turned_on = param('checkbox_name'); =head2 Creating a radio button group print radio_group(-name=>'group_name', -values=>['eenie','meenie','minie'], -default=>'meenie', -linebreak=>'true', -labels=>\%labels, -attributes=>\%attributes); -or- print radio_group('group_name',['eenie','meenie','minie'], 'meenie','true',\%labels,\%attributes); HTML3-COMPATIBLE BROWSERS ONLY: print radio_group(-name=>'group_name', -values=>['eenie','meenie','minie','moe'], -rows=2,-columns=>2); radio_group() creates a set of logically-related radio buttons (turning one member of the group on turns the others off) B<Parameters:> =over 4 =item 1. The first argument is the name of the group and is required (-name). =item 2. The second argument (-values) is the list of values for the radio buttons. The values and the labels that appear on the page are identical. Pass an array I<reference> in the second argument, either using an anonymous array, as shown, or by referencing a named array as in "\@foo". =item 3. The optional third parameter (-default) is the name of the default button to turn on. If not specified, the first item will be the default. You can provide a nonexistent button name, such as "-" to start up with no buttons selected. =item 4. The optional fourth parameter (-linebreak) can be set to 'true' to put line breaks between the buttons, creating a vertical list. =item 5. The optional fifth parameter (-labels) is a pointer to an associative array relating the radio button values to user-visible labels to be used in the display. If not provided, the values themselves are displayed. =back All modern browsers can take advantage of the optional parameters B<-rows>, and B<-columns>. These parameters cause radio_group() to return an HTML3 compatible table containing the radio group formatted with the specified number of rows and columns. You can provide just the -columns parameter if you wish; radio_group will calculate the correct number of rows for you. To include row and column headings in the returned table, you can use the B<-rowheaders> and B<-colheaders> parameters. Both of these accept a pointer to an array of headings to use. The headings are just decorative. They don't reorganize the interpretation of the radio buttons -- they're still a single named unit. The optional B<-tabindex> argument can be used to control the order in which radio buttons receive focus when the user presses the tab button. If passed a scalar numeric value, the first element in the group will receive this tab index and subsequent elements will be incremented by one. If given a reference to an array of radio button values, then the indexes will be jiggered so that the order specified in the array will correspond to the tab order. You can also pass a reference to a hash in which the hash keys are the radio button values and the values are the tab indexes of each button. Examples: -tabindex => 100 # this group starts at index 100 and counts up -tabindex => ['moe','minie','eenie','meenie'] # tab in this order -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order The optional B<-attributes> argument is provided to assign any of the common HTML attributes to an individual menu item. It's a pointer to a hash relating menu values to another hash with the attribute's name as the key and the attribute's value as the value. The optional B<-labelattributes> argument will contain attributes attached to the <label> element that surrounds each button. When the form is processed, the selected radio button can be retrieved using: $which_radio_button = param('group_name'); The value returned by radio_group() is actually an array of button elements. You can capture them and use them within tables, lists, or in other creative ways: @h = radio_group(-name=>'group_name',-values=>\@values); &use_in_creative_way(@h); =head2 Creating a submit button print submit(-name=>'button_name', -value=>'value'); -or- print submit('button_name','value'); submit() will create the query submission button. Every form should have one of these. B<Parameters:> =over 4 =item 1. The first argument (-name) is optional. You can give the button a name if you have several submission buttons in your form and you want to distinguish between them. =item 2. The second argument (-value) is also optional. This gives the button a value that will be passed to your script in the query string. The name will also be used as the user-visible label. =item 3. You can use -label as an alias for -value. I always get confused about which of -name and -value changes the user-visible label on the button. =back You can figure out which button was pressed by using different values for each one: $which_one = param('button_name'); =head2 Creating a reset button print reset reset() creates the "reset" button. Note that it restores the form to its value from the last time the script was called, NOT necessarily to the defaults. Note that this conflicts with the perl reset() built-in. Use CORE::reset() to get the original reset function. =head2 Creating a default button print defaults('button_label') defaults() creates a button that, when invoked, will cause the form to be completely reset to its defaults, wiping out all the changes the user ever made. =head2 Creating a hidden field print hidden(-name=>'hidden_name', -default=>['value1','value2'...]); -or- print hidden('hidden_name','value1','value2'...); hidden() produces a text field that can't be seen by the user. It is useful for passing state variable information from one invocation of the script to the next. B<Parameters:> =over 4 =item 1. The first argument is required and specifies the name of this field (-name). =item 2. The second argument is also required and specifies its value (-default). In the named parameter style of calling, you can provide a single value here or a reference to a whole list =back Fetch the value of a hidden field this way: $hidden_value = param('hidden_name'); Note, that just like all the other form elements, the value of a hidden field is "sticky". If you want to replace a hidden field with some other values after the script has been called once you'll have to do it manually: param('hidden_name','new','values','here'); =head2 Creating a clickable image button print image_button(-name=>'button_name', -src=>'/source/URL', -align=>'MIDDLE'); -or- print image_button('button_name','/source/URL','MIDDLE'); image_button() produces a clickable image. When it's clicked on the position of the click is returned to your script as "button_name.x" and "button_name.y", where "button_name" is the name you've assigned to it. B<Parameters:> =over 4 =item 1. The first argument (-name) is required and specifies the name of this field. =item 2. The second argument (-src) is also required and specifies the URL =item 3. The third option (-align, optional) is an alignment type, and may be TOP, BOTTOM or MIDDLE =back Fetch the value of the button this way: $x = param('button_name.x'); $y = param('button_name.y'); =head2 Creating a javascript action button print button(-name=>'button_name', -value=>'user visible label', -onClick=>"do_something()"); -or- print button('button_name',"user visible value","do_something()"); button() produces an C<< <input> >> tag with C<type="button">. When it's pressed the fragment of JavaScript code pointed to by the B<-onClick> parameter will be executed. =head1 WORKING WITH FRAMES It's possible for CGI.pm scripts to write into several browser panels and windows using the HTML 4 frame mechanism. There are three techniques for defining new frames programmatically: =over 4 =item 1. Create a <Frameset> document After writing out the HTTP header, instead of creating a standard HTML document using the start_html() call, create a <frameset> document that defines the frames on the page. Specify your script(s) (with appropriate parameters) as the SRC for each of the frames. There is no specific support for creating <frameset> sections in CGI.pm, but the HTML is very simple to write. =item 2. Specify the destination for the document in the HTTP header You may provide a B<-target> parameter to the header() method: print header(-target=>'ResultsWindow'); This will tell the browser to load the output of your script into the frame named "ResultsWindow". If a frame of that name doesn't already exist, the browser will pop up a new window and load your script's document into that. There are a number of magic names that you can use for targets. See the HTML C<< <frame> >> documentation for details. =item 3. Specify the destination for the document in the <form> tag You can specify the frame to load in the FORM tag itself. With CGI.pm it looks like this: print start_form(-target=>'ResultsWindow'); When your script is reinvoked by the form, its output will be loaded into the frame named "ResultsWindow". If one doesn't already exist a new window will be created. =back The script "frameset.cgi" in the examples directory shows one way to create pages in which the fill-out form and the response live in side-by-side frames. =head1 SUPPORT FOR JAVASCRIPT The usual way to use JavaScript is to define a set of functions in a <SCRIPT> block inside the HTML header and then to register event handlers in the various elements of the page. Events include such things as the mouse passing over a form element, a button being clicked, the contents of a text field changing, or a form being submitted. When an event occurs that involves an element that has registered an event handler, its associated JavaScript code gets called. The elements that can register event handlers include the <BODY> of an HTML document, hypertext links, all the various elements of a fill-out form, and the form itself. There are a large number of events, and each applies only to the elements for which it is relevant. Here is a partial list: =over 4 =item B<onLoad> The browser is loading the current document. Valid in: + The HTML <BODY> section only. =item B<onUnload> The browser is closing the current page or frame. Valid for: + The HTML <BODY> section only. =item B<onSubmit> The user has pressed the submit button of a form. This event happens just before the form is submitted, and your function can return a value of false in order to abort the submission. Valid for: + Forms only. =item B<onClick> The mouse has clicked on an item in a fill-out form. Valid for: + Buttons (including submit, reset, and image buttons) + Checkboxes + Radio buttons =item B<onChange> The user has changed the contents of a field. Valid for: + Text fields + Text areas + Password fields + File fields + Popup Menus + Scrolling lists =item B<onFocus> The user has selected a field to work with. Valid for: + Text fields + Text areas + Password fields + File fields + Popup Menus + Scrolling lists =item B<onBlur> The user has deselected a field (gone to work somewhere else). Valid for: + Text fields + Text areas + Password fields + File fields + Popup Menus + Scrolling lists =item B<onSelect> The user has changed the part of a text field that is selected. Valid for: + Text fields + Text areas + Password fields + File fields =item B<onMouseOver> The mouse has moved over an element. + Text fields + Text areas + Password fields + File fields + Popup Menus + Scrolling lists =item B<onMouseOut> The mouse has moved off an element. + Text fields + Text areas + Password fields + File fields + Popup Menus + Scrolling lists =back In order to register a JavaScript event handler with an HTML element, just use the event name as a parameter when you call the corresponding CGI method. For example, to have your validateAge() JavaScript code executed every time the textfield named "age" changes, generate the field like this: print textfield(-name=>'age',-onChange=>"validateAge(this)"); This example assumes that you've already declared the validateAge() function by incorporating it into a <SCRIPT> block. The CGI.pm start_html() method provides a convenient way to create this section. Similarly, you can create a form that checks itself over for consistency and alerts the user if some essential value is missing by creating it this way: print start_form(-onSubmit=>"validateMe(this)"); See the javascript.cgi script for a demonstration of how this all works. =head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS CGI.pm has limited support for HTML3's cascading style sheets (css). To incorporate a stylesheet into your document, pass the start_html() method a B<-style> parameter. The value of this parameter may be a scalar, in which case it is treated as the source URL for the stylesheet, or it may be a hash reference. In the latter case you should provide the hash with one or more of B<-src> or B<-code>. B<-src> points to a URL where an externally-defined stylesheet can be found. B<-code> points to a scalar value to be incorporated into a <style> section. Style definitions in B<-code> override similarly-named ones in B<-src>, hence the name "cascading." You may also specify the type of the stylesheet by adding the optional B<-type> parameter to the hash pointed to by B<-style>. If not specified, the style defaults to 'text/css'. To refer to a style within the body of your document, add the B<-class> parameter to any HTML element: print h1({-class=>'Fancy'},'Welcome to the Party'); Or define styles on the fly with the B<-style> parameter: print h1({-style=>'Color: red;'},'Welcome to Hell'); You may also use the new B<span()> element to apply a style to a section of text: print span({-style=>'Color: red;'}, h1('Welcome to Hell'), "Where did that handbasket get to?" ); Note that you must import the ":html3" definitions to have the B<span()> method available. Here's a quick and dirty example of using CSS's. See the CSS specification at http://www.w3.org/Style/CSS/ for more information. use CGI qw/:standard :html3/; #here's a stylesheet incorporated directly into the page $newStyle=<<END; <!-- P.Tip { margin-right: 50pt; margin-left: 50pt; color: red; } P.Alert { font-size: 30pt; font-family: sans-serif; color: red; } --> END print header(); print start_html( -title=>'CGI with Style', -style=>{-src=>'http://www.capricorn.com/style/st1.css', -code=>$newStyle} ); print h1('CGI with Style'), p({-class=>'Tip'}, "Better read the cascading style sheet spec before playing with this!"), span({-style=>'color: magenta'}, "Look Mom, no hands!", p(), "Whooo wee!" ); print end_html; Pass an array reference to B<-code> or B<-src> in order to incorporate multiple stylesheets into your document. Should you wish to incorporate a verbatim stylesheet that includes arbitrary formatting in the header, you may pass a -verbatim tag to the -style hash, as follows: print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");', -src => '/server-common/css/core.css'}); This will generate an HTML header that contains this: <link rel="stylesheet" type="text/css" href="/server-common/css/core.css"> <style type="text/css"> @import url("/server-common/css/main.css"); </style> Any additional arguments passed in the -style value will be incorporated into the <link> tag. For example: start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'], -media => 'all'}); This will give: <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/> <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/> <p> To make more complicated <link> tags, use the Link() function and pass it to start_html() in the -head argument, as in: @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}), Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'})); print start_html({-head=>\@h}) To create primary and "alternate" stylesheet, use the B<-alternate> option: start_html(-style=>{-src=>[ {-src=>'/styles/print.css'}, {-src=>'/styles/alt.css',-alternate=>1} ] }); =head2 Dumping out all the name/value pairs The Dump() method produces a string consisting of all the query's name/value pairs formatted nicely as a nested list. This is useful for debugging purposes: print Dump Produces something that looks like: <ul> <li>name1 <ul> <li>value1 <li>value2 </ul> <li>name2 <ul> <li>value1 </ul> </ul> As a shortcut, you can interpolate the entire CGI object into a string and it will be replaced with the a nice HTML dump shown above: $q=CGI->new; print "<h2>Current Values</h2> $q\n"; =head1 BUGS Address bug reports and comments to: L<https://github.com/leejo/CGI.pm/issues> See the L<https://github.com/leejo/CGI.pm/blob/master/CONTRIBUTING.md> file for information on raising issues and contributing The original bug tracker can be found at: L<https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm> =head1 SEE ALSO L<CGI> - The original source of this documentation / functionality =cut PK ! uX��A0 A0 Encode/Locale.pmnu �[��� package Encode::Locale; use strict; our $VERSION = "1.05"; use base 'Exporter'; our @EXPORT_OK = qw( decode_argv env $ENCODING_LOCALE $ENCODING_LOCALE_FS $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT ); use Encode (); use Encode::Alias (); our $ENCODING_LOCALE; our $ENCODING_LOCALE_FS; our $ENCODING_CONSOLE_IN; our $ENCODING_CONSOLE_OUT; sub DEBUG () { 0 } sub _init { if ($^O eq "MSWin32") { unless ($ENCODING_LOCALE) { # Try to obtain what the Windows ANSI code page is eval { unless (defined &GetACP) { require Win32; eval { Win32::GetACP() }; *GetACP = sub { &Win32::GetACP } unless $@; } unless (defined &GetACP) { require Win32::API; Win32::API->Import('kernel32', 'int GetACP()'); } if (defined &GetACP) { my $cp = GetACP(); $ENCODING_LOCALE = "cp$cp" if $cp; } }; } unless ($ENCODING_CONSOLE_IN) { # only test one since set together unless (defined &GetInputCP) { eval { require Win32; eval { Win32::GetConsoleCP() }; # manually "import" it since Win32->import refuses *GetInputCP = sub { &Win32::GetConsoleCP } unless $@; *GetOutputCP = sub { &Win32::GetConsoleOutputCP } unless $@; }; unless (defined &GetInputCP) { eval { # try Win32::Console module for codepage to use require Win32::Console; eval { Win32::Console::InputCP() }; *GetInputCP = sub { &Win32::Console::InputCP } unless $@; *GetOutputCP = sub { &Win32::Console::OutputCP } unless $@; }; } unless (defined &GetInputCP) { # final fallback *GetInputCP = *GetOutputCP = sub { # another fallback that could work is: # reg query HKLM\System\CurrentControlSet\Control\Nls\CodePage /v ACP ((qx(chcp) || '') =~ /^Active code page: (\d+)/) ? $1 : (); }; } } my $cp = GetInputCP(); $ENCODING_CONSOLE_IN = "cp$cp" if $cp; $cp = GetOutputCP(); $ENCODING_CONSOLE_OUT = "cp$cp" if $cp; } } unless ($ENCODING_LOCALE) { eval { require I18N::Langinfo; $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET()); # Workaround of Encode < v2.25. The "646" encoding alias was # introduced in Encode-2.25, but we don't want to require that version # quite yet. Should avoid the CPAN testers failure reported from # openbsd-4.7/perl-5.10.0 combo. $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646"; # https://rt.cpan.org/Ticket/Display.html?id=66373 $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8"; }; $ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN; } if ($^O eq "darwin") { $ENCODING_LOCALE_FS ||= "UTF-8"; } # final fallback $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8"; $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE; $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE; $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN; unless (Encode::find_encoding($ENCODING_LOCALE)) { my $foundit; if (lc($ENCODING_LOCALE) eq "gb18030") { eval { require Encode::HanExtra; }; if ($@) { die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped"; } $foundit++ if Encode::find_encoding($ENCODING_LOCALE); } die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped" unless $foundit; } # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT; } _init(); Encode::Alias::define_alias(sub { no strict 'refs'; no warnings 'once'; return ${"ENCODING_" . uc(shift)}; }, "locale"); sub _flush_aliases { no strict 'refs'; for my $a (keys %Encode::Alias::Alias) { if (defined ${"ENCODING_" . uc($a)}) { delete $Encode::Alias::Alias{$a}; warn "Flushed alias cache for $a" if DEBUG; } } } sub reinit { $ENCODING_LOCALE = shift; $ENCODING_LOCALE_FS = shift; $ENCODING_CONSOLE_IN = $ENCODING_LOCALE; $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE; _init(); _flush_aliases(); } sub decode_argv { die if defined wantarray; for (@ARGV) { $_ = Encode::decode(locale => $_, @_); } } sub env { my $k = Encode::encode(locale => shift); my $old = $ENV{$k}; if (@_) { my $v = shift; if (defined $v) { $ENV{$k} = Encode::encode(locale => $v); } else { delete $ENV{$k}; } } return Encode::decode(locale => $old) if defined wantarray; } 1; __END__ =head1 NAME Encode::Locale - Determine the locale encoding =head1 SYNOPSIS use Encode::Locale; use Encode; $string = decode(locale => $bytes); $bytes = encode(locale => $string); if (-t) { binmode(STDIN, ":encoding(console_in)"); binmode(STDOUT, ":encoding(console_out)"); binmode(STDERR, ":encoding(console_out)"); } # Processing file names passed in as arguments my $uni_filename = decode(locale => $ARGV[0]); open(my $fh, "<", encode(locale_fs => $uni_filename)) || die "Can't open '$uni_filename': $!"; binmode($fh, ":encoding(locale)"); ... =head1 DESCRIPTION In many applications it's wise to let Perl use Unicode for the strings it processes. Most of the interfaces Perl has to the outside world are still byte based. Programs therefore need to decode byte strings that enter the program from the outside and encode them again on the way out. The POSIX locale system is used to specify both the language conventions requested by the user and the preferred character set to consume and output. The C<Encode::Locale> module looks up the charset and encoding (called a CODESET in the locale jargon) and arranges for the L<Encode> module to know this encoding under the name "locale". It means bytes obtained from the environment can be converted to Unicode strings by calling C<< Encode::encode(locale => $bytes) >> and converted back again with C<< Encode::decode(locale => $string) >>. Where file systems interfaces pass file names in and out of the program we also need care. The trend is for operating systems to use a fixed file encoding that don't actually depend on the locale; and this module determines the most appropriate encoding for file names. The L<Encode> module will know this encoding under the name "locale_fs". For traditional Unix systems this will be an alias to the same encoding as "locale". For programs running in a terminal window (called a "Console" on some systems) the "locale" encoding is usually a good choice for what to expect as input and output. Some systems allows us to query the encoding set for the terminal and C<Encode::Locale> will do that if available and make these encodings known under the C<Encode> aliases "console_in" and "console_out". For systems where we can't determine the terminal encoding these will be aliased as the same encoding as "locale". The advice is to use "console_in" for input known to come from the terminal and "console_out" for output to the terminal. In addition to arranging for various Encode aliases the following functions and variables are provided: =over =item decode_argv( ) =item decode_argv( Encode::FB_CROAK ) This will decode the command line arguments to perl (the C<@ARGV> array) in-place. The function will by default replace characters that can't be decoded by "\x{FFFD}", the Unicode replacement character. Any argument provided is passed as CHECK to underlying Encode::decode() call. Pass the value C<Encode::FB_CROAK> to have the decoding croak if not all the command line arguments can be decoded. See L<Encode/"Handling Malformed Data"> for details on other options for CHECK. =item env( $uni_key ) =item env( $uni_key => $uni_value ) Interface to get/set environment variables. Returns the current value as a Unicode string. The $uni_key and $uni_value arguments are expected to be Unicode strings as well. Passing C<undef> as $uni_value deletes the environment variable named $uni_key. The returned value will have the characters that can't be decoded replaced by "\x{FFFD}", the Unicode replacement character. There is no interface to request alternative CHECK behavior as for decode_argv(). If you need that you need to call encode/decode yourself. For example: my $key = Encode::encode(locale => $uni_key, Encode::FB_CROAK); my $uni_value = Encode::decode(locale => $ENV{$key}, Encode::FB_CROAK); =item reinit( ) =item reinit( $encoding ) Reinitialize the encodings from the locale. You want to call this function if you changed anything in the environment that might influence the locale. This function will croak if the determined encoding isn't recognized by the Encode module. With argument force $ENCODING_... variables to set to the given value. =item $ENCODING_LOCALE The encoding name determined to be suitable for the current locale. L<Encode> know this encoding as "locale". =item $ENCODING_LOCALE_FS The encoding name determined to be suitable for file system interfaces involving file names. L<Encode> know this encoding as "locale_fs". =item $ENCODING_CONSOLE_IN =item $ENCODING_CONSOLE_OUT The encodings to be used for reading and writing output to the a console. L<Encode> know these encodings as "console_in" and "console_out". =back =head1 NOTES This table summarizes the mapping of the encodings set up by the C<Encode::Locale> module: Encode | | | Alias | Windows | Mac OS X | POSIX ------------+---------+--------------+------------ locale | ANSI | nl_langinfo | nl_langinfo locale_fs | ANSI | UTF-8 | nl_langinfo console_in | OEM | nl_langinfo | nl_langinfo console_out | OEM | nl_langinfo | nl_langinfo =head2 Windows Windows has basically 2 sets of APIs. A wide API (based on passing UTF-16 strings) and a byte based API based a character set called ANSI. The regular Perl interfaces to the OS currently only uses the ANSI APIs. Unfortunately ANSI is not a single character set. The encoding that corresponds to ANSI varies between different editions of Windows. For many western editions of Windows ANSI corresponds to CP-1252 which is a character set similar to ISO-8859-1. Conceptually the ANSI character set is a similar concept to the POSIX locale CODESET so this module figures out what the ANSI code page is and make this available as $ENCODING_LOCALE and the "locale" Encoding alias. Windows systems also operate with another byte based character set. It's called the OEM code page. This is the encoding that the Console takes as input and output. It's common for the OEM code page to differ from the ANSI code page. =head2 Mac OS X On Mac OS X the file system encoding is always UTF-8 while the locale can otherwise be set up as normal for POSIX systems. File names on Mac OS X will at the OS-level be converted to NFD-form. A file created by passing a NFC-filename will come in NFD-form from readdir(). See L<Unicode::Normalize> for details of NFD/NFC. Actually, Apple does not follow the Unicode NFD standard since not all character ranges are decomposed. The claim is that this avoids problems with round trip conversions from old Mac text encodings. See L<Encode::UTF8Mac> for details. =head2 POSIX (Linux and other Unixes) File systems might vary in what encoding is to be used for filenames. Since this module has no way to actually figure out what the is correct it goes with the best guess which is to assume filenames are encoding according to the current locale. Users are advised to always specify UTF-8 as the locale charset. =head1 SEE ALSO L<I18N::Langinfo>, L<Encode>, L<Term::Encoding> =head1 AUTHOR Copyright 2010 Gisle Aas <gisle@aas.no>. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK ! ��W[� � Fh.pmnu �[��� # back compatibility package for any code explicitly checking # that the filehandle object is a Fh package Fh; use strict; use warnings; $Fh::VERSION = '4.54'; 1; PK ! )l5�� �� LWP/media.typesnu �[��� # This file maps Internet media types to unique file extension(s). # Although created for httpd, this file is used by many software systems # and has been placed in the public domain for unlimited redisribution. # # The table below contains both registered and (common) unregistered types. # A type that has no unique extension can be ignored -- they are listed # here to guide configurations toward known types and to make it easier to # identify "new" types. File extensions are also commonly used to indicate # content languages and encodings, so choose them carefully. # # Internet media types should be registered as described in RFC 4288. # The registry is at <http://www.iana.org/assignments/media-types/>. # # MIME type (lowercased) Extensions # ============================================ ========== # application/1d-interleaved-parityfec # application/3gpp-ims+xml # application/activemessage application/andrew-inset ez # application/applefile application/applixware aw application/atom+xml atom application/atomcat+xml atomcat # application/atomicmail application/atomsvc+xml atomsvc # application/auth-policy+xml # application/batch-smtp # application/beep+xml # application/cals-1840 application/ccxml+xml ccxml application/cdmi-capability cdmia application/cdmi-container cdmic application/cdmi-domain cdmid application/cdmi-object cdmio application/cdmi-queue cdmiq # application/cea-2018+xml # application/cellml+xml # application/cfw # application/cnrp+xml # application/commonground # application/conference-info+xml # application/cpl+xml # application/csta+xml # application/cstadata+xml application/cu-seeme cu # application/cybercash application/davmount+xml davmount # application/dca-rft # application/dec-dx # application/dialog-info+xml # application/dicom # application/dns # application/dskpp+xml application/dssc+der dssc application/dssc+xml xdssc # application/dvcs application/ecmascript ecma # application/edi-consent # application/edi-x12 # application/edifact application/emma+xml emma # application/epp+xml application/epub+zip epub # application/eshop # application/example application/exi exi # application/fastinfoset # application/fastsoap # application/fits application/font-tdpfr pfr # application/framework-attributes+xml # application/h224 # application/held+xml # application/http application/hyperstudio stk # application/ibe-key-request+xml # application/ibe-pkg-reply+xml # application/ibe-pp-data # application/iges # application/im-iscomposing+xml # application/index # application/index.cmd # application/index.obj # application/index.response # application/index.vnd # application/iotp application/ipfix ipfix # application/ipp # application/isup application/java-archive jar application/java-serialized-object ser application/java-vm class application/javascript js application/json json # application/kpml-request+xml # application/kpml-response+xml application/lost+xml lostxml application/mac-binhex40 hqx application/mac-compactpro cpt # application/macwriteii application/mads+xml mads application/marc mrc application/marcxml+xml mrcx application/mathematica ma nb mb # application/mathml-content+xml # application/mathml-presentation+xml application/mathml+xml mathml # application/mbms-associated-procedure-description+xml # application/mbms-deregister+xml # application/mbms-envelope+xml # application/mbms-msk+xml # application/mbms-msk-response+xml # application/mbms-protection-description+xml # application/mbms-reception-report+xml # application/mbms-register+xml # application/mbms-register-response+xml # application/mbms-user-service-description+xml application/mbox mbox # application/media_control+xml application/mediaservercontrol+xml mscml application/metalink4+xml meta4 application/mets+xml mets # application/mikey application/mods+xml mods # application/moss-keys # application/moss-signature # application/mosskey-data # application/mosskey-request application/mp21 m21 mp21 application/mp4 mp4s # application/mpeg4-generic # application/mpeg4-iod # application/mpeg4-iod-xmt # application/msc-ivr+xml # application/msc-mixer+xml application/msword doc dot application/mxf mxf # application/nasdata # application/news-checkgroups # application/news-groupinfo # application/news-transmission # application/nss # application/ocsp-request # application/ocsp-response application/octet-stream bin dms lha lrf lzh so iso dmg dist distz pkg bpk dump elc deploy application/oda oda application/oebps-package+xml opf application/ogg ogx application/onenote onetoc onetoc2 onetmp onepkg # application/parityfec application/patch-ops-error+xml xer application/pdf pdf application/pgp-encrypted pgp # application/pgp-keys application/pgp-signature asc sig application/pics-rules prf # application/pidf+xml # application/pidf-diff+xml application/pkcs10 p10 application/pkcs7-mime p7m p7c application/pkcs7-signature p7s application/pkcs8 p8 application/pkix-attr-cert ac application/pkix-cert cer application/pkix-crl crl application/pkix-pkipath pkipath application/pkixcmp pki application/pls+xml pls # application/poc-settings+xml application/postscript ai eps ps # application/prs.alvestrand.titrax-sheet application/prs.cww cww # application/prs.nprend # application/prs.plucker # application/prs.rdf-xml-crypt # application/prs.xsf+xml application/pskc+xml pskcxml # application/qsig application/rdf+xml rdf application/reginfo+xml rif application/relax-ng-compact-syntax rnc # application/remote-printing application/resource-lists+xml rl application/resource-lists-diff+xml rld # application/riscos # application/rlmi+xml application/rls-services+xml rs application/rsd+xml rsd application/rss+xml rss application/rtf rtf # application/rtx # application/samlassertion+xml # application/samlmetadata+xml application/sbml+xml sbml application/scvp-cv-request scq application/scvp-cv-response scs application/scvp-vp-request spq application/scvp-vp-response spp application/sdp sdp # application/set-payment application/set-payment-initiation setpay # application/set-registration application/set-registration-initiation setreg # application/sgml # application/sgml-open-catalog application/shf+xml shf # application/sieve # application/simple-filter+xml # application/simple-message-summary # application/simplesymbolcontainer # application/slate # application/smil application/smil+xml smi smil # application/soap+fastinfoset # application/soap+xml application/sparql-query rq application/sparql-results+xml srx # application/spirits-event+xml application/srgs gram application/srgs+xml grxml application/sru+xml sru application/ssml+xml ssml # application/tamp-apex-update # application/tamp-apex-update-confirm # application/tamp-community-update # application/tamp-community-update-confirm # application/tamp-error # application/tamp-sequence-adjust # application/tamp-sequence-adjust-confirm # application/tamp-status-query # application/tamp-status-response # application/tamp-update # application/tamp-update-confirm application/tei+xml tei teicorpus application/thraud+xml tfi # application/timestamp-query # application/timestamp-reply application/timestamped-data tsd # application/tve-trigger # application/ulpfec # application/vemmi # application/vividence.scriptfile # application/vnd.3gpp.bsf+xml application/vnd.3gpp.pic-bw-large plb application/vnd.3gpp.pic-bw-small psb application/vnd.3gpp.pic-bw-var pvb # application/vnd.3gpp.sms # application/vnd.3gpp2.bcmcsinfo+xml # application/vnd.3gpp2.sms application/vnd.3gpp2.tcap tcap application/vnd.3m.post-it-notes pwn application/vnd.accpac.simply.aso aso application/vnd.accpac.simply.imp imp application/vnd.acucobol acu application/vnd.acucorp atc acutc application/vnd.adobe.air-application-installer-package+zip air application/vnd.adobe.fxp fxp fxpl # application/vnd.adobe.partial-upload application/vnd.adobe.xdp+xml xdp application/vnd.adobe.xfdf xfdf # application/vnd.aether.imp # application/vnd.ah-barcode application/vnd.ahead.space ahead application/vnd.airzip.filesecure.azf azf application/vnd.airzip.filesecure.azs azs application/vnd.amazon.ebook azw application/vnd.americandynamics.acc acc application/vnd.amiga.ami ami # application/vnd.amundsen.maze+xml application/vnd.android.package-archive apk application/vnd.anser-web-certificate-issue-initiation cii application/vnd.anser-web-funds-transfer-initiation fti application/vnd.antix.game-component atx application/vnd.apple.installer+xml mpkg application/vnd.apple.mpegurl m3u8 # application/vnd.arastra.swi application/vnd.aristanetworks.swi swi application/vnd.audiograph aep # application/vnd.autopackage # application/vnd.avistar+xml application/vnd.blueice.multipass mpm # application/vnd.bluetooth.ep.oob application/vnd.bmi bmi application/vnd.businessobjects rep # application/vnd.cab-jscript # application/vnd.canon-cpdl # application/vnd.canon-lips # application/vnd.cendio.thinlinc.clientconf application/vnd.chemdraw+xml cdxml application/vnd.chipnuts.karaoke-mmd mmd application/vnd.cinderella cdy # application/vnd.cirpack.isdn-ext application/vnd.claymore cla application/vnd.cloanto.rp9 rp9 application/vnd.clonk.c4group c4g c4d c4f c4p c4u application/vnd.cluetrust.cartomobile-config c11amc application/vnd.cluetrust.cartomobile-config-pkg c11amz # application/vnd.commerce-battelle application/vnd.commonspace csp application/vnd.contact.cmsg cdbcmsg application/vnd.cosmocaller cmc application/vnd.crick.clicker clkx application/vnd.crick.clicker.keyboard clkk application/vnd.crick.clicker.palette clkp application/vnd.crick.clicker.template clkt application/vnd.crick.clicker.wordbank clkw application/vnd.criticaltools.wbs+xml wbs application/vnd.ctc-posml pml # application/vnd.ctct.ws+xml # application/vnd.cups-pdf # application/vnd.cups-postscript application/vnd.cups-ppd ppd # application/vnd.cups-raster # application/vnd.cups-raw application/vnd.curl.car car application/vnd.curl.pcurl pcurl # application/vnd.cybank application/vnd.data-vision.rdz rdz application/vnd.dece.data uvf uvvf uvd uvvd application/vnd.dece.ttml+xml uvt uvvt application/vnd.dece.unspecified uvx uvvx application/vnd.denovo.fcselayout-link fe_launch # application/vnd.dir-bi.plate-dl-nosuffix application/vnd.dna dna application/vnd.dolby.mlp mlp # application/vnd.dolby.mobile.1 # application/vnd.dolby.mobile.2 application/vnd.dpgraph dpg application/vnd.dreamfactory dfac application/vnd.dvb.ait ait # application/vnd.dvb.dvbj # application/vnd.dvb.esgcontainer # application/vnd.dvb.ipdcdftnotifaccess # application/vnd.dvb.ipdcesgaccess # application/vnd.dvb.ipdcesgaccess2 # application/vnd.dvb.ipdcesgpdd # application/vnd.dvb.ipdcroaming # application/vnd.dvb.iptv.alfec-base # application/vnd.dvb.iptv.alfec-enhancement # application/vnd.dvb.notif-aggregate-root+xml # application/vnd.dvb.notif-container+xml # application/vnd.dvb.notif-generic+xml # application/vnd.dvb.notif-ia-msglist+xml # application/vnd.dvb.notif-ia-registration-request+xml # application/vnd.dvb.notif-ia-registration-response+xml # application/vnd.dvb.notif-init+xml # application/vnd.dvb.pfr application/vnd.dvb.service svc # application/vnd.dxr application/vnd.dynageo geo # application/vnd.easykaraoke.cdgdownload # application/vnd.ecdis-update application/vnd.ecowin.chart mag # application/vnd.ecowin.filerequest # application/vnd.ecowin.fileupdate # application/vnd.ecowin.series # application/vnd.ecowin.seriesrequest # application/vnd.ecowin.seriesupdate # application/vnd.emclient.accessrequest+xml application/vnd.enliven nml application/vnd.epson.esf esf application/vnd.epson.msf msf application/vnd.epson.quickanime qam application/vnd.epson.salt slt application/vnd.epson.ssf ssf # application/vnd.ericsson.quickcall application/vnd.eszigno3+xml es3 et3 # application/vnd.etsi.aoc+xml # application/vnd.etsi.cug+xml # application/vnd.etsi.iptvcommand+xml # application/vnd.etsi.iptvdiscovery+xml # application/vnd.etsi.iptvprofile+xml # application/vnd.etsi.iptvsad-bc+xml # application/vnd.etsi.iptvsad-cod+xml # application/vnd.etsi.iptvsad-npvr+xml # application/vnd.etsi.iptvservice+xml # application/vnd.etsi.iptvsync+xml # application/vnd.etsi.iptvueprofile+xml # application/vnd.etsi.mcid+xml # application/vnd.etsi.overload-control-policy-dataset+xml # application/vnd.etsi.sci+xml # application/vnd.etsi.simservs+xml # application/vnd.etsi.tsl+xml # application/vnd.etsi.tsl.der # application/vnd.eudora.data application/vnd.ezpix-album ez2 application/vnd.ezpix-package ez3 # application/vnd.f-secure.mobile application/vnd.fdf fdf application/vnd.fdsn.mseed mseed application/vnd.fdsn.seed seed dataless # application/vnd.ffsns # application/vnd.fints application/vnd.flographit gph application/vnd.fluxtime.clip ftc # application/vnd.font-fontforge-sfd application/vnd.framemaker fm frame maker book application/vnd.frogans.fnc fnc application/vnd.frogans.ltf ltf application/vnd.fsc.weblaunch fsc application/vnd.fujitsu.oasys oas application/vnd.fujitsu.oasys2 oa2 application/vnd.fujitsu.oasys3 oa3 application/vnd.fujitsu.oasysgp fg5 application/vnd.fujitsu.oasysprs bh2 # application/vnd.fujixerox.art-ex # application/vnd.fujixerox.art4 # application/vnd.fujixerox.hbpl application/vnd.fujixerox.ddd ddd application/vnd.fujixerox.docuworks xdw application/vnd.fujixerox.docuworks.binder xbd # application/vnd.fut-misnet application/vnd.fuzzysheet fzs application/vnd.genomatix.tuxedo txd # application/vnd.geocube+xml application/vnd.geogebra.file ggb application/vnd.geogebra.tool ggt application/vnd.geometry-explorer gex gre application/vnd.geonext gxt application/vnd.geoplan g2w application/vnd.geospace g3w # application/vnd.globalplatform.card-content-mgt # application/vnd.globalplatform.card-content-mgt-response application/vnd.gmx gmx application/vnd.google-earth.kml+xml kml application/vnd.google-earth.kmz kmz application/vnd.grafeq gqf gqs # application/vnd.gridmp application/vnd.groove-account gac application/vnd.groove-help ghf application/vnd.groove-identity-message gim application/vnd.groove-injector grv application/vnd.groove-tool-message gtm application/vnd.groove-tool-template tpl application/vnd.groove-vcard vcg application/vnd.hal+xml hal application/vnd.handheld-entertainment+xml zmm application/vnd.hbci hbci # application/vnd.hcl-bireports application/vnd.hhe.lesson-player les application/vnd.hp-hpgl hpgl application/vnd.hp-hpid hpid application/vnd.hp-hps hps application/vnd.hp-jlyt jlt application/vnd.hp-pcl pcl application/vnd.hp-pclxl pclxl # application/vnd.httphone application/vnd.hydrostatix.sof-data sfd-hdstx application/vnd.hzn-3d-crossword x3d # application/vnd.ibm.afplinedata # application/vnd.ibm.electronic-media application/vnd.ibm.minipay mpy application/vnd.ibm.modcap afp listafp list3820 application/vnd.ibm.rights-management irm application/vnd.ibm.secure-container sc application/vnd.iccprofile icc icm application/vnd.igloader igl application/vnd.immervision-ivp ivp application/vnd.immervision-ivu ivu # application/vnd.informedcontrol.rms+xml # application/vnd.informix-visionary # application/vnd.infotech.project # application/vnd.infotech.project+xml application/vnd.insors.igm igm application/vnd.intercon.formnet xpw xpx application/vnd.intergeo i2g # application/vnd.intertrust.digibox # application/vnd.intertrust.nncp application/vnd.intu.qbo qbo application/vnd.intu.qfx qfx # application/vnd.iptc.g2.conceptitem+xml # application/vnd.iptc.g2.knowledgeitem+xml # application/vnd.iptc.g2.newsitem+xml # application/vnd.iptc.g2.packageitem+xml application/vnd.ipunplugged.rcprofile rcprofile application/vnd.irepository.package+xml irp application/vnd.is-xpr xpr application/vnd.isac.fcs fcs application/vnd.jam jam # application/vnd.japannet-directory-service # application/vnd.japannet-jpnstore-wakeup # application/vnd.japannet-payment-wakeup # application/vnd.japannet-registration # application/vnd.japannet-registration-wakeup # application/vnd.japannet-setstore-wakeup # application/vnd.japannet-verification # application/vnd.japannet-verification-wakeup application/vnd.jcp.javame.midlet-rms rms application/vnd.jisp jisp application/vnd.joost.joda-archive joda application/vnd.kahootz ktz ktr application/vnd.kde.karbon karbon application/vnd.kde.kchart chrt application/vnd.kde.kformula kfo application/vnd.kde.kivio flw application/vnd.kde.kontour kon application/vnd.kde.kpresenter kpr kpt application/vnd.kde.kspread ksp application/vnd.kde.kword kwd kwt application/vnd.kenameaapp htke application/vnd.kidspiration kia application/vnd.kinar kne knp application/vnd.koan skp skd skt skm application/vnd.kodak-descriptor sse application/vnd.las.las+xml lasxml # application/vnd.liberty-request+xml application/vnd.llamagraphics.life-balance.desktop lbd application/vnd.llamagraphics.life-balance.exchange+xml lbe application/vnd.lotus-1-2-3 123 application/vnd.lotus-approach apr application/vnd.lotus-freelance pre application/vnd.lotus-notes nsf application/vnd.lotus-organizer org application/vnd.lotus-screencam scm application/vnd.lotus-wordpro lwp application/vnd.macports.portpkg portpkg # application/vnd.marlin.drm.actiontoken+xml # application/vnd.marlin.drm.conftoken+xml # application/vnd.marlin.drm.license+xml # application/vnd.marlin.drm.mdcf application/vnd.mcd mcd application/vnd.medcalcdata mc1 application/vnd.mediastation.cdkey cdkey # application/vnd.meridian-slingshot application/vnd.mfer mwf application/vnd.mfmp mfm application/vnd.micrografx.flo flo application/vnd.micrografx.igx igx application/vnd.mif mif # application/vnd.minisoft-hp3000-save # application/vnd.mitsubishi.misty-guard.trustweb application/vnd.mobius.daf daf application/vnd.mobius.dis dis application/vnd.mobius.mbk mbk application/vnd.mobius.mqy mqy application/vnd.mobius.msl msl application/vnd.mobius.plc plc application/vnd.mobius.txf txf application/vnd.mophun.application mpn application/vnd.mophun.certificate mpc # application/vnd.motorola.flexsuite # application/vnd.motorola.flexsuite.adsi # application/vnd.motorola.flexsuite.fis # application/vnd.motorola.flexsuite.gotap # application/vnd.motorola.flexsuite.kmr # application/vnd.motorola.flexsuite.ttc # application/vnd.motorola.flexsuite.wem # application/vnd.motorola.iprm application/vnd.mozilla.xul+xml xul application/vnd.ms-artgalry cil # application/vnd.ms-asf application/vnd.ms-cab-compressed cab application/vnd.ms-excel xls xlm xla xlc xlt xlw application/vnd.ms-excel.addin.macroenabled.12 xlam application/vnd.ms-excel.sheet.binary.macroenabled.12 xlsb application/vnd.ms-excel.sheet.macroenabled.12 xlsm application/vnd.ms-excel.template.macroenabled.12 xltm application/vnd.ms-fontobject eot application/vnd.ms-htmlhelp chm application/vnd.ms-ims ims application/vnd.ms-lrm lrm # application/vnd.ms-office.activex+xml application/vnd.ms-officetheme thmx application/vnd.ms-pki.seccat cat application/vnd.ms-pki.stl stl # application/vnd.ms-playready.initiator+xml application/vnd.ms-powerpoint ppt pps pot application/vnd.ms-powerpoint.addin.macroenabled.12 ppam application/vnd.ms-powerpoint.presentation.macroenabled.12 pptm application/vnd.ms-powerpoint.slide.macroenabled.12 sldm application/vnd.ms-powerpoint.slideshow.macroenabled.12 ppsm application/vnd.ms-powerpoint.template.macroenabled.12 potm application/vnd.ms-project mpp mpt # application/vnd.ms-tnef # application/vnd.ms-wmdrm.lic-chlg-req # application/vnd.ms-wmdrm.lic-resp # application/vnd.ms-wmdrm.meter-chlg-req # application/vnd.ms-wmdrm.meter-resp application/vnd.ms-word.document.macroenabled.12 docm application/vnd.ms-word.template.macroenabled.12 dotm application/vnd.ms-works wps wks wcm wdb application/vnd.ms-wpl wpl application/vnd.ms-xpsdocument xps application/vnd.mseq mseq # application/vnd.msign # application/vnd.multiad.creator # application/vnd.multiad.creator.cif # application/vnd.music-niff application/vnd.musician mus application/vnd.muvee.style msty # application/vnd.ncd.control # application/vnd.ncd.reference # application/vnd.nervana # application/vnd.netfpx application/vnd.neurolanguage.nlu nlu application/vnd.noblenet-directory nnd application/vnd.noblenet-sealer nns application/vnd.noblenet-web nnw # application/vnd.nokia.catalogs # application/vnd.nokia.conml+wbxml # application/vnd.nokia.conml+xml # application/vnd.nokia.isds-radio-presets # application/vnd.nokia.iptv.config+xml # application/vnd.nokia.landmark+wbxml # application/vnd.nokia.landmark+xml # application/vnd.nokia.landmarkcollection+xml # application/vnd.nokia.n-gage.ac+xml application/vnd.nokia.n-gage.data ngdat application/vnd.nokia.n-gage.symbian.install n-gage # application/vnd.nokia.ncd # application/vnd.nokia.pcd+wbxml # application/vnd.nokia.pcd+xml application/vnd.nokia.radio-preset rpst application/vnd.nokia.radio-presets rpss application/vnd.novadigm.edm edm application/vnd.novadigm.edx edx application/vnd.novadigm.ext ext # application/vnd.ntt-local.file-transfer # application/vnd.ntt-local.sip-ta_remote # application/vnd.ntt-local.sip-ta_tcp_stream application/vnd.oasis.opendocument.chart odc application/vnd.oasis.opendocument.chart-template otc application/vnd.oasis.opendocument.database odb application/vnd.oasis.opendocument.formula odf application/vnd.oasis.opendocument.formula-template odft application/vnd.oasis.opendocument.graphics odg application/vnd.oasis.opendocument.graphics-template otg application/vnd.oasis.opendocument.image odi application/vnd.oasis.opendocument.image-template oti application/vnd.oasis.opendocument.presentation odp application/vnd.oasis.opendocument.presentation-template otp application/vnd.oasis.opendocument.spreadsheet ods application/vnd.oasis.opendocument.spreadsheet-template ots application/vnd.oasis.opendocument.text odt application/vnd.oasis.opendocument.text-master odm application/vnd.oasis.opendocument.text-template ott application/vnd.oasis.opendocument.text-web oth # application/vnd.obn # application/vnd.oipf.contentaccessdownload+xml # application/vnd.oipf.contentaccessstreaming+xml # application/vnd.oipf.cspg-hexbinary # application/vnd.oipf.dae.svg+xml # application/vnd.oipf.dae.xhtml+xml # application/vnd.oipf.mippvcontrolmessage+xml # application/vnd.oipf.pae.gem # application/vnd.oipf.spdiscovery+xml # application/vnd.oipf.spdlist+xml # application/vnd.oipf.ueprofile+xml # application/vnd.oipf.userprofile+xml application/vnd.olpc-sugar xo # application/vnd.oma-scws-config # application/vnd.oma-scws-http-request # application/vnd.oma-scws-http-response # application/vnd.oma.bcast.associated-procedure-parameter+xml # application/vnd.oma.bcast.drm-trigger+xml # application/vnd.oma.bcast.imd+xml # application/vnd.oma.bcast.ltkm # application/vnd.oma.bcast.notification+xml # application/vnd.oma.bcast.provisioningtrigger # application/vnd.oma.bcast.sgboot # application/vnd.oma.bcast.sgdd+xml # application/vnd.oma.bcast.sgdu # application/vnd.oma.bcast.simple-symbol-container # application/vnd.oma.bcast.smartcard-trigger+xml # application/vnd.oma.bcast.sprov+xml # application/vnd.oma.bcast.stkm # application/vnd.oma.cab-address-book+xml # application/vnd.oma.cab-pcc+xml # application/vnd.oma.dcd # application/vnd.oma.dcdc application/vnd.oma.dd2+xml dd2 # application/vnd.oma.drm.risd+xml # application/vnd.oma.group-usage-list+xml # application/vnd.oma.poc.detailed-progress-report+xml # application/vnd.oma.poc.final-report+xml # application/vnd.oma.poc.groups+xml # application/vnd.oma.poc.invocation-descriptor+xml # application/vnd.oma.poc.optimized-progress-report+xml # application/vnd.oma.push # application/vnd.oma.scidm.messages+xml # application/vnd.oma.xcap-directory+xml # application/vnd.omads-email+xml # application/vnd.omads-file+xml # application/vnd.omads-folder+xml # application/vnd.omaloc-supl-init application/vnd.openofficeorg.extension oxt # application/vnd.openxmlformats-officedocument.custom-properties+xml # application/vnd.openxmlformats-officedocument.customxmlproperties+xml # application/vnd.openxmlformats-officedocument.drawing+xml # application/vnd.openxmlformats-officedocument.drawingml.chart+xml # application/vnd.openxmlformats-officedocument.drawingml.chartshapes+xml # application/vnd.openxmlformats-officedocument.drawingml.diagramcolors+xml # application/vnd.openxmlformats-officedocument.drawingml.diagramdata+xml # application/vnd.openxmlformats-officedocument.drawingml.diagramlayout+xml # application/vnd.openxmlformats-officedocument.drawingml.diagramstyle+xml # application/vnd.openxmlformats-officedocument.extended-properties+xml # application/vnd.openxmlformats-officedocument.presentationml.commentauthors+xml # application/vnd.openxmlformats-officedocument.presentationml.comments+xml # application/vnd.openxmlformats-officedocument.presentationml.handoutmaster+xml # application/vnd.openxmlformats-officedocument.presentationml.notesmaster+xml # application/vnd.openxmlformats-officedocument.presentationml.notesslide+xml application/vnd.openxmlformats-officedocument.presentationml.presentation pptx # application/vnd.openxmlformats-officedocument.presentationml.presentation.main+xml # application/vnd.openxmlformats-officedocument.presentationml.presprops+xml application/vnd.openxmlformats-officedocument.presentationml.slide sldx # application/vnd.openxmlformats-officedocument.presentationml.slide+xml # application/vnd.openxmlformats-officedocument.presentationml.slidelayout+xml # application/vnd.openxmlformats-officedocument.presentationml.slidemaster+xml application/vnd.openxmlformats-officedocument.presentationml.slideshow ppsx # application/vnd.openxmlformats-officedocument.presentationml.slideshow.main+xml # application/vnd.openxmlformats-officedocument.presentationml.slideupdateinfo+xml # application/vnd.openxmlformats-officedocument.presentationml.tablestyles+xml # application/vnd.openxmlformats-officedocument.presentationml.tags+xml application/vnd.openxmlformats-officedocument.presentationml.template potx # application/vnd.openxmlformats-officedocument.presentationml.template.main+xml # application/vnd.openxmlformats-officedocument.presentationml.viewprops+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.calcchain+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.chartsheet+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.comments+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.connections+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.dialogsheet+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.externallink+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.pivotcachedefinition+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.pivotcacherecords+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.pivottable+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.querytable+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.revisionheaders+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.revisionlog+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.sharedstrings+xml application/vnd.openxmlformats-officedocument.spreadsheetml.sheet xlsx # application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.sheetmetadata+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.table+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.tablesinglecells+xml application/vnd.openxmlformats-officedocument.spreadsheetml.template xltx # application/vnd.openxmlformats-officedocument.spreadsheetml.template.main+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.usernames+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.volatiledependencies+xml # application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml # application/vnd.openxmlformats-officedocument.theme+xml # application/vnd.openxmlformats-officedocument.themeoverride+xml # application/vnd.openxmlformats-officedocument.vmldrawing # application/vnd.openxmlformats-officedocument.wordprocessingml.comments+xml application/vnd.openxmlformats-officedocument.wordprocessingml.document docx # application/vnd.openxmlformats-officedocument.wordprocessingml.document.glossary+xml # application/vnd.openxmlformats-officedocument.wordprocessingml.document.main+xml # application/vnd.openxmlformats-officedocument.wordprocessingml.endnotes+xml # application/vnd.openxmlformats-officedocument.wordprocessingml.fonttable+xml # application/vnd.openxmlformats-officedocument.wordprocessingml.footer+xml # application/vnd.openxmlformats-officedocument.wordprocessingml.footnotes+xml # application/vnd.openxmlformats-officedocument.wordprocessingml.numbering+xml # application/vnd.openxmlformats-officedocument.wordprocessingml.settings+xml # application/vnd.openxmlformats-officedocument.wordprocessingml.styles+xml application/vnd.openxmlformats-officedocument.wordprocessingml.template dotx # application/vnd.openxmlformats-officedocument.wordprocessingml.template.main+xml # application/vnd.openxmlformats-officedocument.wordprocessingml.websettings+xml # application/vnd.openxmlformats-package.core-properties+xml # application/vnd.openxmlformats-package.digital-signature-xmlsignature+xml # application/vnd.openxmlformats-package.relationships+xml # application/vnd.quobject-quoxdocument # application/vnd.osa.netdeploy application/vnd.osgeo.mapguide.package mgp # application/vnd.osgi.bundle application/vnd.osgi.dp dp # application/vnd.otps.ct-kip+xml application/vnd.palm pdb pqa oprc # application/vnd.paos.xml application/vnd.pawaafile paw application/vnd.pg.format str application/vnd.pg.osasli ei6 # application/vnd.piaccess.application-licence application/vnd.picsel efif application/vnd.pmi.widget wg # application/vnd.poc.group-advertisement+xml application/vnd.pocketlearn plf application/vnd.powerbuilder6 pbd # application/vnd.powerbuilder6-s # application/vnd.powerbuilder7 # application/vnd.powerbuilder7-s # application/vnd.powerbuilder75 # application/vnd.powerbuilder75-s # application/vnd.preminet application/vnd.previewsystems.box box application/vnd.proteus.magazine mgz application/vnd.publishare-delta-tree qps application/vnd.pvi.ptid1 ptid # application/vnd.pwg-multiplexed # application/vnd.pwg-xhtml-print+xml # application/vnd.qualcomm.brew-app-res application/vnd.quark.quarkxpress qxd qxt qwd qwt qxl qxb # application/vnd.radisys.moml+xml # application/vnd.radisys.msml+xml # application/vnd.radisys.msml-audit+xml # application/vnd.radisys.msml-audit-conf+xml # application/vnd.radisys.msml-audit-conn+xml # application/vnd.radisys.msml-audit-dialog+xml # application/vnd.radisys.msml-audit-stream+xml # application/vnd.radisys.msml-conf+xml # application/vnd.radisys.msml-dialog+xml # application/vnd.radisys.msml-dialog-base+xml # application/vnd.radisys.msml-dialog-fax-detect+xml # application/vnd.radisys.msml-dialog-fax-sendrecv+xml # application/vnd.radisys.msml-dialog-group+xml # application/vnd.radisys.msml-dialog-speech+xml # application/vnd.radisys.msml-dialog-transform+xml # application/vnd.rainstor.data # application/vnd.rapid application/vnd.realvnc.bed bed application/vnd.recordare.musicxml mxl application/vnd.recordare.musicxml+xml musicxml # application/vnd.renlearn.rlprint application/vnd.rig.cryptonote cryptonote application/vnd.rim.cod cod application/vnd.rn-realmedia rm application/vnd.route66.link66+xml link66 # application/vnd.ruckus.download # application/vnd.s3sms application/vnd.sailingtracker.track st # application/vnd.sbm.cid # application/vnd.sbm.mid2 # application/vnd.scribus # application/vnd.sealed.3df # application/vnd.sealed.csf # application/vnd.sealed.doc # application/vnd.sealed.eml # application/vnd.sealed.mht # application/vnd.sealed.net # application/vnd.sealed.ppt # application/vnd.sealed.tiff # application/vnd.sealed.xls # application/vnd.sealedmedia.softseal.html # application/vnd.sealedmedia.softseal.pdf application/vnd.seemail see application/vnd.sema sema application/vnd.semd semd application/vnd.semf semf application/vnd.shana.informed.formdata ifm application/vnd.shana.informed.formtemplate itp application/vnd.shana.informed.interchange iif application/vnd.shana.informed.package ipk application/vnd.simtech-mindmapper twd twds application/vnd.smaf mmf # application/vnd.smart.notebook application/vnd.smart.teacher teacher # application/vnd.software602.filler.form+xml # application/vnd.software602.filler.form-xml-zip application/vnd.solent.sdkm+xml sdkm sdkd application/vnd.spotfire.dxp dxp application/vnd.spotfire.sfs sfs # application/vnd.sss-cod # application/vnd.sss-dtf # application/vnd.sss-ntf application/vnd.stardivision.calc sdc application/vnd.stardivision.draw sda application/vnd.stardivision.impress sdd application/vnd.stardivision.math smf application/vnd.stardivision.writer sdw vor application/vnd.stardivision.writer-global sgl application/vnd.stepmania.stepchart sm # application/vnd.street-stream application/vnd.sun.xml.calc sxc application/vnd.sun.xml.calc.template stc application/vnd.sun.xml.draw sxd application/vnd.sun.xml.draw.template std application/vnd.sun.xml.impress sxi application/vnd.sun.xml.impress.template sti application/vnd.sun.xml.math sxm application/vnd.sun.xml.writer sxw application/vnd.sun.xml.writer.global sxg application/vnd.sun.xml.writer.template stw # application/vnd.sun.wadl+xml application/vnd.sus-calendar sus susp application/vnd.svd svd # application/vnd.swiftview-ics application/vnd.symbian.install sis sisx application/vnd.syncml+xml xsm application/vnd.syncml.dm+wbxml bdm application/vnd.syncml.dm+xml xdm # application/vnd.syncml.dm.notification # application/vnd.syncml.ds.notification application/vnd.tao.intent-module-archive tao application/vnd.tmobile-livetv tmo application/vnd.trid.tpt tpt application/vnd.triscape.mxs mxs application/vnd.trueapp tra # application/vnd.truedoc # application/vnd.ubisoft.webplayer application/vnd.ufdl ufd ufdl application/vnd.uiq.theme utz application/vnd.umajin umj application/vnd.unity unityweb application/vnd.uoml+xml uoml # application/vnd.uplanet.alert # application/vnd.uplanet.alert-wbxml # application/vnd.uplanet.bearer-choice # application/vnd.uplanet.bearer-choice-wbxml # application/vnd.uplanet.cacheop # application/vnd.uplanet.cacheop-wbxml # application/vnd.uplanet.channel # application/vnd.uplanet.channel-wbxml # application/vnd.uplanet.list # application/vnd.uplanet.list-wbxml # application/vnd.uplanet.listcmd # application/vnd.uplanet.listcmd-wbxml # application/vnd.uplanet.signal application/vnd.vcx vcx # application/vnd.vd-study # application/vnd.vectorworks # application/vnd.verimatrix.vcas # application/vnd.vidsoft.vidconference application/vnd.visio vsd vst vss vsw application/vnd.visionary vis # application/vnd.vividence.scriptfile application/vnd.vsf vsf # application/vnd.wap.sic # application/vnd.wap.slc application/vnd.wap.wbxml wbxml application/vnd.wap.wmlc wmlc application/vnd.wap.wmlscriptc wmlsc application/vnd.webturbo wtb # application/vnd.wfa.wsc # application/vnd.wmc # application/vnd.wmf.bootstrap # application/vnd.wolfram.mathematica # application/vnd.wolfram.mathematica.package application/vnd.wolfram.player nbp application/vnd.wordperfect wpd application/vnd.wqd wqd # application/vnd.wrq-hp3000-labelled application/vnd.wt.stf stf # application/vnd.wv.csp+wbxml # application/vnd.wv.csp+xml # application/vnd.wv.ssp+xml application/vnd.xara xar application/vnd.xfdl xfdl # application/vnd.xfdl.webform # application/vnd.xmi+xml # application/vnd.xmpie.cpkg # application/vnd.xmpie.dpkg # application/vnd.xmpie.plan # application/vnd.xmpie.ppkg # application/vnd.xmpie.xlim application/vnd.yamaha.hv-dic hvd application/vnd.yamaha.hv-script hvs application/vnd.yamaha.hv-voice hvp application/vnd.yamaha.openscoreformat osf application/vnd.yamaha.openscoreformat.osfpvg+xml osfpvg # application/vnd.yamaha.remote-setup application/vnd.yamaha.smaf-audio saf application/vnd.yamaha.smaf-phrase spf # application/vnd.yamaha.tunnel-udpencap application/vnd.yellowriver-custom-menu cmp application/vnd.zul zir zirz application/vnd.zzazz.deck+xml zaz application/voicexml+xml vxml # application/vq-rtcpxr # application/watcherinfo+xml # application/whoispp-query # application/whoispp-response application/widget wgt application/winhlp hlp # application/wita # application/wordperfect5.1 application/wsdl+xml wsdl application/wspolicy+xml wspolicy application/x-7z-compressed 7z application/x-abiword abw application/x-ace-compressed ace application/x-authorware-bin aab x32 u32 vox application/x-authorware-map aam application/x-authorware-seg aas application/x-bcpio bcpio application/x-bittorrent torrent application/x-bzip bz application/x-bzip2 bz2 boz application/x-cdlink vcd application/x-chat chat application/x-chess-pgn pgn # application/x-compress application/x-cpio cpio application/x-csh csh application/x-debian-package deb udeb application/x-director dir dcr dxr cst cct cxt w3d fgd swa application/x-doom wad application/x-dtbncx+xml ncx application/x-dtbook+xml dtb application/x-dtbresource+xml res application/x-dvi dvi application/x-font-bdf bdf # application/x-font-dos # application/x-font-framemaker application/x-font-ghostscript gsf # application/x-font-libgrx application/x-font-linux-psf psf application/x-font-otf otf application/x-font-pcf pcf application/x-font-snf snf # application/x-font-speedo # application/x-font-sunos-news application/x-font-ttf ttf ttc application/x-font-type1 pfa pfb pfm afm application/x-font-woff woff # application/x-font-vfont application/x-futuresplash spl application/x-gnumeric gnumeric application/x-gtar gtar # application/x-gzip application/x-hdf hdf application/x-java-jnlp-file jnlp application/x-latex latex application/x-mobipocket-ebook prc mobi application/x-ms-application application application/x-ms-wmd wmd application/x-ms-wmz wmz application/x-ms-xbap xbap application/x-msaccess mdb application/x-msbinder obd application/x-mscardfile crd application/x-msclip clp application/x-msdownload exe dll com bat msi application/x-msmediaview mvb m13 m14 application/x-msmetafile wmf application/x-msmoney mny application/x-mspublisher pub application/x-msschedule scd application/x-msterminal trm application/x-mswrite wri application/x-netcdf nc cdf application/x-pkcs12 p12 pfx application/x-pkcs7-certificates p7b spc application/x-pkcs7-certreqresp p7r application/x-rar-compressed rar application/x-sh sh application/x-shar shar application/x-shockwave-flash swf application/x-silverlight-app xap application/x-stuffit sit application/x-stuffitx sitx application/x-sv4cpio sv4cpio application/x-sv4crc sv4crc application/x-tar tar application/x-tcl tcl application/x-tex tex application/x-tex-tfm tfm application/x-texinfo texinfo texi application/x-ustar ustar application/x-wais-source src application/x-x509-ca-cert der crt application/x-xfig fig application/x-xpinstall xpi # application/x400-bp # application/xcap-att+xml # application/xcap-caps+xml application/xcap-diff+xml xdf # application/xcap-el+xml # application/xcap-error+xml # application/xcap-ns+xml # application/xcon-conference-info-diff+xml # application/xcon-conference-info+xml application/xenc+xml xenc application/xhtml+xml xhtml xht # application/xhtml-voice+xml application/xml xml xsl application/xml-dtd dtd # application/xml-external-parsed-entity # application/xmpp+xml application/xop+xml xop application/xslt+xml xslt application/xspf+xml xspf application/xv+xml mxml xhvml xvml xvm application/yang yang application/yin+xml yin application/zip zip # audio/1d-interleaved-parityfec # audio/32kadpcm # audio/3gpp # audio/3gpp2 # audio/ac3 audio/adpcm adp # audio/amr # audio/amr-wb # audio/amr-wb+ # audio/asc # audio/atrac-advanced-lossless # audio/atrac-x # audio/atrac3 audio/basic au snd # audio/bv16 # audio/bv32 # audio/clearmode # audio/cn # audio/dat12 # audio/dls # audio/dsr-es201108 # audio/dsr-es202050 # audio/dsr-es202211 # audio/dsr-es202212 # audio/dvi4 # audio/eac3 # audio/evrc # audio/evrc-qcp # audio/evrc0 # audio/evrc1 # audio/evrcb # audio/evrcb0 # audio/evrcb1 # audio/evrcwb # audio/evrcwb0 # audio/evrcwb1 # audio/example # audio/g719 # audio/g722 # audio/g7221 # audio/g723 # audio/g726-16 # audio/g726-24 # audio/g726-32 # audio/g726-40 # audio/g728 # audio/g729 # audio/g7291 # audio/g729d # audio/g729e # audio/gsm # audio/gsm-efr # audio/gsm-hr-08 # audio/ilbc # audio/l16 # audio/l20 # audio/l24 # audio/l8 # audio/lpc audio/midi mid midi kar rmi # audio/mobile-xmf audio/mp4 mp4a # audio/mp4a-latm # audio/mpa # audio/mpa-robust audio/mpeg mpga mp2 mp2a mp3 m2a m3a # audio/mpeg4-generic audio/ogg oga ogg spx # audio/parityfec # audio/pcma # audio/pcma-wb # audio/pcmu-wb # audio/pcmu # audio/prs.sid # audio/qcelp # audio/red # audio/rtp-enc-aescm128 # audio/rtp-midi # audio/rtx # audio/smv # audio/smv0 # audio/smv-qcp # audio/sp-midi # audio/speex # audio/t140c # audio/t38 # audio/telephone-event # audio/tone # audio/uemclip # audio/ulpfec # audio/vdvi # audio/vmr-wb # audio/vnd.3gpp.iufp # audio/vnd.4sb # audio/vnd.audiokoz # audio/vnd.celp # audio/vnd.cisco.nse # audio/vnd.cmles.radio-events # audio/vnd.cns.anp1 # audio/vnd.cns.inf1 audio/vnd.dece.audio uva uvva audio/vnd.digital-winds eol # audio/vnd.dlna.adts # audio/vnd.dolby.heaac.1 # audio/vnd.dolby.heaac.2 # audio/vnd.dolby.mlp # audio/vnd.dolby.mps # audio/vnd.dolby.pl2 # audio/vnd.dolby.pl2x # audio/vnd.dolby.pl2z # audio/vnd.dolby.pulse.1 audio/vnd.dra dra audio/vnd.dts dts audio/vnd.dts.hd dtshd # audio/vnd.everad.plj # audio/vnd.hns.audio audio/vnd.lucent.voice lvp audio/vnd.ms-playready.media.pya pya # audio/vnd.nokia.mobile-xmf # audio/vnd.nortel.vbk audio/vnd.nuera.ecelp4800 ecelp4800 audio/vnd.nuera.ecelp7470 ecelp7470 audio/vnd.nuera.ecelp9600 ecelp9600 # audio/vnd.octel.sbc # audio/vnd.qcelp # audio/vnd.rhetorex.32kadpcm audio/vnd.rip rip # audio/vnd.sealedmedia.softseal.mpeg # audio/vnd.vmx.cvsd # audio/vorbis # audio/vorbis-config audio/webm weba audio/x-aac aac audio/x-aiff aif aiff aifc audio/x-mpegurl m3u audio/x-ms-wax wax audio/x-ms-wma wma audio/x-pn-realaudio ram ra audio/x-pn-realaudio-plugin rmp audio/x-wav wav chemical/x-cdx cdx chemical/x-cif cif chemical/x-cmdf cmdf chemical/x-cml cml chemical/x-csml csml # chemical/x-pdb chemical/x-xyz xyz image/bmp bmp image/cgm cgm # image/example # image/fits image/g3fax g3 image/gif gif image/ief ief # image/jp2 image/jpeg jpeg jpg jpe # image/jpm # image/jpx image/ktx ktx # image/naplps image/png png image/prs.btif btif # image/prs.pti image/svg+xml svg svgz # image/t38 image/tiff tiff tif # image/tiff-fx image/vnd.adobe.photoshop psd # image/vnd.cns.inf2 image/vnd.dece.graphic uvi uvvi uvg uvvg image/vnd.dvb.subtitle sub image/vnd.djvu djvu djv image/vnd.dwg dwg image/vnd.dxf dxf image/vnd.fastbidsheet fbs image/vnd.fpx fpx image/vnd.fst fst image/vnd.fujixerox.edmics-mmr mmr image/vnd.fujixerox.edmics-rlc rlc # image/vnd.globalgraphics.pgb # image/vnd.microsoft.icon # image/vnd.mix image/vnd.ms-modi mdi image/vnd.net-fpx npx # image/vnd.radiance # image/vnd.sealed.png # image/vnd.sealedmedia.softseal.gif # image/vnd.sealedmedia.softseal.jpg # image/vnd.svf image/vnd.wap.wbmp wbmp image/vnd.xiff xif image/webp webp image/x-cmu-raster ras image/x-cmx cmx image/x-freehand fh fhc fh4 fh5 fh7 image/x-icon ico image/x-pcx pcx image/x-pict pic pct image/x-portable-anymap pnm image/x-portable-bitmap pbm image/x-portable-graymap pgm image/x-portable-pixmap ppm image/x-rgb rgb image/x-xbitmap xbm image/x-xpixmap xpm image/x-xwindowdump xwd # message/cpim # message/delivery-status # message/disposition-notification # message/example # message/external-body # message/feedback-report # message/global # message/global-delivery-status # message/global-disposition-notification # message/global-headers # message/http # message/imdn+xml # message/news # message/partial message/rfc822 eml mime # message/s-http # message/sip # message/sipfrag # message/tracking-status # message/vnd.si.simp # model/example model/iges igs iges model/mesh msh mesh silo model/vnd.collada+xml dae model/vnd.dwf dwf # model/vnd.flatland.3dml model/vnd.gdl gdl # model/vnd.gs-gdl # model/vnd.gs.gdl model/vnd.gtw gtw # model/vnd.moml+xml model/vnd.mts mts # model/vnd.parasolid.transmit.binary # model/vnd.parasolid.transmit.text model/vnd.vtu vtu model/vrml wrl vrml # multipart/alternative # multipart/appledouble # multipart/byteranges # multipart/digest # multipart/encrypted # multipart/example # multipart/form-data # multipart/header-set # multipart/mixed # multipart/parallel # multipart/related # multipart/report # multipart/signed # multipart/voice-message # text/1d-interleaved-parityfec text/calendar ics ifb text/css css text/csv csv # text/directory # text/dns # text/ecmascript # text/enriched # text/example text/html html htm # text/javascript text/n3 n3 # text/parityfec text/plain txt text conf def list log in # text/prs.fallenstein.rst text/prs.lines.tag dsc # text/vnd.radisys.msml-basic-layout # text/red # text/rfc822-headers text/richtext rtx # text/rtf # text/rtp-enc-aescm128 # text/rtx text/sgml sgml sgm # text/t140 text/tab-separated-values tsv text/troff t tr roff man me ms text/turtle ttl # text/ulpfec text/uri-list uri uris urls # text/vnd.abc text/vnd.curl curl text/vnd.curl.dcurl dcurl text/vnd.curl.scurl scurl text/vnd.curl.mcurl mcurl # text/vnd.dmclientscript # text/vnd.esmertec.theme-descriptor text/vnd.fly fly text/vnd.fmi.flexstor flx text/vnd.graphviz gv text/vnd.in3d.3dml 3dml text/vnd.in3d.spot spot # text/vnd.iptc.newsml # text/vnd.iptc.nitf # text/vnd.latex-z # text/vnd.motorola.reflex # text/vnd.ms-mediapackage # text/vnd.net2phone.commcenter.command # text/vnd.si.uricatalogue text/vnd.sun.j2me.app-descriptor jad # text/vnd.trolltech.linguist # text/vnd.wap.si # text/vnd.wap.sl text/vnd.wap.wml wml text/vnd.wap.wmlscript wmls text/x-asm s asm text/x-c c cc cxx cpp h hh dic text/x-fortran f for f77 f90 text/x-pascal p pas text/x-java-source java text/x-setext etx text/x-uuencode uu text/x-vcalendar vcs text/x-vcard vcf # text/xml # text/xml-external-parsed-entity # video/1d-interleaved-parityfec video/3gpp 3gp # video/3gpp-tt video/3gpp2 3g2 # video/bmpeg # video/bt656 # video/celb # video/dv # video/example video/h261 h261 video/h263 h263 # video/h263-1998 # video/h263-2000 video/h264 h264 # video/h264-rcdo # video/h264-svc video/jpeg jpgv # video/jpeg2000 video/jpm jpm jpgm video/mj2 mj2 mjp2 # video/mp1s # video/mp2p # video/mp2t video/mp4 mp4 mp4v mpg4 # video/mp4v-es video/mpeg mpeg mpg mpe m1v m2v # video/mpeg4-generic # video/mpv # video/nv video/ogg ogv # video/parityfec # video/pointer video/quicktime qt mov # video/raw # video/rtp-enc-aescm128 # video/rtx # video/smpte292m # video/ulpfec # video/vc1 # video/vnd.cctv video/vnd.dece.hd uvh uvvh video/vnd.dece.mobile uvm uvvm # video/vnd.dece.mp4 video/vnd.dece.pd uvp uvvp video/vnd.dece.sd uvs uvvs video/vnd.dece.video uvv uvvv # video/vnd.directv.mpeg # video/vnd.directv.mpeg-tts # video/vnd.dlna.mpeg-tts video/vnd.fvt fvt # video/vnd.hns.video # video/vnd.iptvforum.1dparityfec-1010 # video/vnd.iptvforum.1dparityfec-2005 # video/vnd.iptvforum.2dparityfec-1010 # video/vnd.iptvforum.2dparityfec-2005 # video/vnd.iptvforum.ttsavc # video/vnd.iptvforum.ttsmpeg2 # video/vnd.motorola.video # video/vnd.motorola.videop video/vnd.mpegurl mxu m4u video/vnd.ms-playready.media.pyv pyv # video/vnd.nokia.interleaved-multimedia # video/vnd.nokia.videovoip # video/vnd.objectvideo # video/vnd.sealed.mpeg1 # video/vnd.sealed.mpeg4 # video/vnd.sealed.swf # video/vnd.sealedmedia.softseal.mov video/vnd.uvvu.mp4 uvu uvvu video/vnd.vivo viv video/webm webm video/x-f4v f4v video/x-fli fli video/x-flv flv video/x-m4v m4v video/x-ms-asf asf asx video/x-ms-wm wm video/x-ms-wmv wmv video/x-ms-wmx wmx video/x-ms-wvx wvx video/x-msvideo avi video/x-sgi-movie movie x-conference/x-cooltalk ice PK ! m�� � LWP/MediaTypes.pmnu �[��� package LWP::MediaTypes; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(guess_media_type media_suffix); @EXPORT_OK = qw(add_type add_encoding read_media_types); our $VERSION = '6.04'; use strict; use Scalar::Util qw(blessed); use Carp qw(croak); # note: These hashes will also be filled with the entries found in # the 'media.types' file. my %suffixType = ( 'txt' => 'text/plain', 'html' => 'text/html', 'gif' => 'image/gif', 'jpg' => 'image/jpeg', 'xml' => 'text/xml', ); my %suffixExt = ( 'text/plain' => 'txt', 'text/html' => 'html', 'image/gif' => 'gif', 'image/jpeg' => 'jpg', 'text/xml' => 'xml', ); #XXX: there should be some way to define this in the media.types files. my %suffixEncoding = ( 'Z' => 'compress', 'gz' => 'gzip', 'hqx' => 'x-hqx', 'uu' => 'x-uuencode', 'z' => 'x-pack', 'bz2' => 'x-bzip2', ); read_media_types(); sub guess_media_type { my($file, $header) = @_; return undef unless defined $file; my $fullname; if (ref $file) { croak("Unable to determine filetype on unblessed refs") unless blessed($file); if ($file->can('path')) { $file = $file->path; } elsif ($file->can('filename')) { $fullname = $file->filename; } else { $fullname = "" . $file; } } else { $fullname = $file; # enable peek at actual file } my @encoding = (); my $ct = undef; for (file_exts($file)) { # first check this dot part as encoding spec if (exists $suffixEncoding{$_}) { unshift(@encoding, $suffixEncoding{$_}); next; } if (exists $suffixEncoding{lc $_}) { unshift(@encoding, $suffixEncoding{lc $_}); next; } # check content-type if (exists $suffixType{$_}) { $ct = $suffixType{$_}; last; } if (exists $suffixType{lc $_}) { $ct = $suffixType{lc $_}; last; } # don't know nothing about this dot part, bail out last; } unless (defined $ct) { # Take a look at the file if (defined $fullname) { $ct = (-T $fullname) ? "text/plain" : "application/octet-stream"; } else { $ct = "application/octet-stream"; } } if ($header) { $header->header('Content-Type' => $ct); $header->header('Content-Encoding' => \@encoding) if @encoding; } wantarray ? ($ct, @encoding) : $ct; } sub media_suffix { if (!wantarray && @_ == 1 && $_[0] !~ /\*/) { return $suffixExt{lc $_[0]}; } my(@type) = @_; my(@suffix, $ext, $type); foreach (@type) { if (s/\*/.*/) { while(($ext,$type) = each(%suffixType)) { push(@suffix, $ext) if $type =~ /^$_$/i; } } else { my $ltype = lc $_; while(($ext,$type) = each(%suffixType)) { push(@suffix, $ext) if lc $type eq $ltype; } } } wantarray ? @suffix : $suffix[0]; } sub file_exts { require File::Basename; my @parts = reverse split(/\./, File::Basename::basename($_[0])); pop(@parts); # never consider first part @parts; } sub add_type { my($type, @exts) = @_; for my $ext (@exts) { $ext =~ s/^\.//; $suffixType{$ext} = $type; } $suffixExt{lc $type} = $exts[0] if @exts; } sub add_encoding { my($type, @exts) = @_; for my $ext (@exts) { $ext =~ s/^\.//; $suffixEncoding{$ext} = $type; } } sub read_media_types { my(@files) = @_; local($/, $_) = ("\n", undef); # ensure correct $INPUT_RECORD_SEPARATOR my @priv_files = (); push(@priv_files, "$ENV{HOME}/.media.types", "$ENV{HOME}/.mime.types") if defined $ENV{HOME}; # Some doesn't have a home (for instance Win32) # Try to locate "media.types" file, and initialize %suffixType from it my $typefile; unless (@files) { @files = map {"$_/LWP/media.types"} @INC; push @files, @priv_files; } for $typefile (@files) { local(*TYPE); open(TYPE, $typefile) || next; while (<TYPE>) { next if /^\s*#/; # comment line next if /^\s*$/; # blank line s/#.*//; # remove end-of-line comments my($type, @exts) = split(' ', $_); add_type($type, @exts); } close(TYPE); } } 1; __END__ =head1 NAME LWP::MediaTypes - guess media type for a file or a URL =head1 SYNOPSIS use LWP::MediaTypes qw(guess_media_type); $type = guess_media_type("/tmp/foo.gif"); =head1 DESCRIPTION This module provides functions for handling media (also known as MIME) types and encodings. The mapping from file extensions to media types is defined by the F<media.types> file. If the F<~/.media.types> file exists it is used instead. For backwards compatibility we will also look for F<~/.mime.types>. The following functions are exported by default: =over 4 =item guess_media_type( $filename ) =item guess_media_type( $uri ) =item guess_media_type( $filename_or_object, $header_to_modify ) This function tries to guess media type and encoding for a file or objects that support the a C<path> or C<filename> method, eg, L<URI> or L<File::Temp> objects. When an object does not support either method, it will be stringified to determine the filename. It returns the content type, which is a string like C<"text/html">. In array context it also returns any content encodings applied (in the order used to encode the file). You can pass a URI object reference, instead of the file name. If the type can not be deduced from looking at the file name, then guess_media_type() will let the C<-T> Perl operator take a look. If this works (and C<-T> returns a TRUE value) then we return I<text/plain> as the type, otherwise we return I<application/octet-stream> as the type. The optional second argument should be a reference to a HTTP::Headers object or any object that implements the $obj->header method in a similar way. When it is present the values of the 'Content-Type' and 'Content-Encoding' will be set for this header. =item media_suffix( $type, ... ) This function will return all suffixes that can be used to denote the specified media type(s). Wildcard types can be used. In a scalar context it will return the first suffix found. Examples: @suffixes = media_suffix('image/*', 'audio/basic'); $suffix = media_suffix('text/html'); =back The following functions are only exported by explicit request: =over 4 =item add_type( $type, @exts ) Associate a list of file extensions with the given media type. Example: add_type("x-world/x-vrml" => qw(wrl vrml)); =item add_encoding( $type, @ext ) Associate a list of file extensions with an encoding type. Example: add_encoding("x-gzip" => "gz"); =item read_media_types( @files ) Parse media types files and add the type mappings found there. Example: read_media_types("conf/mime.types"); =back =head1 COPYRIGHT Copyright 1995-1999 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. PK ! �2�� � Error/Simple.pmnu �[��� # Error/Simple.pm # # Copyright (c) 2006 Shlomi Fish <shlomif@shlomifish.org>. # This file is free software; you can redistribute it and/or # modify it under the terms of the MIT/X11 license (whereas the licence # of the Error distribution as a whole is the GPLv1+ and the Artistic # licence). package Error::Simple; $Error::Simple::VERSION = '0.17029'; use strict; use warnings; use Error; 1; __END__ =pod =encoding UTF-8 =head1 NAME Error::Simple - the simple error sub-class of Error =head1 VERSION version 0.17029 =head1 SYNOPSIS use base 'Error::Simple'; =head1 DESCRIPTION The only purpose of this module is to allow one to say: use base 'Error::Simple'; and the only thing it does is "use" Error.pm. Refer to the documentation of L<Error> for more information about Error::Simple. =head1 METHODS =head2 Error::Simple->new($text [, $value]) Constructs an Error::Simple with the text C<$text> and the optional value C<$value>. =head2 $err->stringify() Error::Simple overloads this method. =head1 KNOWN BUGS None. =head1 AUTHORS Shlomi Fish ( L<http://www.shlomifish.org/> ) =head1 SEE ALSO L<Error> =for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Websites The following websites have more information about this module, and may be of help to you. As always, in addition to those websites please use your favorite search engine to discover more resources. =over 4 =item * MetaCPAN A modern, open-source CPAN search engine, useful to view POD in HTML format. L<https://metacpan.org/release/Error> =item * Search CPAN The default CPAN search engine, useful to view POD in HTML format. L<http://search.cpan.org/dist/Error> =item * RT: CPAN's Bug Tracker The RT ( Request Tracker ) website is the default bug/issue tracking system for CPAN. L<https://rt.cpan.org/Public/Dist/Display.html?Name=Error> =item * CPAN Ratings The CPAN Ratings is a website that allows community ratings and reviews of Perl modules. L<http://cpanratings.perl.org/d/Error> =item * CPANTS The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution. L<http://cpants.cpanauthors.org/dist/Error> =item * CPAN Testers The CPAN Testers is a network of smoke testers who run automated tests on uploaded CPAN distributions. L<http://www.cpantesters.org/distro/E/Error> =item * CPAN Testers Matrix The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms. L<http://matrix.cpantesters.org/?dist=Error> =item * CPAN Testers Dependencies The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution. L<http://deps.cpantesters.org/?module=Error> =back =head2 Bugs / Feature Requests Please report any bugs or feature requests by email to C<bug-error at rt.cpan.org>, or through the web interface at L<https://rt.cpan.org/Public/Bug/Report.html?Queue=Error>. You will be automatically notified of any progress on the request by the system. =head2 Source Code The code is open to the world, and available for you to hack on. Please feel free to browse it and play with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull from your repository :) L<https://github.com/shlomif/perl-error.pm> git clone git://github.com/shlomif/perl-error.pm.git =head1 AUTHOR Shlomi Fish ( http://www.shlomifish.org/ ) =head1 BUGS Please report any bugs or feature requests on the bugtracker website L<https://github.com/shlomif/perl-error.pm/issues> When submitting a bug or request, please include a test-file or a patch to an existing test-file that illustrates the bug or desired feature. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2020 by Shlomi Fish ( http://www.shlomifish.org/ ). This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut PK ! �x�\ \ HTML/Template.pmnu �[��� package HTML::Template; $HTML::Template::VERSION = '2.97'; =head1 NAME HTML::Template - Perl module to use HTML-like templating language =head1 SYNOPSIS First you make a template - this is just a normal HTML file with a few extra tags, the simplest being C<< <TMPL_VAR> >> For example, test.tmpl: <html> <head><title>Test Template</title></head> <body> My Home Directory is <TMPL_VAR NAME=HOME> <p> My Path is set to <TMPL_VAR NAME=PATH> </body> </html> Now you can use it in a small CGI program: #!/usr/bin/perl -w use HTML::Template; # open the html template my $template = HTML::Template->new(filename => 'test.tmpl'); # fill in some parameters $template->param(HOME => $ENV{HOME}); $template->param(PATH => $ENV{PATH}); # send the obligatory Content-Type and print the template output print "Content-Type: text/html\n\n", $template->output; If all is well in the universe this should show something like this in your browser when visiting the CGI: My Home Directory is /home/some/directory My Path is set to /bin;/usr/bin =head1 DESCRIPTION This module attempts to make using HTML templates simple and natural. It extends standard HTML with a few new HTML-esque tags - C<< <TMPL_VAR> >> C<< <TMPL_LOOP> >>, C<< <TMPL_INCLUDE> >>, C<< <TMPL_IF> >>, C<< <TMPL_ELSE> >> and C<< <TMPL_UNLESS> >>. The file written with HTML and these new tags is called a template. It is usually saved separate from your script - possibly even created by someone else! Using this module you fill in the values for the variables, loops and branches declared in the template. This allows you to separate design - the HTML - from the data, which you generate in the Perl script. This module is licensed under the same terms as Perl. See the LICENSE section below for more details. =head1 TUTORIAL If you're new to HTML::Template, I suggest you start with the introductory article available on Perl Monks: http://www.perlmonks.org/?node_id=65642 =head1 FAQ Please see L<HTML::Template::FAQ> =head1 MOTIVATION It is true that there are a number of packages out there to do HTML templates. On the one hand you have things like L<HTML::Embperl> which allows you freely mix Perl with HTML. On the other hand lie home-grown variable substitution solutions. Hopefully the module can find a place between the two. One advantage of this module over a full L<HTML::Embperl>-esque solution is that it enforces an important divide - design and programming. By limiting the programmer to just using simple variables and loops in the HTML, the template remains accessible to designers and other non-perl people. The use of HTML-esque syntax goes further to make the format understandable to others. In the future this similarity could be used to extend existing HTML editors/analyzers to support HTML::Template. An advantage of this module over home-grown tag-replacement schemes is the support for loops. In my work I am often called on to produce tables of data in html. Producing them using simplistic HTML templates results in programs containing lots of HTML since the HTML itself cannot represent loops. The introduction of loop statements in the HTML simplifies this situation considerably. The designer can layout a single row and the programmer can fill it in as many times as necessary - all they must agree on is the parameter names. For all that, I think the best thing about this module is that it does just one thing and it does it quickly and carefully. It doesn't try to replace Perl and HTML, it just augments them to interact a little better. And it's pretty fast. =head1 THE TAGS =head2 TMPL_VAR <TMPL_VAR NAME="PARAMETER_NAME"> The C<< <TMPL_VAR> >> tag is very simple. For each C<< <TMPL_VAR> >> tag in the template you call: $template->param(PARAMETER_NAME => "VALUE") When the template is output the C<< <TMPL_VAR> >> is replaced with the VALUE text you specified. If you don't set a parameter it just gets skipped in the output. You can also specify the value of the parameter as a code reference in order to have "lazy" variables. These sub routines will only be referenced if the variables are used. See L<LAZY VALUES> for more information. =head3 Attributes The following "attributes" can also be specified in template var tags: =over =item * escape This allows you to escape the value before it's put into the output. This is useful when you want to use a TMPL_VAR in a context where those characters would cause trouble. For example: <input name=param type=text value="<TMPL_VAR PARAM>"> If you called C<param()> with a value like C<sam"my> you'll get in trouble with HTML's idea of a double-quote. On the other hand, if you use C<escape=html>, like this: <input name=param type=text value="<TMPL_VAR PARAM ESCAPE=HTML>"> You'll get what you wanted no matter what value happens to be passed in for param. The following escape values are supported: =over =item * html Replaces the following characters with their HTML entity equivalent: C<&>, C<">, C<'>, C<< < >>, C<< > >> =item * js Escapes (with a backslash) the following characters: C<\>, C<'>, C<">, C<\n>, C<\r> =item * url URL escapes any ASCII characters except for letters, numbers, C<_>, C<.> and C<->. =item * none Performs no escaping. This is the default, but it's useful to be able to explicitly turn off escaping if you are using the C<default_escape> option. =back =item * default With this attribute you can assign a default value to a variable. For example, this will output "the devil gave me a taco" if the C<who> variable is not set. <TMPL_VAR WHO DEFAULT="the devil"> gave me a taco. =back =head2 TMPL_LOOP <TMPL_LOOP NAME="LOOP_NAME"> ... </TMPL_LOOP> The C<< <TMPL_LOOP> >> tag is a bit more complicated than C<< <TMPL_VAR> >>. The C<< <TMPL_LOOP> >> tag allows you to delimit a section of text and give it a name. Inside this named loop you place C<< <TMPL_VAR> >>s. Now you pass to C<param()> a list (an array ref) of parameter assignments (hash refs) for this loop. The loop iterates over the list and produces output from the text block for each pass. Unset parameters are skipped. Here's an example: In the template: <TMPL_LOOP NAME=EMPLOYEE_INFO> Name: <TMPL_VAR NAME=NAME> <br> Job: <TMPL_VAR NAME=JOB> <p> </TMPL_LOOP> In your Perl code: $template->param( EMPLOYEE_INFO => [{name => 'Sam', job => 'programmer'}, {name => 'Steve', job => 'soda jerk'}] ); print $template->output(); The output is: Name: Sam Job: programmer Name: Steve Job: soda jerk As you can see above the C<< <TMPL_LOOP> >> takes a list of variable assignments and then iterates over the loop body producing output. Often you'll want to generate a C<< <TMPL_LOOP> >>'s contents programmatically. Here's an example of how this can be done (many other ways are possible!): # a couple of arrays of data to put in a loop: my @words = qw(I Am Cool); my @numbers = qw(1 2 3); my @loop_data = (); # initialize an array to hold your loop while (@words and @numbers) { my %row_data; # get a fresh hash for the row data # fill in this row $row_data{WORD} = shift @words; $row_data{NUMBER} = shift @numbers; # the crucial step - push a reference to this row into the loop! push(@loop_data, \%row_data); } # finally, assign the loop data to the loop param, again with a reference: $template->param(THIS_LOOP => \@loop_data); The above example would work with a template like: <TMPL_LOOP NAME="THIS_LOOP"> Word: <TMPL_VAR NAME="WORD"> Number: <TMPL_VAR NAME="NUMBER"> </TMPL_LOOP> It would produce output like: Word: I Number: 1 Word: Am Number: 2 Word: Cool Number: 3 C<< <TMPL_LOOP> >>s within C<< <TMPL_LOOP> >>s are fine and work as you would expect. If the syntax for the C<param()> call has you stumped, here's an example of a param call with one nested loop: $template->param( LOOP => [ { name => 'Bobby', nicknames => [{name => 'the big bad wolf'}, {name => 'He-Man'}], }, ], ); Basically, each C<< <TMPL_LOOP> >> gets an array reference. Inside the array are any number of hash references. These hashes contain the name=>value pairs for a single pass over the loop template. Inside a C<< <TMPL_LOOP> >>, the only variables that are usable are the ones from the C<< <TMPL_LOOP> >>. The variables in the outer blocks are not visible within a template loop. For the computer-science geeks among you, a C<< <TMPL_LOOP> >> introduces a new scope much like a perl subroutine call. If you want your variables to be global you can use C<global_vars> option to C<new()> described below. =head2 TMPL_INCLUDE <TMPL_INCLUDE NAME="filename.tmpl"> This tag includes a template directly into the current template at the point where the tag is found. The included template contents are used exactly as if its contents were physically included in the master template. The file specified can be an absolute path (beginning with a '/' under Unix, for example). If it isn't absolute, the path to the enclosing file is tried first. After that the path in the environment variable C<HTML_TEMPLATE_ROOT> is tried, if it exists. Next, the "path" option is consulted, first as-is and then with C<HTML_TEMPLATE_ROOT> prepended if available. As a final attempt, the filename is passed to C<open()> directly. See below for more information on C<HTML_TEMPLATE_ROOT> and the C<path> option to C<new()>. As a protection against infinitely recursive includes, an arbitrary limit of 10 levels deep is imposed. You can alter this limit with the C<max_includes> option. See the entry for the C<max_includes> option below for more details. =head2 TMPL_IF <TMPL_IF NAME="PARAMETER_NAME"> ... </TMPL_IF> The C<< <TMPL_IF> >> tag allows you to include or not include a block of the template based on the value of a given parameter name. If the parameter is given a value that is true for Perl - like '1' - then the block is included in the output. If it is not defined, or given a false value - like '0' - then it is skipped. The parameters are specified the same way as with C<< <TMPL_VAR> >>. Example Template: <TMPL_IF NAME="BOOL"> Some text that only gets displayed if BOOL is true! </TMPL_IF> Now if you call C<< $template->param(BOOL => 1) >> then the above block will be included by output. C<< <TMPL_IF> </TMPL_IF> >> blocks can include any valid HTML::Template construct - C<VAR>s and C<LOOP>s and other C<IF>/C<ELSE> blocks. Note, however, that intersecting a C<< <TMPL_IF> >> and a C<< <TMPL_LOOP> >> is invalid. Not going to work: <TMPL_IF BOOL> <TMPL_LOOP SOME_LOOP> </TMPL_IF> </TMPL_LOOP> If the name of a C<< <TMPL_LOOP> >> is used in a C<< <TMPL_IF> >>, the C<IF> block will output if the loop has at least one row. Example: <TMPL_IF LOOP_ONE> This will output if the loop is not empty. </TMPL_IF> <TMPL_LOOP LOOP_ONE> .... </TMPL_LOOP> WARNING: Much of the benefit of HTML::Template is in decoupling your Perl and HTML. If you introduce numerous cases where you have C<TMPL_IF>s and matching Perl C<if>s, you will create a maintenance problem in keeping the two synchronized. I suggest you adopt the practice of only using C<TMPL_IF> if you can do so without requiring a matching C<if> in your Perl code. =head2 TMPL_ELSE <TMPL_IF NAME="PARAMETER_NAME"> ... <TMPL_ELSE> ... </TMPL_IF> You can include an alternate block in your C<< <TMPL_IF> >> block by using C<< <TMPL_ELSE> >>. NOTE: You still end the block with C<< </TMPL_IF> >>, not C<< </TMPL_ELSE> >>! Example: <TMPL_IF BOOL> Some text that is included only if BOOL is true <TMPL_ELSE> Some text that is included only if BOOL is false </TMPL_IF> =head2 TMPL_UNLESS <TMPL_UNLESS NAME="PARAMETER_NAME"> ... </TMPL_UNLESS> This tag is the opposite of C<< <TMPL_IF> >>. The block is output if the C<PARAMETER_NAME> is set false or not defined. You can use C<< <TMPL_ELSE> >> with C<< <TMPL_UNLESS> >> just as you can with C<< <TMPL_IF> >>. Example: <TMPL_UNLESS BOOL> Some text that is output only if BOOL is FALSE. <TMPL_ELSE> Some text that is output only if BOOL is TRUE. </TMPL_UNLESS> If the name of a C<< <TMPL_LOOP> >> is used in a C<< <TMPL_UNLESS> >>, the C<< <UNLESS> >> block output if the loop has zero rows. <TMPL_UNLESS LOOP_ONE> This will output if the loop is empty. </TMPL_UNLESS> <TMPL_LOOP LOOP_ONE> .... </TMPL_LOOP> =cut =head2 NOTES HTML::Template's tags are meant to mimic normal HTML tags. However, they are allowed to "break the rules". Something like: <img src="<TMPL_VAR IMAGE_SRC>"> is not really valid HTML, but it is a perfectly valid use and will work as planned. The C<NAME=> in the tag is optional, although for extensibility's sake I recommend using it. Example - C<< <TMPL_LOOP LOOP_NAME> >> is acceptable. If you're a fanatic about valid HTML and would like your templates to conform to valid HTML syntax, you may optionally type template tags in the form of HTML comments. This may be of use to HTML authors who would like to validate their templates' HTML syntax prior to HTML::Template processing, or who use DTD-savvy editing tools. <!-- TMPL_VAR NAME=PARAM1 --> In order to realize a dramatic savings in bandwidth, the standard (non-comment) tags will be used throughout this documentation. =head1 METHODS =head2 new Call C<new()> to create a new Template object: my $template = HTML::Template->new( filename => 'file.tmpl', option => 'value', ); You must call C<new()> with at least one C<name => value> pair specifying how to access the template text. You can use C<< filename => 'file.tmpl' >> to specify a filename to be opened as the template. Alternately you can use: my $t = HTML::Template->new( scalarref => $ref_to_template_text, option => 'value', ); and my $t = HTML::Template->new( arrayref => $ref_to_array_of_lines, option => 'value', ); These initialize the template from in-memory resources. In almost every case you'll want to use the filename parameter. If you're worried about all the disk access from reading a template file just use mod_perl and the cache option detailed below. You can also read the template from an already opened filehandle, either traditionally as a glob or as a L<FileHandle>: my $t = HTML::Template->new(filehandle => *FH, option => 'value'); The four C<new()> calling methods can also be accessed as below, if you prefer. my $t = HTML::Template->new_file('file.tmpl', option => 'value'); my $t = HTML::Template->new_scalar_ref($ref_to_template_text, option => 'value'); my $t = HTML::Template->new_array_ref($ref_to_array_of_lines, option => 'value'); my $t = HTML::Template->new_filehandle($fh, option => 'value'); And as a final option, for those that might prefer it, you can call new as: my $t = HTML::Template->new( type => 'filename', source => 'file.tmpl', ); Which works for all three of the source types. If the environment variable C<HTML_TEMPLATE_ROOT> is set and your filename doesn't begin with "/", then the path will be relative to the value of c<HTML_TEMPLATE_ROOT>. B<Example> - if the environment variable C<HTML_TEMPLATE_ROOT> is set to F</home/sam> and I call C<< HTML::Template->new() >> with filename set to "sam.tmpl", HTML::Template will try to open F</home/sam/sam.tmpl> to access the template file. You can also affect the search path for files with the C<path> option to C<new()> - see below for more information. You can modify the Template object's behavior with C<new()>. The options are available: =head3 Error Detection Options =over =item * die_on_bad_params If set to 0 the module will let you call: $template->param(param_name => 'value') even if 'param_name' doesn't exist in the template body. Defaults to 1. =item * force_untaint If set to 1 the module will not allow you to set unescaped parameters with tainted values. If set to 2 you will have to untaint all parameters, including ones with the escape attribute. This option makes sure you untaint everything so you don't accidentally introduce e.g. cross-site-scripting (XSS) vulnerabilities. Requires taint mode. Defaults to 0. =item * strict - if set to 0 the module will allow things that look like they might be TMPL_* tags to get by without dieing. Example: <TMPL_HUH NAME=ZUH> Would normally cause an error, but if you call new with C<< strict => 0 >> HTML::Template will ignore it. Defaults to 1. =item * vanguard_compatibility_mode If set to 1 the module will expect to see C<< <TMPL_VAR> >>s that look like C<%NAME%> in addition to the standard syntax. Also sets C<die_on_bad_params => 0>. If you're not at Vanguard Media trying to use an old format template don't worry about this one. Defaults to 0. =back =head3 Caching Options =over =item * cache If set to 1 the module will cache in memory the parsed templates based on the filename parameter, the modification date of the file and the options passed to C<new()>. This only applies to templates opened with the filename parameter specified, not scalarref or arrayref templates. Caching also looks at the modification times of any files included using C<< <TMPL_INCLUDE> >> tags, but again, only if the template is opened with filename parameter. This is mainly of use in a persistent environment like Apache/mod_perl. It has absolutely no benefit in a normal CGI environment since the script is unloaded from memory after every request. For a cache that does work for a non-persistent environment see the C<shared_cache> option below. My simplistic testing shows that using cache yields a 90% performance increase under mod_perl. Cache defaults to 0. =item * shared_cache If set to 1 the module will store its cache in shared memory using the L<IPC::SharedCache> module (available from CPAN). The effect of this will be to maintain a single shared copy of each parsed template for all instances of HTML::Template on the same machine to use. This can be a significant reduction in memory usage in an environment with a single machine but multiple servers. As an example, on one of our systems we use 4MB of template cache and maintain 25 httpd processes - shared_cache results in saving almost 100MB! Of course, some reduction in speed versus normal caching is to be expected. Another difference between normal caching and shared_cache is that shared_cache will work in a non-persistent environment (like normal CGI) - normal caching is only useful in a persistent environment like Apache/mod_perl. By default HTML::Template uses the IPC key 'TMPL' as a shared root segment (0x4c504d54 in hex), but this can be changed by setting the C<ipc_key> C<new()> parameter to another 4-character or integer key. Other options can be used to affect the shared memory cache correspond to L<IPC::SharedCache> options - C<ipc_mode>, C<ipc_segment_size> and C<ipc_max_size>. See L<IPC::SharedCache> for a description of how these work - in most cases you shouldn't need to change them from the defaults. For more information about the shared memory cache system used by HTML::Template see L<IPC::SharedCache>. =item * double_cache If set to 1 the module will use a combination of C<shared_cache> and normal cache mode for the best possible caching. Of course, it also uses the most memory of all the cache modes. All the same ipc_* options that work with C<shared_cache> apply to C<double_cache> as well. Defaults to 0. =item * blind_cache If set to 1 the module behaves exactly as with normal caching but does not check to see if the file has changed on each request. This option should be used with caution, but could be of use on high-load servers. My tests show C<blind_cache> performing only 1 to 2 percent faster than cache under mod_perl. B<NOTE>: Combining this option with shared_cache can result in stale templates stuck permanently in shared memory! =item * file_cache If set to 1 the module will store its cache in a file using the L<Storable> module. It uses no additional memory, and my simplistic testing shows that it yields a 50% performance advantage. Like C<shared_cache>, it will work in a non-persistent environments (like CGI). Default is 0. If you set this option you must set the C<file_cache_dir> option. See below for details. B<NOTE>: L<Storable> uses C<flock()> to ensure safe access to cache files. Using C<file_cache> on a system or filesystem (like NFS) without C<flock()> support is dangerous. =item * file_cache_dir Sets the directory where the module will store the cache files if C<file_cache> is enabled. Your script will need write permissions to this directory. You'll also need to make sure the sufficient space is available to store the cache files. =item * file_cache_dir_mode Sets the file mode for newly created C<file_cache> directories and subdirectories. Defaults to "0700" for security but this may be inconvenient if you do not have access to the account running the webserver. =item * double_file_cache If set to 1 the module will use a combination of C<file_cache> and normal C<cache> mode for the best possible caching. The file_cache_* options that work with file_cache apply to C<double_file_cache> as well. Defaults to 0. =item * cache_lazy_vars The option tells HTML::Template to cache the values returned from code references used for C<TMPL_VAR>s. See L<LAZY VALUES> for details. =item * cache_lazy_loops The option tells HTML::Template to cache the values returned from code references used for C<TMPL_LOOP>s. See L<LAZY VALUES> for details. =back =head3 Filesystem Options =over =item * path You can set this variable with a list of paths to search for files specified with the C<filename> option to C<new()> and for files included with the C<< <TMPL_INCLUDE> >> tag. This list is only consulted when the filename is relative. The C<HTML_TEMPLATE_ROOT> environment variable is always tried first if it exists. Also, if C<HTML_TEMPLATE_ROOT> is set then an attempt will be made to prepend C<HTML_TEMPLATE_ROOT> onto paths in the path array. In the case of a C<< <TMPL_INCLUDE> >> file, the path to the including file is also tried before path is consulted. Example: my $template = HTML::Template->new( filename => 'file.tmpl', path => ['/path/to/templates', '/alternate/path'], ); B<NOTE>: the paths in the path list must be expressed as UNIX paths, separated by the forward-slash character ('/'). =item * search_path_on_include If set to a true value the module will search from the top of the array of paths specified by the path option on every C<< <TMPL_INCLUDE> >> and use the first matching template found. The normal behavior is to look only in the current directory for a template to include. Defaults to 0. =item * utf8 Setting this to true tells HTML::Template to treat your template files as UTF-8 encoded. This will apply to any file's passed to C<new()> or any included files. It won't do anything special to scalars templates passed to C<new()> since you should be doing the encoding on those yourself. my $template = HTML::Template->new( filename => 'umlauts_are_awesome.tmpl', utf8 => 1, ); Most templates are either ASCII (the default) or UTF-8 encoded Unicode. But if you need some other encoding other than these 2, look at the C<open_mode> option. B<NOTE>: The C<utf8> and C<open_mode> options cannot be used at the same time. =item * open_mode You can set this option to an opening mode with which all template files will be opened. For example, if you want to use a template that is UTF-16 encoded unicode: my $template = HTML::Template->new( filename => 'file.tmpl', open_mode => '<:encoding(UTF-16)', ); That way you can force a different encoding (than the default ASCII or UTF-8), CR/LF properties etc. on the template files. See L<PerlIO> for details. B<NOTE>: this only works in perl 5.7.1 and above. B<NOTE>: you have to supply an opening mode that actually permits reading from the file handle. B<NOTE>: The C<utf8> and C<open_mode> options cannot be used at the same time. =back =head3 Debugging Options =over =item * debug If set to 1 the module will write random debugging information to STDERR. Defaults to 0. =item * stack_debug If set to 1 the module will use Data::Dumper to print out the contents of the parse_stack to STDERR. Defaults to 0. =item * cache_debug If set to 1 the module will send information on cache loads, hits and misses to STDERR. Defaults to 0. =item * shared_cache_debug If set to 1 the module will turn on the debug option in L<IPC::SharedCache>. Defaults to 0. =item * memory_debug If set to 1 the module will send information on cache memory usage to STDERR. Requires the L<GTop> module. Defaults to 0. =back =head3 Miscellaneous Options =over =item * associate This option allows you to inherit the parameter values from other objects. The only requirement for the other object is that it have a C<param()> method that works like HTML::Template's C<param()>. A good candidate would be a L<CGI> query object. Example: my $query = CGI->new; my $template = HTML::Template->new( filename => 'template.tmpl', associate => $query, ); Now, C<< $template->output() >> will act as though $template->param(form_field => $cgi->param('form_field')); had been specified for each key/value pair that would be provided by the C<< $cgi->param() >> method. Parameters you set directly take precedence over associated parameters. You can specify multiple objects to associate by passing an anonymous array to the associate option. They are searched for parameters in the order they appear: my $template = HTML::Template->new( filename => 'template.tmpl', associate => [$query, $other_obj], ); B<NOTE>: The parameter names are matched in a case-insensitive manner. If you have two parameters in a CGI object like 'NAME' and 'Name' one will be chosen randomly by associate. This behavior can be changed by the C<case_sensitive> option. =item * case_sensitive Setting this option to true causes HTML::Template to treat template variable names case-sensitively. The following example would only set one parameter without the C<case_sensitive> option: my $template = HTML::Template->new( filename => 'template.tmpl', case_sensitive => 1 ); $template->param( FieldA => 'foo', fIELDa => 'bar', ); This option defaults to off. B<NOTE>: with C<case_sensitive> and C<loop_context_vars> the special loop variables are available in lower-case only. =item * loop_context_vars When this parameter is set to true (it is false by default) extra variables that depend on the loop's context are made available inside a loop. These are: =over =item * __first__ Value that is true for the first iteration of the loop and false every other time. =item * __last__ Value that is true for the last iteration of the loop and false every other time. =item * __inner__ Value that is true for the every iteration of the loop except for the first and last. =item * __outer__ Value that is true for the first and last iterations of the loop. =item * __odd__ Value that is true for the every odd iteration of the loop. =item * __even__ Value that is true for the every even iteration of the loop. =item * __counter__ An integer (starting from 1) whose value increments for each iteration of the loop. =item * __index__ An integer (starting from 0) whose value increments for each iteration of the loop. =back Just like any other C<TMPL_VAR>s these variables can be used in C<< <TMPL_IF> >>, C<< <TMPL_UNLESS> >> and C<< <TMPL_ELSE> >> to control how a loop is output. Example: <TMPL_LOOP NAME="FOO"> <TMPL_IF NAME="__first__"> This only outputs on the first pass. </TMPL_IF> <TMPL_IF NAME="__odd__"> This outputs every other pass, on the odd passes. </TMPL_IF> <TMPL_UNLESS NAME="__odd__"> This outputs every other pass, on the even passes. </TMPL_UNLESS> <TMPL_IF NAME="__inner__"> This outputs on passes that are neither first nor last. </TMPL_IF> This is pass number <TMPL_VAR NAME="__counter__">. <TMPL_IF NAME="__last__"> This only outputs on the last pass. </TMPL_IF> </TMPL_LOOP> One use of this feature is to provide a "separator" similar in effect to the perl function C<join()>. Example: <TMPL_LOOP FRUIT> <TMPL_IF __last__> and </TMPL_IF> <TMPL_VAR KIND><TMPL_UNLESS __last__>, <TMPL_ELSE>.</TMPL_UNLESS> </TMPL_LOOP> Would output something like: Apples, Oranges, Brains, Toes, and Kiwi. Given an appropriate C<param()> call, of course. B<NOTE>: A loop with only a single pass will get both C<__first__> and C<__last__> set to true, but not C<__inner__>. =item * no_includes Set this option to 1 to disallow the C<< <TMPL_INCLUDE> >> tag in the template file. This can be used to make opening untrusted templates B<slightly> less dangerous. Defaults to 0. =item * max_includes Set this variable to determine the maximum depth that includes can reach. Set to 10 by default. Including files to a depth greater than this value causes an error message to be displayed. Set to 0 to disable this protection. =item * die_on_missing_include If true, then HTML::Template will die if it can't find a file for a C<< <TMPL_INCLUDE> >>. This defaults to true. =item * global_vars Normally variables declared outside a loop are not available inside a loop. This option makes C<< <TMPL_VAR> >>s like global variables in Perl - they have unlimited scope. This option also affects C<< <TMPL_IF> >> and C<< <TMPL_UNLESS> >>. Example: This is a normal variable: <TMPL_VAR NORMAL>.<P> <TMPL_LOOP NAME=FROOT_LOOP> Here it is inside the loop: <TMPL_VAR NORMAL><P> </TMPL_LOOP> Normally this wouldn't work as expected, since C<< <TMPL_VAR NORMAL> >>'s value outside the loop is not available inside the loop. The global_vars option also allows you to access the values of an enclosing loop within an inner loop. For example, in this loop the inner loop will have access to the value of C<OUTER_VAR> in the correct iteration: <TMPL_LOOP OUTER_LOOP> OUTER: <TMPL_VAR OUTER_VAR> <TMPL_LOOP INNER_LOOP> INNER: <TMPL_VAR INNER_VAR> INSIDE OUT: <TMPL_VAR OUTER_VAR> </TMPL_LOOP> </TMPL_LOOP> One side-effect of C<global_vars> is that variables you set with C<param()> that might otherwise be ignored when C<die_on_bad_params> is off will stick around. This is necessary to allow inner loops to access values set for outer loops that don't directly use the value. B<NOTE>: C<global_vars> is not C<global_loops> (which does not exist). That means that loops you declare at one scope are not available inside other loops even when C<global_vars> is on. =item * filter This option allows you to specify a filter for your template files. A filter is a subroutine that will be called after HTML::Template reads your template file but before it starts parsing template tags. In the most simple usage, you simply assign a code reference to the filter parameter. This subroutine will receive a single argument - a reference to a string containing the template file text. Here is an example that accepts templates with tags that look like C<!!!ZAP_VAR FOO!!!> and transforms them into HTML::Template tags: my $filter = sub { my $text_ref = shift; $$text_ref =~ s/!!!ZAP_(.*?)!!!/<TMPL_$1>/g; }; # open zap.tmpl using the above filter my $template = HTML::Template->new( filename => 'zap.tmpl', filter => $filter, ); More complicated usages are possible. You can request that your filter receives the template text as an array of lines rather than as a single scalar. To do that you need to specify your filter using a hash-ref. In this form you specify the filter using the C<sub> key and the desired argument format using the C<format> key. The available formats are C<scalar> and C<array>. Using the C<array> format will incur a performance penalty but may be more convenient in some situations. my $template = HTML::Template->new( filename => 'zap.tmpl', filter => { sub => $filter, format => 'array', } ); You may also have multiple filters. This allows simple filters to be combined for more elaborate functionality. To do this you specify an array of filters. The filters are applied in the order they are specified. my $template = HTML::Template->new( filename => 'zap.tmpl', filter => [ { sub => \&decompress, format => 'scalar', }, { sub => \&remove_spaces, format => 'array', }, ] ); The specified filters will be called for any C<TMPL_INCLUDE>ed files just as they are for the main template file. =item * default_escape Set this parameter to a valid escape type (see the C<escape> option) and HTML::Template will apply the specified escaping to all variables unless they declare a different escape in the template. =back =cut use integer; # no floating point math so far! use strict; # and no funny business, either. use Carp; # generate better errors with more context use File::Spec; # generate paths that work on all platforms use Digest::MD5 qw(md5_hex); # generate cache keys use Scalar::Util qw(tainted); # define accessor constants used to improve readability of array # accesses into "objects". I used to use 'use constant' but that # seems to cause occasional irritating warnings in older Perls. package HTML::Template::LOOP; sub TEMPLATE_HASH () { 0 } sub PARAM_SET () { 1 } package HTML::Template::COND; sub VARIABLE () { 0 } sub VARIABLE_TYPE () { 1 } sub VARIABLE_TYPE_VAR () { 0 } sub VARIABLE_TYPE_LOOP () { 1 } sub JUMP_IF_TRUE () { 2 } sub JUMP_ADDRESS () { 3 } sub WHICH () { 4 } sub UNCONDITIONAL_JUMP () { 5 } sub IS_ELSE () { 6 } sub WHICH_IF () { 0 } sub WHICH_UNLESS () { 1 } # back to the main package scope. package HTML::Template; my %OPTIONS; # set the default options BEGIN { %OPTIONS = ( debug => 0, stack_debug => 0, timing => 0, search_path_on_include => 0, cache => 0, blind_cache => 0, file_cache => 0, file_cache_dir => '', file_cache_dir_mode => 0700, force_untaint => 0, cache_debug => 0, shared_cache_debug => 0, memory_debug => 0, die_on_bad_params => 1, vanguard_compatibility_mode => 0, associate => [], path => [], strict => 1, loop_context_vars => 0, max_includes => 10, shared_cache => 0, double_cache => 0, double_file_cache => 0, ipc_key => 'TMPL', ipc_mode => 0666, ipc_segment_size => 65536, ipc_max_size => 0, global_vars => 0, no_includes => 0, case_sensitive => 0, filter => [], open_mode => '', utf8 => 0, cache_lazy_vars => 0, cache_lazy_loops => 0, die_on_missing_include => 1, ); } # open a new template and return an object handle sub new { my $pkg = shift; my $self; { my %hash; $self = bless(\%hash, $pkg); } # the options hash my $options = {}; $self->{options} = $options; # set default parameters in options hash %$options = %OPTIONS; # load in options supplied to new() $options = _load_supplied_options([@_], $options); # blind_cache = 1 implies cache = 1 $options->{blind_cache} and $options->{cache} = 1; # shared_cache = 1 implies cache = 1 $options->{shared_cache} and $options->{cache} = 1; # file_cache = 1 implies cache = 1 $options->{file_cache} and $options->{cache} = 1; # double_cache is a combination of shared_cache and cache. $options->{double_cache} and $options->{cache} = 1; $options->{double_cache} and $options->{shared_cache} = 1; # double_file_cache is a combination of file_cache and cache. $options->{double_file_cache} and $options->{cache} = 1; $options->{double_file_cache} and $options->{file_cache} = 1; # vanguard_compatibility_mode implies die_on_bad_params = 0 $options->{vanguard_compatibility_mode} and $options->{die_on_bad_params} = 0; # handle the "type", "source" parameter format (does anyone use it?) if (exists($options->{type})) { exists($options->{source}) or croak("HTML::Template->new() called with 'type' parameter set, but no 'source'!"); ( $options->{type} eq 'filename' or $options->{type} eq 'scalarref' or $options->{type} eq 'arrayref' or $options->{type} eq 'filehandle' ) or croak("HTML::Template->new() : type parameter must be set to 'filename', 'arrayref', 'scalarref' or 'filehandle'!"); $options->{$options->{type}} = $options->{source}; delete $options->{type}; delete $options->{source}; } # make sure taint mode is on if force_untaint flag is set if ($options->{force_untaint}) { if ($] < 5.008000) { warn("HTML::Template->new() : 'force_untaint' option needs at least Perl 5.8.0!"); } elsif (!${^TAINT}) { croak("HTML::Template->new() : 'force_untaint' option set but perl does not run in taint mode!"); } } # associate should be an array of one element if it's not # already an array. if (ref($options->{associate}) ne 'ARRAY') { $options->{associate} = [$options->{associate}]; } # path should be an array if it's not already if (ref($options->{path}) ne 'ARRAY') { $options->{path} = [$options->{path}]; } # filter should be an array if it's not already if (ref($options->{filter}) ne 'ARRAY') { $options->{filter} = [$options->{filter}]; } # make sure objects in associate area support param() foreach my $object (@{$options->{associate}}) { defined($object->can('param')) or croak("HTML::Template->new called with associate option, containing object of type " . ref($object) . " which lacks a param() method!"); } # check for syntax errors: my $source_count = 0; exists($options->{filename}) and $source_count++; exists($options->{filehandle}) and $source_count++; exists($options->{arrayref}) and $source_count++; exists($options->{scalarref}) and $source_count++; if ($source_count != 1) { croak( "HTML::Template->new called with multiple (or no) template sources specified! A valid call to new() has exactly one filename => 'file' OR exactly one scalarref => \\\$scalar OR exactly one arrayref => \\\@array OR exactly one filehandle => \*FH" ); } # check that cache options are not used with non-cacheable templates croak "Cannot have caching when template source is not file" if grep { exists($options->{$_}) } qw( filehandle arrayref scalarref) and grep { $options->{$_} } qw( cache blind_cache file_cache shared_cache double_cache double_file_cache ); # check that filenames aren't empty if (exists($options->{filename})) { croak("HTML::Template->new called with empty filename parameter!") unless length $options->{filename}; } # do some memory debugging - this is best started as early as possible if ($options->{memory_debug}) { # memory_debug needs GTop eval { require GTop; }; croak("Could not load GTop. You must have GTop installed to use HTML::Template in memory_debug mode. The error was: $@") if ($@); $self->{gtop} = GTop->new(); $self->{proc_mem} = $self->{gtop}->proc_mem($$); print STDERR "\n### HTML::Template Memory Debug ### START ", $self->{proc_mem}->size(), "\n"; } if ($options->{file_cache}) { # make sure we have a file_cache_dir option croak("You must specify the file_cache_dir option if you want to use file_cache.") unless length $options->{file_cache_dir}; # file_cache needs some extra modules loaded eval { require Storable; }; croak( "Could not load Storable. You must have Storable installed to use HTML::Template in file_cache mode. The error was: $@" ) if ($@); } if ($options->{shared_cache}) { # shared_cache needs some extra modules loaded eval { require IPC::SharedCache; }; croak( "Could not load IPC::SharedCache. You must have IPC::SharedCache installed to use HTML::Template in shared_cache mode. The error was: $@" ) if ($@); # initialize the shared cache my %cache; tie %cache, 'IPC::SharedCache', ipc_key => $options->{ipc_key}, load_callback => [\&_load_shared_cache, $self], validate_callback => [\&_validate_shared_cache, $self], debug => $options->{shared_cache_debug}, ipc_mode => $options->{ipc_mode}, max_size => $options->{ipc_max_size}, ipc_segment_size => $options->{ipc_segment_size}; $self->{cache} = \%cache; } if ($options->{default_escape}) { $options->{default_escape} = uc $options->{default_escape}; unless ($options->{default_escape} =~ /^(NONE|HTML|URL|JS)$/i) { croak( "HTML::Template->new(): Invalid setting for default_escape - '$options->{default_escape}'. Valid values are 'none', 'html', 'url', or 'js'." ); } } # no 3 args form of open before perl 5.7.1 if ($options->{open_mode} && $] < 5.007001) { croak("HTML::Template->new(): open_mode cannot be used in Perl < 5.7.1"); } if($options->{utf8}) { croak("HTML::Template->new(): utf8 cannot be used in Perl < 5.7.1") if $] < 5.007001; croak("HTML::Template->new(): utf8 and open_mode cannot be used at the same time") if $options->{open_mode}; # utf8 is just a short-cut for a common open_mode $options->{open_mode} = '<:encoding(utf8)'; } print STDERR "### HTML::Template Memory Debug ### POST CACHE INIT ", $self->{proc_mem}->size(), "\n" if $options->{memory_debug}; # initialize data structures $self->_init; print STDERR "### HTML::Template Memory Debug ### POST _INIT CALL ", $self->{proc_mem}->size(), "\n" if $options->{memory_debug}; # drop the shared cache - leaving out this step results in the # template object evading garbage collection since the callbacks in # the shared cache tie hold references to $self! This was not easy # to find, by the way. delete $self->{cache} if $options->{shared_cache}; return $self; } sub _load_supplied_options { my $argsref = shift; my $options = shift; for (my $x = 0 ; $x < @{$argsref} ; $x += 2) { defined(${$argsref}[($x + 1)]) or croak("HTML::Template->new() called with odd number of option parameters - should be of the form option => value"); $options->{lc(${$argsref}[$x])} = ${$argsref}[($x + 1)]; } return $options; } # an internally used new that receives its parse_stack and param_map as input sub _new_from_loop { my $pkg = shift; my $self; { my %hash; $self = bless(\%hash, $pkg); } # the options hash my $options = { debug => $OPTIONS{debug}, stack_debug => $OPTIONS{stack_debug}, die_on_bad_params => $OPTIONS{die_on_bad_params}, associate => [@{$OPTIONS{associate}}], loop_context_vars => $OPTIONS{loop_context_vars}, }; $self->{options} = $options; $options = _load_supplied_options([@_], $options); $self->{param_map} = $options->{param_map}; $self->{parse_stack} = $options->{parse_stack}; delete($options->{param_map}); delete($options->{parse_stack}); return $self; } # a few shortcuts to new(), of possible use... sub new_file { my $pkg = shift; return $pkg->new('filename', @_); } sub new_filehandle { my $pkg = shift; return $pkg->new('filehandle', @_); } sub new_array_ref { my $pkg = shift; return $pkg->new('arrayref', @_); } sub new_scalar_ref { my $pkg = shift; return $pkg->new('scalarref', @_); } # initializes all the object data structures, either from cache or by # calling the appropriate routines. sub _init { my $self = shift; my $options = $self->{options}; if ($options->{double_cache}) { # try the normal cache, return if we have it. $self->_fetch_from_cache(); return if (defined $self->{param_map} and defined $self->{parse_stack}); # try the shared cache $self->_fetch_from_shared_cache(); # put it in the local cache if we got it. $self->_commit_to_cache() if (defined $self->{param_map} and defined $self->{parse_stack}); } elsif ($options->{double_file_cache}) { # try the normal cache, return if we have it. $self->_fetch_from_cache(); return if (defined $self->{param_map}); # try the file cache $self->_fetch_from_file_cache(); # put it in the local cache if we got it. $self->_commit_to_cache() if (defined $self->{param_map}); } elsif ($options->{shared_cache}) { # try the shared cache $self->_fetch_from_shared_cache(); } elsif ($options->{file_cache}) { # try the file cache $self->_fetch_from_file_cache(); } elsif ($options->{cache}) { # try the normal cache $self->_fetch_from_cache(); } # if we got a cache hit, return return if (defined $self->{param_map}); # if we're here, then we didn't get a cached copy, so do a full # init. $self->_init_template(); $self->_parse(); # now that we have a full init, cache the structures if caching is # on. shared cache is already cool. if ($options->{file_cache}) { $self->_commit_to_file_cache(); } $self->_commit_to_cache() if ( ($options->{cache} and not $options->{shared_cache} and not $options->{file_cache}) or ($options->{double_cache}) or ($options->{double_file_cache})); } # Caching subroutines - they handle getting and validating cache # records from either the in-memory or shared caches. # handles the normal in memory cache use vars qw( %CACHE ); sub _fetch_from_cache { my $self = shift; my $options = $self->{options}; # return if there's no file here my $filepath = $self->_find_file($options->{filename}); return unless (defined($filepath)); $options->{filepath} = $filepath; # return if there's no cache entry for this key my $key = $self->_cache_key(); return unless exists($CACHE{$key}); # validate the cache my $mtime = $self->_mtime($filepath); if (defined $mtime) { # return if the mtime doesn't match the cache if (defined($CACHE{$key}{mtime}) and ($mtime != $CACHE{$key}{mtime})) { $options->{cache_debug} and print STDERR "CACHE MISS : $filepath : $mtime\n"; return; } # if the template has includes, check each included file's mtime # and return if different if (exists($CACHE{$key}{included_mtimes})) { foreach my $filename (keys %{$CACHE{$key}{included_mtimes}}) { next unless defined($CACHE{$key}{included_mtimes}{$filename}); my $included_mtime = (stat($filename))[9]; if ($included_mtime != $CACHE{$key}{included_mtimes}{$filename}) { $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE MISS : $filepath : INCLUDE $filename : $included_mtime\n"; return; } } } } # got a cache hit! $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE HIT : $filepath => $key\n"; $self->{param_map} = $CACHE{$key}{param_map}; $self->{parse_stack} = $CACHE{$key}{parse_stack}; exists($CACHE{$key}{included_mtimes}) and $self->{included_mtimes} = $CACHE{$key}{included_mtimes}; # clear out values from param_map from last run $self->_normalize_options(); $self->clear_params(); } sub _commit_to_cache { my $self = shift; my $options = $self->{options}; my $key = $self->_cache_key(); my $filepath = $options->{filepath}; $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE LOAD : $filepath => $key\n"; $options->{blind_cache} or $CACHE{$key}{mtime} = $self->_mtime($filepath); $CACHE{$key}{param_map} = $self->{param_map}; $CACHE{$key}{parse_stack} = $self->{parse_stack}; exists($self->{included_mtimes}) and $CACHE{$key}{included_mtimes} = $self->{included_mtimes}; } # create a cache key from a template object. The cache key includes # the full path to the template and options which affect template # loading. sub _cache_key { my $self = shift; my $options = $self->{options}; # assemble pieces of the key my @key = ($options->{filepath}); push(@key, @{$options->{path}}); push(@key, $options->{search_path_on_include} || 0); push(@key, $options->{loop_context_vars} || 0); push(@key, $options->{global_vars} || 0); push(@key, $options->{open_mode} || 0); # compute the md5 and return it return md5_hex(@key); } # generates MD5 from filepath to determine filename for cache file sub _get_cache_filename { my ($self, $filepath) = @_; # get a cache key $self->{options}{filepath} = $filepath; my $hash = $self->_cache_key(); # ... and build a path out of it. Using the first two characters # gives us 255 buckets. This means you can have 255,000 templates # in the cache before any one directory gets over a few thousand # files in it. That's probably pretty good for this planet. If not # then it should be configurable. if (wantarray) { return (substr($hash, 0, 2), substr($hash, 2)); } else { return File::Spec->join($self->{options}{file_cache_dir}, substr($hash, 0, 2), substr($hash, 2)); } } # handles the file cache sub _fetch_from_file_cache { my $self = shift; my $options = $self->{options}; # return if there's no cache entry for this filename my $filepath = $self->_find_file($options->{filename}); return unless defined $filepath; my $cache_filename = $self->_get_cache_filename($filepath); return unless -e $cache_filename; eval { $self->{record} = Storable::lock_retrieve($cache_filename); }; croak("HTML::Template::new() - Problem reading cache file $cache_filename (file_cache => 1) : $@") if $@; croak("HTML::Template::new() - Problem reading cache file $cache_filename (file_cache => 1) : $!") unless defined $self->{record}; ($self->{mtime}, $self->{included_mtimes}, $self->{param_map}, $self->{parse_stack}) = @{$self->{record}}; $options->{filepath} = $filepath; # validate the cache my $mtime = $self->_mtime($filepath); if (defined $mtime) { # return if the mtime doesn't match the cache if (defined($self->{mtime}) and ($mtime != $self->{mtime})) { $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE MISS : $filepath : $mtime\n"; ($self->{mtime}, $self->{included_mtimes}, $self->{param_map}, $self->{parse_stack}) = (undef, undef, undef, undef); return; } # if the template has includes, check each included file's mtime # and return if different if (exists($self->{included_mtimes})) { foreach my $filename (keys %{$self->{included_mtimes}}) { next unless defined($self->{included_mtimes}{$filename}); my $included_mtime = (stat($filename))[9]; if ($included_mtime != $self->{included_mtimes}{$filename}) { $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE MISS : $filepath : INCLUDE $filename : $included_mtime\n"; ($self->{mtime}, $self->{included_mtimes}, $self->{param_map}, $self->{parse_stack}) = (undef, undef, undef, undef); return; } } } } # got a cache hit! $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE HIT : $filepath\n"; # clear out values from param_map from last run $self->_normalize_options(); $self->clear_params(); } sub _commit_to_file_cache { my $self = shift; my $options = $self->{options}; my $filepath = $options->{filepath}; if (not defined $filepath) { $filepath = $self->_find_file($options->{filename}); confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.") unless defined($filepath); $options->{filepath} = $filepath; } my ($cache_dir, $cache_file) = $self->_get_cache_filename($filepath); $cache_dir = File::Spec->join($options->{file_cache_dir}, $cache_dir); if (not -d $cache_dir) { if (not -d $options->{file_cache_dir}) { mkdir($options->{file_cache_dir}, $options->{file_cache_dir_mode}) or croak("HTML::Template->new() : can't mkdir $options->{file_cache_dir} (file_cache => 1): $!"); } mkdir($cache_dir, $options->{file_cache_dir_mode}) or croak("HTML::Template->new() : can't mkdir $cache_dir (file_cache => 1): $!"); } $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE LOAD : $options->{filepath}\n"; my $result; eval { $result = Storable::lock_store([$self->{mtime}, $self->{included_mtimes}, $self->{param_map}, $self->{parse_stack}], scalar File::Spec->join($cache_dir, $cache_file)); }; croak("HTML::Template::new() - Problem writing cache file $cache_dir/$cache_file (file_cache => 1) : $@") if $@; croak("HTML::Template::new() - Problem writing cache file $cache_dir/$cache_file (file_cache => 1) : $!") unless defined $result; } # Shared cache routines. sub _fetch_from_shared_cache { my $self = shift; my $options = $self->{options}; my $filepath = $self->_find_file($options->{filename}); return unless defined $filepath; # fetch from the shared cache. $self->{record} = $self->{cache}{$filepath}; ($self->{mtime}, $self->{included_mtimes}, $self->{param_map}, $self->{parse_stack}) = @{$self->{record}} if defined($self->{record}); $options->{cache_debug} and defined($self->{record}) and print STDERR "### HTML::Template Cache Debug ### CACHE HIT : $filepath\n"; # clear out values from param_map from last run $self->_normalize_options(), $self->clear_params() if (defined($self->{record})); delete($self->{record}); return $self; } sub _validate_shared_cache { my ($self, $filename, $record) = @_; my $options = $self->{options}; $options->{shared_cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE VALIDATE : $filename\n"; return 1 if $options->{blind_cache}; my ($c_mtime, $included_mtimes, $param_map, $parse_stack) = @$record; # if the modification time has changed return false my $mtime = $self->_mtime($filename); if ( defined $mtime and defined $c_mtime and $mtime != $c_mtime) { $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE MISS : $filename : $mtime\n"; return 0; } # if the template has includes, check each included file's mtime # and return false if different if (defined $mtime and defined $included_mtimes) { foreach my $fname (keys %$included_mtimes) { next unless defined($included_mtimes->{$fname}); if ($included_mtimes->{$fname} != (stat($fname))[9]) { $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE MISS : $filename : INCLUDE $fname\n"; return 0; } } } # all done - return true return 1; } sub _load_shared_cache { my ($self, $filename) = @_; my $options = $self->{options}; my $cache = $self->{cache}; $self->_init_template(); $self->_parse(); $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE LOAD : $options->{filepath}\n"; print STDERR "### HTML::Template Memory Debug ### END CACHE LOAD ", $self->{proc_mem}->size(), "\n" if $options->{memory_debug}; return [$self->{mtime}, $self->{included_mtimes}, $self->{param_map}, $self->{parse_stack}]; } # utility function - given a filename performs documented search and # returns a full path or undef if the file cannot be found. sub _find_file { my ($self, $filename, $extra_path) = @_; my $options = $self->{options}; my $filepath; # first check for a full path return File::Spec->canonpath($filename) if (File::Spec->file_name_is_absolute($filename) and (-e $filename)); # try the extra_path if one was specified if (defined($extra_path)) { $extra_path->[$#{$extra_path}] = $filename; $filepath = File::Spec->canonpath(File::Spec->catfile(@$extra_path)); return File::Spec->canonpath($filepath) if -e $filepath; } # try pre-prending HTML_Template_Root if (defined($ENV{HTML_TEMPLATE_ROOT})) { $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $filename); return File::Spec->canonpath($filepath) if -e $filepath; } # try "path" option list.. foreach my $path (@{$options->{path}}) { $filepath = File::Spec->catfile($path, $filename); return File::Spec->canonpath($filepath) if -e $filepath; } # try even a relative path from the current directory... return File::Spec->canonpath($filename) if -e $filename; # try "path" option list with HTML_TEMPLATE_ROOT prepended... if (defined($ENV{HTML_TEMPLATE_ROOT})) { foreach my $path (@{$options->{path}}) { $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $path, $filename); return File::Spec->canonpath($filepath) if -e $filepath; } } return undef; } # utility function - computes the mtime for $filename sub _mtime { my ($self, $filepath) = @_; my $options = $self->{options}; return (undef) if ($options->{blind_cache}); # make sure it still exists in the filesystem (-r $filepath) or Carp::confess("HTML::Template : template file $filepath does not exist or is unreadable."); # get the modification time return (stat(_))[9]; } # utility function - enforces new() options across LOOPs that have # come from a cache. Otherwise they would have stale options hashes. sub _normalize_options { my $self = shift; my $options = $self->{options}; my @pstacks = ($self->{parse_stack}); while (@pstacks) { my $pstack = pop(@pstacks); foreach my $item (@$pstack) { next unless (ref($item) eq 'HTML::Template::LOOP'); foreach my $template (values %{$item->[HTML::Template::LOOP::TEMPLATE_HASH]}) { # must be the same list as the call to _new_from_loop... $template->{options}{debug} = $options->{debug}; $template->{options}{stack_debug} = $options->{stack_debug}; $template->{options}{die_on_bad_params} = $options->{die_on_bad_params}; $template->{options}{case_sensitive} = $options->{case_sensitive}; $template->{options}{parent_global_vars} = $options->{parent_global_vars}; push(@pstacks, $template->{parse_stack}); } } } } # initialize the template buffer sub _init_template { my $self = shift; my $options = $self->{options}; print STDERR "### HTML::Template Memory Debug ### START INIT_TEMPLATE ", $self->{proc_mem}->size(), "\n" if $options->{memory_debug}; if (exists($options->{filename})) { my $filepath = $options->{filepath}; if (not defined $filepath) { $filepath = $self->_find_file($options->{filename}); confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.") unless defined($filepath); # we'll need this for future reference - to call stat() for example. $options->{filepath} = $filepath; } # use the open_mode if we have one if (my $mode = $options->{open_mode}) { open(TEMPLATE, $mode, $filepath) || confess("HTML::Template->new() : Cannot open included file $filepath with mode $mode: $!"); } else { open(TEMPLATE, $filepath) or confess("HTML::Template->new() : Cannot open included file $filepath : $!"); } $self->{mtime} = $self->_mtime($filepath); # read into scalar, note the mtime for the record $self->{template} = ""; while (read(TEMPLATE, $self->{template}, 10240, length($self->{template}))) { } close(TEMPLATE); } elsif (exists($options->{scalarref})) { # copy in the template text $self->{template} = ${$options->{scalarref}}; delete($options->{scalarref}); } elsif (exists($options->{arrayref})) { # if we have an array ref, join and store the template text $self->{template} = join("", @{$options->{arrayref}}); delete($options->{arrayref}); } elsif (exists($options->{filehandle})) { # just read everything in in one go local $/ = undef; $self->{template} = readline($options->{filehandle}); delete($options->{filehandle}); } else { confess("HTML::Template : Need to call new with filename, filehandle, scalarref or arrayref parameter specified."); } print STDERR "### HTML::Template Memory Debug ### END INIT_TEMPLATE ", $self->{proc_mem}->size(), "\n" if $options->{memory_debug}; # handle filters if necessary $self->_call_filters(\$self->{template}) if @{$options->{filter}}; return $self; } # handle calling user defined filters sub _call_filters { my $self = shift; my $template_ref = shift; my $options = $self->{options}; my ($format, $sub); foreach my $filter (@{$options->{filter}}) { croak("HTML::Template->new() : bad value set for filter parameter - must be a code ref or a hash ref.") unless ref $filter; # translate into CODE->HASH $filter = {'format' => 'scalar', 'sub' => $filter} if (ref $filter eq 'CODE'); if (ref $filter eq 'HASH') { $format = $filter->{'format'}; $sub = $filter->{'sub'}; # check types and values croak( "HTML::Template->new() : bad value set for filter parameter - hash must contain \"format\" key and \"sub\" key.") unless defined $format and defined $sub; croak("HTML::Template->new() : bad value set for filter parameter - \"format\" must be either 'array' or 'scalar'") unless $format eq 'array' or $format eq 'scalar'; croak("HTML::Template->new() : bad value set for filter parameter - \"sub\" must be a code ref") unless ref $sub and ref $sub eq 'CODE'; # catch errors eval { if ($format eq 'scalar') { # call $sub->($template_ref); } else { # modulate my @array = map { $_ . "\n" } split("\n", $$template_ref); # call $sub->(\@array); # demodulate $$template_ref = join("", @array); } }; croak("HTML::Template->new() : fatal error occurred during filter call: $@") if $@; } else { croak("HTML::Template->new() : bad value set for filter parameter - must be code ref or hash ref"); } } # all done return $template_ref; } # _parse sifts through a template building up the param_map and # parse_stack structures. # # The end result is a Template object that is fully ready for # output(). sub _parse { my $self = shift; my $options = $self->{options}; $options->{debug} and print STDERR "### HTML::Template Debug ### In _parse:\n"; # setup the stacks and maps - they're accessed by typeglobs that # reference the top of the stack. They are masked so that a loop # can transparently have its own versions. use vars qw(@pstack %pmap @ifstack @ucstack %top_pmap); local (*pstack, *ifstack, *pmap, *ucstack, *top_pmap); # the pstack is the array of scalar refs (plain text from the # template file), VARs, LOOPs, IFs and ELSEs that output() works on # to produce output. Looking at output() should make it clear what # _parse is trying to accomplish. my @pstacks = ([]); *pstack = $pstacks[0]; $self->{parse_stack} = $pstacks[0]; # the pmap binds names to VARs, LOOPs and IFs. It allows param() to # access the right variable. NOTE: output() does not look at the # pmap at all! my @pmaps = ({}); *pmap = $pmaps[0]; *top_pmap = $pmaps[0]; $self->{param_map} = $pmaps[0]; # the ifstack is a temporary stack containing pending ifs and elses # waiting for a /if. my @ifstacks = ([]); *ifstack = $ifstacks[0]; # the ucstack is a temporary stack containing conditions that need # to be bound to param_map entries when their block is finished. # This happens when a conditional is encountered before any other # reference to its NAME. Since a conditional can reference VARs and # LOOPs it isn't possible to make the link right away. my @ucstacks = ([]); *ucstack = $ucstacks[0]; # the loopstack is another temp stack for closing loops. unlike # those above it doesn't get scoped inside loops, therefore it # doesn't need the typeglob magic. my @loopstack = (); # the fstack is a stack of filenames and counters that keeps track # of which file we're in and where we are in it. This allows # accurate error messages even inside included files! # fcounter, fmax and fname are aliases for the current file's info use vars qw($fcounter $fname $fmax); local (*fcounter, *fname, *fmax); my @fstack = ([$options->{filepath} || "/fake/path/for/non/file/template", 1, scalar @{[$self->{template} =~ m/(\n)/g]} + 1]); (*fname, *fcounter, *fmax) = \(@{$fstack[0]}); my $NOOP = HTML::Template::NOOP->new(); my $ESCAPE = HTML::Template::ESCAPE->new(); my $JSESCAPE = HTML::Template::JSESCAPE->new(); my $URLESCAPE = HTML::Template::URLESCAPE->new(); # all the tags that need NAMEs: my %need_names = map { $_ => 1 } qw(TMPL_VAR TMPL_LOOP TMPL_IF TMPL_UNLESS TMPL_INCLUDE); # variables used below that don't need to be my'd in the loop my ($name, $which, $escape, $default); # handle the old vanguard format $options->{vanguard_compatibility_mode} and $self->{template} =~ s/%([-\w\/\.+]+)%/<TMPL_VAR NAME=$1>/g; # now split up template on '<', leaving them in my @chunks = split(m/(?=<)/, $self->{template}); # all done with template delete $self->{template}; # loop through chunks, filling up pstack my $last_chunk = $#chunks; CHUNK: for (my $chunk_number = 0 ; $chunk_number <= $last_chunk ; $chunk_number++) { next unless defined $chunks[$chunk_number]; my $chunk = $chunks[$chunk_number]; # a general regex to match any and all TMPL_* tags if ( $chunk =~ /^< (?:!--\s*)? ( \/?tmpl_ (?: (?:var) | (?:loop) | (?:if) | (?:else) | (?:unless) | (?:include) ) ) # $1 => $which - start of the tag \s* # DEFAULT attribute (?: default \s*=\s* (?: "([^">]*)" # $2 => double-quoted DEFAULT value " | '([^'>]*)' # $3 => single-quoted DEFAULT value | ([^\s=>]*) # $4 => unquoted DEFAULT value ) )? \s* # ESCAPE attribute (?: escape \s*=\s* (?: ( (?:["']?0["']?)| (?:["']?1["']?)| (?:["']?html["']?) | (?:["']?url["']?) | (?:["']?js["']?) | (?:["']?none["']?) ) # $5 => ESCAPE on ) )* # allow multiple ESCAPEs \s* # DEFAULT attribute (?: default \s*=\s* (?: "([^">]*)" # $6 => double-quoted DEFAULT value " | '([^'>]*)' # $7 => single-quoted DEFAULT value | ([^\s=>]*) # $8 => unquoted DEFAULT value ) )? \s* # NAME attribute (?: (?: name \s*=\s*)? (?: "([^">]*)" # $9 => double-quoted NAME value " | '([^'>]*)' # $10 => single-quoted NAME value | ([^\s=>]*) # $11 => unquoted NAME value ) )? \s* # DEFAULT attribute (?: default \s*=\s* (?: "([^">]*)" # $12 => double-quoted DEFAULT value " | '([^'>]*)' # $13 => single-quoted DEFAULT value | ([^\s=>]*) # $14 => unquoted DEFAULT value ) )? \s* # ESCAPE attribute (?: escape \s*=\s* (?: ( (?:["']?0["']?)| (?:["']?1["']?)| (?:["']?html["']?) | (?:["']?url["']?) | (?:["']?js["']?) | (?:["']?none["']?) ) # $15 => ESCAPE on ) )* # allow multiple ESCAPEs \s* # DEFAULT attribute (?: default \s*=\s* (?: "([^">]*)" # $16 => double-quoted DEFAULT value " | '([^'>]*)' # $17 => single-quoted DEFAULT value | ([^\s=>]*) # $18 => unquoted DEFAULT value ) )? \s* (?:--)?\/?> (.*) # $19 => $post - text that comes after the tag $/isx ) { $which = uc($1); # which tag is it $escape = defined $5 ? $5 : defined $15 ? $15 : (defined $options->{default_escape} && $which eq 'TMPL_VAR') ? $options->{default_escape} : 0; # escape set? # what name for the tag? undef for a /tag at most, one of the # following three will be defined $name = defined $9 ? $9 : defined $10 ? $10 : defined $11 ? $11 : undef; # is there a default? $default = defined $2 ? $2 : defined $3 ? $3 : defined $4 ? $4 : defined $6 ? $6 : defined $7 ? $7 : defined $8 ? $8 : defined $12 ? $12 : defined $13 ? $13 : defined $14 ? $14 : defined $16 ? $16 : defined $17 ? $17 : defined $18 ? $18 : undef; my $post = $19; # what comes after on the line # allow mixed case in filenames, otherwise flatten $name = lc($name) unless (not defined $name or $which eq 'TMPL_INCLUDE' or $options->{case_sensitive}); # die if we need a name and didn't get one die "HTML::Template->new() : No NAME given to a $which tag at $fname : line $fcounter." if ($need_names{$which} and (not defined $name or not length $name)); # die if we got an escape but can't use one die "HTML::Template->new() : ESCAPE option invalid in a $which tag at $fname : line $fcounter." if ($escape and ($which ne 'TMPL_VAR')); # die if we got a default but can't use one die "HTML::Template->new() : DEFAULT option invalid in a $which tag at $fname : line $fcounter." if (defined $default and ($which ne 'TMPL_VAR')); # take actions depending on which tag found if ($which eq 'TMPL_VAR') { print STDERR "### HTML::Template Debug ### $fname : line $fcounter : parsed VAR $name\n" if $options->{debug}; # if we already have this var, then simply link to the existing # HTML::Template::VAR, else create a new one. my $var; if (exists $pmap{$name}) { $var = $pmap{$name}; if( $options->{die_on_bad_params} && ref($var) ne 'HTML::Template::VAR') { die "HTML::Template->new() : Already used param name $name as a TMPL_LOOP, found in a TMPL_VAR at $fname : line $fcounter."; } } else { $var = HTML::Template::VAR->new(); $pmap{$name} = $var; $top_pmap{$name} = HTML::Template::VAR->new() if $options->{global_vars} and not exists $top_pmap{$name}; } # if a DEFAULT was provided, push a DEFAULT object on the # stack before the variable. if (defined $default) { push(@pstack, HTML::Template::DEF->new($default)); } # if ESCAPE was set, push an ESCAPE op on the stack before # the variable. output will handle the actual work. # unless of course, they have set escape=0 or escape=none if ($escape) { if ($escape =~ /^["']?url["']?$/i) { push(@pstack, $URLESCAPE); } elsif ($escape =~ /^["']?js["']?$/i) { push(@pstack, $JSESCAPE); } elsif ($escape =~ /^["']?0["']?$/) { # do nothing if escape=0 } elsif ($escape =~ /^["']?none["']?$/i) { # do nothing if escape=none } else { push(@pstack, $ESCAPE); } } push(@pstack, $var); } elsif ($which eq 'TMPL_LOOP') { # we've got a loop start print STDERR "### HTML::Template Debug ### $fname : line $fcounter : LOOP $name start\n" if $options->{debug}; # if we already have this loop, then simply link to the existing # HTML::Template::LOOP, else create a new one. my $loop; if (exists $pmap{$name}) { $loop = $pmap{$name}; if( $options->{die_on_bad_params} && ref($loop) ne 'HTML::Template::LOOP') { die "HTML::Template->new() : Already used param name $name as a TMPL_VAR, TMPL_IF or TMPL_UNLESS, found in a TMPL_LOOP at $fname : line $fcounter!"; } } else { # store the results in a LOOP object - actually just a # thin wrapper around another HTML::Template object. $loop = HTML::Template::LOOP->new(); $pmap{$name} = $loop; } # get it on the loopstack, pstack of the enclosing block push(@pstack, $loop); push(@loopstack, [$loop, $#pstack]); # magic time - push on a fresh pmap and pstack, adjust the typeglobs. # this gives the loop a separate namespace (i.e. pmap and pstack). push(@pstacks, []); *pstack = $pstacks[$#pstacks]; push(@pmaps, {}); *pmap = $pmaps[$#pmaps]; push(@ifstacks, []); *ifstack = $ifstacks[$#ifstacks]; push(@ucstacks, []); *ucstack = $ucstacks[$#ucstacks]; # auto-vivify __FIRST__, __LAST__ and __INNER__ if # loop_context_vars is set. Otherwise, with # die_on_bad_params set output() will might cause errors # when it tries to set them. if ($options->{loop_context_vars}) { $pmap{__first__} = HTML::Template::VAR->new(); $pmap{__inner__} = HTML::Template::VAR->new(); $pmap{__outer__} = HTML::Template::VAR->new(); $pmap{__last__} = HTML::Template::VAR->new(); $pmap{__odd__} = HTML::Template::VAR->new(); $pmap{__even__} = HTML::Template::VAR->new(); $pmap{__counter__} = HTML::Template::VAR->new(); $pmap{__index__} = HTML::Template::VAR->new(); } } elsif ($which eq '/TMPL_LOOP') { $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : LOOP end\n"; my $loopdata = pop(@loopstack); die "HTML::Template->new() : found </TMPL_LOOP> with no matching <TMPL_LOOP> at $fname : line $fcounter!" unless defined $loopdata; my ($loop, $starts_at) = @$loopdata; # resolve pending conditionals foreach my $uc (@ucstack) { my $var = $uc->[HTML::Template::COND::VARIABLE]; if (exists($pmap{$var})) { $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; } else { $pmap{$var} = HTML::Template::VAR->new(); $top_pmap{$var} = HTML::Template::VAR->new() if $options->{global_vars} and not exists $top_pmap{$var}; $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; } if (ref($pmap{$var}) eq 'HTML::Template::VAR') { $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR; } else { $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP; } } # get pmap and pstack for the loop, adjust the typeglobs to # the enclosing block. my $param_map = pop(@pmaps); *pmap = $pmaps[$#pmaps]; my $parse_stack = pop(@pstacks); *pstack = $pstacks[$#pstacks]; scalar(@ifstack) and die "HTML::Template->new() : Dangling <TMPL_IF> or <TMPL_UNLESS> in loop ending at $fname : line $fcounter."; pop(@ifstacks); *ifstack = $ifstacks[$#ifstacks]; pop(@ucstacks); *ucstack = $ucstacks[$#ucstacks]; # instantiate the sub-Template, feeding it parse_stack and # param_map. This means that only the enclosing template # does _parse() - sub-templates get their parse_stack and # param_map fed to them already filled in. $loop->[HTML::Template::LOOP::TEMPLATE_HASH]{$starts_at} = ref($self)->_new_from_loop( parse_stack => $parse_stack, param_map => $param_map, debug => $options->{debug}, die_on_bad_params => $options->{die_on_bad_params}, loop_context_vars => $options->{loop_context_vars}, case_sensitive => $options->{case_sensitive}, force_untaint => $options->{force_untaint}, parent_global_vars => ($options->{global_vars} || $options->{parent_global_vars} || 0) ); # if this loop has been used multiple times we need to merge the "param_map" between them # all so that die_on_bad_params doesn't complain if we try to use different vars in # each instance of the same loop if ($options->{die_on_bad_params}) { my $loops = $loop->[HTML::Template::LOOP::TEMPLATE_HASH]; my @loop_keys = sort { $a <=> $b } keys %$loops; if (@loop_keys > 1) { my $last_loop = pop(@loop_keys); foreach my $loop (@loop_keys) { # make sure all the params in the last loop are also in this loop foreach my $param (keys %{$loops->{$last_loop}->{param_map}}) { next if $loops->{$loop}->{param_map}->{$param}; $loops->{$loop}->{param_map}->{$param} = $loops->{$last_loop}->{param_map}->{$param}; } # make sure all the params in this loop are also in the last loop foreach my $param (keys %{$loops->{$loop}->{param_map}}) { next if $loops->{$last_loop}->{param_map}->{$param}; $loops->{$last_loop}->{param_map}->{$param} = $loops->{$loop}->{param_map}->{$param}; } } } } } elsif ($which eq 'TMPL_IF' or $which eq 'TMPL_UNLESS') { $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : $which $name start\n"; # if we already have this var, then simply link to the existing # HTML::Template::VAR/LOOP, else defer the mapping my $var; if (exists $pmap{$name}) { $var = $pmap{$name}; } else { $var = $name; } # connect the var to a conditional my $cond = HTML::Template::COND->new($var); if ($which eq 'TMPL_IF') { $cond->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_IF; $cond->[HTML::Template::COND::JUMP_IF_TRUE] = 0; } else { $cond->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_UNLESS; $cond->[HTML::Template::COND::JUMP_IF_TRUE] = 1; } # push unconnected conditionals onto the ucstack for # resolution later. Otherwise, save type information now. if ($var eq $name) { push(@ucstack, $cond); } else { if (ref($var) eq 'HTML::Template::VAR') { $cond->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR; } else { $cond->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP; } } # push what we've got onto the stacks push(@pstack, $cond); push(@ifstack, $cond); } elsif ($which eq '/TMPL_IF' or $which eq '/TMPL_UNLESS') { $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : $which end\n"; my $cond = pop(@ifstack); die "HTML::Template->new() : found </${which}> with no matching <TMPL_IF> at $fname : line $fcounter." unless defined $cond; if ($which eq '/TMPL_IF') { die "HTML::Template->new() : found </TMPL_IF> incorrectly terminating a <TMPL_UNLESS> (use </TMPL_UNLESS>) at $fname : line $fcounter.\n" if ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_UNLESS); } else { die "HTML::Template->new() : found </TMPL_UNLESS> incorrectly terminating a <TMPL_IF> (use </TMPL_IF>) at $fname : line $fcounter.\n" if ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_IF); } # connect the matching to this "address" - place a NOOP to # hold the spot. This allows output() to treat an IF in the # assembler-esque "Conditional Jump" mode. push(@pstack, $NOOP); $cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack; } elsif ($which eq 'TMPL_ELSE') { $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : ELSE\n"; my $cond = pop(@ifstack); die "HTML::Template->new() : found <TMPL_ELSE> with no matching <TMPL_IF> or <TMPL_UNLESS> at $fname : line $fcounter." unless defined $cond; die "HTML::Template->new() : found second <TMPL_ELSE> tag for <TMPL_IF> or <TMPL_UNLESS> at $fname : line $fcounter." if $cond->[HTML::Template::COND::IS_ELSE]; my $else = HTML::Template::COND->new($cond->[HTML::Template::COND::VARIABLE]); $else->[HTML::Template::COND::WHICH] = $cond->[HTML::Template::COND::WHICH]; $else->[HTML::Template::COND::UNCONDITIONAL_JUMP] = 1; $else->[HTML::Template::COND::IS_ELSE] = 1; # need end-block resolution? if (defined($cond->[HTML::Template::COND::VARIABLE_TYPE])) { $else->[HTML::Template::COND::VARIABLE_TYPE] = $cond->[HTML::Template::COND::VARIABLE_TYPE]; } else { push(@ucstack, $else); } push(@pstack, $else); push(@ifstack, $else); # connect the matching to this "address" - thus the if, # failing jumps to the ELSE address. The else then gets # elaborated, and of course succeeds. On the other hand, if # the IF fails and falls though, output will reach the else # and jump to the /if address. $cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack; } elsif ($which eq 'TMPL_INCLUDE') { # handle TMPL_INCLUDEs $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : INCLUDE $name \n"; # no includes here, bub $options->{no_includes} and croak("HTML::Template : Illegal attempt to use TMPL_INCLUDE in template file : (no_includes => 1)"); my $filename = $name; # look for the included file... my $filepath; if ($options->{search_path_on_include}) { $filepath = $self->_find_file($filename); } else { $filepath = $self->_find_file($filename, [File::Spec->splitdir($fstack[-1][0])]); } die "HTML::Template->new() : Cannot open included file $filename : file not found." if !defined $filepath && $options->{die_on_missing_include}; my $included_template = ""; if( $filepath ) { # use the open_mode if we have one if (my $mode = $options->{open_mode}) { open(TEMPLATE, $mode, $filepath) || confess("HTML::Template->new() : Cannot open included file $filepath with mode $mode: $!"); } else { open(TEMPLATE, $filepath) or confess("HTML::Template->new() : Cannot open included file $filepath : $!"); } # read into the array while (read(TEMPLATE, $included_template, 10240, length($included_template))) { } close(TEMPLATE); } # call filters if necessary $self->_call_filters(\$included_template) if @{$options->{filter}}; if ($included_template) { # not empty # handle the old vanguard format - this needs to happen here # since we're not about to do a next CHUNKS. $options->{vanguard_compatibility_mode} and $included_template =~ s/%([-\w\/\.+]+)%/<TMPL_VAR NAME=$1>/g; # collect mtimes for included files if ($options->{cache} and !$options->{blind_cache}) { $self->{included_mtimes}{$filepath} = (stat($filepath))[9]; } # adjust the fstack to point to the included file info push(@fstack, [$filepath, 1, scalar @{[$included_template =~ m/(\n)/g]} + 1]); (*fname, *fcounter, *fmax) = \(@{$fstack[$#fstack]}); # make sure we aren't infinitely recursing die "HTML::Template->new() : likely recursive includes - parsed $options->{max_includes} files deep and giving up (set max_includes higher to allow deeper recursion)." if ($options->{max_includes} and (scalar(@fstack) > $options->{max_includes})); # stick the remains of this chunk onto the bottom of the # included text. $included_template .= $post; $post = undef; # move the new chunks into place. splice(@chunks, $chunk_number, 1, split(m/(?=<)/, $included_template)); # recalculate stopping point $last_chunk = $#chunks; # start in on the first line of the included text - nothing # else to do on this line. $chunk = $chunks[$chunk_number]; redo CHUNK; } } else { # zuh!? die "HTML::Template->new() : Unknown or unmatched TMPL construct at $fname : line $fcounter."; } # push the rest after the tag if (defined($post)) { if (ref($pstack[$#pstack]) eq 'SCALAR') { ${$pstack[$#pstack]} .= $post; } else { push(@pstack, \$post); } } } else { # just your ordinary markup # make sure we didn't reject something TMPL_* but badly formed if ($options->{strict}) { die "HTML::Template->new() : Syntax error in <TMPL_*> tag at $fname : $fcounter." if ($chunk =~ /<(?:!--\s*)?\/?tmpl_/i); } # push the rest and get next chunk if (defined($chunk)) { if (ref($pstack[$#pstack]) eq 'SCALAR') { ${$pstack[$#pstack]} .= $chunk; } else { push(@pstack, \$chunk); } } } # count newlines in chunk and advance line count $fcounter += scalar(@{[$chunk =~ m/(\n)/g]}); # if we just crossed the end of an included file # pop off the record and re-alias to the enclosing file's info pop(@fstack), (*fname, *fcounter, *fmax) = \(@{$fstack[$#fstack]}) if ($fcounter > $fmax); } # next CHUNK # make sure we don't have dangling IF or LOOP blocks scalar(@ifstack) and die "HTML::Template->new() : At least one <TMPL_IF> or <TMPL_UNLESS> not terminated at end of file!"; scalar(@loopstack) and die "HTML::Template->new() : At least one <TMPL_LOOP> not terminated at end of file!"; # resolve pending conditionals foreach my $uc (@ucstack) { my $var = $uc->[HTML::Template::COND::VARIABLE]; if (exists($pmap{$var})) { $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; } else { $pmap{$var} = HTML::Template::VAR->new(); $top_pmap{$var} = HTML::Template::VAR->new() if $options->{global_vars} and not exists $top_pmap{$var}; $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; } if (ref($pmap{$var}) eq 'HTML::Template::VAR') { $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR; } else { $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP; } } # want a stack dump? if ($options->{stack_debug}) { require 'Data/Dumper.pm'; print STDERR "### HTML::Template _param Stack Dump ###\n\n", Data::Dumper::Dumper($self->{parse_stack}), "\n"; } # get rid of filters - they cause runtime errors if Storable tries # to store them. This can happen under global_vars. delete $options->{filter}; } # a recursive sub that associates each loop with the loops above # (treating the top-level as a loop) sub _globalize_vars { my $self = shift; # associate with the loop (and top-level templates) above in the tree. push(@{$self->{options}{associate}}, @_); # recurse down into the template tree, adding ourself to the end of # list. push(@_, $self); map { $_->_globalize_vars(@_) } map { values %{$_->[HTML::Template::LOOP::TEMPLATE_HASH]} } grep { ref($_) eq 'HTML::Template::LOOP' } @{$self->{parse_stack}}; } # method used to recursively un-hook associate sub _unglobalize_vars { my $self = shift; # disassociate $self->{options}{associate} = undef; # recurse down into the template tree disassociating map { $_->_unglobalize_vars() } map { values %{$_->[HTML::Template::LOOP::TEMPLATE_HASH]} } grep { ref($_) eq 'HTML::Template::LOOP' } @{$self->{parse_stack}}; } =head2 config A package method that is used to set/get the global default configuration options. For instance, if you want to set the C<utf8> flag to always be on for every template loaded by this process you would do: HTML::Template->config(utf8 => 1); Or if you wanted to check if the C<utf8> flag was on or not, you could do: my %config = HTML::Template->config; if( $config{utf8} ) { ... } Any configuration options that are valid for C<new()> are acceptable to be passed to this method. =cut sub config { my ($pkg, %options) = @_; foreach my $opt (keys %options) { if( $opt eq 'associate' || $opt eq 'filter' || $opt eq 'path' ) { push(@{$OPTIONS{$opt}}, $options{$opt}); } else { $OPTIONS{$opt} = $options{$opt}; } } return %OPTIONS; } =head2 param C<param()> can be called in a number of ways =over =item 1 - To return a list of parameters in the template : my @parameter_names = $self->param(); =item 2 - To return the value set to a param : my $value = $self->param('PARAM'); =item 3 - To set the value of a parameter : # For simple TMPL_VARs: $self->param(PARAM => 'value'); # with a subroutine reference that gets called to get the value # of the scalar. The sub will receive the template object as a # parameter. $self->param(PARAM => sub { return 'value' }); # And TMPL_LOOPs: $self->param(LOOP_PARAM => [{PARAM => VALUE_FOR_FIRST_PASS}, {PARAM => VALUE_FOR_SECOND_PASS}]); =item 4 - To set the value of a number of parameters : # For simple TMPL_VARs: $self->param( PARAM => 'value', PARAM2 => 'value' ); # And with some TMPL_LOOPs: $self->param( PARAM => 'value', PARAM2 => 'value', LOOP_PARAM => [{PARAM => VALUE_FOR_FIRST_PASS}, {PARAM => VALUE_FOR_SECOND_PASS}], ANOTHER_LOOP_PARAM => [{PARAM => VALUE_FOR_FIRST_PASS}, {PARAM => VALUE_FOR_SECOND_PASS}], ); =item 5 - To set the value of a number of parameters using a hash-ref : $self->param( { PARAM => 'value', PARAM2 => 'value', LOOP_PARAM => [{PARAM => VALUE_FOR_FIRST_PASS}, {PARAM => VALUE_FOR_SECOND_PASS}], ANOTHER_LOOP_PARAM => [{PARAM => VALUE_FOR_FIRST_PASS}, {PARAM => VALUE_FOR_SECOND_PASS}], } ); An error occurs if you try to set a value that is tainted if the C<force_untaint> option is set. =back =cut sub param { my $self = shift; my $options = $self->{options}; my $param_map = $self->{param_map}; # the no-parameter case - return list of parameters in the template. return keys(%$param_map) unless scalar(@_); my $first = shift; my $type = ref $first; # the one-parameter case - could be a parameter value request or a # hash-ref. if (!scalar(@_) and !length($type)) { my $param = $options->{case_sensitive} ? $first : lc $first; # check for parameter existence $options->{die_on_bad_params} and !exists($param_map->{$param}) and croak( "HTML::Template : Attempt to get nonexistent parameter '$param' - this parameter name doesn't match any declarations in the template file : (die_on_bad_params set => 1)" ); return undef unless (exists($param_map->{$param}) and defined($param_map->{$param})); return ${$param_map->{$param}} if (ref($param_map->{$param}) eq 'HTML::Template::VAR'); return $param_map->{$param}[HTML::Template::LOOP::PARAM_SET]; } if (!scalar(@_)) { croak("HTML::Template->param() : Single reference arg to param() must be a hash-ref! You gave me a $type.") unless $type eq 'HASH' or UNIVERSAL::isa($first, 'HASH'); push(@_, %$first); } else { unshift(@_, $first); } croak("HTML::Template->param() : You gave me an odd number of parameters to param()!") unless ((@_ % 2) == 0); # strangely, changing this to a "while(@_) { shift, shift }" type # loop causes perl 5.004_04 to die with some nonsense about a # read-only value. for (my $x = 0 ; $x <= $#_ ; $x += 2) { my $param = $options->{case_sensitive} ? $_[$x] : lc $_[$x]; my $value = $_[($x + 1)]; # check that this param exists in the template $options->{die_on_bad_params} and !exists($param_map->{$param}) and croak( "HTML::Template : Attempt to set nonexistent parameter '$param' - this parameter name doesn't match any declarations in the template file : (die_on_bad_params => 1)" ); # if we're not going to die from bad param names, we need to ignore # them... unless (exists($param_map->{$param})) { next if not $options->{parent_global_vars}; # ... unless global vars is on - in which case we can't be # sure we won't need it in a lower loop. if (ref($value) eq 'ARRAY') { $param_map->{$param} = HTML::Template::LOOP->new(); } else { $param_map->{$param} = HTML::Template::VAR->new(); } } # figure out what we've got, taking special care to allow for # objects that are compatible underneath. my $type = ref $value || ''; if ($type eq 'REF') { croak("HTML::Template::param() : attempt to set parameter '$param' with a reference to a reference!"); } elsif ($type && ($type eq 'ARRAY' || ($type !~ /^(CODE)|(HASH)|(SCALAR)$/ && $value->isa('ARRAY')))) { ref($param_map->{$param}) eq 'HTML::Template::LOOP' || croak( "HTML::Template::param() : attempt to set parameter '$param' with an array ref - parameter is not a TMPL_LOOP!"); $param_map->{$param}[HTML::Template::LOOP::PARAM_SET] = [@{$value}]; } elsif( $type eq 'CODE' ) { # code can be used for a var or a loop if( ref($param_map->{$param}) eq 'HTML::Template::LOOP' ) { $param_map->{$param}[HTML::Template::LOOP::PARAM_SET] = $value; } else { ${$param_map->{$param}} = $value; } } else { ref($param_map->{$param}) eq 'HTML::Template::VAR' || croak( "HTML::Template::param() : attempt to set parameter '$param' with a scalar - parameter is not a TMPL_VAR!"); ${$param_map->{$param}} = $value; } } } =head2 clear_params Sets all the parameters to undef. Useful internally, if nowhere else! =cut sub clear_params { my $self = shift; my $type; foreach my $name (keys %{$self->{param_map}}) { $type = ref($self->{param_map}{$name}); undef(${$self->{param_map}{$name}}) if ($type eq 'HTML::Template::VAR'); undef($self->{param_map}{$name}[HTML::Template::LOOP::PARAM_SET]) if ($type eq 'HTML::Template::LOOP'); } } # obsolete implementation of associate sub associateCGI { my $self = shift; my $cgi = shift; (ref($cgi) eq 'CGI') or croak("Warning! non-CGI object was passed to HTML::Template::associateCGI()!\n"); push(@{$self->{options}{associate}}, $cgi); return 1; } =head2 output C<output()> returns the final result of the template. In most situations you'll want to print this, like: print $template->output(); When output is called each occurrence of C<< <TMPL_VAR NAME=name> >> is replaced with the value assigned to "name" via C<param()>. If a named parameter is unset it is simply replaced with ''. C<< <TMPL_LOOP> >>s are evaluated once per parameter set, accumulating output on each pass. Calling C<output()> is guaranteed not to change the state of the HTML::Template object, in case you were wondering. This property is mostly important for the internal implementation of loops. You may optionally supply a filehandle to print to automatically as the template is generated. This may improve performance and lower memory consumption. Example: $template->output(print_to => *STDOUT); The return value is undefined when using the C<print_to> option. =cut use vars qw(%URLESCAPE_MAP); sub output { my $self = shift; my $options = $self->{options}; local $_; croak("HTML::Template->output() : You gave me an odd number of parameters to output()!") unless ((@_ % 2) == 0); my %args = @_; print STDERR "### HTML::Template Memory Debug ### START OUTPUT ", $self->{proc_mem}->size(), "\n" if $options->{memory_debug}; $options->{debug} and print STDERR "### HTML::Template Debug ### In output\n"; # want a stack dump? if ($options->{stack_debug}) { require 'Data/Dumper.pm'; print STDERR "### HTML::Template output Stack Dump ###\n\n", Data::Dumper::Dumper($self->{parse_stack}), "\n"; } # globalize vars - this happens here to localize the circular # references created by global_vars. $self->_globalize_vars() if ($options->{global_vars}); # support the associate magic, searching for undefined params and # attempting to fill them from the associated objects. if (scalar(@{$options->{associate}})) { # prepare case-mapping hashes to do case-insensitive matching # against associated objects. This allows CGI.pm to be # case-sensitive and still work with associate. my (%case_map, $lparam); foreach my $associated_object (@{$options->{associate}}) { # what a hack! This should really be optimized out for case_sensitive. if ($options->{case_sensitive}) { map { $case_map{$associated_object}{$_} = $_ } $associated_object->param(); } else { map { $case_map{$associated_object}{lc($_)} = $_ } $associated_object->param(); } } foreach my $param (keys %{$self->{param_map}}) { unless (defined($self->param($param))) { OBJ: foreach my $associated_object (reverse @{$options->{associate}}) { $self->param($param, scalar $associated_object->param($case_map{$associated_object}{$param})), last OBJ if (exists($case_map{$associated_object}{$param})); } } } } use vars qw($line @parse_stack); local (*line, *parse_stack); # walk the parse stack, accumulating output in $result *parse_stack = $self->{parse_stack}; my $result = ''; tie $result, 'HTML::Template::PRINTSCALAR', $args{print_to} if defined $args{print_to} && !eval { tied *{$args{print_to}} }; my $type; my $parse_stack_length = $#parse_stack; for (my $x = 0 ; $x <= $parse_stack_length ; $x++) { *line = \$parse_stack[$x]; $type = ref($line); if ($type eq 'SCALAR') { $result .= $$line; } elsif ($type eq 'HTML::Template::VAR' and ref($$line) eq 'CODE') { if (defined($$line)) { my $tmp_val = $$line->($self); croak("HTML::Template->output() : 'force_untaint' option but coderef returns tainted value") if $options->{force_untaint} && tainted($tmp_val); $result .= $tmp_val; # change the reference to point to the value now not the code reference $$line = $tmp_val if $options->{cache_lazy_vars} } } elsif ($type eq 'HTML::Template::VAR') { if (defined $$line) { if ($options->{force_untaint} && tainted($$line)) { croak("HTML::Template->output() : tainted value with 'force_untaint' option"); } $result .= $$line; } } elsif ($type eq 'HTML::Template::LOOP') { if (defined($line->[HTML::Template::LOOP::PARAM_SET])) { eval { $result .= $line->output($x, $options->{loop_context_vars}); }; croak("HTML::Template->output() : fatal error in loop output : $@") if $@; } } elsif ($type eq 'HTML::Template::COND') { if ($line->[HTML::Template::COND::UNCONDITIONAL_JUMP]) { $x = $line->[HTML::Template::COND::JUMP_ADDRESS]; } else { if ($line->[HTML::Template::COND::JUMP_IF_TRUE]) { if ($line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR) { if (defined ${$line->[HTML::Template::COND::VARIABLE]}) { if (ref(${$line->[HTML::Template::COND::VARIABLE]}) eq 'CODE') { my $tmp_val = ${$line->[HTML::Template::COND::VARIABLE]}->($self); $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if $tmp_val; ${$line->[HTML::Template::COND::VARIABLE]} = $tmp_val if $options->{cache_lazy_vars}; } else { $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if ${$line->[HTML::Template::COND::VARIABLE]}; } } } else { # if it's a code reference, execute it to get the values my $loop_values = $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]; if (defined $loop_values && ref $loop_values eq 'CODE') { $loop_values = $loop_values->($self); $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET] = $loop_values if $options->{cache_lazy_loops}; } # if we have anything for the loop, jump to the next part if (defined $loop_values && @$loop_values) { $x = $line->[HTML::Template::COND::JUMP_ADDRESS]; } } } else { if ($line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR) { if (defined ${$line->[HTML::Template::COND::VARIABLE]}) { if (ref(${$line->[HTML::Template::COND::VARIABLE]}) eq 'CODE') { my $tmp_val = ${$line->[HTML::Template::COND::VARIABLE]}->($self); $x = $line->[HTML::Template::COND::JUMP_ADDRESS] unless $tmp_val; ${$line->[HTML::Template::COND::VARIABLE]} = $tmp_val if $options->{cache_lazy_vars}; } else { $x = $line->[HTML::Template::COND::JUMP_ADDRESS] unless ${$line->[HTML::Template::COND::VARIABLE]}; } } else { $x = $line->[HTML::Template::COND::JUMP_ADDRESS]; } } else { # if we don't have anything for the loop, jump to the next part my $loop_values = $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]; if(!defined $loop_values) { $x = $line->[HTML::Template::COND::JUMP_ADDRESS]; } else { # check to see if the loop is a code ref and if it is execute it to get the values if( ref $loop_values eq 'CODE' ) { $loop_values = $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]->($self); $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET] = $loop_values if $options->{cache_lazy_loops}; } # if we don't have anything in the loop, jump to the next part if(!@$loop_values) { $x = $line->[HTML::Template::COND::JUMP_ADDRESS]; } } } } } } elsif ($type eq 'HTML::Template::NOOP') { next; } elsif ($type eq 'HTML::Template::DEF') { $_ = $x; # remember default place in stack # find next VAR, there might be an ESCAPE in the way *line = \$parse_stack[++$x]; *line = \$parse_stack[++$x] if ref $line eq 'HTML::Template::ESCAPE' or ref $line eq 'HTML::Template::JSESCAPE' or ref $line eq 'HTML::Template::URLESCAPE'; # either output the default or go back if (defined $$line) { $x = $_; } else { $result .= ${$parse_stack[$_]}; } next; } elsif ($type eq 'HTML::Template::ESCAPE') { *line = \$parse_stack[++$x]; if (defined($$line)) { my $tmp_val; if (ref($$line) eq 'CODE') { $tmp_val = $$line->($self); if ($options->{force_untaint} > 1 && tainted($_)) { croak("HTML::Template->output() : 'force_untaint' option but coderef returns tainted value"); } $$line = $tmp_val if $options->{cache_lazy_vars}; } else { $tmp_val = $$line; if ($options->{force_untaint} > 1 && tainted($_)) { croak("HTML::Template->output() : tainted value with 'force_untaint' option"); } } # straight from the CGI.pm bible. $tmp_val =~ s/&/&/g; $tmp_val =~ s/\"/"/g; $tmp_val =~ s/>/>/g; $tmp_val =~ s/</</g; $tmp_val =~ s/'/'/g; $result .= $tmp_val; } next; } elsif ($type eq 'HTML::Template::JSESCAPE') { $x++; *line = \$parse_stack[$x]; if (defined($$line)) { my $tmp_val; if (ref($$line) eq 'CODE') { $tmp_val = $$line->($self); if ($options->{force_untaint} > 1 && tainted($_)) { croak("HTML::Template->output() : 'force_untaint' option but coderef returns tainted value"); } $$line = $tmp_val if $options->{cache_lazy_vars}; } else { $tmp_val = $$line; if ($options->{force_untaint} > 1 && tainted($_)) { croak("HTML::Template->output() : tainted value with 'force_untaint' option"); } } $tmp_val =~ s/\\/\\\\/g; $tmp_val =~ s/'/\\'/g; $tmp_val =~ s/"/\\"/g; $tmp_val =~ s/[\n\x{2028}]/\\n/g; $tmp_val =~ s/\x{2029}/\\n\\n/g; $tmp_val =~ s/\r/\\r/g; $result .= $tmp_val; } } elsif ($type eq 'HTML::Template::URLESCAPE') { $x++; *line = \$parse_stack[$x]; if (defined($$line)) { my $tmp_val; if (ref($$line) eq 'CODE') { $tmp_val = $$line->($self); if ($options->{force_untaint} > 1 && tainted($_)) { croak("HTML::Template->output() : 'force_untaint' option but coderef returns tainted value"); } $$line = $tmp_val if $options->{cache_lazy_vars}; } else { $tmp_val = $$line; if ($options->{force_untaint} > 1 && tainted($_)) { croak("HTML::Template->output() : tainted value with 'force_untaint' option"); } } # Build a char->hex map if one isn't already available unless (exists($URLESCAPE_MAP{chr(1)})) { for (0 .. 255) { $URLESCAPE_MAP{chr($_)} = sprintf('%%%02X', $_); } } # do the translation (RFC 2396 ^uric) $tmp_val =~ s!([^a-zA-Z0-9_.\-])!$URLESCAPE_MAP{$1}!g; $result .= $tmp_val; } } else { confess("HTML::Template::output() : Unknown item in parse_stack : " . $type); } } # undo the globalization circular refs $self->_unglobalize_vars() if ($options->{global_vars}); print STDERR "### HTML::Template Memory Debug ### END OUTPUT ", $self->{proc_mem}->size(), "\n" if $options->{memory_debug}; return undef if defined $args{print_to}; return $result; } =head2 query This method allow you to get information about the template structure. It can be called in a number of ways. The simplest usage of query is simply to check whether a parameter name exists in the template, using the C<name> option: if ($template->query(name => 'foo')) { # do something if a variable of any type named FOO is in the template } This same usage returns the type of the parameter. The type is the same as the tag minus the leading 'TMPL_'. So, for example, a C<TMPL_VAR> parameter returns 'VAR' from C<query()>. if ($template->query(name => 'foo') eq 'VAR') { # do something if FOO exists and is a TMPL_VAR } Note that the variables associated with C<TMPL_IF>s and C<TMPL_UNLESS>s will be identified as 'VAR' unless they are also used in a C<TMPL_LOOP>, in which case they will return 'LOOP'. C<query()> also allows you to get a list of parameters inside a loop (and inside loops inside loops). Example loop: <TMPL_LOOP NAME="EXAMPLE_LOOP"> <TMPL_VAR NAME="BEE"> <TMPL_VAR NAME="BOP"> <TMPL_LOOP NAME="EXAMPLE_INNER_LOOP"> <TMPL_VAR NAME="INNER_BEE"> <TMPL_VAR NAME="INNER_BOP"> </TMPL_LOOP> </TMPL_LOOP> And some query calls: # returns 'LOOP' $type = $template->query(name => 'EXAMPLE_LOOP'); # returns ('bop', 'bee', 'example_inner_loop') @param_names = $template->query(loop => 'EXAMPLE_LOOP'); # both return 'VAR' $type = $template->query(name => ['EXAMPLE_LOOP', 'BEE']); $type = $template->query(name => ['EXAMPLE_LOOP', 'BOP']); # and this one returns 'LOOP' $type = $template->query(name => ['EXAMPLE_LOOP', 'EXAMPLE_INNER_LOOP']); # and finally, this returns ('inner_bee', 'inner_bop') @inner_param_names = $template->query(loop => ['EXAMPLE_LOOP', 'EXAMPLE_INNER_LOOP']); # for non existent parameter names you get undef this returns undef. $type = $template->query(name => 'DWEAZLE_ZAPPA'); # calling loop on a non-loop parameter name will cause an error. This dies: $type = $template->query(loop => 'DWEAZLE_ZAPPA'); As you can see above the C<loop> option returns a list of parameter names and both C<name> and C<loop> take array refs in order to refer to parameters inside loops. It is an error to use C<loop> with a parameter that is not a loop. Note that all the names are returned in lowercase and the types are uppercase. Just like C<param()>, C<query()> with no arguments returns all the parameter names in the template at the top level. =cut sub query { my $self = shift; $self->{options}{debug} and print STDERR "### HTML::Template Debug ### query(", join(', ', @_), ")\n"; # the no-parameter case - return $self->param() return $self->param() unless scalar(@_); croak("HTML::Template::query() : Odd number of parameters passed to query!") if (scalar(@_) % 2); croak("HTML::Template::query() : Wrong number of parameters passed to query - should be 2.") if (scalar(@_) != 2); my ($opt, $path) = (lc shift, shift); croak("HTML::Template::query() : invalid parameter ($opt)") unless ($opt eq 'name' or $opt eq 'loop'); # make path an array unless it already is $path = [$path] unless (ref $path); # find the param in question. my @objs = $self->_find_param(@$path); return undef unless scalar(@objs); my ($obj, $type); # do what the user asked with the object if ($opt eq 'name') { # we only look at the first one. new() should make sure they're # all the same. ($obj, $type) = (shift(@objs), shift(@objs)); return undef unless defined $obj; return 'VAR' if $type eq 'HTML::Template::VAR'; return 'LOOP' if $type eq 'HTML::Template::LOOP'; croak("HTML::Template::query() : unknown object ($type) in param_map!"); } elsif ($opt eq 'loop') { my %results; while (@objs) { ($obj, $type) = (shift(@objs), shift(@objs)); croak( "HTML::Template::query() : Search path [", join(', ', @$path), "] doesn't end in a TMPL_LOOP - it is an error to use the 'loop' option on a non-loop parameter. To avoid this problem you can use the 'name' option to query() to check the type first." ) unless ((defined $obj) and ($type eq 'HTML::Template::LOOP')); # SHAZAM! This bit extracts all the parameter names from all the # loop objects for this name. map { $results{$_} = 1 } map { keys(%{$_->{'param_map'}}) } values(%{$obj->[HTML::Template::LOOP::TEMPLATE_HASH]}); } # this is our loop list, return it. return keys(%results); } } # a function that returns the object(s) corresponding to a given path and # its (their) ref()(s). Used by query() in the obvious way. sub _find_param { my $self = shift; my $spot = $self->{options}{case_sensitive} ? shift : lc shift; # get the obj and type for this spot my $obj = $self->{'param_map'}{$spot}; return unless defined $obj; my $type = ref $obj; # return if we're here or if we're not but this isn't a loop return ($obj, $type) unless @_; return unless ($type eq 'HTML::Template::LOOP'); # recurse. this is a depth first search on the template tree, for # the algorithm geeks in the audience. return map { $_->_find_param(@_) } values(%{$obj->[HTML::Template::LOOP::TEMPLATE_HASH]}); } # HTML::Template::VAR, LOOP, etc are *light* objects - their internal # spec is used above. No encapsulation or information hiding is to be # assumed. package HTML::Template::VAR; sub new { my $value; return bless(\$value, $_[0]); } package HTML::Template::DEF; sub new { my $value = $_[1]; return bless(\$value, $_[0]); } package HTML::Template::LOOP; sub new { return bless([], $_[0]); } sub output { my $self = shift; my $index = shift; my $loop_context_vars = shift; my $template = $self->[TEMPLATE_HASH]{$index}; my $value_sets_array = $self->[PARAM_SET]; return unless defined($value_sets_array); my $result = ''; my $count = 0; my $odd = 0; # execute the code to get the values if it's a code reference if( ref $value_sets_array eq 'CODE' ) { $value_sets_array = $value_sets_array->($template); croak("HTML::Template->output: TMPL_LOOP code reference did not return an ARRAY reference!") unless ref $value_sets_array && ref $value_sets_array eq 'ARRAY'; $self->[PARAM_SET] = $value_sets_array if $template->{options}->{cache_lazy_loops}; } foreach my $value_set (@$value_sets_array) { if ($loop_context_vars) { if ($count == 0) { @{$value_set}{qw(__first__ __inner__ __outer__ __last__)} = (1, 0, 1, $#{$value_sets_array} == 0); } elsif ($count == $#{$value_sets_array}) { @{$value_set}{qw(__first__ __inner__ __outer__ __last__)} = (0, 0, 1, 1); } else { @{$value_set}{qw(__first__ __inner__ __outer__ __last__)} = (0, 1, 0, 0); } $odd = $value_set->{__odd__} = !$odd; $value_set->{__even__} = !$odd; $value_set->{__counter__} = $count + 1; $value_set->{__index__} = $count; } $template->param($value_set); $result .= $template->output; $template->clear_params; @{$value_set}{qw(__first__ __last__ __inner__ __outer__ __odd__ __even__ __counter__ __index__)} = (0, 0, 0, 0, 0, 0, 0) if ($loop_context_vars); $count++; } return $result; } package HTML::Template::COND; sub new { my $pkg = shift; my $var = shift; my $self = []; $self->[VARIABLE] = $var; bless($self, $pkg); return $self; } package HTML::Template::NOOP; sub new { my $unused; my $self = \$unused; bless($self, $_[0]); return $self; } package HTML::Template::ESCAPE; sub new { my $unused; my $self = \$unused; bless($self, $_[0]); return $self; } package HTML::Template::JSESCAPE; sub new { my $unused; my $self = \$unused; bless($self, $_[0]); return $self; } package HTML::Template::URLESCAPE; sub new { my $unused; my $self = \$unused; bless($self, $_[0]); return $self; } # scalar-tying package for output(print_to => *HANDLE) implementation package HTML::Template::PRINTSCALAR; use strict; sub TIESCALAR { bless \$_[1], $_[0]; } sub FETCH { } sub STORE { my $self = shift; local *FH = $$self; print FH @_; } 1; __END__ =head1 LAZY VALUES As mentioned above, both C<TMPL_VAR> and C<TMPL_LOOP> values can be code references. These code references are only executed if the variable or loop is used in the template. This is extremely useful if you want to make a variable available to template designers but it can be expensive to calculate, so you only want to do so if you have to. Maybe an example will help to illustrate. Let's say you have a template like this: <tmpl_if we_care> <tmpl_if life_universe_and_everything> </tmpl_if> If C<life_universe_and_everything> is expensive to calculate we can wrap it's calculation in a code reference and HTML::Template will only execute that code if C<we_care> is also true. $tmpl->param(life_universe_and_everything => sub { calculate_42() }); Your code reference will be given a single argument, the HTML::Template object in use. In the above example, if we wanted C<calculate_42()> to have this object we'd do something like this: $tmpl->param(life_universe_and_everything => sub { calculate_42(shift) }); This same approach can be used for C<TMPL_LOOP>s too: <tmpl_if we_care> <tmpl_loop needles_in_haystack> Found <tmpl_var __counter>! </tmpl_loop> </tmpl_if> And in your Perl code: $tmpl->param(needles_in_haystack => sub { find_needles() }); The only difference in the C<TMPL_LOOP> case is that the subroutine needs to return a reference to an ARRAY, not just a scalar value. =head2 Multiple Calls It's important to recognize that while this feature is designed to save processing time when things aren't needed, if you're not careful it can actually increase the number of times you perform your calculation. HTML::Template calls your code reference each time it seems your loop in the template, this includes the times that you might use the loop in a conditional (C<TMPL_IF> or C<TMPL_UNLESS>). For instance: <tmpl_if we care> <tmpl_if needles_in_haystack> <tmpl_loop needles_in_haystack> Found <tmpl_var __counter>! </tmpl_loop> <tmpl_else> No needles found! </tmpl_if> </tmpl_if> This will actually call C<find_needles()> twice which will be even worse than you had before. One way to work around this is to cache the return value yourself: my $needles; $tmpl->param(needles_in_haystack => sub { defined $needles ? $needles : $needles = find_needles() }); =head1 BUGS I am aware of no bugs - if you find one, join the mailing list and tell us about it. You can join the HTML::Template mailing-list by visiting: http://lists.sourceforge.net/lists/listinfo/html-template-users Of course, you can still email me directly (C<sam@tregar.com>) with bugs, but I reserve the right to forward bug reports to the mailing list. When submitting bug reports, be sure to include full details, including the VERSION of the module, a test script and a test template demonstrating the problem! If you're feeling really adventurous, HTML::Template has a publically available Git repository. See below for more information in the PUBLIC GIT REPOSITORY section. =head1 CREDITS This module was the brain child of my boss, Jesse Erlbaum (C<jesse@vm.com>) at Vanguard Media (http://vm.com) . The most original idea in this module - the C<< <TMPL_LOOP> >> - was entirely his. Fixes, Bug Reports, Optimizations and Ideas have been generously provided by: =over =item * Richard Chen =item * Mike Blazer =item * Adriano Nagelschmidt Rodrigues =item * Andrej Mikus =item * Ilya Obshadko =item * Kevin Puetz =item * Steve Reppucci =item * Richard Dice =item * Tom Hukins =item * Eric Zylberstejn =item * David Glasser =item * Peter Marelas =item * James William Carlson =item * Frank D. Cringle =item * Winfried Koenig =item * Matthew Wickline =item * Doug Steinwand =item * Drew Taylor =item * Tobias Brox =item * Michael Lloyd =item * Simran Gambhir =item * Chris Houser <chouser@bluweb.com> =item * Larry Moore =item * Todd Larason =item * Jody Biggs =item * T.J. Mather =item * Martin Schroth =item * Dave Wolfe =item * uchum =item * Kawai Takanori =item * Peter Guelich =item * Chris Nokleberg =item * Ralph Corderoy =item * William Ward =item * Ade Olonoh =item * Mark Stosberg =item * Lance Thomas =item * Roland Giersig =item * Jere Julian =item * Peter Leonard =item * Kenny Smith =item * Sean P. Scanlon =item * Martin Pfeffer =item * David Ferrance =item * Gyepi Sam =item * Darren Chamberlain =item * Paul Baker =item * Gabor Szabo =item * Craig Manley =item * Richard Fein =item * The Phalanx Project =item * Sven Neuhaus =item * Michael Peters =item * Jan Dubois =item * Moritz Lenz =back Thanks! =head1 WEBSITE You can find information about HTML::Template and other related modules at: http://html-template.sourceforge.net =head1 PUBLIC GIT REPOSITORY HTML::Template now has a publicly accessible Git repository provided by GitHub (github.com). You can access it by going to https://github.com/mpeters/html-template. Give it a try! =head1 AUTHOR Sam Tregar, C<sam@tregar.com> =head1 CO-MAINTAINER Michael Peters, C<mpeters@plusthree.com> =head1 LICENSE HTML::Template : A module for using HTML Templates with Perl Copyright (C) 2000-2011 Sam Tregar (sam@tregar.com) This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, which means using either: a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" which comes with this module. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the Artistic License for more details. You should have received a copy of the Artistic License with this module. If not, I'll be glad to provide one. You should have received a copy of the GNU General Public License along with this program. If not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! ��a�2 �2 HTML/Tagset.pmnu �[��� package HTML::Tagset; use strict; =head1 NAME HTML::Tagset - data tables useful in parsing HTML =head1 VERSION Version 3.20 =cut use vars qw( $VERSION ); $VERSION = '3.20'; =head1 SYNOPSIS use HTML::Tagset; # Then use any of the items in the HTML::Tagset package # as need arises =head1 DESCRIPTION This module contains several data tables useful in various kinds of HTML parsing operations. Note that all tag names used are lowercase. In the following documentation, a "hashset" is a hash being used as a set -- the hash conveys that its keys are there, and the actual values associated with the keys are not significant. (But what values are there, are always true.) =cut use vars qw( $VERSION %emptyElement %optionalEndTag %linkElements %boolean_attr %isHeadElement %isBodyElement %isPhraseMarkup %is_Possible_Strict_P_Content %isHeadOrBodyElement %isList %isTableElement %isFormElement %isKnown %canTighten @p_closure_barriers %isCDATA_Parent ); =head1 VARIABLES Note that none of these variables are exported. =head2 hashset %HTML::Tagset::emptyElement This hashset has as values the tag-names (GIs) of elements that cannot have content. (For example, "base", "br", "hr".) So C<$HTML::Tagset::emptyElement{'hr'}> exists and is true. C<$HTML::Tagset::emptyElement{'dl'}> does not exist, and so is not true. =cut %emptyElement = map {; $_ => 1 } qw(base link meta isindex img br hr wbr input area param embed bgsound spacer basefont col frame ~comment ~literal ~declaration ~pi ); # The "~"-initial names are for pseudo-elements used by HTML::Entities # and TreeBuilder =head2 hashset %HTML::Tagset::optionalEndTag This hashset lists tag-names for elements that can have content, but whose end-tags are generally, "safely", omissible. Example: C<$HTML::Tagset::emptyElement{'li'}> exists and is true. =cut %optionalEndTag = map {; $_ => 1 } qw(p li dt dd); # option th tr td); =head2 hash %HTML::Tagset::linkElements Values in this hash are tagnames for elements that might contain links, and the value for each is a reference to an array of the names of attributes whose values can be links. =cut %linkElements = ( 'a' => ['href'], 'applet' => ['archive', 'codebase', 'code'], 'area' => ['href'], 'base' => ['href'], 'bgsound' => ['src'], 'blockquote' => ['cite'], 'body' => ['background'], 'del' => ['cite'], 'embed' => ['pluginspage', 'src'], 'form' => ['action'], 'frame' => ['src', 'longdesc'], 'iframe' => ['src', 'longdesc'], 'ilayer' => ['background'], 'img' => ['src', 'lowsrc', 'longdesc', 'usemap'], 'input' => ['src', 'usemap'], 'ins' => ['cite'], 'isindex' => ['action'], 'head' => ['profile'], 'layer' => ['background', 'src'], 'link' => ['href'], 'object' => ['classid', 'codebase', 'data', 'archive', 'usemap'], 'q' => ['cite'], 'script' => ['src', 'for'], 'table' => ['background'], 'td' => ['background'], 'th' => ['background'], 'tr' => ['background'], 'xmp' => ['href'], ); =head2 hash %HTML::Tagset::boolean_attr This hash (not hashset) lists what attributes of what elements can be printed without showing the value (for example, the "noshade" attribute of "hr" elements). For elements with only one such attribute, its value is simply that attribute name. For elements with many such attributes, the value is a reference to a hashset containing all such attributes. =cut %boolean_attr = ( # TODO: make these all hashes 'area' => 'nohref', 'dir' => 'compact', 'dl' => 'compact', 'hr' => 'noshade', 'img' => 'ismap', 'input' => { 'checked' => 1, 'readonly' => 1, 'disabled' => 1 }, 'menu' => 'compact', 'ol' => 'compact', 'option' => 'selected', 'select' => 'multiple', 'td' => 'nowrap', 'th' => 'nowrap', 'ul' => 'compact', ); #========================================================================== # List of all elements from Extensible HTML version 1.0 Transitional DTD: # # a abbr acronym address applet area b base basefont bdo big # blockquote body br button caption center cite code col colgroup # dd del dfn dir div dl dt em fieldset font form h1 h2 h3 h4 h5 h6 # head hr html i iframe img input ins isindex kbd label legend li # link map menu meta noframes noscript object ol optgroup option p # param pre q s samp script select small span strike strong style # sub sup table tbody td textarea tfoot th thead title tr tt u ul # var # # Varia from Mozilla source internal table of tags: # Implemented: # xmp listing wbr nobr frame frameset noframes ilayer # layer nolayer spacer embed multicol # But these are unimplemented: # sound?? keygen?? server?? # Also seen here and there: # marquee?? app?? (both unimplemented) #========================================================================== =head2 hashset %HTML::Tagset::isPhraseMarkup This hashset contains all phrasal-level elements. =cut %isPhraseMarkup = map {; $_ => 1 } qw( span abbr acronym q sub sup cite code em kbd samp strong var dfn strike b i u s tt small big a img br wbr nobr blink font basefont bdo spacer embed noembed ); # had: center, hr, table =head2 hashset %HTML::Tagset::is_Possible_Strict_P_Content This hashset contains all phrasal-level elements that be content of a P element, for a strict model of HTML. =cut %is_Possible_Strict_P_Content = ( %isPhraseMarkup, %isFormElement, map {; $_ => 1} qw( object script map ) # I've no idea why there's these latter exceptions. # I'm just following the HTML4.01 DTD. ); #from html4 strict: #<!ENTITY % fontstyle "TT | I | B | BIG | SMALL"> # #<!ENTITY % phrase "EM | STRONG | DFN | CODE | # SAMP | KBD | VAR | CITE | ABBR | ACRONYM" > # #<!ENTITY % special # "A | IMG | OBJECT | BR | SCRIPT | MAP | Q | SUB | SUP | SPAN | BDO"> # #<!ENTITY % formctrl "INPUT | SELECT | TEXTAREA | LABEL | BUTTON"> # #<!-- %inline; covers inline or "text-level" elements --> #<!ENTITY % inline "#PCDATA | %fontstyle; | %phrase; | %special; | %formctrl;"> =head2 hashset %HTML::Tagset::isHeadElement This hashset contains all elements that elements that should be present only in the 'head' element of an HTML document. =cut %isHeadElement = map {; $_ => 1 } qw(title base link meta isindex script style object bgsound); =head2 hashset %HTML::Tagset::isList This hashset contains all elements that can contain "li" elements. =cut %isList = map {; $_ => 1 } qw(ul ol dir menu); =head2 hashset %HTML::Tagset::isTableElement This hashset contains all elements that are to be found only in/under a "table" element. =cut %isTableElement = map {; $_ => 1 } qw(tr td th thead tbody tfoot caption col colgroup); =head2 hashset %HTML::Tagset::isFormElement This hashset contains all elements that are to be found only in/under a "form" element. =cut %isFormElement = map {; $_ => 1 } qw(input select option optgroup textarea button label); =head2 hashset %HTML::Tagset::isBodyElement This hashset contains all elements that are to be found only in/under the "body" element of an HTML document. =cut %isBodyElement = map {; $_ => 1 } qw( h1 h2 h3 h4 h5 h6 p div pre plaintext address blockquote xmp listing center multicol iframe ilayer nolayer bgsound hr ol ul dir menu li dl dt dd ins del fieldset legend map area applet param object isindex script noscript table center form ), keys %isFormElement, keys %isPhraseMarkup, # And everything phrasal keys %isTableElement, ; =head2 hashset %HTML::Tagset::isHeadOrBodyElement This hashset includes all elements that I notice can fall either in the head or in the body. =cut %isHeadOrBodyElement = map {; $_ => 1 } qw(script isindex style object map area param noscript bgsound); # i.e., if we find 'script' in the 'body' or the 'head', don't freak out. =head2 hashset %HTML::Tagset::isKnown This hashset lists all known HTML elements. =cut %isKnown = (%isHeadElement, %isBodyElement, map{; $_=>1 } qw( head body html frame frameset noframes ~comment ~pi ~directive ~literal )); # that should be all known tags ever ever =head2 hashset %HTML::Tagset::canTighten This hashset lists elements that might have ignorable whitespace as children or siblings. =cut %canTighten = %isKnown; delete @canTighten{ keys(%isPhraseMarkup), 'input', 'select', 'xmp', 'listing', 'plaintext', 'pre', }; # xmp, listing, plaintext, and pre are untightenable, and # in a really special way. @canTighten{'hr','br'} = (1,1); # exceptional 'phrasal' things that ARE subject to tightening. # The one case where I can think of my tightening rules failing is: # <p>foo bar<center> <em>baz quux</em> ... # ^-- that would get deleted. # But that's pretty gruesome code anyhow. You gets what you pays for. #========================================================================== =head2 array @HTML::Tagset::p_closure_barriers This array has a meaning that I have only seen a need for in C<HTML::TreeBuilder>, but I include it here on the off chance that someone might find it of use: When we see a "E<lt>pE<gt>" token, we go lookup up the lineage for a p element we might have to minimize. At first sight, we might say that if there's a p anywhere in the lineage of this new p, it should be closed. But that's wrong. Consider this document: <html> <head> <title>foo</title> </head> <body> <p>foo <table> <tr> <td> foo <p>bar </td> </tr> </table> </p> </body> </html> The second p is quite legally inside a much higher p. My formalization of the reason why this is legal, but this: <p>foo<p>bar</p></p> isn't, is that something about the table constitutes a "barrier" to the application of the rule about what p must minimize. So C<@HTML::Tagset::p_closure_barriers> is the list of all such barrier-tags. =cut @p_closure_barriers = qw( li blockquote ul ol menu dir dl dt dd td th tr table caption div ); # In an ideal world (i.e., XHTML) we wouldn't have to bother with any of this # monkey business of barriers to minimization! =head2 hashset %isCDATA_Parent This hashset includes all elements whose content is CDATA. =cut %isCDATA_Parent = map {; $_ => 1 } qw(script style xmp listing plaintext); # TODO: there's nothing else that takes CDATA children, right? # As the HTML3 DTD (Raggett 1995-04-24) noted: # The XMP, LISTING and PLAINTEXT tags are incompatible with SGML # and derive from very early versions of HTML. They require non- # standard parsers and will cause problems for processing # documents with standard SGML tools. =head1 CAVEATS You may find it useful to alter the behavior of modules (like C<HTML::Element> or C<HTML::TreeBuilder>) that use C<HTML::Tagset>'s data tables by altering the data tables themselves. You are welcome to try, but be careful; and be aware that different modules may or may react differently to the data tables being changed. Note that it may be inappropriate to use these tables for I<producing> HTML -- for example, C<%isHeadOrBodyElement> lists the tagnames for all elements that can appear either in the head or in the body, such as "script". That doesn't mean that I am saying your code that produces HTML should feel free to put script elements in either place! If you are producing programs that spit out HTML, you should be I<intimately> familiar with the DTDs for HTML or XHTML (available at C<http://www.w3.org/>), and you should slavishly obey them, not the data tables in this document. =head1 SEE ALSO L<HTML::Element>, L<HTML::TreeBuilder>, L<HTML::LinkExtor> =head1 COPYRIGHT & LICENSE Copyright 1995-2000 Gisle Aas. Copyright 2000-2005 Sean M. Burke. Copyright 2005-2008 Andy Lester. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 ACKNOWLEDGEMENTS Most of the code/data in this module was adapted from code written by Gisle Aas for C<HTML::Element>, C<HTML::TreeBuilder>, and C<HTML::LinkExtor>. Then it was maintained by Sean M. Burke. =head1 AUTHOR Current maintainer: Andy Lester, C<< <andy at petdance.com> >> =head1 BUGS Please report any bugs or feature requests to C<bug-html-tagset at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=HTML-Tagset>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =cut 1; PK ! �D=� � HTML/Template/FAQ.pmnu �[��� use strict; use warnings; package HTML::Template::FAQ; # ABSTRACT: Frequently Asked Questions about HTML::Template use Carp (); Carp::confess "you're not meant to use the FAQ, just read it!"; 1; __END__ =pod =head1 NAME HTML::Template::FAQ - Frequently Asked Questions about HTML::Template =head1 SYNOPSIS In the interest of greater understanding I've started a FAQ section of the perldocs. Please look in here before you send me email. =head1 FREQUENTLY ASKED QUESTIONS =head2 Is there a place to go to discuss HTML::Template and/or get help? There's a mailing-list for discussing L<HTML::Template> at html-template-users@lists.sourceforge.net. Join at: http://lists.sourceforge.net/lists/listinfo/html-template-users If you just want to get email when new releases are available you can join the announcements mailing-list here: http://lists.sourceforge.net/lists/listinfo/html-template-announce =head2 Is there a searchable archive for the mailing-list? Yes, you can find an archive of the SourceForge list here: http://dir.gmane.org/gmane.comp.lang.perl.modules.html-template =head2 I want support for <TMPL_XXX>! How about it? Maybe. I definitely encourage people to discuss their ideas for L<HTML::Template> on the mailing list. Please be ready to explain to me how the new tag fits in with HTML::Template's mission to provide a fast, lightweight system for using HTML templates. NOTE: Offering to program said addition and provide it in the form of a patch to the most recent version of L<HTML::Template> will definitely have a softening effect on potential opponents! =head2 I found a bug, can you fix it? That depends. Did you send me the VERSION of L<HTML::Template>, a test script and a test template? If so, then almost certainly. If you're feeling really adventurous, L<HTML::Template> is publicly available on GitHub (https://github.com/mpeters/html-template). Please feel free to fork it and send me a pull request with any changes you have. =head2 <TMPL_VAR>s from the main template aren't working inside a <TMPL_LOOP>! Why? This is the intended behavior. C<< <TMPL_LOOP> >> introduces a separate scope for C<< <TMPL_VAR>s >> much like a subroutine call in Perl introduces a separate scope for C<my> variables. If you want your C<< <TMPL_VAR> >>s to be global you can set the C<global_vars> option when you call C<new()>. See above for documentation of the C<global_vars> C<new()> option. =head2 How can I pre-load my templates using cache-mode and mod_perl? Add something like this to your startup.pl: use HTML::Template; use File::Find; print STDERR "Pre-loading HTML Templates...\n"; find( sub { return unless /\.tmpl$/; HTML::Template->new( filename => "$File::Find::dir/$_", cache => 1, ); }, '/path/to/templates', '/another/path/to/templates/' ); Note that you'll need to modify the C<return unless> line to specify the extension you use for your template files - I use F<.tmpl>, as you can see. You'll also need to specify the path to your template files. One potential problem: the F</path/to/templates/> must be B<EXACTLY> the same path you use when you call C<< HTML::Template->new() >>. Otherwise the cache won't know they're the same file and will load a new copy - instead getting a speed increase, you'll double your memory usage. To find out if this is happening set C<cache_debug => 1> in your application code and look for "CACHE MISS" messages in the logs. =head2 What characters are allowed in TMPL_* names? Numbers, letters, '.', '/', '+', '-' and '_'. =head2 How can I execute a program from inside my template? Short answer: you can't. Longer answer: you shouldn't since this violates the fundamental concept behind L<HTML::Template> - that design and code should be separate. But, inevitably some people still want to do it. If that describes you then you should take a look at L<HTML::Template::Expr>. Using L<HTML::Template::Expr> it should be easy to write a C<run_program()> function. Then you can do awful stuff like: <tmpl_var expr="run_program('foo.pl')"> Just, please, don't tell me about it. I'm feeling guilty enough just for writing L<HTML::Template::Expr> in the first place. =head2 What's the best way to create a <select> form element using HTML::Template? There is much disagreement on this issue. My personal preference is to use L<CGI.pm>'s excellent C<popup_menu()> and C<scrolling_list()> functions to fill in a single C<< <tmpl_var select_foo> >> variable. To some people this smacks of mixing HTML and code in a way that they hoped L<HTML::Template> would help them avoid. To them I'd say that HTML is a violation of the principle of separating design from programming. There's no clear separation between the programmatic elements of the C<< <form> >> tags and the layout of the C<< <form> >> tags. You'll have to draw the line somewhere - clearly the designer can't be entirely in charge of form creation. It's a balancing act and you have to weigh the pros and cons on each side. It is certainly possible to produce a C<< <select> >> element entirely inside the template. What you end up with is a rat's nest of loops and conditionals. Alternately you can give up a certain amount of flexibility in return for vastly simplifying your templates. I generally choose the latter. Another option is to investigate L<HTML::FillInForm> which some have reported success using to solve this problem. PK ! �!�u �u Error.pmnu �[��� # Error.pm # # Copyright (c) 1997-8 Graham Barr <gbarr@ti.com>. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Based on my original Error.pm, and Exceptions.pm by Peter Seibel # <peter@weblogic.com> and adapted by Jesse Glick <jglick@sig.bsh.com>. # # but modified ***significantly*** package Error; $Error::VERSION = '0.17029'; use strict; use warnings; use 5.004; use overload ( '""' => 'stringify', '0+' => 'value', 'bool' => sub { return 1; }, 'fallback' => 1 ); $Error::Depth = 0; # Depth to pass to caller() $Error::Debug = 0; # Generate verbose stack traces @Error::STACK = (); # Clause stack for try $Error::THROWN = undef; # last error thrown, a workaround until die $ref works my $LAST; # Last error created my %ERROR; # Last error associated with package sub _throw_Error_Simple { my $args = shift; return Error::Simple->new( $args->{'text'} ); } $Error::ObjectifyCallback = \&_throw_Error_Simple; # Exported subs are defined in Error::subs use Scalar::Util (); sub import { shift; my @tags = @_; local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; @tags = grep { if ( $_ eq ':warndie' ) { Error::WarnDie->import(); 0; } else { 1; } } @tags; Error::subs->import(@tags); } # I really want to use last for the name of this method, but it is a keyword # which prevent the syntax last Error sub prior { shift; # ignore return $LAST unless @_; my $pkg = shift; return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef unless ref($pkg); my $obj = $pkg; my $err = undef; if ( $obj->isa('HASH') ) { $err = $obj->{'__Error__'} if exists $obj->{'__Error__'}; } elsif ( $obj->isa('GLOB') ) { $err = ${*$obj}{'__Error__'} if exists ${*$obj}{'__Error__'}; } $err; } sub flush { shift; #ignore unless (@_) { $LAST = undef; return; } my $pkg = shift; return unless ref($pkg); undef $ERROR{$pkg} if defined $ERROR{$pkg}; } # Return as much information as possible about where the error # happened. The -stacktrace element only exists if $Error::DEBUG # was set when the error was created sub stacktrace { my $self = shift; return $self->{'-stacktrace'} if exists $self->{'-stacktrace'}; my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died"; $text .= sprintf( " at %s line %d.\n", $self->file, $self->line ) unless ( $text =~ /\n$/s ); $text; } sub associate { my $err = shift; my $obj = shift; return unless ref($obj); if ( $obj->isa('HASH') ) { $obj->{'__Error__'} = $err; } elsif ( $obj->isa('GLOB') ) { ${*$obj}{'__Error__'} = $err; } $obj = ref($obj); $ERROR{ ref($obj) } = $err; return; } sub new { my $self = shift; my ( $pkg, $file, $line ) = caller($Error::Depth); my $err = bless { '-package' => $pkg, '-file' => $file, '-line' => $line, @_ }, $self; $err->associate( $err->{'-object'} ) if ( exists $err->{'-object'} ); # To always create a stacktrace would be very inefficient, so # we only do it if $Error::Debug is set if ($Error::Debug) { require Carp; local $Carp::CarpLevel = $Error::Depth; my $text = defined( $err->{'-text'} ) ? $err->{'-text'} : "Error"; my $trace = Carp::longmess($text); # Remove try calls from the trace $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; $err->{'-stacktrace'} = $trace; } $@ = $LAST = $ERROR{$pkg} = $err; } # Throw an error. this contains some very gory code. sub throw { my $self = shift; local $Error::Depth = $Error::Depth + 1; # if we are not rethrow-ing then create the object to throw $self = $self->new(@_) unless ref($self); die $Error::THROWN = $self; } # syntactic sugar for # # die with Error( ... ); sub with { my $self = shift; local $Error::Depth = $Error::Depth + 1; $self->new(@_); } # syntactic sugar for # # record Error( ... ) and return; sub record { my $self = shift; local $Error::Depth = $Error::Depth + 1; $self->new(@_); } # catch clause for # # try { ... } catch CLASS with { ... } sub catch { my $pkg = shift; my $code = shift; my $clauses = shift || {}; my $catch = $clauses->{'catch'} ||= []; unshift @$catch, $pkg, $code; $clauses; } # Object query methods sub object { my $self = shift; exists $self->{'-object'} ? $self->{'-object'} : undef; } sub file { my $self = shift; exists $self->{'-file'} ? $self->{'-file'} : undef; } sub line { my $self = shift; exists $self->{'-line'} ? $self->{'-line'} : undef; } sub text { my $self = shift; exists $self->{'-text'} ? $self->{'-text'} : undef; } # overload methods sub stringify { my $self = shift; defined $self->{'-text'} ? $self->{'-text'} : "Died"; } sub value { my $self = shift; exists $self->{'-value'} ? $self->{'-value'} : undef; } package Error::Simple; $Error::Simple::VERSION = '0.17029'; @Error::Simple::ISA = qw(Error); sub new { my $self = shift; my $text = "" . shift; my $value = shift; my (@args) = (); local $Error::Depth = $Error::Depth + 1; @args = ( -file => $1, -line => $2 ) if ( $text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s ); push( @args, '-value', 0 + $value ) if defined($value); $self->SUPER::new( -text => $text, @args ); } sub stringify { my $self = shift; my $text = $self->SUPER::stringify; $text .= sprintf( " at %s line %d.\n", $self->file, $self->line ) unless ( $text =~ /\n$/s ); $text; } ########################################################################## ########################################################################## # Inspired by code from Jesse Glick <jglick@sig.bsh.com> and # Peter Seibel <peter@weblogic.com> package Error::subs; $Error::subs::VERSION = '0.17029'; use Exporter (); use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS); @EXPORT_OK = qw(try with finally except otherwise); %EXPORT_TAGS = ( try => \@EXPORT_OK ); @ISA = qw(Exporter); sub run_clauses ($$$\@) { my ( $clauses, $err, $wantarray, $result ) = @_; my $code = undef; $err = $Error::ObjectifyCallback->( { 'text' => $err } ) unless ref($err); CATCH: { # catch my $catch; if ( defined( $catch = $clauses->{'catch'} ) ) { my $i = 0; CATCHLOOP: for ( ; $i < @$catch ; $i += 2 ) { my $pkg = $catch->[$i]; unless ( defined $pkg ) { #except splice( @$catch, $i, 2, $catch->[ $i + 1 ]->($err) ); $i -= 2; next CATCHLOOP; } elsif ( Scalar::Util::blessed($err) && $err->isa($pkg) ) { $code = $catch->[ $i + 1 ]; while (1) { my $more = 0; local ( $Error::THROWN, $@ ); my $ok = eval { $@ = $err; if ($wantarray) { @{$result} = $code->( $err, \$more ); } elsif ( defined($wantarray) ) { @{$result} = (); $result->[0] = $code->( $err, \$more ); } else { $code->( $err, \$more ); } 1; }; if ($ok) { next CATCHLOOP if $more; undef $err; } else { $err = $@ || $Error::THROWN; $err = $Error::ObjectifyCallback->( { 'text' => $err } ) unless ref($err); } last CATCH; } } } } # otherwise my $owise; if ( defined( $owise = $clauses->{'otherwise'} ) ) { my $code = $clauses->{'otherwise'}; my $more = 0; local ( $Error::THROWN, $@ ); my $ok = eval { $@ = $err; if ($wantarray) { @{$result} = $code->( $err, \$more ); } elsif ( defined($wantarray) ) { @{$result} = (); $result->[0] = $code->( $err, \$more ); } else { $code->( $err, \$more ); } 1; }; if ($ok) { undef $err; } else { $err = $@ || $Error::THROWN; $err = $Error::ObjectifyCallback->( { 'text' => $err } ) unless ref($err); } } } $err; } sub try (&;$) { my $try = shift; my $clauses = @_ ? shift : {}; my $ok = 0; my $err = undef; my @result = (); unshift @Error::STACK, $clauses; my $wantarray = wantarray(); do { local $Error::THROWN = undef; local $@ = undef; $ok = eval { if ($wantarray) { @result = $try->(); } elsif ( defined $wantarray ) { $result[0] = $try->(); } else { $try->(); } 1; }; $err = $@ || $Error::THROWN unless $ok; }; shift @Error::STACK; $err = run_clauses( $clauses, $err, wantarray, @result ) unless ($ok); $clauses->{'finally'}->() if ( defined( $clauses->{'finally'} ) ); if ( defined($err) ) { if ( Scalar::Util::blessed($err) && $err->can('throw') ) { throw $err; } else { die $err; } } wantarray ? @result : $result[0]; } # Each clause adds a sub to the list of clauses. The finally clause is # always the last, and the otherwise clause is always added just before # the finally clause. # # All clauses, except the finally clause, add a sub which takes one argument # this argument will be the error being thrown. The sub will return a code ref # if that clause can handle that error, otherwise undef is returned. # # The otherwise clause adds a sub which unconditionally returns the users # code reference, this is why it is forced to be last. # # The catch clause is defined in Error.pm, as the syntax causes it to # be called as a method sub with (&;$) { @_; } sub finally (&) { my $code = shift; my $clauses = { 'finally' => $code }; $clauses; } # The except clause is a block which returns a hashref or a list of # key-value pairs, where the keys are the classes and the values are subs. sub except (&;$) { my $code = shift; my $clauses = shift || {}; my $catch = $clauses->{'catch'} ||= []; my $sub = sub { my $ref; my (@array) = $code->( $_[0] ); if ( @array == 1 && ref( $array[0] ) ) { $ref = $array[0]; $ref = [%$ref] if ( UNIVERSAL::isa( $ref, 'HASH' ) ); } else { $ref = \@array; } @$ref; }; unshift @{$catch}, undef, $sub; $clauses; } sub otherwise (&;$) { my $code = shift; my $clauses = shift || {}; if ( exists $clauses->{'otherwise'} ) { require Carp; Carp::croak("Multiple otherwise clauses"); } $clauses->{'otherwise'} = $code; $clauses; } 1; package Error::WarnDie; $Error::WarnDie::VERSION = '0.17029'; sub gen_callstack($) { my ($start) = @_; require Carp; local $Carp::CarpLevel = $start; my $trace = Carp::longmess(""); # Remove try calls from the trace $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; my @callstack = split( m/\n/, $trace ); return @callstack; } my $old_DIE; my $old_WARN; sub DEATH { my ($e) = @_; local $SIG{__DIE__} = $old_DIE if ( defined $old_DIE ); die @_ if $^S; my ( $etype, $message, $location, @callstack ); if ( ref($e) && $e->isa("Error") ) { $etype = "exception of type " . ref($e); $message = $e->text; $location = $e->file . ":" . $e->line; @callstack = split( m/\n/, $e->stacktrace ); } else { # Don't apply subsequent layer of message formatting die $e if ( $e =~ m/^\nUnhandled perl error caught at toplevel:\n\n/ ); $etype = "perl error"; my $stackdepth = 0; while ( caller($stackdepth) =~ m/^Error(?:$|::)/ ) { ++$stackdepth; } @callstack = gen_callstack( $stackdepth + 1 ); $message = "$e"; chomp $message; if ( $message =~ s/ at (.*?) line (\d+)\.$// ) { $location = $1 . ":" . $2; } else { my @caller = caller($stackdepth); $location = $caller[1] . ":" . $caller[2]; } } shift @callstack; # Do it this way in case there are no elements; we don't print a spurious \n my $callstack = join( "", map { "$_\n" } @callstack ); die "\nUnhandled $etype caught at toplevel:\n\n $message\n\nThrown from: $location\n\nFull stack trace:\n\n$callstack\n"; } sub TAXES { my ($message) = @_; local $SIG{__WARN__} = $old_WARN if ( defined $old_WARN ); $message =~ s/ at .*? line \d+\.$//; chomp $message; my @callstack = gen_callstack(1); my $location = shift @callstack; # $location already starts in a leading space $message .= $location; # Do it this way in case there are no elements; we don't print a spurious \n my $callstack = join( "", map { "$_\n" } @callstack ); warn "$message:\n$callstack"; } sub import { $old_DIE = $SIG{__DIE__}; $old_WARN = $SIG{__WARN__}; $SIG{__DIE__} = \&DEATH; $SIG{__WARN__} = \&TAXES; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Error - Error/exception handling in an OO-ish way =head1 VERSION version 0.17029 =head1 SYNOPSIS use Error qw(:try); throw Error::Simple( "A simple error"); sub xyz { ... record Error::Simple("A simple error") and return; } unlink($file) or throw Error::Simple("$file: $!",$!); try { do_some_stuff(); die "error!" if $condition; throw Error::Simple "Oops!" if $other_condition; } catch Error::IO with { my $E = shift; print STDERR "File ", $E->{'-file'}, " had a problem\n"; } except { my $E = shift; my $general_handler=sub {send_message $E->{-description}}; return { UserException1 => $general_handler, UserException2 => $general_handler }; } otherwise { print STDERR "Well I don't know what to say\n"; } finally { close_the_garage_door_already(); # Should be reliable }; # Don't forget the trailing ; or you might be surprised =head1 DESCRIPTION The C<Error> package provides two interfaces. Firstly C<Error> provides a procedural interface to exception handling. Secondly C<Error> is a base class for errors/exceptions that can either be thrown, for subsequent catch, or can simply be recorded. Errors in the class C<Error> should not be thrown directly, but the user should throw errors from a sub-class of C<Error>. =head1 WARNING Using the "Error" module is B<no longer recommended> due to the black-magical nature of its syntactic sugar, which often tends to break. Its maintainers have stopped actively writing code that uses it, and discourage people from doing so. See the "SEE ALSO" section below for better recommendations. =head1 PROCEDURAL INTERFACE C<Error> exports subroutines to perform exception handling. These will be exported if the C<:try> tag is used in the C<use> line. =over 4 =item try BLOCK CLAUSES C<try> is the main subroutine called by the user. All other subroutines exported are clauses to the try subroutine. The BLOCK will be evaluated and, if no error is throw, try will return the result of the block. C<CLAUSES> are the subroutines below, which describe what to do in the event of an error being thrown within BLOCK. =item catch CLASS with BLOCK This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)> to be caught and handled by evaluating C<BLOCK>. C<BLOCK> will be passed two arguments. The first will be the error being thrown. The second is a reference to a scalar variable. If this variable is set by the catch block then, on return from the catch block, try will continue processing as if the catch block was never found. The error will also be available in C<$@>. To propagate the error the catch block may call C<$err-E<gt>throw> If the scalar reference by the second argument is not set, and the error is not thrown. Then the current try block will return with the result from the catch block. =item except BLOCK When C<try> is looking for a handler, if an except clause is found C<BLOCK> is evaluated. The return value from this block should be a HASHREF or a list of key-value pairs, where the keys are class names and the values are CODE references for the handler of errors of that type. =item otherwise BLOCK Catch any error by executing the code in C<BLOCK> When evaluated C<BLOCK> will be passed one argument, which will be the error being processed. The error will also be available in C<$@>. Only one otherwise block may be specified per try block =item finally BLOCK Execute the code in C<BLOCK> either after the code in the try block has successfully completed, or if the try block throws an error then C<BLOCK> will be executed after the handler has completed. If the handler throws an error then the error will be caught, the finally block will be executed and the error will be re-thrown. Only one finally block may be specified per try block =back =head1 COMPATIBILITY L<Moose> exports a keyword called C<with> which clashes with Error's. This example returns a prototype mismatch error: package MyTest; use warnings; use Moose; use Error qw(:try); (Thanks to C<maik.hentsche@amd.com> for the report.). =head1 CLASS INTERFACE =head2 CONSTRUCTORS The C<Error> object is implemented as a HASH. This HASH is initialized with the arguments that are passed to it's constructor. The elements that are used by, or are retrievable by the C<Error> class are listed below, other classes may add to these. -file -line -text -value -object If C<-file> or C<-line> are not specified in the constructor arguments then these will be initialized with the file name and line number where the constructor was called from. If the error is associated with an object then the object should be passed as the C<-object> argument. This will allow the C<Error> package to associate the error with the object. The C<Error> package remembers the last error created, and also the last error associated with a package. This could either be the last error created by a sub in that package, or the last error which passed an object blessed into that package as the C<-object> argument. =over 4 =item Error->new() See the Error::Simple documentation. =item throw ( [ ARGS ] ) Create a new C<Error> object and throw an error, which will be caught by a surrounding C<try> block, if there is one. Otherwise it will cause the program to exit. C<throw> may also be called on an existing error to re-throw it. =item with ( [ ARGS ] ) Create a new C<Error> object and returns it. This is defined for syntactic sugar, eg die with Some::Error ( ... ); =item record ( [ ARGS ] ) Create a new C<Error> object and returns it. This is defined for syntactic sugar, eg record Some::Error ( ... ) and return; =back =head2 STATIC METHODS =over 4 =item prior ( [ PACKAGE ] ) Return the last error created, or the last error associated with C<PACKAGE> =item flush ( [ PACKAGE ] ) Flush the last error created, or the last error associated with C<PACKAGE>.It is necessary to clear the error stack before exiting the package or uncaught errors generated using C<record> will be reported. $Error->flush; =back =head2 OBJECT METHODS =over 4 =item stacktrace If the variable C<$Error::Debug> was non-zero when the error was created, then C<stacktrace> returns a string created by calling C<Carp::longmess>. If the variable was zero the C<stacktrace> returns the text of the error appended with the filename and line number of where the error was created, providing the text does not end with a newline. =item object The object this error was associated with =item file The file where the constructor of this error was called from =item line The line where the constructor of this error was called from =item text The text of the error =item $err->associate($obj) Associates an error with an object to allow error propagation. I.e: $ber->encode(...) or return Error->prior($ber)->associate($ldap); =back =head2 OVERLOAD METHODS =over 4 =item stringify A method that converts the object into a string. This method may simply return the same as the C<text> method, or it may append more information. For example the file name and line number. By default this method returns the C<-text> argument that was passed to the constructor, or the string C<"Died"> if none was given. =item value A method that will return a value that can be associated with the error. For example if an error was created due to the failure of a system call, then this may return the numeric value of C<$!> at the time. By default this method returns the C<-value> argument that was passed to the constructor. =back =head1 PRE-DEFINED ERROR CLASSES =head2 Error::Simple This class can be used to hold simple error strings and values. It's constructor takes two arguments. The first is a text value, the second is a numeric value. These values are what will be returned by the overload methods. If the text value ends with C<at file line 1> as $@ strings do, then this information will be used to set the C<-file> and C<-line> arguments of the error object. This class is used internally if an eval'd block die's with an error that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified) =head1 $Error::ObjectifyCallback This variable holds a reference to a subroutine that converts errors that are plain strings to objects. It is used by Error.pm to convert textual errors to objects, and can be overridden by the user. It accepts a single argument which is a hash reference to named parameters. Currently the only named parameter passed is C<'text'> which is the text of the error, but others may be available in the future. For example the following code will cause Error.pm to throw objects of the class MyError::Bar by default: sub throw_MyError_Bar { my $args = shift; my $err = MyError::Bar->new(); $err->{'MyBarText'} = $args->{'text'}; return $err; } { local $Error::ObjectifyCallback = \&throw_MyError_Bar; # Error handling here. } =head1 MESSAGE HANDLERS C<Error> also provides handlers to extend the output of the C<warn()> perl function, and to handle the printing of a thrown C<Error> that is not caught or otherwise handled. These are not installed by default, but are requested using the C<:warndie> tag in the C<use> line. use Error qw( :warndie ); These new error handlers are installed in C<$SIG{__WARN__}> and C<$SIG{__DIE__}>. If these handlers are already defined when the tag is imported, the old values are stored, and used during the new code. Thus, to arrange for custom handling of warnings and errors, you will need to perform something like the following: BEGIN { $SIG{__WARN__} = sub { print STDERR "My special warning handler: $_[0]" }; } use Error qw( :warndie ); Note that setting C<$SIG{__WARN__}> after the C<:warndie> tag has been imported will overwrite the handler that C<Error> provides. If this cannot be avoided, then the tag can be explicitly C<import>ed later use Error; $SIG{__WARN__} = ...; import Error qw( :warndie ); =head2 EXAMPLE The C<__DIE__> handler turns messages such as Can't call method "foo" on an undefined value at examples/warndie.pl line 16. into Unhandled perl error caught at toplevel: Can't call method "foo" on an undefined value Thrown from: examples/warndie.pl:16 Full stack trace: main::inner('undef') called at examples/warndie.pl line 20 main::outer('undef') called at examples/warndie.pl line 23 =head1 SEE ALSO See L<Exception::Class> for a different module providing Object-Oriented exception handling, along with a convenient syntax for declaring hierarchies for them. It doesn't provide Error's syntactic sugar of C<try { ... }>, C<catch { ... }>, etc. which may be a good thing or a bad thing based on what you want. (Because Error's syntactic sugar tends to break.) L<Error::Exception> aims to combine L<Error> and L<Exception::Class> "with correct stringification". L<TryCatch> and L<Try::Tiny> are similar in concept to Error.pm only providing a syntax that hopefully breaks less. =head1 KNOWN BUGS None, but that does not mean there are not any. =head1 AUTHORS Graham Barr <gbarr@pobox.com> The code that inspired me to write this was originally written by Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick <jglick@sig.bsh.com>. C<:warndie> handlers added by Paul Evans <leonerd@leonerd.org.uk> =head1 MAINTAINER Shlomi Fish, L<http://www.shlomifish.org/> . =head1 PAST MAINTAINERS Arun Kumar U <u_arunkumar@yahoo.com> =head1 COPYRIGHT Copyright (c) 1997-8 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Websites The following websites have more information about this module, and may be of help to you. As always, in addition to those websites please use your favorite search engine to discover more resources. =over 4 =item * MetaCPAN A modern, open-source CPAN search engine, useful to view POD in HTML format. L<https://metacpan.org/release/Error> =item * Search CPAN The default CPAN search engine, useful to view POD in HTML format. L<http://search.cpan.org/dist/Error> =item * RT: CPAN's Bug Tracker The RT ( Request Tracker ) website is the default bug/issue tracking system for CPAN. L<https://rt.cpan.org/Public/Dist/Display.html?Name=Error> =item * CPAN Ratings The CPAN Ratings is a website that allows community ratings and reviews of Perl modules. L<http://cpanratings.perl.org/d/Error> =item * CPANTS The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution. L<http://cpants.cpanauthors.org/dist/Error> =item * CPAN Testers The CPAN Testers is a network of smoke testers who run automated tests on uploaded CPAN distributions. L<http://www.cpantesters.org/distro/E/Error> =item * CPAN Testers Matrix The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms. L<http://matrix.cpantesters.org/?dist=Error> =item * CPAN Testers Dependencies The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution. L<http://deps.cpantesters.org/?module=Error> =back =head2 Bugs / Feature Requests Please report any bugs or feature requests by email to C<bug-error at rt.cpan.org>, or through the web interface at L<https://rt.cpan.org/Public/Bug/Report.html?Queue=Error>. You will be automatically notified of any progress on the request by the system. =head2 Source Code The code is open to the world, and available for you to hack on. Please feel free to browse it and play with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull from your repository :) L<https://github.com/shlomif/perl-error.pm> git clone git://github.com/shlomif/perl-error.pm.git =head1 AUTHOR Shlomi Fish ( http://www.shlomifish.org/ ) =head1 BUGS Please report any bugs or feature requests on the bugtracker website L<https://github.com/shlomif/perl-error.pm/issues> When submitting a bug or request, please include a test-file or a patch to an existing test-file that illustrates the bug or desired feature. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2020 by Shlomi Fish ( http://www.shlomifish.org/ ). This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut PK ! A�g? g? HTTP/Request/Common.pmnu �[��� PK ! �69( B B �? HTTP/Response.pmnu �[��� PK ! �-�Bb Bb � HTTP/Headers.pmnu �[��� PK ! ����" �" �� HTTP/Request.pmnu �[��� PK ! U�S�l. l. � HTTP/Date.pmnu �[��� PK ! (o۔�2 �2 Y6 HTTP/Status.pmnu �[��� PK ! �[��j{ j{ Zi HTTP/Message.pmnu �[��� PK ! K=�� � � HTTP/Headers/Util.pmnu �[��� PK ! �-�y. . '� HTTP/Headers/Auth.pmnu �[��� PK ! ����� � � HTTP/Headers/ETag.pmnu �[��� PK ! h�{�%. %. � HTTP/Config.pmnu �[��� PK ! +z 6; DebianLinux.pmnu �[��� PK ! Ӭ�ӯ � & �P Debconf/Element/Noninteractive/Note.pmnu �[��� PK ! !���� � * �Q Debconf/Element/Noninteractive/Password.pmnu �[��� PK ! }V�� * �R Debconf/Element/Noninteractive/Progress.pmnu �[��� PK ! �� Z Z ( T Debconf/Element/Noninteractive/Select.pmnu �[��� PK ! y6 � � & �V Debconf/Element/Noninteractive/Text.pmnu �[��� PK ! cb�� � ) �W Debconf/Element/Noninteractive/Boolean.pmnu �[��� PK ! 0� � � - �X Debconf/Element/Noninteractive/Multiselect.pmnu �[��� PK ! �w� � ( Z Debconf/Element/Noninteractive/String.pmnu �[��� PK ! ��Ҝ� � ' [ Debconf/Element/Noninteractive/Error.pmnu �[��� PK ! qzIw� � �a Debconf/Element/Web/Note.pmnu �[��� PK ! M�G�� � �b Debconf/Element/Web/Password.pmnu �[��� PK ! ]�p� � e Debconf/Element/Web/Progress.pmnu �[��� PK ! 6"��m m >f Debconf/Element/Web/Select.pmnu �[��� PK ! Q��@; ; �i Debconf/Element/Web/Text.pmnu �[��� PK ! ��]� � ~k Debconf/Element/Web/Boolean.pmnu �[��� PK ! ��W� � " `n Debconf/Element/Web/Multiselect.pmnu �[��� PK ! �� � pr Debconf/Element/Web/String.pmnu �[��� PK ! <f� � �t Debconf/Element/Web/Error.pmnu �[��� PK ! ��߾ � |u Debconf/Element/Select.pmnu �[��� PK ! l�5�� � �} Debconf/Element/Editor/Note.pmnu �[��� PK ! ���ë � " u~ Debconf/Element/Editor/Password.pmnu �[��� PK ! �m�� � " r Debconf/Element/Editor/Progress.pmnu �[��� PK ! �6�B B �� Debconf/Element/Editor/Select.pmnu �[��� PK ! �t�C< < A� Debconf/Element/Editor/Text.pmnu �[��� PK ! � ��� � ! ˅ Debconf/Element/Editor/Boolean.pmnu �[��� PK ! � � � % � Debconf/Element/Editor/Multiselect.pmnu �[��� PK ! F%�s� � �� Debconf/Element/Editor/String.pmnu �[��� PK ! �� � �� Debconf/Element/Editor/Error.pmnu �[��� PK ! UJ d4 4 � Debconf/Element/Gnome/Note.pmnu �[��� PK ! X��D D ! r� Debconf/Element/Gnome/Password.pmnu �[��� PK ! ihE Y Y ! � Debconf/Element/Gnome/Progress.pmnu �[��� PK ! �]�� � �� Debconf/Element/Gnome/Select.pmnu �[��� PK ! � " " Π Debconf/Element/Gnome/Text.pmnu �[��� PK ! xP�֬ � =� Debconf/Element/Gnome/Boolean.pmnu �[��� PK ! �t�� � $ 9� Debconf/Element/Gnome/Multiselect.pmnu �[��� PK ! Y�KO� � :� Debconf/Element/Gnome/String.pmnu �[��� PK ! ��J� � � Debconf/Element/Gnome/Error.pmnu �[��� PK ! � 7 7 � Debconf/Element/Gnome.pmnu �[��� PK ! ��U�� � m� Debconf/Element/Multiselect.pmnu �[��� PK ! �ۯJ J O� Debconf/Element/Dialog/Note.pmnu �[��� PK ! H�Ce� � " �� Debconf/Element/Dialog/Password.pmnu �[��� PK ! !���6 6 " �� Debconf/Element/Dialog/Progress.pmnu �[��� PK ! ��/B� � s� Debconf/Element/Dialog/Select.pmnu �[��� PK ! � 7�J J [� Debconf/Element/Dialog/Text.pmnu �[��� PK ! ��h�� � ! �� Debconf/Element/Dialog/Boolean.pmnu �[��� PK ! �XcA� � % � Debconf/Element/Dialog/Multiselect.pmnu �[��� PK ! ��5 �� Debconf/Element/Dialog/String.pmnu �[��� PK ! <_��K K b� Debconf/Element/Dialog/Error.pmnu �[��� PK ! ���� � �� Debconf/Element/Teletype/Note.pmnu �[��� PK ! �Otu u $ �� Debconf/Element/Teletype/Password.pmnu �[��� PK ! ��% % $ �� Debconf/Element/Teletype/Progress.pmnu �[��� PK ! �zs� � " !� Debconf/Element/Teletype/Select.pmnu �[��� PK ! ]zL; ; O Debconf/Element/Teletype/Text.pmnu �[��� PK ! �ޫ� � # � Debconf/Element/Teletype/Boolean.pmnu �[��� PK ! a?�� � ' � Debconf/Element/Teletype/Multiselect.pmnu �[��� PK ! i �= = " � Debconf/Element/Teletype/String.pmnu �[��� PK ! ��� � ! � Debconf/Element/Teletype/Error.pmnu �[��� PK ! �/X\V V ! � Debconf/Element/Noninteractive.pmnu �[��� PK ! n u u ' Debconf/FrontEnd/Editor.pmnu �[��� PK ! ��Yq q � Debconf/FrontEnd/ScreenSize.pmnu �[��� PK ! ;-*�% % �" Debconf/FrontEnd/Teletype.pmnu �[��� PK ! ~#��� � ) Debconf/FrontEnd/Dialog.pmnu �[��� PK ! ��� �G Debconf/FrontEnd/Readline.pmnu �[��� PK ! ,U`�\ \ aV Debconf/FrontEnd/Gnome.pmnu �[��� PK ! (� �� � t Debconf/FrontEnd/Text.pmnu �[��� PK ! �]\�% % �t Debconf/FrontEnd/Kde.pmnu �[��� PK ! I44y� � U} Debconf/FrontEnd/Passthrough.pmnu �[��� PK ! Yh� � � " �� Debconf/FrontEnd/Noninteractive.pmnu �[��� PK ! ����i i ̜ Debconf/FrontEnd/Web.pmnu �[��� PK ! ϵ� |� Debconf/Template.pmnu �[��� PK ! ��PF[ [ �� Debconf/Format/822.pmnu �[��� PK ! �gS� � h� Debconf/Iterator.pmnu �[��� PK ! ɗ|�� � q� Debconf/Element.pmnu �[��� PK ! �0t�f f w� Debconf/DbDriver/Backup.pmnu �[��� PK ! ���s� � '� Debconf/DbDriver/DirTree.pmnu �[��� PK ! �߶ � 8� Debconf/DbDriver/Debug.pmnu �[��� PK ! ���t t 7� Debconf/DbDriver/Directory.pmnu �[��� PK ! )��&� � �� Debconf/DbDriver/File.pmnu �[��� PK ! ��/zW W � Debconf/DbDriver/PackageDir.pmnu �[��� PK ! ��R R o Debconf/DbDriver/LDAP.pmnu �[��� PK ! Tu� � � * Debconf/DbDriver/Pipe.pmnu �[��� PK ! ��ۙ� � H1 Debconf/DbDriver/Copy.pmnu �[��� PK ! ųb�� � F5 Debconf/DbDriver/Cache.pmnu �[��� PK ! �A�_� � hH Debconf/DbDriver/Stack.pmnu �[��� PK ! a�^= = 9] Debconf/ConfModule.pmnu �[��� PK ! �5G� � �� Debconf/Format.pmnu �[��� PK ! h�z� � [� Debconf/Question.pmnu �[��� PK ! 5 H�v v �� Debconf/TmpFile.pmnu �[��� PK ! ���� � A� Debconf/Log.pmnu �[��� PK ! e�Jb� � � Debconf/Base.pmnu �[��� PK ! ���- - C� Debconf/Gettext.pmnu �[��� PK ! �l��< < �� Debconf/Client/ConfModule.pmnu �[��� PK ! ��A=< < :� Debconf/DbDriver.pmnu �[��� PK ! � ��# # �� Debconf/Path.pmnu �[��� PK ! @��� � � Debconf/Config.pmnu �[��� PK ! Z�[0 0 M� Debconf/FrontEnd.pmnu �[��� PK ! M6�T T �� Debconf/Template/Transient.pmnu �[��� PK ! ���� � a Debconf/Encoding.pmnu �[��� PK ! ��ʲ � s Debconf/Db.pmnu �[��� PK ! X#O� � b Debconf/Priority.pmnu �[��� PK ! ��O� � ' Debconf/AutoSelect.pmnu �[��� PK ! @{1�� �� URI.pmnu �[��� PK ! � Ƞ TimeDate.pmnu �[��� PK ! �/g�ډ ډ � JSON/backportPP.pmnu �[��� PK ! 6! �� � *, JSON/backportPP/Compat5005.pmnu �[��� PK ! [ ��Q Q l7 JSON/backportPP/Boolean.pmnu �[��� PK ! +�d� � ; JSON/backportPP/Compat5006.pmnu �[��� PK ! �09��� �� IJ Git.pmnu �[��� PK ! #"L L % @ Debian/Debhelper/Sequence/perl_dbi.pmnu �[��� PK ! i�� � , � Debian/Debhelper/Sequence/bash_completion.pmnu �[��� PK ! 'j˝� � � Debian/AdduserCommon.pmnu �[��� PK ! 9�$b b # � Debian/DebConf/Client/ConfModule.pmnu �[��� PK ! L�� � N" Text/WrapI18N.pmnu �[��� PK ! �Y���% �% �; Date/Format.pmnu �[��� PK ! '`=�� � na Date/Language/Occitan.pmnu �[��� PK ! �9 | | ze Date/Language/Romanian.pmnu �[��� PK ! �1UU U ?i Date/Language/Hungarian.pmnu �[��� PK ! ҅�� � �q Date/Language/Austrian.pmnu �[��� PK ! kEY4( ( v Date/Language/Gedeo.pmnu �[��� PK ! d�� � wz Date/Language/Czech.pmnu �[��� PK ! H� � � @� Date/Language/Sidama.pmnu �[��� PK ! |p�0� � [� Date/Language/Tigrinya.pmnu �[��� PK ! ���J� � >� Date/Language/Amharic.pmnu �[��� PK ! U�!�> > � Date/Language/Dutch.pmnu �[��� PK ! ���<� � �� Date/Language/Italian.pmnu �[��� PK ! ϣ�� ǚ Date/Language/German.pmnu �[��� PK ! Ŵ�-� � � Date/Language/Oromo.pmnu �[��� PK ! �t�qh h K� Date/Language/Russian.pmnu �[��� PK ! i[Wj� � �� Date/Language/Somali.pmnu �[��� PK ! 7��m� � ŭ Date/Language/Spanish.pmnu �[��� PK ! f0��� � �� Date/Language/Norwegian.pmnu �[��� PK ! ��� � ݵ Date/Language/English.pmnu �[��� PK ! 4E&S� � � Date/Language/Brazilian.pmnu �[��� PK ! <6�p p ! � Date/Language/TigrinyaEritrean.pmnu �[��� PK ! {K� �� Date/Language/Russian_koi8r.pmnu �[��� PK ! ?� Ob b � Date/Language/Swedish.pmnu �[��� PK ! N�zz �� Date/Language/Afar.pmnu �[��� PK ! p½\� � � Date/Language/French.pmnu �[��� PK ! �po� � " U� Date/Language/TigrinyaEthiopian.pmnu �[��� PK ! ��"h 1� Date/Language/Russian_cp1251.pmnu �[��� PK ! ��D`� � �� Date/Language/Finnish.pmnu �[��� PK ! �_b �� Date/Language/Turkish.pmnu �[��� PK ! �73 � � � Date/Language/Chinese_GB.pmnu �[��� PK ! ��� � �� Date/Language/Chinese.pmnu �[��� PK ! ��C� � Date/Language/Icelandic.pmnu �[��� PK ! (!p c� Date/Language/Greek.pmnu �[��� PK ! ���� � Date/Language/Bulgarian.pmnu �[��� PK ! � �� Date/Language/Danish.pmnu �[��� PK ! U�N��# �# V Date/Parse.pmnu �[��� PK ! �� Wl l 8; Date/Language.pmnu �[��� PK ! �����L �L �E IO/HTML.pmnu �[��� PK ! �n P� � � Time/Zone.pmnu �[��� PK ! �" �P P ߳ Git/IndexInfo.pmnu �[��� PK ! R��T T o� Git/Packet.pmnu �[��� PK ! 9�P�k k � Git/LoadCPAN.pmnu �[��� PK ! ao�� � �� Git/I18N.pmnu �[��� PK ! 6�q�� � �� Git/LoadCPAN/Mail/Address.pmnu �[��� PK ! ��<=� � �� Git/LoadCPAN/Error.pmnu �[��� PK ! H���� � �� PgCommon.pmnu �[��� PK ! ��!�^ �^ &� Config/IniFiles.pmnu �[��� PK ! X��=� =� � CGI.pmnu �[��� PK ! �*I�P� P� �� JSON.pmnu �[��� PK ! x��Uv v � CGI.podnu �[��� PK ! �Wy�� � �� Types/Serialiser/Error.pmnu �[��� PK ! ?��# �# �� Types/Serialiser.pmnu �[��� PK ! ӣ !& !& �� URI/file.pmnu �[��� PK ! � LT� � $ URI/http.pmnu �[��� PK ! ���9� � & URI/_punycode.pmnu �[��� PK ! J�2t� � 6< URI/ldapi.pmnu �[��� PK ! hV�� � *> URI/sips.pmnu �[��� PK ! �l�� � �> URI/telnet.pmnu �[��� PK ! �� � �? URI/pop.pmnu �[��� PK ! h-�� � �D URI/file/FAT.pmnu �[��� PK ! �JL� � �F URI/file/Unix.pmnu �[��� PK ! <��(� � K URI/file/Mac.pmnu �[��� PK ! �{{�1 1 U URI/file/OS2.pmnu �[��� PK ! C �2� � tW URI/file/Base.pmnu �[��� PK ! �!�M� � �] URI/file/Win32.pmnu �[��� PK ! �y��Q Q �d URI/file/QNX.pmnu �[��� PK ! T?�k� � /f URI/rsync.pmnu �[��� PK ! ���� � :g URI/urn/isbn.pmnu �[��� PK ! ΄�� ]q URI/urn/oid.pmnu �[��� PK ! QV � � �r URI/QueryParam.pmnu �[��� PK ! y��[� � � URI/ldaps.pmnu �[��� PK ! ��s �� URI/_idna.pmnu �[��� PK ! �{�l l � URI/ldap.pmnu �[��� PK ! ϝ<� URI/nntp.pmnu �[��� PK ! ��I� � |� URI/news.pmnu �[��� PK ! :ښ_1 1 e� URI/Split.pmnu �[��� PK ! ���~� � Ҫ URI/https.pmnu �[��� PK ! >�\�� � �� URI/Escape.pmnu �[��� PK ! �F� � � p� URI/sip.pmnu �[��� PK ! hj\�k k I� URI/_foreign.pmnu �[��� PK ! ( �Rb b �� URI/sftp.pmnu �[��� PK ! ��-�o o �� URI/URL.pmnu �[��� PK ! �u� 9� URI/Heuristic.pmnu �[��� PK ! kc̥~ ~ �� URI/rtspu.pmnu �[��� PK ! �綧� � �� URI/nntps.pmnu �[��� PK ! �'y y ~ URI/mailto.pmnu �[��� PK ! 1��! 4 URI/urn.pmnu �[��� PK ! �y� � � � URI/_server.pmnu �[��� PK ! �j�5� � � URI/ssh.pmnu �[��� PK ! x�=�� � � URI/_generic.pmnu �[��� PK ! M�[> > �6 URI/data.pmnu �[��� PK ! O-�� � D URI/_query.pmnu �[��� PK ! E.�% 6N URI/WithBase.pmnu �[��� PK ! ]�: �] URI/ftp.pmnu �[��� PK ! ����| | �a URI/gopher.pmnu �[��� PK ! `;z�� � �k URI/_login.pmnu �[��� PK ! [�� �l URI/_userpass.pmnu �[��� PK ! ޜ} } q URI/mms.pmnu �[��� PK ! r�� � �q URI/tn3270.pmnu �[��� PK ! WT�} } �r URI/rtsp.pmnu �[��� PK ! ѻ�F 8s URI/IRI.pmnu �[��� PK ! ��� � �v URI/_ldap.pmnu �[��� PK ! ��g� � y� URI/snews.pmnu �[��� PK ! �m�2� � a� URI/rlogin.pmnu �[��� PK ! ���� � � URI/_segment.pmnu �[��� PK ! � ��'& '& �� CGI/Fast.pmnu �[��� PK ! ZP��� � `� CGI/Pretty.pmnu �[��� PK ! P+��- �- 4� CGI/Util.pmnu �[��� PK ! �=�[D [D � CGI/Cookie.pmnu �[��� PK ! ��� � �' CGI/File/Temp.pmnu �[��� PK ! 9e �SJ SJ �+ CGI/Carp.pmnu �[��� PK ! r��}' }' $v CGI/Push.pmnu �[��� PK ! ��} } ܝ CGI/HTML/Functions.pmnu �[��� PK ! G ":p� p� �� CGI/HTML/Functions.podnu �[��� PK ! uX��A0 A0 T� Encode/Locale.pmnu �[��� PK ! ��W[� � ջ Fh.pmnu �[��� PK ! )l5�� �� �� LWP/media.typesnu �[��� PK ! m�� � � LWP/MediaTypes.pmnu �[��� PK ! �2�� � ƚ Error/Simple.pmnu �[��� PK ! �x�\ \ � HTML/Template.pmnu �[��� PK ! ��a�2 �2 �� HTML/Tagset.pmnu �[��� PK ! �D=� � X� HTML/Template/FAQ.pmnu �[��� PK ! �!�u �u B Error.pmnu �[��� PK � � /S Bv
| ver. 1.4 |
Github
|
.
| PHP 8.3.30 | Генерация страницы: 0.09 |
proxy
|
phpinfo
|
Настройка