diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/site/lib |
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib')
241 files changed, 62080 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Cpanel/JSON/XS.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Cpanel/JSON/XS.pm new file mode 100644 index 0000000000..6154f649ff --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Cpanel/JSON/XS.pm @@ -0,0 +1,2332 @@ +package Cpanel::JSON::XS; +our $VERSION = '4.09'; +our $XS_VERSION = $VERSION; +# $VERSION = eval $VERSION; + +=pod + +=head1 NAME + +Cpanel::JSON::XS - cPanel fork of JSON::XS, fast and correct serializing + +=head1 SYNOPSIS + + use Cpanel::JSON::XS; + + # 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 + + $coder = Cpanel::JSON::XS->new->ascii->pretty->allow_nonref; + $pretty_printed_unencoded = $coder->encode ($perl_scalar); + $perl_scalar = $coder->decode ($unicode_json_text); + + # Note that 5.6 misses most smart utf8 and encoding functionalities + # of newer releases. + + # Note that L<JSON::MaybeXS> will automatically use Cpanel::JSON::XS + # if available, at virtually no speed overhead either, so you should + # be able to just: + + use JSON::MaybeXS; + + # and do the same things, except that you have a pure-perl fallback now. + +=head1 DESCRIPTION + +This module converts Perl data structures to JSON and vice versa. Its +primary goal is to be I<correct> and its secondary goal is to be +I<fast>. To reach the latter goal it was written in C. + +As this is the n-th-something JSON module on CPAN, what was the reason +to write yet another JSON module? While it seems there are many JSON +modules, none of them correctly handle all corner cases, and in most cases +their maintainers are unresponsive, gone missing, or not listening to bug +reports for other reasons. + +See below for the cPanel fork. + +See MAPPING, below, on how Cpanel::JSON::XS maps perl values to JSON +values and vice versa. + +=head2 FEATURES + +=over 4 + +=item * correct Unicode handling + +This module knows how to handle Unicode with Perl version higher than 5.8.5, +documents how and when it does so, and even documents what "correct" means. + +=item * round-trip integrity + +When you serialize a perl data structure using only data types supported +by JSON and Perl, the deserialized data structure is identical on the Perl +level. (e.g. the string "2.0" doesn't suddenly become "2" just because +it looks like a number). There I<are> minor exceptions to this, read the +MAPPING section below to learn about those. + +=item * strict checking of JSON correctness + +There is no guessing, no generating of illegal JSON texts by default, +and only JSON is accepted as input by default. the latter is a security +feature. + +=item * fast + +Compared to other JSON modules and other serializers such as Storable, +this module usually compares favourably in terms of speed, too. + +=item * simple to use + +This module has both a simple functional interface as well as an object +oriented interface. + +=item * reasonably versatile output formats + +You can choose between the most compact guaranteed-single-line format +possible (nice for simple line-based protocols), a pure-ASCII format +(for when your transport is not 8-bit clean, still supports the whole +Unicode range), or a pretty-printed format (for when you want to read that +stuff). Or you can combine those features in whatever way you like. + +=back + +=head2 cPanel fork + +Since the original author MLEHMANN has no public +bugtracker, this cPanel fork sits now on github. + +src repo: L<https://github.com/rurban/Cpanel-JSON-XS> +original: L<http://cvs.schmorp.de/JSON-XS/> + +RT: L<https://github.com/rurban/Cpanel-JSON-XS/issues> +or L<https://rt.cpan.org/Public/Dist/Display.html?Queue=Cpanel-JSON-XS> + +B<Changes to JSON::XS> + +- stricter decode_json() as documented. non-refs are disallowed. + added a 2nd optional argument. decode() honors now allow_nonref. + +- fixed encode of numbers for dual-vars. Different string + representations are preserved, but numbers with temporary strings + which represent the same number are here treated as numbers, not + strings. Cpanel::JSON::XS is a bit slower, but preserves numeric + types better. + +- numbers ending with .0 stay numbers, are not converted to + integers. [#63] dual-vars which are represented as number not + integer (42+"bar" != 5.8.9) are now encoded as number (=> 42.0) + because internally it's now a NOK type. However !!1 which is + wrongly encoded in 5.8 as "1"/1.0 is still represented as integer. + +- different handling of inf/nan. Default now to null, optionally with + stringify_infnan() to "inf"/"nan". [#28, #32] + +- added C<binary> extension, non-JSON and non JSON parsable, allows + C<\xNN> and C<\NNN> sequences. + +- 5.6.2 support; sacrificing some utf8 features (assuming bytes + all-over), no multi-byte unicode characters with 5.6. + +- interop for true/false overloading. JSON::XS, JSON::PP and Mojo::JSON + representations for booleans are accepted and JSON::XS accepts + Cpanel::JSON::XS booleans [#13, #37] + Fixed overloading of booleans. Cpanel::JSON::XS::true stringifies again + to "1", not "true", analog to all other JSON modules. + +- native boolean mapping of yes and no to true and false, as in YAML::XS. + In perl C<!0> is yes, C<!1> is no. + The JSON value true maps to 1, false maps to 0. [#39] + +- support arbitrary stringification with encode, with convert_blessed + and allow_blessed. + +- ithread support. Cpanel::JSON::XS is thread-safe, JSON::XS not + +- is_bool can be called as method, JSON::XS::is_bool not. + +- performance optimizations for threaded Perls + +- relaxed mode, allowing many popular extensions + +- additional fixes for: + + - [cpan #88061] AIX atof without USE_LONG_DOUBLE + + - #10 unshare_hek crash + + - #7, #29 avoid re-blessing where possible. It fails in JSON::XS for + READONLY values, i.e. restricted hashes. + + - #41 overloading of booleans, use the object not the reference. + + - #62 -Dusequadmath conversion and no SEGV. + + - #72 parsing of values followed \0, like 1\0 does fail. + + - #72 parsing of illegal unicode or non-unicode characters. + + - #96 locale-insensitive numeric conversion + +- public maintenance and bugtracker + +- use ppport.h, sanify XS.xs comment styles, harness C coding style + +- common::sense is optional. When available it is not used in the + published production module, just during development and testing. + +- extended testsuite, passes all http://seriot.ch/parsing_json.html + tests. In fact it is the only know JSON decoder which does so, + while also being the fastest. + +- support many more options and methods from JSON::PP: + stringify_infnan, allow_unknown, allow_stringify, allow_barekey, + encode_stringify, allow_bignum, allow_singlequote, sort_by + (partially), escape_slash, convert_blessed, ... optional + decode_json(, allow_nonref) arg. + relaxed implements allow_dupkeys. + +- support all 5 unicode BOM's: UTF-8, UTF-16LE, UTF-16BE, UTF-32LE, + UTF-32BE, encoding internally to UTF-8. + +=cut + +our @ISA = qw(Exporter); +our @EXPORT = qw(encode_json decode_json to_json from_json); + +sub to_json($@) { + if ($] >= 5.008) { + require Carp; + Carp::croak ("Cpanel::JSON::XS::to_json has been renamed to encode_json,". + " either downgrade to pre-2.0 versions of Cpanel::JSON::XS or". + " rename the call"); + } else { + _to_json(@_); + } +} + +sub from_json($@) { + if ($] >= 5.008) { + require Carp; + Carp::croak ("Cpanel::JSON::XS::from_json has been renamed to decode_json,". + " either downgrade to pre-2.0 versions of Cpanel::JSON::XS or". + " rename the call"); + } else { + _from_json(@_); + } +} + +use Exporter; +use XSLoader; + +=head1 FUNCTIONAL INTERFACE + +The following convenience methods are provided by this module. They are +exported by default: + +=over 4 + +=item $json_text = encode_json $perl_scalar, [json_type] + +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 = Cpanel::JSON::XS->new->utf8->encode ($perl_scalar) + +Except being faster. + +For the type argument see L<Cpanel::JSON::XS::Type>. + +=item $perl_scalar = decode_json $json_text [, $allow_nonref ] + +The opposite of C<encode_json>: expects an UTF-8 (binary) string of an +json reference 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 = Cpanel::JSON::XS->new->utf8->decode ($json_text) + +except being faster. + +Note that older decode_json versions in Cpanel::JSON::XS older than +3.0116 and JSON::XS did not set allow_nonref but allowed them due to a +bug in the decoder. + +If the new optional $allow_nonref argument is set and not false, the +allow_nonref option will be set and the function will act is described +as in the relaxed RFC 7159 allowing all values such as objects, +arrays, strings, numbers, "null", "true", and "false". + +=item $is_boolean = Cpanel::JSON::XS::is_bool $scalar + +Returns true if the passed scalar represents either C<JSON::XS::true> +or C<JSON::XS::false>, two constants that act like C<1> and C<0>, +respectively and are used to represent JSON C<true> and C<false> +values in Perl. + +See MAPPING, below, for more information on how JSON values are mapped +to Perl. + +=back + +=head1 DEPRECATED FUNCTIONS + +=over + +=item from_json + +from_json has been renamed to decode_json + +=item to_json + +to_json has been renamed to encode_json + +=back + + +=head1 A FEW NOTES ON UNICODE AND PERL + +Since this often leads to confusion, here are a few very clear words on +how Unicode works in Perl, modulo bugs. + +=over 4 + +=item 1. Perl strings can store characters with ordinal values > 255. + +This enables you to store Unicode characters as single characters in a +Perl string - very natural. + +=item 2. Perl does I<not> associate an encoding with your strings. + +... until you force it to, e.g. when matching it against a regex, or +printing the scalar to a file, in which case Perl either interprets +your string as locale-encoded text, octets/binary, or as Unicode, +depending on various settings. In no case is an encoding stored +together with your data, it is I<use> that decides encoding, not any +magical meta data. + +=item 3. The internal utf-8 flag has no meaning with regards to the +encoding of your string. + +=item 4. A "Unicode String" is simply a string where each character +can be validly interpreted as a Unicode code point. + +If you have UTF-8 encoded data, it is no longer a Unicode string, but +a Unicode string encoded in UTF-8, giving you a binary string. + +=item 5. A string containing "high" (> 255) character values is I<not> +a UTF-8 string. + +=item 6. Unicode noncharacters only warn, as in core. + +The 66 Unicode noncharacters U+FDD0..U+FDEF, and U+*FFFE, U+*FFFF just +warn, see L<http://www.unicode.org/versions/corrigendum9.html>. But +illegal surrogate pairs fail to parse. + +=item 7. Raw non-Unicode characters above U+10FFFF are disallowed. + +Raw non-Unicode characters outside the valid unicode range fail to +parse, because "A string is a sequence of zero or more Unicode +characters" RFC 7159 section 1 and "JSON text SHALL be encoded in +Unicode RFC 7159 section 8.1. We use now the UTF8_DISALLOW_SUPER +flag when parsing unicode. + +=back + +I hope this helps :) + + +=head1 OBJECT-ORIENTED INTERFACE + +The object oriented interface lets you configure your own encoding or +decoding style, within the limits of supported formats. + +=over 4 + +=item $json = new Cpanel::JSON::XS + +Creates a new JSON object that can be used to de/encode JSON +strings. All boolean flags described below are by default I<disabled>. + +The mutators for flags all return the JSON object again and thus calls can +be chained: + + my $json = Cpanel::JSON::XS->new->utf8->space_after->encode ({a => [1,2]}) + => {"a": [1, 2]} + +=item $json = $json->ascii ([$enable]) + +=item $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 C<\uXXXX> (BMP characters) or a double C<\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. + + Cpanel::JSON::XS->new->ascii (1)->encode ([chr 0x10401]) + => ["\ud801\udc01"] + +=item $json = $json->latin1 ([$enable]) + +=item $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. + + Cpanel::JSON::XS->new->latin1->encode (["\x{89}\x{abc}"] + => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) + + +=item $json = $json->binary ([$enable]) + +=item $enabled = $json = $json->get_binary + +If the C<$enable> argument is true (or missing), then the C<encode> +method will not try to detect an UTF-8 encoding in any JSON string, it +will strictly interpret it as byte sequence. The result might contain +new C<\xNN> sequences, which is B<unparsable JSON>. The C<decode> +method forbids C<\uNNNN> sequences and accepts C<\xNN> and octal +C<\NNN> sequences. + +There is also a special logic for perl 5.6 and utf8. 5.6 encodes any +string to utf-8 automatically when seeing a codepoint >= C<0x80> and +< C<0x100>. With the binary flag enabled decode the perl utf8 encoded +string to the original byte encoding and encode this with C<\xNN> +escapes. This will result to the same encodings as with newer +perls. But note that binary multi-byte codepoints with 5.6 will +result in C<illegal unicode character in binary string> errors, +unlike with newer perls. + +If C<$enable> is false, then the C<encode> method will smartly try to +detect Unicode characters unless required by the JSON syntax or other +flags and hex and octal sequences are forbidden. + +See also the section I<ENCODING/CODESET FLAG NOTES> later in this +document. + +The main use for this flag is to avoid the smart unicode detection and +possible double encoding. The disadvantage is that the resulting JSON +text is encoded in new C<\xNN> and in latin1 characters and must +correctly be treated as such when storing and transferring, a rare +encoding for JSON. It will produce non-readable JSON strings in the +browser. 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. The +binary decoding method can also be used when an encoder produced a +non-JSON conformant hex or octal encoding C<\xNN> or C<\NNN>. + + Cpanel::JSON::XS->new->binary->encode (["\x{89}\x{abc}"]) + 5.6: Error: malformed or illegal unicode character in binary string + >=5.8: ['\x89\xe0\xaa\xbc'] + + Cpanel::JSON::XS->new->binary->encode (["\x{89}\x{bc}"]) + => ["\x89\xbc"] + + Cpanel::JSON::XS->new->binary->decode (["\x89\ua001"]) + Error: malformed or illegal unicode character in binary string + + Cpanel::JSON::XS->new->decode (["\x89"]) + Error: illegal hex character in non-binary string + + +=item $json = $json->utf8 ([$enable]) + +=item $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", Cpanel::JSON::XS->new->encode ($object); + +Example, decode UTF-32LE-encoded JSON: + + use Encode; + $object = Cpanel::JSON::XS->new->decode (decode "UTF-32LE", $jsontext); + +=item $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. + +Example, pretty-print some simple structure: + + my $json = Cpanel::JSON::XS->new->pretty(1)->encode ({a => [1,2]}) + => + { + "a" : [ + 1, + 2 + ] + } + + +=item $json = $json->indent ([$enable]) + +=item $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. + +=item $json = $json->indent_length([$number_of_spaces]) + +=item $length = $json->get_indent_length() + +Set the indent length (default C<3>). +This option is only useful when you also enable indent or pretty. +The acceptable range is from 0 (no indentation) to 15 + +=item $json = $json->space_before ([$enable]) + +=item $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"} + +=item $json = $json->space_after ([$enable]) + +=item $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"} + +=item $json = $json->relaxed ([$enable]) + +=item $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 * literal ASCII TAB characters in strings + +Literal ASCII TAB characters are now allowed in strings (and treated as +C<\t>) in relaxed mode. Despite JSON mandates, that TAB character is +substituted for "\t" sequence. + + [ + "Hello\tWorld", + "Hello<TAB>World", # literal <TAB> would not normally be allowed + ] + +=item * allow_singlequote + +Single quotes are accepted instead of double quotes. See the +L</allow_singlequote> option. + + { "foo":'bar' } + { 'foo':"bar" } + { 'foo':'bar' } + +=item * allow_barekey + +Accept unquoted object keys instead of with mandatory double quotes. See the +L</allow_barekey> option. + + { foo:"bar" } + +=item * allow_dupkeys + +Allow decoding of duplicate keys in hashes. By default duplicate keys are forbidden. +See L<http://seriot.ch/parsing_json.php#24>: +RFC 7159 section 4: "The names within an object should be unique." +See the L</allow_dupkeys> option. + +=back + + +=item $json = $json->canonical ([$enable]) + +=item $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. + + +=item $json = $json->sort_by (undef, 0, 1 or a block) + +This currently only (un)sets the C<canonical> option, and ignores +custom sort blocks. + +This setting has no effect when decoding JSON texts. + +This setting has currently no effect on tied hashes. + + +=item $json = $json->escape_slash ([$enable]) + +=item $enabled = $json->get_escape_slash + +According to the JSON Grammar, the I<forward slash> character (U+002F) +C<"/"> need to be escaped. But by default strings are encoded without +escaping slashes in all perl JSON encoders. + +If C<$enable> is true (or missing), then C<encode> will escape slashes, +C<"\/">. + +This setting has no effect when decoding JSON texts. + + +=item $json = $json->unblessed_bool ([$enable]) + +=item $enabled = $json->get_unblessed_bool + + $json = $json->unblessed_bool([$enable]) + +If C<$enable> is true (or missing), then C<decode> will return +Perl non-object boolean variables (1 and 0) for JSON booleans +(C<true> and C<false>). If C<$enable> is false, then C<decode> +will return C<Cpanel::JSON::XS::Boolean> objects for JSON booleans. + + +=item $json = $json->allow_singlequote ([$enable]) + +=item $enabled = $json->get_allow_singlequote + + $json = $json->allow_singlequote([$enable]) + +If C<$enable> is true (or missing), then C<decode> will accept +JSON strings quoted by single quotations that are invalid JSON +format. + + $json->allow_singlequote->decode({"foo":'bar'}); + $json->allow_singlequote->decode({'foo':"bar"}); + $json->allow_singlequote->decode({'foo':'bar'}); + +This is also enabled with C<relaxed>. +As same as the C<relaxed> option, this option may be used to parse +application-specific files written by humans. + + +=item $json = $json->allow_barekey ([$enable]) + +=item $enabled = $json->get_allow_barekey + + $json = $json->allow_barekey([$enable]) + +If C<$enable> is true (or missing), then C<decode> will accept +bare keys of JSON object that are invalid JSON format. + +Same as with the C<relaxed> option, this option may be used to parse +application-specific files written by humans. + + $json->allow_barekey->decode('{foo:"bar"}'); + +=item $json = $json->allow_bignum ([$enable]) + +=item $enabled = $json->get_allow_bignum + + $json = $json->allow_bignum([$enable]) + +If C<$enable> is true (or missing), then C<decode> will convert +the big integer Perl cannot handle as integer into a L<Math::BigInt> +object and convert a floating number (any) into a L<Math::BigFloat>. + +On the contrary, C<encode> converts C<Math::BigInt> objects and +C<Math::BigFloat> objects into JSON numbers with C<allow_blessed> +enable. + + $json->allow_nonref->allow_blessed->allow_bignum; + $bigfloat = $json->decode('2.000000000000000000000000001'); + print $json->encode($bigfloat); + # => 2.000000000000000000000000001 + +See L</MAPPING> about the normal conversion of JSON number. + + +=item $json = $json->allow_bigint ([$enable]) + +This option is obsolete and replaced by allow_bignum. + + +=item $json = $json->allow_nonref ([$enable]) + +=item $enabled = $json->get_allow_nonref + +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: + + Cpanel::JSON::XS->new->allow_nonref->encode ("Hello, World!") + => "Hello, World!" + +=item $json = $json->allow_unknown ([$enable]) + +=item $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_nonref>. + +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. + +=item $json = $json->allow_stringify ([$enable]) + +=item $enabled = $json->get_allow_stringify + +If C<$enable> is true (or missing), then C<encode> will stringify the +non-object perl value or reference. Note that blessed objects are not +included here and are handled separately by C<allow_blessed> and +C<convert_blessed>. String references are stringified to the string +value, other references as in perl. + +This option does not affect C<decode> in any way. + +This option is special to this module, it is not supported by other +encoders. So it is not recommended to use it. + +=item $json = $json->allow_dupkeys ([$enable]) + +=item $enabled = $json->get_allow_dupkeys + +If C<$enable> is true (or missing), then the C<decode> method will not +die when it encounters duplicate keys in a hash. +C<allow_dupkeys> is also enabled in the C<relaxed> mode. + +The JSON spec allows duplicate name in objects but recommends to +disable it, however with Perl hashes they are impossible, parsing +JSON in Perl silently ignores duplicate names, using the last value +found. + +See L<http://seriot.ch/parsing_json.php#24>: +RFC 7159 section 4: "The names within an object should be unique." + +=item $json = $json->allow_blessed ([$enable]) + +=item $enabled = $json->get_allow_blessed + +If C<$enable> is true (or missing), then the C<encode> method will not +barf when it encounters a blessed reference. Instead, the value of the +B<convert_blessed> option will decide whether C<null> (C<convert_blessed> +disabled or no C<TO_JSON> method found) or a representation of the +object (C<convert_blessed> enabled and C<TO_JSON> method found) is being +encoded. Has no effect on C<decode>. + +If C<$enable> is false (the default), then C<encode> will throw an +exception when it encounters a blessed object. + +This setting has no effect on C<decode>. + +=item $json = $json->convert_blessed ([$enable]) + +=item $enabled = $json->get_convert_blessed + +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. If no +C<TO_JSON> method is found, a stringification overload method is tried next. +If both are not found, the value of C<allow_blessed> will decide what +to do. + +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>. + +=item $json = $json->allow_tags ([$enable]) + +=item $enabled = $json->get_allow_tags + +See L<OBJECT SERIALIZATION> 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 serialize 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 deserialize +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. + +=item $json = $json->filter_json_object ([$coderef->($hashref)]) + +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 (i.e. a copy of that scalar to avoid +aliasing) is inserted into the deserialized data structure. If it returns +an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the +original deserialized 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 deserialized hash in any +way. + +Example, convert all JSON objects into the integer 5: + + my $js = Cpanel::JSON::XS->new->filter_json_object (sub { 5 }); + # returns [5] + $js->decode ('[{}]') + # throw an exception because allow_nonref is not enabled + # so a lone 5 is not allowed. + $js->decode ('{"a":1, "b":2}'); + +=item $json = $json->filter_json_single_key_object ($key [=> $coderef->($value)]) + +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 serialize 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 serialized 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}: + Cpanel::JSON::XS + ->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 serialization to json: + sub WidgetBase::TO_JSON { + my ($self) = @_; + + unless ($self->{id}) { + $self->{id} = ..get..some..id..; + $WIDGET{$self->{id}} = $self; + } + + { __widget__ => $self->{id} } + } + +=item $json = $json->shrink ([$enable]) + +=item $enabled = $json->get_shrink + +Perl usually over-allocates memory a bit when allocating space for +strings. This flag optionally resizes strings generated by either +C<encode> or C<decode> to their minimum size possible. This can save +memory when your JSON texts are either very very long or you have many +short strings. It will also try to downgrade any strings to octet-form +if possible: perl stores strings internally either in an encoding called +UTF-X or in octet-form. The latter cannot store everything but uses less +space in general (and some buggy Perl or C code might even rely on that +internal representation being used). + +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 true (or missing), the string returned by C<encode> will +be shrunk-to-fit, while all strings generated by C<decode> will also be +shrunk-to-fit. + +If C<$enable> is false, then the normal perl allocation algorithms are used. +If you work with your data, then this is likely to be faster. + +In the future, this setting might control other things, such as converting +strings that look like integers or floats into integers or floats +internally (there is no difference on the Perl level), saving space. + +=item $json = $json->max_depth ([$maximum_nesting_depth]) + +=item $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. + +Note that nesting is implemented by recursion in C. The default value has +been chosen to be as large as typical operating systems allow without +crashing. + +See SECURITY CONSIDERATIONS, below, for more info on why this is useful. + +=item $json = $json->max_size ([$maximum_string_size]) + +=item $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</SECURITY CONSIDERATIONS>, below, for more info on why this is useful. + +=item $json->stringify_infnan ([$infnan_mode = 1]) + +=item $infnan_mode = $json->get_stringify_infnan + +Get or set how Cpanel::JSON::XS encodes C<inf>, C<-inf> or C<nan> for numeric +values. Also qnan, snan or negative nan on some platforms. + +C<null>: infnan_mode = 0. Similar to most JSON modules in other languages. +Always null. + +stringified: infnan_mode = 1. As in Mojo::JSON. Platform specific strings. +Stringified via sprintf(%g), with double quotes. + +inf/nan: infnan_mode = 2. As in JSON::XS, and older releases. +Passes through platform dependent values, invalid JSON. Stringified via +sprintf(%g), but without double quotes. + +"inf/-inf/nan": infnan_mode = 3. Platform independent inf/nan/-inf +strings. No QNAN/SNAN/negative NAN support, unified to "nan". Much +easier to detect, but may conflict with valid strings. + +=item $json_text = $json->encode ($perl_scalar) + +Converts the given Perl data structure (a simple scalar or a reference +to a hash or array) to its JSON representation. Simple scalars will be +converted into JSON string or number sequences, while references to +arrays become JSON arrays and references to hashes become JSON +objects. Undefined Perl values (e.g. C<undef>) become JSON C<null> +values. Neither C<true> nor C<false> values will be generated. + +=item $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. + +JSON numbers and strings become simple Perl scalars. JSON arrays become +Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes +C<1>, C<false> becomes C<0> and C<null> becomes C<undef>. + +=item ($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. + + Cpanel::JSON::XS->new->decode_prefix ("[1] the tail") + => ([1], 3) + +=item $json->to_json ($perl_hash_or_arrayref) + +Deprecated method for perl 5.8 and newer. Use L<encode_json> instead. + +=item $json->from_json ($utf8_encoded_json_text) + +Deprecated method for perl 5.8 and newer. Use L<decode_json> instead. + +=back + + +=head1 INCREMENTAL PARSING + +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). + +Cpanel::JSON::XS 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. + +=over 4 + +=item [void, scalar or list context] = $json->incr_parse ([$string]) + +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 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 = Cpanel::JSON::XS->new->incr_parse ("[5][7][1,2]"); + +=item $lvalue_string = $json->incr_text (>5.8 only) + +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, and +2. only with Perl >= 5.8 + +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. + +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). + +=item $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. + +=item $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. + +=back + +=head2 LIMITATIONS + +All options that affect decoding are supported, except +C<allow_nonref>. The reason for this is that it cannot be made to work +sensibly: JSON objects and arrays are self-delimited, i.e. you can +concatenate them back to back and still decode them perfectly. This +does not hold true for JSON numbers, however. + +For example, is the string C<1> a single JSON number, or is it simply +the start of C<12>? Or is C<12> a single JSON number, or the +concatenation of C<1> and C<2>? In neither case you can tell, and this +is why Cpanel::JSON::XS takes the conservative route and disallows +this case. + +=head2 EXAMPLES + +Some examples will make all this clearer. First, a simple example that +works similarly to C<decode_prefix>: We want to decode the JSON object at +the start of a string and identify the portion after the JSON object: + + my $text = "[1,2,3] hello"; + + my $json = new Cpanel::JSON::XS; + + my $obj = $json->incr_parse ($text) + or die "expected JSON object or array at beginning of string"; + + my $tail = $json->incr_text; + # $tail now contains " hello" + +Easy, isn't it? + +Now for a more complicated example: Imagine a hypothetical protocol where +you read some requests from a TCP stream, and each request is a JSON +array, without any separation between them (in fact, it is often useful to +use newlines as "separators", as these get interpreted as whitespace at +the start of the JSON text, which makes it possible to test said protocol +with C<telnet>...). + +Here is how you'd do it (it is trivial to write this in an event-based +manner): + + my $json = new Cpanel::JSON::XS; + + # read some data from the socket + while (sysread $socket, my $buf, 4096) { + + # split and decode as many requests as possible + for my $request ($json->incr_parse ($buf)) { + # act on the $request + } + } + +Another complicated example: Assume you have a string with JSON objects +or arrays, all separated by (optional) comma characters (e.g. C<[1],[2], +[3]>). To parse them, we have to skip the commas between the JSON texts, +and here is where the lvalue-ness of C<incr_text> comes in useful: + + my $text = "[1],[2], [3]"; + my $json = new Cpanel::JSON::XS; + + # void context, so no parsing done + $json->incr_parse ($text); + + # now extract as many objects as possible. note the + # use of scalar context so incr_text can be called. + while (my $obj = $json->incr_parse) { + # do something with $obj + + # now skip the optional comma + $json->incr_text =~ s/^ \s* , //x; + } + +Now lets go for a very complex example: Assume that you have a gigantic +JSON array-of-objects, many gigabytes in size, and you want to parse it, +but you cannot load it into memory fully (this has actually happened in +the real world :). + +Well, you lost, you have to implement your own JSON parser. But +Cpanel::JSON::XS can still help you: You implement a (very simple) +array parser and let JSON decode the array elements, which are all +full JSON objects on their own (this wouldn't work if the array +elements could be JSON numbers, for example): + + my $json = new Cpanel::JSON::XS; + + # open the monster + open my $fh, "<bigfile.json" + or die "bigfile: $!"; + + # first parse the initial "[" + for (;;) { + sysread $fh, my $buf, 65536 + or die "read error: $!"; + $json->incr_parse ($buf); # void context, so no parsing + + # Exit the loop once we found and removed(!) the initial "[". + # In essence, we are (ab-)using the $json object as a simple scalar + # we append data to. + last if $json->incr_text =~ s/^ \s* \[ //x; + } + + # now we have the skipped the initial "[", so continue + # parsing all the elements. + for (;;) { + # in this loop we read data until we got a single JSON object + for (;;) { + if (my $obj = $json->incr_parse) { + # do something with $obj + last; + } + + # add more data + sysread $fh, my $buf, 65536 + or die "read error: $!"; + $json->incr_parse ($buf); # void context, so no parsing + } + + # in this loop we read data until we either found and parsed the + # separating "," between elements, or the final "]" + for (;;) { + # first skip whitespace + $json->incr_text =~ s/^\s*//; + + # if we find "]", we are done + if ($json->incr_text =~ s/^\]//) { + print "finished.\n"; + exit; + } + + # if we find ",", we can continue with the next element + if ($json->incr_text =~ s/^,//) { + last; + } + + # if we find anything else, we have a parse error! + if (length $json->incr_text) { + die "parse error near ", $json->incr_text; + } + + # else add more data + sysread $fh, my $buf, 65536 + or die "read error: $!"; + $json->incr_parse ($buf); # void context, so no parsing + } + +This is a complex example, but most of the complexity comes from the fact +that we are trying to be correct (bear with me if I am wrong, I never ran +the above example :). + +=head1 BOM + +Detect all unicode B<Byte Order Marks> on decode. +Which are UTF-8, UTF-16LE, UTF-16BE, UTF-32LE and UTF-32BE. + +B<Warning>: With perls older than 5.20 you need load the Encode module +before loading a multibyte BOM, i.e. >= UTF-16. Otherwise an error is +thrown. This is an implementation limitation and might get fixed later. + +See L<https://tools.ietf.org/html/rfc7159#section-8.1> +I<"JSON text SHALL be encoded in UTF-8, UTF-16, or UTF-32."> + +I<"Implementations MUST NOT add a byte order mark to the beginning of a +JSON text", "implementations (...) MAY ignore the presence of a byte +order mark rather than treating it as an error".> + +See also L<http://www.unicode.org/faq/utf_bom.html#BOM>. + +Beware that Cpanel::JSON::XS is currently the only JSON module which +does accept and decode a BOM. + +The latest JSON spec +L<https://www.greenbytes.de/tech/webdav/rfc8259.html#character.encoding> +forbid the usage of UTF-16 or UTF-32, the character encoding is UTF-8. +Thus in subsequent updates BOM's of UTF-16 or UTF-32 will throw an error. + +=head1 MAPPING + +This section describes how Cpanel::JSON::XS 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, Cpanel::JSON::XS 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, C<Cpanel::JSON::XS> only guarantees precision +up to but not including the least significant bit. + +=item true, false + +These JSON atoms become C<Cpanel::JSON::XS::true> and +C<Cpanel::JSON::XS::false>, respectively. They are C<JSON::PP::Boolean> +objects and 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<Cpanel::JSON::XS::is_bool> function. + +The other round, from perl to JSON, C<!0> which is represented as +C<yes> becomes C<true>, and C<!1> which is represented as +C<no> becomes C<false>. + +Via L<Cpanel::JSON::XS::Type> you can now even force negation in C<encode>, +without overloading of C<!>: + + my $false = Cpanel::JSON::XS::false; + print($json->encode([!$false], [JSON_TYPE_BOOL])); + => [true] + +=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 SERIALIZATION>, 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 that can change between runs of the same program but +stays generally the same within a single run of a program. Cpanel::JSON::XS can +optionally sort the hash keys (determined by the I<canonical> flag), so +the same datastructure will serialize to the same JSON text (given same +settings and version of Cpanel::JSON::XS), 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. + +With the option C<allow_stringify>, you can ignore the exception and return +the stringification of the perl value. + +With the option C<allow_unknown>, you can ignore the exception and +return C<null> instead. + + encode_json [\"x"] # => cannot encode reference to scalar 'SCALAR(0x..)' + # unless the scalar is 0 or 1 + encode_json [\0, \1] # yields [false,true] + + allow_stringify->encode_json [\"x"] # yields "x" unlike JSON::PP + allow_unknown->encode_json [\"x"] # yields null as in JSON::PP + +=item Cpanel::JSON::XS::true, Cpanel::JSON::XS::false + +These special values become JSON true and JSON false values, +respectively. You can also use C<\1> and C<\0> or C<!0> and C<!1> +directly if you want. + + encode_json [Cpanel::JSON::XS::true, Cpanel::JSON::XS::true] # yields [false,true] + encode_json [!1, !0] # yields [false,true] + +eq/ne comparisons with true, false: + +false is eq to the empty string or the string 'false' or the special +empty string C<!!0>, i.e. C<SV_NO>, or the numbers 0 or 0.0. + +true is eq to the string 'true' or to the special string C<!0> +(i.e. C<SV_YES>) or to the numbers 1 or 1.0. + +=item blessed objects + +Blessed objects are not directly representable in JSON, but +C<Cpanel::JSON::XS> allows various optional ways of handling +objects. See L<OBJECT SERIALIZATION>, below, for details. + +See the C<allow_blessed> and C<convert_blessed> methods on various +options on how to deal with this: basically, you can choose between +throwing an exception, encoding the reference as if it weren't +blessed, use the objects overloaded stringification method or provide +your own serializer method. + +=item simple scalars + +Simple Perl scalars (any scalar that is not a reference) are the most +difficult objects to encode: Cpanel::JSON::XS will encode undefined +scalars or inf/nan 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, but the two representations are for the same number + print $value; + encode_json [$value] # yields [5] + + # used as different string (non-matching dual-var) + my $str = '0 but true'; + my $num = 1 + $str; + encode_json [$num, $str] # yields [1,"0 but true"] + + # undef becomes null + encode_json [undef] # yields [null] + + # inf or nan becomes null, unless you answered + # "Do you want to handle inf/nan as strings" with yes + encode_json [9**9**9] # 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 + +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. + +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 thus +null is returned instead. Optionally you can configure it to stringify +inf and nan values. + +=back + +=head2 OBJECT SERIALIZATION + +As JSON cannot directly represent Perl objects, you have to choose between +a pure JSON representation (without the ability to deserialize the object +automatically again), and a nonstandard extension to the JSON syntax, +tagged values. + +=head3 SERIALIZATION + +What happens when C<Cpanel::JSON::XS> 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<Cpanel::JSON::XS> uses the L<Types::Serialiser> object +serialization protocol to create 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 serialize, and the second argument being the +constant string C<JSON> to distinguish it from other serializers. + +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, $serializer) = @_; + + ($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 serialized. The fact that these values +originally were L<URI> objects is lost. + + sub URI::TO_JSON { + my ($uri) = @_; + $uri->as_string + } + +=item 2. C<convert_blessed> is enabled and the object has a stringification overload. + +In this case, the overloaded C<""> 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<""> method will convert all L<URI> +objects to JSON strings when serialized. The fact that these values +originally were L<URI> objects is lost. + + package URI; + use overload '""' => sub { shift->as_string }; + +=item 3. C<allow_blessed> is enabled. + +The object will be serialized as a JSON null value. + +=item 4. none of the above + +If none of the settings are enabled or the respective methods are missing, +C<Cpanel::JSON::XS> throws an exception. + +=back + +=head3 DESERIALIZATION + +For deserialization 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 deserialized, 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: I 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<Cpanel::JSON::XS> will look up the C<THAW> method +of the package/classname used during serialization (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<enable_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, $serializer, $type, $id) = @_; + + $class->new (type => $type, id => $id) + } + +See the L</SECURITY CONSIDERATIONS> section below. Allowing external +json objects being deserialized to perl objects is usually a very bad +idea. + + +=head1 ENCODING/CODESET FLAG NOTES + +The interested reader might have seen a number of flags that signify +encodings or codesets - C<utf8>, C<latin1>, C<binary> 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>, C<binary> 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. +With C<binary> enabled, ordinal values > 255 are illegal. + +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>, C<binary> 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> or C<binary> 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 + + +=head2 JSON and ECMAscript + +JSON syntax is based on how literals are represented in javascript (the +not-standardized predecessor of ECMAscript) which is presumably why it is +called "JavaScript Object Notation". + +However, JSON is not a subset (and also not a superset of course) of +ECMAscript (the standard) or javascript (whatever browsers actually +implement). + +If you want to use javascript's C<eval> function to "parse" JSON, you +might run into parse errors for valid JSON texts, or the resulting data +structure might not be queryable: + +One of the problems is that U+2028 and U+2029 are valid characters inside +JSON strings, but are not allowed in ECMAscript string literals, so the +following Perl fragment will not output something that can be guaranteed +to be parsable by javascript's C<eval>: + + use Cpanel::JSON::XS; + + print encode_json [chr 0x2028]; + +The right fix for this is to use a proper JSON parser in your javascript +programs, and not rely on C<eval> (see for example Douglas Crockford's +F<json2.js> parser). + +If this is not an option, you can, as a stop-gap measure, simply encode to +ASCII-only JSON: + + use Cpanel::JSON::XS; + + print Cpanel::JSON::XS->new->ascii->encode ([chr 0x2028]); + +Note that this will enlarge the resulting JSON text quite a bit if you +have many non-ASCII characters. You might be tempted to run some regexes +to only escape U+2028 and U+2029, e.g.: + + # DO NOT USE THIS! + my $json = Cpanel::JSON::XS->new->utf8->encode ([chr 0x2028]); + $json =~ s/\xe2\x80\xa8/\\u2028/g; # escape U+2028 + $json =~ s/\xe2\x80\xa9/\\u2029/g; # escape U+2029 + print $json; + +Note that I<this is a bad idea>: the above only works for U+2028 and +U+2029 and thus only for fully ECMAscript-compliant parsers. Many existing +javascript implementations, however, have issues with other characters as +well - using C<eval> naively simply I<will> cause problems. + +Another problem is that some javascript implementations reserve +some property names for their own purposes (which probably makes +them non-ECMAscript-compliant). For example, Iceweasel reserves the +C<__proto__> property name for its own purposes. + +If that is a problem, you could parse try to filter the resulting JSON +output for these property strings, e.g.: + + $json =~ s/"__proto__"\s*:/"__proto__renamed":/g; + +This works because C<__proto__> is not valid outside of strings, so every +occurrence of C<"__proto__"\s*:> must be a string used as property name. + +Unicode non-characters between U+FFFD and U+10FFFF are decoded either +to the recommended U+FFFD REPLACEMENT CHARACTER (see Unicode PR #121: +Recommended Practice for Replacement Characters), or in the binary or +relaxed mode left as is, keeping the illegal non-characters as before. + +Raw non-Unicode characters outside the valid unicode range fail now to +parse, because "A string is a sequence of zero or more Unicode +characters" RFC 7159 section 1 and "JSON text SHALL be encoded in +Unicode RFC 7159 section 8.1. We use now the UTF8_DISALLOW_SUPER +flag when parsing unicode. + +If you know of other incompatibilities, please let me know. + + +=head2 JSON and YAML + +You often hear that JSON is a subset of YAML. I<in general, there is +no way to configure JSON::XS to output a data structure as valid YAML> +that works in all cases. If you really must use Cpanel::JSON::XS to +generate YAML, you should use this algorithm (subject to change in +future versions): + + my $to_yaml = Cpanel::JSON::XS->new->utf8->space_after (1); + my $yaml = $to_yaml->encode ($ref) . "\n"; + +This will I<usually> generate JSON texts that also parse as valid +YAML. + + +=head2 SPEED + +It seems that JSON::XS is surprisingly fast, as shown in the following +tables. They have been generated with the help of the C<eg/bench> program +in the JSON::XS distribution, to make it easy to compare on your own +system. + +JSON::XS is with L<Data::MessagePack> and L<Sereal> one of the fastest +serializers, because JSON and JSON::XS do not support backrefs (no +graph structures), only trees. Storable supports backrefs, +i.e. graphs. Data::MessagePack encodes its data binary (as Storable) +and supports only very simple subset of JSON. + +First comes a comparison between various modules using +a very short single-line JSON string (also available at +L<http://dist.schmorp.de/misc/json/short.json>). + + {"method": "handleMessage", "params": ["user1", + "we were just talking"], "id": null, "array":[1,11,234,-5,1e5,1e7, + 1, 0]} + +It shows the number of encodes/decodes per second (JSON::XS uses +the functional interface, while Cpanel::JSON::XS/2 uses the OO interface +with pretty-printing and hash key sorting enabled, Cpanel::JSON::XS/3 enables +shrink. JSON::DWIW/DS uses the deserialize function, while JSON::DWIW::FJ +uses the from_json method). Higher is better: + + module | encode | decode | + --------------|------------|------------| + JSON::DWIW/DS | 86302.551 | 102300.098 | + JSON::DWIW/FJ | 86302.551 | 75983.768 | + JSON::PP | 15827.562 | 6638.658 | + JSON::Syck | 63358.066 | 47662.545 | + JSON::XS | 511500.488 | 511500.488 | + JSON::XS/2 | 291271.111 | 388361.481 | + JSON::XS/3 | 361577.931 | 361577.931 | + Storable | 66788.280 | 265462.278 | + --------------+------------+------------+ + +That is, JSON::XS is almost six times faster than JSON::DWIW on encoding, +about five times faster on decoding, and over thirty to seventy times +faster than JSON's pure perl implementation. It also compares favourably +to Storable for small amounts of data. + +Using a longer test string (roughly 18KB, generated from Yahoo! Locals +search API (L<http://dist.schmorp.de/misc/json/long.json>). + + module | encode | decode | + --------------|------------|------------| + JSON::DWIW/DS | 1647.927 | 2673.916 | + JSON::DWIW/FJ | 1630.249 | 2596.128 | + JSON::PP | 400.640 | 62.311 | + JSON::Syck | 1481.040 | 1524.869 | + JSON::XS | 20661.596 | 9541.183 | + JSON::XS/2 | 10683.403 | 9416.938 | + JSON::XS/3 | 20661.596 | 9400.054 | + Storable | 19765.806 | 10000.725 | + --------------+------------+------------+ + +Again, JSON::XS leads by far (except for Storable which non-surprisingly +decodes a bit faster). + +On large strings containing lots of high Unicode characters, some modules +(such as JSON::PC) seem to decode faster than JSON::XS, but the result +will be broken due to missing (or wrong) Unicode handling. Others refuse +to decode or encode properly, so it was impossible to prepare a fair +comparison table for that case. + +For updated graphs see L<https://github.com/Sereal/Sereal/wiki/Sereal-Comparison-Graphs> + + +=head1 INTEROP with JSON and JSON::XS and other JSON modules + +As long as you only serialize data that can be directly expressed in +JSON, C<Cpanel::JSON::XS> is incapable of generating invalid JSON +output (modulo bugs, but C<JSON::XS> has found more bugs in the +official JSON testsuite (1) than the official JSON testsuite has found +in C<JSON::XS> (0)). +C<Cpanel::JSON::XS> is currently the only known JSON decoder which passes all +L<http://seriot.ch/parsing_json.html> tests, while being the fastest also. + +When you have trouble decoding JSON generated by this module using other +decoders, then it is very likely that you have an encoding mismatch or the +other decoder is broken. + +When decoding, C<JSON::XS> is strict by default and will likely catch +all errors. There are currently two settings that change this: +C<relaxed> makes C<JSON::XS> accept (but not generate) some +non-standard extensions, and C<allow_tags> or C<allow_blessed> will +allow you to encode and decode Perl objects, at the cost of being +totally insecure and not outputting valid JSON anymore. + +JSON-XS-3.01 broke interoperability with JSON-2.90 with booleans. See L<JSON>. + +Cpanel::JSON::XS needs to know the JSON and JSON::XS versions to be able work +with those objects, especially when encoding a booleans like C<{"is_true":true}>. +So you need to load these modules before. + +true/false overloading and boolean representations are supported. + +JSON::XS and JSON::PP representations are accepted and older JSON::XS +accepts Cpanel::JSON::XS booleans. All JSON modules JSON, JSON, PP, +JSON::XS, Cpanel::JSON::XS produce JSON::PP::Boolean objects, just +Mojo and JSON::YAJL not. Mojo produces Mojo::JSON::_Bool and +JSON::YAJL::Parser just an unblessed IV. + +Cpanel::JSON::XS accepts JSON::PP::Boolean and Mojo::JSON::_Bool +objects as booleans. + +I cannot think of any reason to still use JSON::XS anymore. + + +=head2 TAGGED VALUE SYNTAX AND STANDARD JSON EN/DECODERS + +When you use C<allow_tags> to use the extended (and also nonstandard +and invalid) JSON syntax for serialized objects, and you still want to +decode the generated serialize objects, you can run a regex to replace +the tagged syntax by standard JSON arrays (it only works for "normal" +package names without comma, newlines or single colons). First, the +readable Perl version: + + # if your FREEZE methods return no values, you need this replace first: + $json =~ s/\( \s* (" (?: [^\\":,]+|\\.|::)* ") \s* \) \s* \[\s*\]/[$1]/gx; + + # this works for non-empty constructor arg lists: + $json =~ s/\( \s* (" (?: [^\\":,]+|\\.|::)* ") \s* \) \s* \[/[$1,/gx; + +And here is a less readable version that is easy to adapt to other +languages: + + $json =~ s/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/[$1,/g; + +Here is an ECMAScript version (same regex): + + json = json.replace (/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/g, "[$1,"); + +Since this syntax converts to standard JSON arrays, it might be hard to +distinguish serialized objects from normal arrays. You can prepend a +"magic number" as first array element to reduce chances of a collision: + + $json =~ s/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/["XU1peReLzT4ggEllLanBYq4G9VzliwKF",$1,/g; + +And after decoding the JSON text, you could walk the data +structure looking for arrays with a first element of +C<XU1peReLzT4ggEllLanBYq4G9VzliwKF>. + +The same approach can be used to create the tagged format with another +encoder. First, you create an array with the magic string as first member, +the classname as second, and constructor arguments last, encode it as part +of your JSON structure, and then: + + $json =~ s/\[\s*"XU1peReLzT4ggEllLanBYq4G9VzliwKF"\s*,\s*("([^\\":,]+|\\.|::)*")\s*,/($1)[/g; + +Again, this has some limitations - the magic string must not be encoded +with character escapes, and the constructor arguments must be non-empty. + + +=head1 RFC7159 + +Since this module was written, Google has written a new JSON RFC, RFC 7159 +(and RFC7158). Unfortunately, this RFC breaks compatibility with both the +original JSON specification on www.json.org and RFC4627. + +As far as I can see, you can get partial compatibility when parsing by +using C<< ->allow_nonref >>. However, consider the security implications +of doing so. + +I haven't decided yet when to break compatibility with RFC4627 by default +(and potentially leave applications insecure) and change the default to +follow RFC7159, but application authors are well advised to call C<< +->allow_nonref(0) >> even if this is the current default, if they cannot +handle non-reference values, in preparation for the day when the default +will change. + +=head1 SECURITY CONSIDERATIONS + +JSON::XS and Cpanel::JSON::XS are not only fast. JSON is generally the +most secure serializing format, because it is the only one besides +Data::MessagePack, which does not deserialize objects per default. For +all languages, not just perl. The binary variant BSON (MongoDB) does +more but is unsafe. + +It is trivial for any attacker to create such serialized objects in +JSON and trick perl into expanding them, thereby triggering certain +methods. Watch L<https://www.youtube.com/watch?v=Gzx6KlqiIZE> for an +exploit demo for "CVE-2015-1592 SixApart MovableType Storable Perl +Code Execution" for a deserializer which expands objects. +Deserializing even coderefs (methods, functions) or external +data would be considered the most dangerous. + +Security relevant overview of serializers regarding deserializing +objects by default: + + Objects Coderefs External Data + + Data::Dumper YES YES YES + Storable YES NO (def) NO + Sereal YES NO NO + YAML YES NO NO + B::C YES YES YES + B::Bytecode YES YES YES + BSON YES YES NO + JSON::SL YES NO YES + JSON NO (def) NO NO + Data::MessagePack NO NO NO + XML NO NO YES + + Pickle YES YES YES + PHP Deserialize YES NO NO + +When you are using JSON in a protocol, talking to untrusted potentially +hostile creatures requires relatively few measures. + +First of all, your JSON decoder should be secure, that is, should not have +any buffer overflows. Obviously, this module should ensure that. + +Second, you need to avoid resource-starving attacks. That means you should +limit the size of JSON texts you accept, or make sure then when your +resources run out, that's just fine (e.g. by using a separate process that +can crash safely). The size of a JSON text in octets or characters is +usually a good indication of the size of the resources required to decode +it into a Perl structure. While JSON::XS can check the size of the JSON +text, it might be too late when you already have it in memory, so you +might want to check the size before you accept the string. + +Third, Cpanel::JSON::XS recurses using the C stack when decoding objects and +arrays. The C stack is a limited resource: for instance, on my amd64 +machine with 8MB of stack size I can decode around 180k nested arrays but +only 14k nested JSON objects (due to perl itself recursing deeply on croak +to free the temporary). If that is exceeded, the program crashes. To be +conservative, the default nesting limit is set to 512. If your process +has a smaller stack, you should adjust this setting accordingly with the +C<max_depth> method. + +Also keep in mind that Cpanel::JSON::XS might leak contents of your Perl data +structures in its error messages, so when you serialize sensitive +information you might want to make sure that exceptions thrown by JSON::XS +will not end up in front of untrusted eyes. + +If you are using Cpanel::JSON::XS to return packets to consumption +by JavaScript scripts in a browser you should have a look at +L<http://blog.archive.jpsykes.com/47/practical-csrf-and-json-security/> to +see whether you are vulnerable to some common attack vectors (which really +are browser design bugs, but it is still you who will have to deal with +it, as major browser developers care only for features, not about getting +security right). You might also want to also look at L<Mojo::JSON> +special escape rules to prevent from XSS attacks. + +=head1 "OLD" VS. "NEW" JSON (RFC 4627 VS. RFC 7159) + +TL;DR: Due to security concerns, Cpanel::JSON::XS will not allow +scalar data in JSON texts by default - you need to create your own +Cpanel::JSON::XS object and enable C<allow_nonref>: + + + my $json = JSON::XS->new->allow_nonref; + + $text = $json->encode ($data); + $data = $json->decode ($text); + +The long version: JSON being an important and supposedly stable format, +the IETF standardized it as RFC 4627 in 2006. Unfortunately the inventor +of JSON Douglas Crockford unilaterally changed the definition of JSON in +javascript. Rather than create a fork, the IETF decided to standardize the +new syntax (apparently, so I as told, without finding it very amusing). + +The biggest difference between the original JSON and the new JSON is that +the new JSON supports scalars (anything other than arrays and objects) at +the top-level of a JSON text. While this is strictly backwards compatible +to older versions, it breaks a number of protocols that relied on sending +JSON back-to-back, and is a minor security concern. + +For example, imagine you have two banks communicating, and on one side, +the JSON coder gets upgraded. Two messages, such as C<10> and C<1000> +might then be confused to mean C<101000>, something that couldn't happen +in the original JSON, because neither of these messages would be valid +JSON. + +If one side accepts these messages, then an upgrade in the coder on either +side could result in this becoming exploitable. + +This module has always allowed these messages as an optional extension, by +default disabled. The security concerns are the reason why the default is +still disabled, but future versions might/will likely upgrade to the newer +RFC as default format, so you are advised to check your implementation +and/or override the default with C<< ->allow_nonref (0) >> to ensure that +future versions are safe. + +=head1 THREADS + +Cpanel::JSON::XS has proper ithreads support, unlike JSON::XS. If you +encounter any bugs with thread support please report them. + +=head1 BUGS + +While the goal of the Cpanel::JSON::XS module is to be correct, that +unfortunately does not mean it's bug-free, only that the author thinks +its design is bug-free. If you keep reporting bugs and tests they will +be fixed swiftly, though. + +Since the JSON::XS author refuses to use a public bugtracker and +prefers private emails, we've setup a tracker at RT, so you might want +to report any issues twice. Once in private to MLEHMANN to be fixed in +JSON::XS and one to our the public tracker. Issues fixed by JSON::XS +with a new release will also be backported to Cpanel::JSON::XS and +5.6.2, as long as cPanel relies on 5.6.2 and Cpanel::JSON::XS as our +serializer of choice. + +L<https://rt.cpan.org/Public/Dist/Display.html?Queue=Cpanel-JSON-XS> + +=head1 LICENSE + +This module is available under the same licences as perl, the Artistic +license and the GPL. + +=cut + +sub allow_bigint { + Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead."); +} + +BEGIN { + package + JSON::PP::Boolean; + + require overload; + + local $^W; # silence redefine warnings. no warnings 'redefine' does not help + &overload::import( 'overload', # workaround 5.6 reserved keyword warning + "0+" => sub { ${$_[0]} }, + "++" => sub { $_[0] = ${$_[0]} + 1 }, + "--" => sub { $_[0] = ${$_[0]} - 1 }, + '""' => sub { ${$_[0]} == 1 ? '1' : '0' }, # GH 29 + 'eq' => sub { + my ($obj, $op) = $_[2] ? ($_[1], $_[0]) : ($_[0], $_[1]); + #warn "eq obj:$obj op:$op len:", length($op) > 0, " swap:$_[2]"; + if (ref $op) { # if 2nd also blessed might recurse endlessly + return $obj ? 1 == $op : 0 == $op; + } + # if string, only accept numbers or true|false or "" (e.g. !!0 / SV_NO) + elsif ($op !~ /^[0-9]+$/) { + return "$obj" eq '1' ? 'true' eq $op : 'false' eq $op || "" eq $op; + } + else { + return $obj ? 1 == $op : 0 == $op; + } + }, + 'ne' => sub { + my ($obj, $op) = $_[2] ? ($_[1], $_[0]) : ($_[0], $_[1]); + #warn "ne obj:$obj op:$op"; + return !($obj eq $op); + }, + fallback => 1); +} + +our ($true, $false); +BEGIN { + if ($INC{'JSON/XS.pm'} + and $INC{'Types/Serialiser.pm'} + and $JSON::XS::VERSION ge "3.00") { + $true = $Types::Serialiser::true; # readonly if loaded by JSON::XS + $false = $Types::Serialiser::false; + } else { + $true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; + $false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; + } +} + +BEGIN { + my $const_true = $true; + my $const_false = $false; + *true = sub () { $const_true }; + *false = sub () { $const_false }; +} + +sub is_bool($) { + shift if @_ == 2; # as method call + (ref($_[0]) and UNIVERSAL::isa( $_[0], JSON::PP::Boolean::)) + or (exists $INC{'Types/Serialiser.pm'} and Types::Serialiser::is_bool($_[0])) +} + +XSLoader::load 'Cpanel::JSON::XS', $XS_VERSION; + +1; + +=head1 SEE ALSO + +The F<cpanel_json_xs> command line utility for quick experiments. + +L<JSON>, L<JSON::XS>, L<JSON::MaybeXS>, L<Mojo::JSON>, L<Mojo::JSON::MaybeXS>, +L<JSON::SL>, L<JSON::DWIW>, L<JSON::YAJL>, L<JSON::Any>, L<Test::JSON>, +L<Locale::Wolowitz>, +L<https://metacpan.org/search?q=JSON> + +L<https://tools.ietf.org/html/rfc7159> + +L<https://tools.ietf.org/html/rfc4627> + + +=head1 AUTHOR + +Reini Urban <rurban@cpan.org> + +Marc Lehmann <schmorp@schmorp.de>, http://home.schmorp.de/ + +=head1 MAINTAINER + +Reini Urban <rurban@cpan.org> + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Cpanel/JSON/XS/Boolean.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Cpanel/JSON/XS/Boolean.pm new file mode 100644 index 0000000000..5b2bf4f48a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Cpanel/JSON/XS/Boolean.pm @@ -0,0 +1,29 @@ +=head1 NAME + +Cpanel::JSON::XS::Boolean - true and false values + +=head1 SYNOPSIS + + # do not "use" yourself + +See L<Cpanel::JSON::XS/"true, false"> + +=head1 DESCRIPTION + +This module exists only to provide overload resolution for Storable +and similar modules and interop with L<JSON::XS> booleans. See +L<Cpanel::JSON::XS> for more info about this class. + +=cut + +use Cpanel::JSON::XS (); + +1; + +=head1 AUTHOR + + Marc Lehmann <schmorp@schmorp.de> + http://home.schmorp.de/ + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Cpanel/JSON/XS/Type.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Cpanel/JSON/XS/Type.pm new file mode 100644 index 0000000000..9367f1b4fa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Cpanel/JSON/XS/Type.pm @@ -0,0 +1,311 @@ +package Cpanel::JSON::XS::Type; + +=pod + +=head1 NAME + +Cpanel::JSON::XS::Type - Type support for JSON encode + +=head1 SYNOPSIS + + use Cpanel::JSON::XS; + use Cpanel::JSON::XS::Type; + + + encode_json([10, "10", 10.25], [JSON_TYPE_INT, JSON_TYPE_INT, JSON_TYPE_STRING]); + # '[10,10,"10.25"]' + + encode_json([10, "10", 10.25], json_type_arrayof(JSON_TYPE_INT)); + # '[10,10,10]' + + encode_json(1, JSON_TYPE_BOOL); + # 'true' + + my $perl_struct = { key1 => 1, key2 => "2", key3 => 1 }; + my $type_spec = { key1 => JSON_TYPE_STRING, key2 => JSON_TYPE_INT, key3 => JSON_TYPE_BOOL }; + my $json_string = encode_json($perl_struct, $type_spec); + # '{"key1":"1","key2":2,"key3":true}' + + my $perl_struct = { key1 => "value1", key2 => "value2", key3 => 0, key4 => 1, key5 => "string", key6 => "string2" }; + my $type_spec = json_type_hashof(JSON_TYPE_STRING); + my $json_string = encode_json($perl_struct, $type_spec); + # '{"key1":"value1","key2":"value2","key3":"0","key4":"1","key5":"string","key6":"string2"}' + + my $perl_struct = { key1 => { key2 => [ 10, "10", 10.6 ] }, key3 => "10.5" }; + my $type_spec = { key1 => json_type_anyof(JSON_TYPE_FLOAT, json_type_hashof(json_type_arrayof(JSON_TYPE_INT))), key3 => JSON_TYPE_FLOAT }; + my $json_string = encode_json($perl_struct, $type_spec); + # '{"key1":{"key2":[10,10,10]},"key3":10.5}' + + + my $value = decode_json('false', 1, my $type); + # $value is 0 and $type is JSON_TYPE_BOOL + + my $value = decode_json('0', 1, my $type); + # $value is 0 and $type is JSON_TYPE_INT + + my $value = decode_json('"0"', 1, my $type); + # $value is 0 and $type is JSON_TYPE_STRING + + my $json_string = '{"key1":{"key2":[10,"10",10.6]},"key3":"10.5"}'; + my $perl_struct = decode_json($json_string, 0, my $type_spec); + # $perl_struct is { key1 => { key2 => [ 10, 10, 10.6 ] }, key3 => 10.5 } + # $type_spec is { key1 => { key2 => [ JSON_TYPE_INT, JSON_TYPE_STRING, JSON_TYPE_FLOAT ] }, key3 => JSON_TYPE_STRING } + +=head1 DESCRIPTION + +This module provides stable JSON type support for the +L<Cpanel::JSON::XS|Cpanel::JSON::XS> encoder which doesn't depend on +any internal perl scalar flags or characteristics. Also it provides +real JSON types for L<Cpanel::JSON::XS|Cpanel::JSON::XS> decoder. + +In most cases perl structures passed to +L<encode_json|Cpanel::JSON::XS/encode_json> come from other functions +or from other modules and caller of Cpanel::JSON::XS module does not +have control of internals or they are subject of change. So it is not +easy to support enforcing types as described in the +L<simple scalars|Cpanel::JSON::XS/simple scalars> section. + +For services based on JSON contents it is sometimes needed to correctly +process and enforce JSON types. + +The function L<decode_json|Cpanel::JSON::XS/decode_json> takes optional +third scalar parameter and fills it with specification of json types. + +The function L<encode_json|Cpanel::JSON::XS/encode_json> takes a perl +structure as its input and optionally also a json type specification in +the second parameter. + +If the specification is not provided (or is undef) internal perl +scalar flags are used for the resulting JSON type. The internal flags +can be changed by perl itself, but also by external modules. Which +means that types in resulting JSON string aren't stable. Specially it +does not work reliable for dual vars and scalars which were used in +both numeric and string operations. See L<simple +scalars|Cpanel::JSON::XS/simple scalars>. + +=head2 JSON type specification for scalars: + +=over 4 + +=item JSON_TYPE_BOOL + +It enforces JSON boolean in resulting JSON, i.e. either C<true> or +C<false>. For determining whether the scalar passed to the encoder +is true, standard perl boolean logic is used. + +=item JSON_TYPE_INT + +It enforces JSON number without fraction part in the resulting JSON. +Equivalent of perl function L<int|perlfunc/int> is used for conversion. + +=item JSON_TYPE_FLOAT + +It enforces JSON number with fraction part in the resulting JSON. +Equivalent of perl operation C<+0> is used for conversion. + +=item JSON_TYPE_STRING + +It enforces JSON string type in the resulting JSON. + +=item JSON_TYPE_NULL + +It represents JSON C<null> value. Makes sense only when passing +perl's C<undef> value. + +=back + +For each type, there also exists a type with the suffix C<_OR_NULL> +which encodes perl's C<undef> into JSON C<null>. Without type with +suffix C<_OR_NULL> perl's C<undef> is converted to specific type +according to above rules. + +=head2 JSON type specification for arrays: + +=over 4 + +=item [...] + +The array must contain the same number of elements as in the perl +array passed for encoding. Each element of the array describes the +JSON type which is enforced for the corresponding element of the +perl array. + +=item json_type_arrayof + +This function takes a JSON type specification as its argument which +is enforced for every element of the passed perl array. + +=back + +=head2 JSON type specification for hashes: + +=over 4 + +=item {...} + +Each hash value for corresponding key describes the JSON type +specification for values of passed perl hash structure. Keys in hash +which are not present in passed perl hash structure are simple +ignored and not used. + +=item json_type_hashof + +This function takes a JSON type specification as its argument which +is enforced for every value of passed perl hash structure. + +=back + +=head2 JSON type specification for alternatives: + +=over 4 + +=item json_type_anyof + +This function takes a list of JSON type alternative specifications +(maximally one scalar, one array, and one hash) as its input and the +JSON encoder chooses one that matches. + +=item json_type_null_or_anyof + +Like L<C<json_type_anyof>|/json_type_anyof>, but scalar can be only +perl's C<undef>. + +=item json_type_weaken + +This function can be used as an argument for L</json_type_arrayof>, +L</json_type_hashof> or L</json_type_anyof> functions to create weak +references suitable for complicated recursive structures. It depends +on L<the weaken function from Scalar::Util|Scalar::Util/weaken> module. +See following example: + + my $struct = { + type => JSON_TYPE_STRING, + array => json_type_arrayof(JSON_TYPE_INT), + }; + $struct->{recursive} = json_type_anyof( + json_type_weaken($struct), + json_type_arrayof(JSON_TYPE_STRING), + ); + +=back + +=head1 AUTHOR + +Pali E<lt>pali@cpan.orgE<gt> + +=head1 COPYRIGHT & LICENSE + +Copyright (c) 2017, GoodData Corporation. All rights reserved. + +This module is available under the same licences as perl, the Artistic +license and the GPL. + +=cut + +use strict; +use warnings; + +BEGIN { + if (eval { require Scalar::Util }) { + Scalar::Util->import('weaken'); + } else { + *weaken = sub($) { die 'Scalar::Util is required for weaken' }; + } +} + +# This exports needed XS constants to perl +use Cpanel::JSON::XS (); + +use Exporter; +our @ISA = qw(Exporter); +our @EXPORT = our @EXPORT_OK = qw( + json_type_arrayof + json_type_hashof + json_type_anyof + json_type_null_or_anyof + json_type_weaken + JSON_TYPE_NULL + JSON_TYPE_BOOL + JSON_TYPE_INT + JSON_TYPE_FLOAT + JSON_TYPE_STRING + JSON_TYPE_BOOL_OR_NULL + JSON_TYPE_INT_OR_NULL + JSON_TYPE_FLOAT_OR_NULL + JSON_TYPE_STRING_OR_NULL + JSON_TYPE_ARRAYOF_CLASS + JSON_TYPE_HASHOF_CLASS + JSON_TYPE_ANYOF_CLASS +); + +use constant JSON_TYPE_WEAKEN_CLASS => 'Cpanel::JSON::XS::Type::Weaken'; + +sub json_type_anyof { + my ($scalar, $array, $hash); + my ($scalar_weaken, $array_weaken, $hash_weaken); + foreach (@_) { + my $type = $_; + my $ref = ref($_); + my $weaken; + if ($ref eq JSON_TYPE_WEAKEN_CLASS) { + $type = ${$type}; + $ref = ref($type); + $weaken = 1; + } + if ($ref eq '') { + die 'Only one scalar type can be specified in anyof' if defined $scalar; + $scalar = $type; + $scalar_weaken = $weaken; + } elsif ($ref eq 'ARRAY' or $ref eq JSON_TYPE_ARRAYOF_CLASS) { + die 'Only one array type can be specified in anyof' if defined $array; + $array = $type; + $array_weaken = $weaken; + } elsif ($ref eq 'HASH' or $ref eq JSON_TYPE_HASHOF_CLASS) { + die 'Only one hash type can be specified in anyof' if defined $hash; + $hash = $type; + $hash_weaken = $weaken; + } else { + die 'Only scalar, array or hash can be specified in anyof'; + } + } + my $type = [$scalar, $array, $hash]; + weaken $type->[0] if $scalar_weaken; + weaken $type->[1] if $array_weaken; + weaken $type->[2] if $hash_weaken; + return bless $type, JSON_TYPE_ANYOF_CLASS; +} + +sub json_type_null_or_anyof { + foreach (@_) { + die 'Scalar cannot be specified in null_or_anyof' if ref($_) eq ''; + } + return json_type_anyof(JSON_TYPE_CAN_BE_NULL, @_); +} + +sub json_type_arrayof { + die 'Exactly one type must be specified in arrayof' if scalar @_ != 1; + my $type = $_[0]; + if (ref($type) eq JSON_TYPE_WEAKEN_CLASS) { + $type = ${$type}; + weaken $type; + } + return bless \$type, JSON_TYPE_ARRAYOF_CLASS; +} + +sub json_type_hashof { + die 'Exactly one type must be specified in hashof' if scalar @_ != 1; + my $type = $_[0]; + if (ref($type) eq JSON_TYPE_WEAKEN_CLASS) { + $type = ${$type}; + weaken $type; + } + return bless \$type, JSON_TYPE_HASHOF_CLASS; +} + +sub json_type_weaken { + die 'Exactly one type must be specified in weaken' if scalar @_ != 1; + die 'Scalar cannot be specfied in weaken' if ref($_[0]) eq ''; + return bless \(my $type = $_[0]), JSON_TYPE_WEAKEN_CLASS; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Format.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Format.pm new file mode 100644 index 0000000000..3a1ea90ef1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Format.pm @@ -0,0 +1,403 @@ +# 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 + + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language.pm new file mode 100644 index 0000000000..02a05e7186 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language.pm @@ -0,0 +1,144 @@ + +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 + +=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 + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Afar.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Afar.pm new file mode 100644 index 0000000000..f67cf37685 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Afar.pm @@ -0,0 +1,49 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Amharic.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Amharic.pm new file mode 100644 index 0000000000..a79984ecff --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Amharic.pm @@ -0,0 +1,87 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Austrian.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Austrian.pm new file mode 100644 index 0000000000..8ff398bd10 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Austrian.pm @@ -0,0 +1,36 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Brazilian.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Brazilian.pm new file mode 100644 index 0000000000..fa4d15fff9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Brazilian.pm @@ -0,0 +1,35 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Bulgarian.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Bulgarian.pm new file mode 100644 index 0000000000..cf3d127486 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Bulgarian.pm @@ -0,0 +1,92 @@ +## +## 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 + + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Chinese.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Chinese.pm new file mode 100644 index 0000000000..abfb3c0572 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Chinese.pm @@ -0,0 +1,36 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Chinese_GB.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Chinese_GB.pm new file mode 100644 index 0000000000..7be0555226 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Chinese_GB.pm @@ -0,0 +1,36 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Czech.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Czech.pm new file mode 100644 index 0000000000..756f5c552f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Czech.pm @@ -0,0 +1,58 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Danish.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Danish.pm new file mode 100644 index 0000000000..c43d08528e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Danish.pm @@ -0,0 +1,36 @@ +##
+## 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;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Dutch.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Dutch.pm new file mode 100644 index 0000000000..219758b4b2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Dutch.pm @@ -0,0 +1,40 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/English.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/English.pm new file mode 100644 index 0000000000..638cb3c2a2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/English.pm @@ -0,0 +1,37 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Finnish.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Finnish.pm new file mode 100644 index 0000000000..415b50c73d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Finnish.pm @@ -0,0 +1,45 @@ +## +## 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;
\ No newline at end of file diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/French.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/French.pm new file mode 100644 index 0000000000..91b414c2eb --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/French.pm @@ -0,0 +1,36 @@ +## +## 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] } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Gedeo.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Gedeo.pm new file mode 100644 index 0000000000..c18ad8cadd --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Gedeo.pm @@ -0,0 +1,51 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/German.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/German.pm new file mode 100644 index 0000000000..11242c4c46 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/German.pm @@ -0,0 +1,37 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Greek.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Greek.pm new file mode 100644 index 0000000000..00f917ce47 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Greek.pm @@ -0,0 +1,91 @@ +## +## 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; + + + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Hungarian.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Hungarian.pm new file mode 100644 index 0000000000..d9c838d15b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Hungarian.pm @@ -0,0 +1,88 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Icelandic.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Icelandic.pm new file mode 100644 index 0000000000..5ca3ee3209 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Icelandic.pm @@ -0,0 +1,36 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Italian.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Italian.pm new file mode 100644 index 0000000000..6db0a8e67c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Italian.pm @@ -0,0 +1,36 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Norwegian.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Norwegian.pm new file mode 100644 index 0000000000..bbd997f0b4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Norwegian.pm @@ -0,0 +1,36 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Oromo.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Oromo.pm new file mode 100644 index 0000000000..b6a6230c87 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Oromo.pm @@ -0,0 +1,37 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Romanian.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Romanian.pm new file mode 100644 index 0000000000..cbd2c8cbc4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Romanian.pm @@ -0,0 +1,37 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Russian.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Russian.pm new file mode 100644 index 0000000000..ca9f414232 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Russian.pm @@ -0,0 +1,49 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Russian_cp1251.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Russian_cp1251.pm new file mode 100644 index 0000000000..cc28e6ed43 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Russian_cp1251.pm @@ -0,0 +1,39 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Russian_koi8r.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Russian_koi8r.pm new file mode 100644 index 0000000000..53de8d0567 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Russian_koi8r.pm @@ -0,0 +1,39 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Sidama.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Sidama.pm new file mode 100644 index 0000000000..bc26d7c3f0 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Sidama.pm @@ -0,0 +1,37 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Somali.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Somali.pm new file mode 100644 index 0000000000..5b2496170e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Somali.pm @@ -0,0 +1,62 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Spanish.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Spanish.pm new file mode 100644 index 0000000000..d464ae78ad --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Spanish.pm @@ -0,0 +1,35 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Swedish.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Swedish.pm new file mode 100644 index 0000000000..8f16594ba7 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Swedish.pm @@ -0,0 +1,41 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Tigrinya.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Tigrinya.pm new file mode 100644 index 0000000000..ce4fcb3a1c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Tigrinya.pm @@ -0,0 +1,58 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/TigrinyaEritrean.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/TigrinyaEritrean.pm new file mode 100644 index 0000000000..7ab8d0fdd1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/TigrinyaEritrean.pm @@ -0,0 +1,93 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/TigrinyaEthiopian.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/TigrinyaEthiopian.pm new file mode 100644 index 0000000000..84fb7237c3 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/TigrinyaEthiopian.pm @@ -0,0 +1,93 @@ +## +## 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Turkish.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Turkish.pm new file mode 100644 index 0000000000..593e20925c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Language/Turkish.pm @@ -0,0 +1,59 @@ +#----------------------------------------------------# +# +# 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__ diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Parse.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Parse.pm new file mode 100644 index 0000000000..12b04c14ad --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Date/Parse.pm @@ -0,0 +1,380 @@ +# 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.30"; + +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($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; + } + } + + $year -= 1900 if defined $year && $year > 1900; + + $zone += 3600 if defined $zone && $dst; + $ss += "0.$frac" if $frac; + + return ($ss,$mm,$hh,$day,$month,$year,$zone); +} +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) = @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); + + 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)>. 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. + +=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 + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Digest/SHA1.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Digest/SHA1.pm new file mode 100644 index 0000000000..bd2647a1de --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Digest/SHA1.pm @@ -0,0 +1,246 @@ +package Digest::SHA1; + +use strict; +use vars qw($VERSION @ISA @EXPORT_OK); + +$VERSION = '2.13'; + +require Exporter; +*import = \&Exporter::import; +@EXPORT_OK = qw(sha1 sha1_hex sha1_base64 sha1_transform); + +require DynaLoader; +@ISA=qw(DynaLoader); + +eval { + require Digest::base; + push(@ISA, 'Digest::base'); +}; +if ($@) { + my $err = $@; + *add_bits = sub { die $err }; +} + +Digest::SHA1->bootstrap($VERSION); + +1; +__END__ + +=head1 NAME + +Digest::SHA1 - Perl interface to the SHA-1 algorithm + +=head1 SYNOPSIS + + # Functional style + use Digest::SHA1 qw(sha1 sha1_hex sha1_base64); + + $digest = sha1($data); + $digest = sha1_hex($data); + $digest = sha1_base64($data); + $digest = sha1_transform($data); + + + # OO style + use Digest::SHA1; + + $sha1 = Digest::SHA1->new; + + $sha1->add($data); + $sha1->addfile(*FILE); + + $sha1_copy = $sha1->clone; + + $digest = $sha1->digest; + $digest = $sha1->hexdigest; + $digest = $sha1->b64digest; + $digest = $sha1->transform; + +=head1 DESCRIPTION + +The C<Digest::SHA1> module allows you to use the NIST SHA-1 message +digest algorithm from within Perl programs. The algorithm takes as +input a message of arbitrary length and produces as output a 160-bit +"fingerprint" or "message digest" of the input. + +In 2005, security flaws were identified in SHA-1, namely that a possible +mathematical weakness might exist, indicating that a stronger hash function +would be desirable. The L<Digest::SHA> module implements the stronger +algorithms in the SHA family. + +The C<Digest::SHA1> module provide a procedural interface for simple +use, as well as an object oriented interface that can handle messages +of arbitrary length and which can read files directly. + +=head1 FUNCTIONS + +The following functions can be exported from the C<Digest::SHA1> +module. No functions are exported by default. + +=over 4 + +=item sha1($data,...) + +This function will concatenate all arguments, calculate the SHA-1 +digest of this "message", and return it in binary form. The returned +string will be 20 bytes long. + +The result of sha1("a", "b", "c") will be exactly the same as the +result of sha1("abc"). + +=item sha1_hex($data,...) + +Same as sha1(), but will return the digest in hexadecimal form. The +length of the returned string will be 40 and it will only contain +characters from this set: '0'..'9' and 'a'..'f'. + +=item sha1_base64($data,...) + +Same as sha1(), but will return the digest as a base64 encoded string. +The length of the returned string will be 27 and it will only contain +characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+' and +'/'. + +Note that the base64 encoded string returned is not padded to be a +multiple of 4 bytes long. If you want interoperability with other +base64 encoded sha1 digests you might want to append the redundant +string "=" to the result. + +=item sha1_transform($data) + +Implements the basic SHA1 transform on a 64 byte block. The $data +argument and the returned $digest are in binary form. This algorithm +is used in NIST FIPS 186-2 + +=back + +=head1 METHODS + +The object oriented interface to C<Digest::SHA1> is described in this +section. After a C<Digest::SHA1> object has been created, you will add +data to it and finally ask for the digest in a suitable format. A +single object can be used to calculate multiple digests. + +The following methods are provided: + +=over 4 + +=item $sha1 = Digest::SHA1->new + +The constructor returns a new C<Digest::SHA1> object which encapsulate +the state of the SHA-1 message-digest algorithm. + +If called as an instance method (i.e. $sha1->new) it will just reset the +state the object to the state of a newly created object. No new +object is created in this case. + +=item $sha1->reset + +This is just an alias for $sha1->new. + +=item $sha1->clone + +This a copy of the $sha1 object. It is useful when you do not want to +destroy the digests state, but need an intermediate value of the +digest, e.g. when calculating digests iteratively on a continuous data +stream. Example: + + my $sha1 = Digest::SHA1->new; + while (<>) { + $sha1->add($_); + print "Line $.: ", $sha1->clone->hexdigest, "\n"; + } + +=item $sha1->add($data,...) + +The $data provided as argument are appended to the message we +calculate the digest for. The return value is the $sha1 object itself. + +All these lines will have the same effect on the state of the $sha1 +object: + + $sha1->add("a"); $sha1->add("b"); $sha1->add("c"); + $sha1->add("a")->add("b")->add("c"); + $sha1->add("a", "b", "c"); + $sha1->add("abc"); + +=item $sha1->addfile($io_handle) + +The $io_handle will be read until EOF and its content appended to the +message we calculate the digest for. The return value is the $sha1 +object itself. + +The addfile() method will croak() if it fails reading data for some +reason. If it croaks it is unpredictable what the state of the $sha1 +object will be in. The addfile() method might have been able to read +the file partially before it failed. It is probably wise to discard +or reset the $sha1 object if this occurs. + +In most cases you want to make sure that the $io_handle is in +C<binmode> before you pass it as argument to the addfile() method. + +=item $sha1->add_bits($data, $nbits) + +=item $sha1->add_bits($bitstring) + +This implementation of SHA-1 only supports byte oriented input so you +might only add bits as multiples of 8. If you need bit level support +please consider using the C<Digest::SHA> module instead. The +add_bits() method is provided here for compatibility with other digest +implementations. See L<Digest> for description of the arguments that +add_bits() take. + +=item $sha1->digest + +Return the binary digest for the message. The returned string will be +20 bytes long. + +Note that the C<digest> operation is effectively a destructive, +read-once operation. Once it has been performed, the C<Digest::SHA1> +object is automatically C<reset> and can be used to calculate another +digest value. Call $sha1->clone->digest if you want to calculate the +digest without reseting the digest state. + +=item $sha1->hexdigest + +Same as $sha1->digest, but will return the digest in hexadecimal +form. The length of the returned string will be 40 and it will only +contain characters from this set: '0'..'9' and 'a'..'f'. + +=item $sha1->b64digest + +Same as $sha1->digest, but will return the digest as a base64 encoded +string. The length of the returned string will be 27 and it will only +contain characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+' +and '/'. + + +The base64 encoded string returned is not padded to be a multiple of 4 +bytes long. If you want interoperability with other base64 encoded +SHA-1 digests you might want to append the string "=" to the result. + +=back + +=head1 SEE ALSO + +L<Digest>, L<Digest::HMAC_SHA1>, L<Digest::SHA>, L<Digest::MD5> + +http://www.itl.nist.gov/fipspubs/fip180-1.htm + +http://en.wikipedia.org/wiki/SHA_hash_functions + +=head1 COPYRIGHT + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + Copyright 1999-2004 Gisle Aas. + Copyright 1997 Uwe Hollerbach. + +=head1 AUTHORS + +Peter C. Gutmann, +Uwe Hollerbach <uh@alumni.caltech.edu>, +Gisle Aas <gisle@aas.no> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/Locale.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/Locale.pm new file mode 100644 index 0000000000..1933778f4b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/Locale.pm @@ -0,0 +1,373 @@ +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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat.pm new file mode 100644 index 0000000000..39432b8f9d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat.pm @@ -0,0 +1,87 @@ +# $File: //member/autrijus/Encode-compat/lib/Encode/compat.pm $ $Author: autrijus $ +# $Revision: #7 $ $Change: 10735 $ $DateTime: 2004/06/03 14:08:57 $ + +package Encode::compat; +$Encode::compat::VERSION = '0.07'; + +use strict; + +if ($] >= 5.007001 or $INC{'Encode.pm'}) { + # nothing happens -- Encode.pm already available. +} +elsif ($] >= 5.006001 and $] <= 5.007) { + require Encode::compat::Alias; + $INC{'Encode/Alias.pm'} = $INC{'Encode/compat/Alias.pm'}; + + require Encode::compat::common; + require Encode::compat::5006001; + $INC{'Encode.pm'} = __FILE__; +} +else { + die "Encode.pm compatibility layer for $] not yet available."; +} + +1; + +__END__ + +=head1 NAME + +Encode::compat - Encode.pm emulation layer + +=head1 VERSION + +This document describes version 0.07 of Encode::compat, released +June 3, 2004. + +=head1 SYNOPSIS + + use Encode::compat; # a no-op for Perl v5.7.1+ + use Encode qw(...); # all constants and imports works transparently + + # use Encode functions as normal + +=head1 DESCRIPTION + +WARNING: THIS IS A PROOF-OF-CONCEPT. Most functions are incomplete. +All implementation details are subject to change! + +This module provide a compatibility layer for B<Encode.pm> users on perl +versions earlier than v5.7.1. It translates whatever call it receives +into B<Text::Iconv>, or (in the future) B<Unicode::MapUTF8> to perform +the actual work. + +The C<is_utf8()>, C<_utf8_on()> and C<_utf8_off()> calls are performed +by the method native to the perl version -- 5.6.1 would use +C<pack>/C<unpack>, 5.6.0 uses C<tr//CU>, etc. + +Theoretically, it could be backported to 5.005 and earlier, with none of +the unicode-related semantics available, and serves only as a +abstraction layer above C<Text::Iconv>, C<Unicode::MapUTF8> and possibly +other transcoding modules. + +=head1 CAVEATS + +Currently, this module only support 5.6.1+, and merely provides the three +utility function above (C<encode()>, C<decode()> and C<from_to()>), with +a very kludgy C<FB_HTMLCREF> fallback against C<latin-1> in +C<from_to()>. + +=head1 SEE ALSO + +L<Encode>, L<perlunicode> + +=head1 AUTHORS + +Autrijus Tang E<lt>autrijus@autrijus.orgE<gt> + +=head1 COPYRIGHT + +Copyright 2002, 2003, 2004 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat/5006001.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat/5006001.pm new file mode 100644 index 0000000000..cbe2d50180 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat/5006001.pm @@ -0,0 +1,32 @@ +# $File: //member/autrijus/Encode-compat/lib/Encode/compat/5006001.pm $ $Author: autrijus $ +# $Revision: #3 $ $Change: 2534 $ $DateTime: 2002/12/02 00:33:16 $ + +package Encode::compat::5006001; +our $VERSION = '0.05'; + +1; + +package Encode; + +use strict; +use base 'Exporter'; +no warnings 'redefine'; + +sub _utf8_on { + $_[0] = pack('U*', unpack('U0U*', $_[0])) +} + +sub _utf8_off { + $_[0] = pack('C*', unpack('C*', $_[0])) +} + +sub is_utf8 { + # XXX: got any better ideas? + use utf8; + foreach my $char (split(//, $_[0])) { + return 1 if ord($char) > 255; + } + return 0; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat/Alias.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat/Alias.pm new file mode 100644 index 0000000000..6e8d74e6a6 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat/Alias.pm @@ -0,0 +1,330 @@ +# $File: //member/autrijus/.vimrc $ $Author: autrijus $ +# $Revision: #1 $ $Change: 1649 $ $DateTime: 2002/10/24 15:21:23 $ + +package Encode::compat::Alias; +our $VERSION = '0.05'; + +1; + +package Encode::Alias; +use strict; +our $VERSION = '0.05'; +our $DEBUG = 0; + +use base qw(Exporter); + +# Public, encouraged API is exported by default + +our @EXPORT = + qw ( + define_alias + find_alias + ); + +our @Alias; # ordered matching list +our %Alias; # cached known aliases + +sub find_alias +{ + my $class = shift; + local $_ = shift; + unless (exists $Alias{$_}) + { + $Alias{$_} = undef; # Recursion guard + for (my $i=0; $i < @Alias; $i += 2) + { + my $alias = $Alias[$i]; + my $val = $Alias[$i+1]; + my $new; + if (ref($alias) eq 'Regexp' && $_ =~ $alias) + { + $DEBUG and warn "eval $val"; + $new = eval $val; + # $@ and warn "$val, $@"; + } + elsif (ref($alias) eq 'CODE') + { + $DEBUG and warn "$alias", "->", "($val)"; + $new = $alias->($val); + } + elsif (lc($_) eq lc($alias)) + { + $new = $val; + } + if (defined($new)) + { + next if $new eq $_; # avoid (direct) recursion on bugs + $DEBUG and warn "$alias, $new"; + my $enc = (ref($new)) ? $new : Encode::find_encoding($new); + if ($enc) + { + $Alias{$_} = $enc; + last; + } + } + } + } + if ($DEBUG){ + my $name; + if (my $e = $Alias{$_}){ + $name = $e->name; + }else{ + $name = ""; + } + warn "find_alias($class, $_)->name = $name"; + } + return $Alias{$_}; +} + +sub define_alias +{ + while (@_) + { + my ($alias,$name) = splice(@_,0,2); + unshift(@Alias, $alias => $name); # newer one has precedence + # clear %Alias cache to allow overrides + if (ref($alias)){ + my @a = keys %Alias; + for my $k (@a){ + if (ref($alias) eq 'Regexp' && $k =~ $alias) + { + $DEBUG and warn "delete \$Alias\{$k\}"; + delete $Alias{$k}; + } + elsif (ref($alias) eq 'CODE') + { + $DEBUG and warn "delete \$Alias\{$k\}"; + delete $Alias{$alias->($name)}; + } + } + }else{ + $DEBUG and warn "delete \$Alias\{$alias\}"; + delete $Alias{$alias}; + } + } +} + +# Allow latin-1 style names as well + # 0 1 2 3 4 5 6 7 8 9 10 +our @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 ); +# Allow winlatin1 style names as well +our %Winlatin2cp = ( + 'latin1' => 1252, + 'latin2' => 1250, + 'cyrillic' => 1251, + 'greek' => 1253, + 'turkish' => 1254, + 'hebrew' => 1255, + 'arabic' => 1256, + 'baltic' => 1257, + 'vietnamese' => 1258, + ); + +init_aliases(); + +sub undef_aliases{ + @Alias = (); + %Alias = (); +} + +sub init_aliases +{ + undef_aliases(); + + # Try all-lower-case version should all else fails + define_alias( qr/^(.*)$/ => '"\L$1"' ); + + # UTF/UCS stuff + define_alias( qr/^UCS-?2-?LE$/i => '"UCS-2LE"' ); + define_alias( qr/^UCS-?2-?(BE)?$/i => '"UCS-2BE"', + qr/^UCS-?4-?(BE|LE)?$/i => 'uc("UTF-32$1")', + qr/^iso-10646-1$/i => '"UCS-2BE"' ); + define_alias( qr/^UTF(16|32)-?BE$/i => '"UTF-$1BE"', + qr/^UTF(16|32)-?LE$/i => '"UTF-$1LE"', + qr/^UTF(16|32)$/i => '"UTF-$1"', + ); + # ASCII + define_alias(qr/^(?:US-?)ascii$/i => '"ascii"'); + define_alias('C' => 'ascii'); + define_alias(qr/\bISO[-_]?646[-_]?US$/i => '"ascii"'); + # Allow variants of iso-8859-1 etc. + define_alias( qr/\biso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' ); + + # At least HP-UX has these. + define_alias( qr/\biso8859(\d+)$/i => '"iso-8859-$1"' ); + + # More HP stuff. + define_alias( qr/\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/i => '"${1}8"' ); + + # The Official name of ASCII. + define_alias( qr/\bANSI[-_]?X3\.4[-_]?1968$/i => '"ascii"' ); + + # This is a font issue, not an encoding issue. + # (The currency symbol of the Latin 1 upper half + # has been redefined as the euro symbol.) + define_alias( qr/^(.+)\@euro$/i => '"$1"' ); + + define_alias( qr/\b(?:iso[-_]?)?latin[-_]?(\d+)$/i + => 'defined $Encode::Alias::Latin2iso[$1] ? "iso-8859-$Encode::Alias::Latin2iso[$1]" : undef' ); + + define_alias( qr/\bwin(latin[12]|cyrillic|baltic|greek|turkish| + hebrew|arabic|baltic|vietnamese)$/ix => + '"cp" . $Encode::Alias::Winlatin2cp{lc($1)}' ); + + # Common names for non-latin prefered MIME names + define_alias( 'ascii' => 'US-ascii', + 'cyrillic' => 'iso-8859-5', + 'arabic' => 'iso-8859-6', + 'greek' => 'iso-8859-7', + 'hebrew' => 'iso-8859-8', + 'thai' => 'iso-8859-11', + 'tis620' => 'iso-8859-11', + ); + + # At least AIX has IBM-NNN (surprisingly...) instead of cpNNN. + # And Microsoft has their own naming (again, surprisingly). + # And windows-* is registered in IANA! + define_alias( qr/\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/i => '"cp$1"'); + + # Sometimes seen with a leading zero. + # define_alias( qr/\bcp037\b/i => '"cp37"'); + + # Mac Mappings + # predefined in *.ucm; unneeded + # define_alias( qr/\bmacIcelandic$/i => '"macIceland"'); + define_alias( qr/^mac_(.*)$/i => '"mac$1"'); + # Ououououou. gone. They are differente! + # define_alias( qr/\bmacRomanian$/i => '"macRumanian"'); + + # Standardize on the dashed versions. + # define_alias( qr/\butf8$/i => 'utf-8' ); + define_alias( qr/\bkoi8r$/i => 'koi8-r' ); + define_alias( qr/\bkoi8u$/i => 'koi8-u' ); + + unless ($Encode::ON_EBCDIC){ + # for Encode::CN + define_alias( qr/\beuc.*cn$/i => '"euc-cn"' ); + define_alias( qr/\bcn.*euc$/i => '"euc-cn"' ); + # define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' ) + # CP936 doesn't have vendor-addon for GBK, so they're identical. + define_alias( qr/^gbk$/i => '"cp936"'); + # This fixes gb2312 vs. euc-cn confusion, practically + define_alias( qr/\bGB[-_ ]?2312(?:\D.*$|$)/i => '"euc-cn"' ); + # for Encode::JP + define_alias( qr/\bjis$/i => '"7bit-jis"' ); + define_alias( qr/\beuc.*jp$/i => '"euc-jp"' ); + define_alias( qr/\bjp.*euc$/i => '"euc-jp"' ); + define_alias( qr/\bujis$/i => '"euc-jp"' ); + define_alias( qr/\bshift.*jis$/i => '"shiftjis"' ); + define_alias( qr/\bsjis$/i => '"shiftjis"' ); + # for Encode::KR + define_alias( qr/\beuc.*kr$/i => '"euc-kr"' ); + define_alias( qr/\bkr.*euc$/i => '"euc-kr"' ); + # This fixes ksc5601 vs. euc-kr confusion, practically + define_alias( qr/(?:x-)?uhc$/i => '"cp949"' ); + define_alias( qr/(?:x-)?windows-949$/i => '"cp949"' ); + define_alias( qr/\bks_c_5601-1987$/i => '"cp949"' ); + # for Encode::TW + define_alias( qr/\bbig-?5$/i => '"big5-eten"' ); + define_alias( qr/\bbig5-?et(?:en)?$/i => '"big5-eten"' ); + define_alias( qr/\btca[-_]?big5$/i => '"big5-eten"' ); + define_alias( qr/\bbig5-?hk(?:scs)?$/i => '"big5-hkscs"' ); + define_alias( qr/\bhk(?:scs)?[-_]?big5$/i => '"big5-hkscs"' ); + } + # utf8 is blessed :) + define_alias( qr/^UTF-8$/i => '"utf8"',); + # At last, Map white space and _ to '-' + define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' ); +} + +1; +__END__ + +# TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8 +# TODO: HP-UX '15' encodings japanese15 korean15 roi15 +# TODO: Cyrillic encoding ISO-IR-111 (useful?) +# TODO: Armenian encoding ARMSCII-8 +# TODO: Hebrew encoding ISO-8859-8-1 +# TODO: Thai encoding TCVN +# TODO: Vietnamese encodings VPS +# TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese +# ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic +# Farsi Georgian Gujarati Gurmukhi Hebrew Japanese +# Kannada Khmer Korean Laotian Malayalam Mongolian +# Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese + +=head1 NAME + +Encode::Alias - alias definitions to encodings + +=head1 SYNOPSIS + + use Encode; + use Encode::Alias; + define_alias( newName => ENCODING); + +=head1 DESCRIPTION + +Allows newName to be used as an alias for ENCODING. ENCODING may be +either the name of an encoding or an encoding object (as described +in L<Encode>). + +Currently I<newName> can be specified in the following ways: + +=over 4 + +=item As a simple string. + +=item As a qr// compiled regular expression, e.g.: + + define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' ); + +In this case, if I<ENCODING> is not a reference, it is C<eval>-ed +in order to allow C<$1> etc. to be substituted. The example is one +way to alias names as used in X11 fonts to the MIME names for the +iso-8859-* family. Note the double quotes inside the single quotes. + +If you are using a regex here, you have to use the quotes as shown or +it won't work. Also note that regex handling is tricky even for the +experienced. Use it with caution. + +=item As a code reference, e.g.: + + define_alias( sub { return /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } , ''); + +In this case, C<$_> will be set to the name that is being looked up and +I<ENCODING> is passed to the sub as its first argument. The example +is another way to alias names as used in X11 fonts to the MIME names +for the iso-8859-* family. + +=back + +=head2 Alias overloading + +You can override predefined aliases by simply applying define_alias(). +The new alias is always evaluated first, and when neccessary, +define_alias() flushes the internal cache to make the new definition +available. + + # redirect SHIFT_JIS to MS/IBM Code Page 932, which is a + # superset of SHIFT_JIS + + define_alias( qr/shift.*jis$/i => '"cp932"' ); + define_alias( qr/sjis$/i => '"cp932"' ); + +If you want to zap all predefined aliases, you can use + + Encode::Alias->undef_aliases; + +to do so. And + + Encode::Alias->init_aliases; + +gets the factory settings back. + +=head1 SEE ALSO + +L<Encode>, L<Encode::Supported> + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat/common.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat/common.pm new file mode 100644 index 0000000000..f9ba21cb67 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Encode/compat/common.pm @@ -0,0 +1,127 @@ +# $File: //member/autrijus/Encode-compat/lib/Encode/compat/common.pm $ $Author: autrijus $ +# $Revision: #7 $ $Change: 10024 $ $DateTime: 2004/02/13 21:42:35 $ + +package Encode::compat::common; +our $VERSION = '0.06'; + +1; + +package Encode; + +use strict; +our $VERSION = '0.06'; + +our @EXPORT = qw( + decode decode_utf8 encode encode_utf8 + encodings find_encoding +); + +use constant DIE_ON_ERR => 1; +use constant WARN_ON_ERR => 2; +use constant RETURN_ON_ERR => 4; +use constant LEAVE_SRC => 8; + +use constant PERLQQ => 256; +use constant HTMLCREF => 512; +use constant XMLCREF => 1024; + +use constant FB_DEFAULT => 0; +use constant FB_CROAK => 1; +use constant FB_QUIET => 4; +use constant FB_WARN => 6; +use constant FB_PERLQQ => 256; +use constant FB_HTMLCREF => 512; +use constant FB_XMLCREF => 1024; + +our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC + PERLQQ HTMLCREF XMLCREF); +our @FB_CONSTS = qw(FB_DEFAULT FB_CROAK FB_QUIET FB_WARN + FB_PERLQQ FB_HTMLCREF FB_XMLCREF); + +our @EXPORT_OK = + ( + qw( + _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit + is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade + ), + @FB_FLAGS, @FB_CONSTS, + ); + +our %EXPORT_TAGS = + ( + all => [ @EXPORT, @EXPORT_OK ], + fallbacks => [ @FB_CONSTS ], + fallback_all => [ @FB_CONSTS, @FB_FLAGS ], + ); + +sub from_to ($$$;$) { + use utf8; + + # XXX: bad hack + if ($_[3] and $_[3] == FB_HTMLCREF() and lc($_[2]) eq 'latin1') { + $_[0] = join('', map { + ord($_) < 128 + ? $_ : '&#' . ord($_) . ';' + } split(//, decode($_[1], $_[0]))); + } + else { + $_[0] = _convert(@_[0..2]); + } +} + +sub encodings { + # XXX: revisit + require Encode::Alias; + return sort values %Encode::Alias::Alias; +} + +sub find_encoding { + return $_[0]; +} + +sub decode_utf8($;$) { + return decode("utf-8", @_); +} + +sub encode_utf8($;$) { + return encode("utf-8", @_); +} + +sub decode($$;$) { + my $result = ($_[0] =~ /utf-?8/i) + ? $_[1] : _convert($_[1], $_[0] => 'utf-8'); + _utf8_on($result); + return $result; +} + +sub encode($$;$) { + my $result = ($_[0] =~ /utf-?8/i) + ? $_[1] : _convert($_[1], 'utf-8' => $_[0]); + _utf8_off($result); + return $result; +} + +{ + my %decoder; + sub _convert { + require Text::Iconv; + Text::Iconv->raise_error(1); + + require Encode::Alias; + my ($from, $to) = map { + s/^utf8$/utf-8/i; + s/^big5-eten$/big5/i; + $_; + } map { + Encode::Alias->find_alias($_) || lc($_) + } ($_[1], $_[2]); + + my $result = ($from eq $to) ? $_[0] : ( + $decoder{$from, $to} ||= Text::Iconv->new( $from, $to ) + )->convert($_[0]); + + return $result; + } +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Listing.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Listing.pm new file mode 100644 index 0000000000..c8d72a7185 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Listing.pm @@ -0,0 +1,435 @@ +package File::Listing; + +sub Version { $VERSION; } +$VERSION = "6.04"; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(parse_dir); + +use strict; + +use Carp (); +use HTTP::Date qw(str2time); + + + +sub parse_dir ($;$$$) +{ + my($dir, $tz, $fstype, $error) = @_; + + $fstype ||= 'unix'; + $fstype = "File::Listing::" . lc $fstype; + + my @args = $_[0]; + push(@args, $tz) if(@_ >= 2); + push(@args, $error) if(@_ >= 4); + + $fstype->parse(@args); +} + + +sub line { Carp::croak("Not implemented yet"); } +sub init { } # Dummy sub + + +sub file_mode ($) +{ + Carp::croak("Input to file_mode() must be a 10 character string.") + unless length($_[0]) == 10; + + # This routine was originally borrowed from Graham Barr's + # Net::FTP package. + + local $_ = shift; + my $mode = 0; + my($type); + + s/^(.)// and $type = $1; + + # When the set-group-ID bit (file mode bit 02000) is set, and the group + # execution bit (file mode bit 00020) is unset, and it is a regular file, + # some implementations of `ls' use the letter `S', others use `l' or `L'. + # Convert this `S'. + + s/[Ll](...)$/S$1/; + + while (/(.)/g) { + $mode <<= 1; + $mode |= 1 if $1 ne "-" && + $1 ne 'S' && + $1 ne 'T'; + } + + $mode |= 0004000 if /^..s....../i; + $mode |= 0002000 if /^.....s.../i; + $mode |= 0001000 if /^........t/i; + + # De facto standard definitions. From 'stat.h' on Solaris 9. + + $type eq "p" and $mode |= 0010000 or # fifo + $type eq "c" and $mode |= 0020000 or # character special + $type eq "d" and $mode |= 0040000 or # directory + $type eq "b" and $mode |= 0060000 or # block special + $type eq "-" and $mode |= 0100000 or # regular + $type eq "l" and $mode |= 0120000 or # symbolic link + $type eq "s" and $mode |= 0140000 or # socket + $type eq "D" and $mode |= 0150000 or # door + Carp::croak("Unknown file type: $type"); + + $mode; +} + + +sub parse +{ + my($pkg, $dir, $tz, $error) = @_; + + # First let's try to determine what kind of dir parameter we have + # received. We allow both listings, reference to arrays and + # file handles to read from. + + if (ref($dir) eq 'ARRAY') { + # Already splitted up + } + elsif (ref($dir) eq 'GLOB') { + # A file handle + } + elsif (ref($dir)) { + Carp::croak("Illegal argument to parse_dir()"); + } + elsif ($dir =~ /^\*\w+(::\w+)+$/) { + # This scalar looks like a file handle, so we assume it is + } + else { + # A normal scalar listing + $dir = [ split(/\n/, $dir) ]; + } + + $pkg->init(); + + my @files = (); + if (ref($dir) eq 'ARRAY') { + for (@$dir) { + push(@files, $pkg->line($_, $tz, $error)); + } + } + else { + local($_); + while (<$dir>) { + chomp; + push(@files, $pkg->line($_, $tz, $error)); + } + } + wantarray ? @files : \@files; +} + + + +package File::Listing::unix; + +use HTTP::Date qw(str2time); + +# A place to remember current directory from last line parsed. +use vars qw($curdir @ISA); + +@ISA = qw(File::Listing); + + + +sub init +{ + $curdir = ''; +} + + +sub line +{ + shift; # package name + local($_) = shift; + my($tz, $error) = @_; + + s/\015//g; + #study; + + my ($kind, $size, $date, $name); + if (($kind, $size, $date, $name) = + /^([\-FlrwxsStTdD]{10}) # Type and permission bits + .* # Graps + \D(\d+) # File size + \s+ # Some space + (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})|\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2}) # Date + \s+ # Some more space + (.*)$ # File name + /x ) + + { + return if $name eq '.' || $name eq '..'; + $name = "$curdir/$name" if length $curdir; + my $type = '?'; + if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) { + $name = $1; + $type = "l $2"; + } + elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file + $type = 'f'; + } + elsif ($kind =~ /^[dD]/) { + $type = 'd'; + $size = undef; # Don't believe the reported size + } + return [$name, $type, $size, str2time($date, $tz), + File::Listing::file_mode($kind)]; + + } + elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) { + my $dir = $1; + return () if $dir eq '.'; + $curdir = $dir; + return (); + } + elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) { + return (); + } + elsif (/not found/ || # OSF1, HPUX, and SunOS return + # "$file not found" + /No such file/ || # IRIX returns + # "UX:ls: ERROR: Cannot access $file: No such file or directory" + # Solaris returns + # "$file: No such file or directory" + /cannot find/ # Windows NT returns + # "The system cannot find the path specified." + ) { + return () unless defined $error; + &$error($_) if ref($error) eq 'CODE'; + warn "Error: $_\n" if $error eq 'warn'; + return (); + } + elsif ($_ eq '') { # AIX, and Linux return nothing + return () unless defined $error; + &$error("No such file or directory") if ref($error) eq 'CODE'; + warn "Warning: No such file or directory\n" if $error eq 'warn'; + return (); + } + else { + # parse failed, check if the dosftp parse understands it + File::Listing::dosftp->init(); + return(File::Listing::dosftp->line($_,$tz,$error)); + } + +} + + + +package File::Listing::dosftp; + +use HTTP::Date qw(str2time); + +# A place to remember current directory from last line parsed. +use vars qw($curdir @ISA); + +@ISA = qw(File::Listing); + + + +sub init +{ + $curdir = ''; +} + + +sub line +{ + shift; # package name + local($_) = shift; + my($tz, $error) = @_; + + s/\015//g; + + my ($date, $size_or_dir, $name, $size); + + # 02-05-96 10:48AM 1415 src.slf + # 09-10-96 09:18AM <DIR> sl_util + if (($date, $size_or_dir, $name) = + /^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM) # Date and time info + \s+ # Some space + (<\w{3}>|\d+) # Dir or Size + \s+ # Some more space + (.+)$ # File name + /x ) + { + return if $name eq '.' || $name eq '..'; + $name = "$curdir/$name" if length $curdir; + my $type = '?'; + if ($size_or_dir eq '<DIR>') { + $type = "d"; + $size = ""; # directories have no size in the pc listing + } + else { + $type = 'f'; + $size = $size_or_dir; + } + return [$name, $type, $size, str2time($date, $tz), undef]; + } + else { + return () unless defined $error; + &$error($_) if ref($error) eq 'CODE'; + warn "Can't parse: $_\n" if $error eq 'warn'; + return (); + } + +} + + + +package File::Listing::vms; +@File::Listing::vms::ISA = qw(File::Listing); + +package File::Listing::netware; +@File::Listing::netware::ISA = qw(File::Listing); + + + +package File::Listing::apache; + +use vars qw(@ISA); + +@ISA = qw(File::Listing); + + +sub init { } + + +sub line { + shift; # package name + local($_) = shift; + my($tz, $error) = @_; # ignored for now... + + s!</?t[rd][^>]*>! !g; # clean away various table stuff + if (m!<A\s+HREF=\"([^\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) { + my($filename, $filesize) = ($1, $7); + my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6); + if ($m =~ /^\d+$/) { + ($d,$y) = ($y,$d) # iso date + } + else { + $m = _monthabbrev_number($m); + } + + $filesize = 0 if $filesize eq '-'; + if ($filesize =~ s/k$//i) { + $filesize *= 1024; + } + elsif ($filesize =~ s/M$//) { + $filesize *= 1024*1024; + } + elsif ($filesize =~ s/G$//) { + $filesize *= 1024*1024*1024; + } + $filesize = int $filesize; + + require Time::Local; + my $filetime = Time::Local::timelocal(0,$M,$H,$d,$m-1,_guess_year($y)-1900); + my $filetype = ($filename =~ s|/$|| ? "d" : "f"); + return [$filename, $filetype, $filesize, $filetime, undef]; + } + + return (); +} + + +sub _guess_year { + my $y = shift; + if ($y >= 90) { + $y = 1900+$y; + } + elsif ($y < 100) { + $y = 2000+$y; + } + $y; +} + + +sub _monthabbrev_number { + my $mon = shift; + +{'Jan' => 1, + 'Feb' => 2, + 'Mar' => 3, + 'Apr' => 4, + 'May' => 5, + 'Jun' => 6, + 'Jul' => 7, + 'Aug' => 8, + 'Sep' => 9, + 'Oct' => 10, + 'Nov' => 11, + 'Dec' => 12, + }->{$mon}; +} + + +1; + +__END__ + +=head1 NAME + +File::Listing - parse directory listing + +=head1 SYNOPSIS + + use File::Listing qw(parse_dir); + $ENV{LANG} = "C"; # dates in non-English locales not supported + for (parse_dir(`ls -l`)) { + ($name, $type, $size, $mtime, $mode) = @$_; + next if $type ne 'f'; # plain file + #... + } + + # directory listing can also be read from a file + open(LISTING, "zcat ls-lR.gz|"); + $dir = parse_dir(\*LISTING, '+0000'); + +=head1 DESCRIPTION + +This module exports a single function called parse_dir(), which can be +used to parse directory listings. + +The first parameter to parse_dir() is the directory listing to parse. +It can be a scalar, a reference to an array of directory lines or a +glob representing a filehandle to read the directory listing from. + +The second parameter is the time zone to use when parsing time stamps +in the listing. If this value is undefined, then the local time zone is +assumed. + +The third parameter is the type of listing to assume. Currently +supported formats are 'unix', 'apache' and 'dosftp'. The default +value is 'unix'. Ideally, the listing type should be determined +automatically. + +The fourth parameter specifies how unparseable lines should be treated. +Values can be 'ignore', 'warn' or a code reference. Warn means that +the perl warn() function will be called. If a code reference is +passed, then this routine will be called and the return value from it +will be incorporated in the listing. The default is 'ignore'. + +Only the first parameter is mandatory. + +The return value from parse_dir() is a list of directory entries. In +a scalar context the return value is a reference to the list. The +directory entries are represented by an array consisting of [ +$filename, $filetype, $filesize, $filetime, $filemode ]. The +$filetype value is one of the letters 'f', 'd', 'l' or '?'. The +$filetime value is the seconds since Jan 1, 1970. The +$filemode is a bitmask like the mode returned by stat(). + +=head1 COPYRIGHT + +Copyright 1996-2010, Gisle Aas + +Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and +Net::FTP's parse_dir (Graham Barr). + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Which.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Which.pm new file mode 100644 index 0000000000..f9fa0be66e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/File/Which.pm @@ -0,0 +1,392 @@ +package File::Which; + +use strict; +use warnings; +use Exporter (); +use File::Spec (); + +# ABSTRACT: Perl implementation of the which utility as an API +our $VERSION = '1.23'; # VERSION + + +our @ISA = 'Exporter'; +our @EXPORT = 'which'; +our @EXPORT_OK = 'where'; + +use constant IS_VMS => ($^O eq 'VMS'); +use constant IS_MAC => ($^O eq 'MacOS'); +use constant IS_WIN => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2'); +use constant IS_DOS => IS_WIN(); +use constant IS_CYG => ($^O eq 'cygwin' || $^O eq 'msys'); + +our $IMPLICIT_CURRENT_DIR = IS_WIN || IS_VMS || IS_MAC; + +# For Win32 systems, stores the extensions used for +# executable files +# For others, the empty string is used +# because 'perl' . '' eq 'perl' => easier +my @PATHEXT = (''); +if ( IS_WIN ) { + # WinNT. PATHEXT might be set on Cygwin, but not used. + if ( $ENV{PATHEXT} ) { + push @PATHEXT, split ';', $ENV{PATHEXT}; + } else { + # Win9X or other: doesn't have PATHEXT, so needs hardcoded. + push @PATHEXT, qw{.com .exe .bat}; + } +} elsif ( IS_VMS ) { + push @PATHEXT, qw{.exe .com}; +} elsif ( IS_CYG ) { + # See this for more info + # http://cygwin.com/cygwin-ug-net/using-specialnames.html#pathnames-exe + push @PATHEXT, qw{.exe .com}; +} + + +sub which { + my ($exec) = @_; + + return undef unless defined $exec; + return undef if $exec eq ''; + + my $all = wantarray; + my @results = (); + + # check for aliases first + if ( IS_VMS ) { + my $symbol = `SHOW SYMBOL $exec`; + chomp($symbol); + unless ( $? ) { + return $symbol unless $all; + push @results, $symbol; + } + } + if ( IS_MAC ) { + my @aliases = split /\,/, $ENV{Aliases}; + foreach my $alias ( @aliases ) { + # This has not been tested!! + # PPT which says MPW-Perl cannot resolve `Alias $alias`, + # let's just hope it's fixed + if ( lc($alias) eq lc($exec) ) { + chomp(my $file = `Alias $alias`); + last unless $file; # if it failed, just go on the normal way + return $file unless $all; + push @results, $file; + # we can stop this loop as if it finds more aliases matching, + # it'll just be the same result anyway + last; + } + } + } + + return $exec + if !IS_VMS and !IS_MAC and !IS_WIN and $exec =~ /\// and -f $exec and -x $exec; + + my @path; + if($^O eq 'MSWin32') { + # File::Spec (at least recent versions) + # add the implicit . for you on MSWin32, + # but we may or may not want to include + # that. + @path = split(';', $ENV{PATH}); + s/"//g for @path; + @path = grep length, @path; + } else { + @path = File::Spec->path; + } + if ( $IMPLICIT_CURRENT_DIR ) { + unshift @path, File::Spec->curdir; + } + + foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) { + for my $ext ( @PATHEXT ) { + my $file = $base.$ext; + + # We don't want dirs (as they are -x) + next if -d $file; + + if ( + # Executable, normal case + -x _ + or ( + # MacOS doesn't mark as executable so we check -e + IS_MAC + || + ( + ( IS_WIN or IS_CYG ) + and + grep { + $file =~ /$_\z/i + } @PATHEXT[1..$#PATHEXT] + ) + # DOSish systems don't pass -x on + # non-exe/bat/com files. so we check -e. + # However, we don't want to pass -e on files + # that aren't in PATHEXT, like README. + and -e _ + ) + ) { + return $file unless $all; + push @results, $file; + } + } + } + + if ( $all ) { + return @results; + } else { + return undef; + } +} + + +sub where { + # force wantarray + my @res = which($_[0]); + return @res; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::Which - Perl implementation of the which utility as an API + +=head1 VERSION + +version 1.23 + +=head1 SYNOPSIS + + use File::Which; # exports which() + use File::Which qw(which where); # exports which() and where() + + my $exe_path = which 'perldoc'; + + my @paths = where 'perl'; + # Or + my @paths = which 'perl'; # an array forces search for all of them + +=head1 DESCRIPTION + +L<File::Which> finds the full or relative paths to executable programs on +the system. This is normally the function of C<which> utility. C<which> is +typically implemented as either a program or a built in shell command. On +some platforms, such as Microsoft Windows it is not provided as part of the +core operating system. This module provides a consistent API to this +functionality regardless of the underlying platform. + +The focus of this module is correctness and portability. As a consequence +platforms where the current directory is implicitly part of the search path +such as Microsoft Windows will find executables in the current directory, +whereas on platforms such as UNIX where this is not the case executables +in the current directory will only be found if the current directory is +explicitly added to the path. + +If you need a portable C<which> on the command line in an environment that +does not provide it, install L<App::pwhich> which provides a command line +interface to this API. + +=head2 Implementations + +L<File::Which> searches the directories of the user's C<PATH> (the current +implementation uses L<File::Spec#path> to determine the correct C<PATH>), +looking for executable files having the name specified as a parameter to +L</which>. Under Win32 systems, which do not have a notion of directly +executable files, but uses special extensions such as C<.exe> and C<.bat> +to identify them, C<File::Which> takes extra steps to assure that +you will find the correct file (so for example, you might be searching for +C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.) + +=head3 Linux, *BSD and other UNIXes + +There should not be any surprises here. The current directory will not be +searched unless it is explicitly added to the path. + +=head3 Modern Windows (including NT, XP, Vista, 7, 8, 10 etc) + +Windows NT has a special environment variable called C<PATHEXT>, which is used +by the shell to look for executable files. Usually, it will contain a list in +the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an +environment variable, it parses the list and uses it as the different +extensions. + +=head3 Cygwin + +Cygwin provides a Unix-like environment for Microsoft Windows users. In most +ways it works like other Unix and Unix-like environments, but in a few key +aspects it works like Windows. As with other Unix environments, the current +directory is not included in the search unless it is explicitly included in +the search path. Like on Windows, files with C<.EXE> or <.BAT> extensions will +be discovered even if they are not part of the query. C<.COM> or extensions +specified using the C<PATHEXT> environment variable will NOT be discovered +without the fully qualified name, however. + +=head3 Windows ME, 98, 95, MS-DOS, OS/2 + +This set of operating systems don't have the C<PATHEXT> variable, and usually +you will find executable files there with the extensions C<.exe>, C<.bat> and +(less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running +under Win32 but does not find a C<PATHEXT> variable. + +As of 2015 none of these platforms are tested frequently (or perhaps ever), +but the current maintainer is determined not to intentionally remove support +for older operating systems. + +=head3 VMS + +Same case as Windows 9x: uses C<.exe> and C<.com> (in that order). + +As of 2015 the current maintainer does not test on VMS, and is in fact not +certain it has ever been tested on VMS. If this platform is important to you +and you can help me verify and or support it on that platform please contact +me. + +=head1 FUNCTIONS + +=head2 which + + my $path = which $short_exe_name; + my @paths = which $short_exe_name; + +Exported by default. + +C<$short_exe_name> is the name used in the shell to call the program (for +example, C<perl>). + +If it finds an executable with the name you specified, C<which()> will return +the absolute path leading to this executable (for example, F</usr/bin/perl> or +F<C:\Perl\Bin\perl.exe>). + +If it does I<not> find the executable, it returns C<undef>. + +If C<which()> is called in list context, it will return I<all> the +matches. + +=head2 where + + my @paths = where $short_exe_name; + +Not exported by default. + +Same as L</which> in array context. Similar to the C<where> csh +built-in command or C<which -a> command for platforms that support the +C<-a> option. Will return an array containing all the path names +matching C<$short_exe_name>. + +=head1 GLOBALS + +=head2 $IMPLICIT_CURRENT_DIR + +True if the current directory is included in the search implicitly on +whatever platform you are using. Normally the default is reasonable, +but on Windows the current directory is included implicitly for older +shells like C<cmd.exe> and C<command.com>, but not for newer shells +like PowerShell. If you overrule this default, you should ALWAYS +localize the variable to the tightest scope possible, since setting +this variable from a module can affect other modules. Thus on Windows +you can get the correct result if the user is running either C<cmd.exe> +or PowerShell on Windows you can do this: + + use File::Which qw( which ); + use Shell::Guess; + + my $path = do { + my $is_power = Shell::Guess->running_shell->is_power; + local $File::Which::IMPLICIT_CURRENT_DIR = !$is_power; + which 'foo'; + }; + +For a variety of reasons it is difficult to accurately compute the +shell that a user is using, but L<Shell::Guess> makes a reasonable +effort. + +=head1 CAVEATS + +This module has no non-core requirements for Perl 5.6.2 and better. + +This module is fully supported back to Perl 5.8.1. It may work on 5.8.0. +It should work on Perl 5.6.x and I may even test on 5.6.2. I will accept +patches to maintain compatibility for such older Perls, but you may +need to fix it on 5.6.x / 5.8.0 and send me a patch. + +Not tested on VMS although there is platform specific code +for those. Anyone who haves a second would be very kind to send me a +report of how it went. + +=head1 SUPPORT + +Bugs should be reported via the GitHub issue tracker + +L<https://github.com/plicease/File-Which/issues> + +For other issues, contact the maintainer. + +=head1 SEE ALSO + +=over 4 + +=item L<pwhich>, L<App::pwhich> + +Command line interface to this module. + +=item L<IPC::Cmd> + +This module provides (among other things) a C<can_run> function, which is +similar to C<which>. It is a much heavier module since it does a lot more, +and if you use C<can_run> it pulls in L<ExtUtils::MakeMaker>. This combination +may be overkill for applications which do not need L<IPC::Cmd>'s complicated +interface for running programs, or do not need the memory overhead required +for installing Perl modules. + +At least some older versions will find executables in the current directory, +even if the current directory is not in the search path (which is the default +on modern Unix). + +C<can_run> converts directory path name to the 8.3 version on Windows using +C<Win32::GetShortPathName> in some cases. This is frequently useful for tools +that just need to run something using C<system> in scalar mode, but may be +inconvenient for tools like L<App::pwhich> where user readability is a premium. +Relying on C<Win32::GetShortPathName> to produce filenames without spaces +is problematic, as 8.3 filenames can be turned off with tweaks to the +registry (see L<https://technet.microsoft.com/en-us/library/cc959352.aspx>). + +=item L<Devel::CheckBin> + +This module purports to "check that a command is available", but does not +provide any documentation on how you might use it. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Per Einar Ellefsen <pereinar@cpan.org> + +=item * + +Adam Kennedy <adamk@cpan.org> + +=item * + +Graham Ollis <plicease@cpan.org> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2002 by Per Einar Ellefsen <pereinar@cpan.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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Entities.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Entities.pm new file mode 100644 index 0000000000..ecd8e0d31f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Entities.pm @@ -0,0 +1,483 @@ +package HTML::Entities; + +=encoding utf8 + +=head1 NAME + +HTML::Entities - Encode or decode strings with HTML entities + +=head1 SYNOPSIS + + use HTML::Entities; + + $a = "Våre norske tegn bør æres"; + decode_entities($a); + encode_entities($a, "\200-\377"); + +For example, this: + + $input = "vis-à -vis Beyoncé's naïve\npapier-mâché résumé"; + print encode_entities($input), "\n" + +Prints this out: + + vis-à-vis Beyoncé's naïve + papier-mâché résumé + +=head1 DESCRIPTION + +This module deals with encoding and decoding of strings with HTML +character entities. The module provides the following functions: + +=over 4 + +=item decode_entities( $string, ... ) + +This routine replaces HTML entities found in the $string with the +corresponding Unicode character. Unrecognized entities are left alone. + +If multiple strings are provided as argument they are each decoded +separately and the same number of strings are returned. + +If called in void context the arguments are decoded in-place. + +This routine is exported by default. + +=item _decode_entities( $string, \%entity2char ) + +=item _decode_entities( $string, \%entity2char, $expand_prefix ) + +This will in-place replace HTML entities in $string. The %entity2char +hash must be provided. Named entities not found in the %entity2char +hash are left alone. Numeric entities are expanded unless their value +overflow. + +The keys in %entity2char are the entity names to be expanded and their +values are what they should expand into. The values do not have to be +single character strings. If a key has ";" as suffix, +then occurrences in $string are only expanded if properly terminated +with ";". Entities without ";" will be expanded regardless of how +they are terminated for compatibility with how common browsers treat +entities in the Latin-1 range. + +If $expand_prefix is TRUE then entities without trailing ";" in +%entity2char will even be expanded as a prefix of a longer +unrecognized name. The longest matching name in %entity2char will be +used. This is mainly present for compatibility with an MSIE +misfeature. + + $string = "foo bar"; + _decode_entities($string, { nb => "@", nbsp => "\xA0" }, 1); + print $string; # will print "foo bar" + +This routine is exported by default. + +=item encode_entities( $string ) + +=item encode_entities( $string, $unsafe_chars ) + +This routine replaces unsafe characters in $string with their entity +representation. A second argument can be given to specify which characters to +consider unsafe. The unsafe characters is specified using the regular +expression character class syntax (what you find within brackets in regular +expressions). + +The default set of characters to encode are control chars, high-bit chars, and +the C<< < >>, C<< & >>, C<< > >>, C<< ' >> and C<< " >> characters. But this, +for example, would encode I<just> the C<< < >>, C<< & >>, C<< > >>, and C<< " +>> characters: + + $encoded = encode_entities($input, '<>&"'); + +and this would only encode non-plain ascii: + + $encoded = encode_entities($input, '^\n\x20-\x25\x27-\x7e'); + +This routine is exported by default. + +=item encode_entities_numeric( $string ) + +=item encode_entities_numeric( $string, $unsafe_chars ) + +This routine works just like encode_entities, except that the replacement +entities are always C<&#xI<hexnum>;> and never C<&I<entname>;>. For +example, C<encode_entities("r\xF4le")> returns "rôle", but +C<encode_entities_numeric("r\xF4le")> returns "rôle". + +This routine is I<not> exported by default. But you can always +export it with C<use HTML::Entities qw(encode_entities_numeric);> +or even C<use HTML::Entities qw(:DEFAULT encode_entities_numeric);> + +=back + +All these routines modify the string passed as the first argument, if +called in a void context. In scalar and array contexts, the encoded or +decoded string is returned (without changing the input string). + +If you prefer not to import these routines into your namespace, you can +call them as: + + use HTML::Entities (); + $decoded = HTML::Entities::decode($a); + $encoded = HTML::Entities::encode($a); + $encoded = HTML::Entities::encode_numeric($a); + +The module can also export the %char2entity and the %entity2char +hashes, which contain the mapping from all characters to the +corresponding entities (and vice versa, respectively). + +=head1 COPYRIGHT + +Copyright 1995-2006 Gisle Aas. All rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); +use vars qw(%entity2char %char2entity); + +require 5.004; +require Exporter; +@ISA = qw(Exporter); + +@EXPORT = qw(encode_entities decode_entities _decode_entities); +@EXPORT_OK = qw(%entity2char %char2entity encode_entities_numeric); + +$VERSION = "3.69"; +sub Version { $VERSION; } + +require HTML::Parser; # for fast XS implemented decode_entities + + +%entity2char = ( + # Some normal chars that have special meaning in SGML context + amp => '&', # ampersand +'gt' => '>', # greater than +'lt' => '<', # less than + quot => '"', # double quote + apos => "'", # single quote + + # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML + AElig => chr(198), # capital AE diphthong (ligature) + Aacute => chr(193), # capital A, acute accent + Acirc => chr(194), # capital A, circumflex accent + Agrave => chr(192), # capital A, grave accent + Aring => chr(197), # capital A, ring + Atilde => chr(195), # capital A, tilde + Auml => chr(196), # capital A, dieresis or umlaut mark + Ccedil => chr(199), # capital C, cedilla + ETH => chr(208), # capital Eth, Icelandic + Eacute => chr(201), # capital E, acute accent + Ecirc => chr(202), # capital E, circumflex accent + Egrave => chr(200), # capital E, grave accent + Euml => chr(203), # capital E, dieresis or umlaut mark + Iacute => chr(205), # capital I, acute accent + Icirc => chr(206), # capital I, circumflex accent + Igrave => chr(204), # capital I, grave accent + Iuml => chr(207), # capital I, dieresis or umlaut mark + Ntilde => chr(209), # capital N, tilde + Oacute => chr(211), # capital O, acute accent + Ocirc => chr(212), # capital O, circumflex accent + Ograve => chr(210), # capital O, grave accent + Oslash => chr(216), # capital O, slash + Otilde => chr(213), # capital O, tilde + Ouml => chr(214), # capital O, dieresis or umlaut mark + THORN => chr(222), # capital THORN, Icelandic + Uacute => chr(218), # capital U, acute accent + Ucirc => chr(219), # capital U, circumflex accent + Ugrave => chr(217), # capital U, grave accent + Uuml => chr(220), # capital U, dieresis or umlaut mark + Yacute => chr(221), # capital Y, acute accent + aacute => chr(225), # small a, acute accent + acirc => chr(226), # small a, circumflex accent + aelig => chr(230), # small ae diphthong (ligature) + agrave => chr(224), # small a, grave accent + aring => chr(229), # small a, ring + atilde => chr(227), # small a, tilde + auml => chr(228), # small a, dieresis or umlaut mark + ccedil => chr(231), # small c, cedilla + eacute => chr(233), # small e, acute accent + ecirc => chr(234), # small e, circumflex accent + egrave => chr(232), # small e, grave accent + eth => chr(240), # small eth, Icelandic + euml => chr(235), # small e, dieresis or umlaut mark + iacute => chr(237), # small i, acute accent + icirc => chr(238), # small i, circumflex accent + igrave => chr(236), # small i, grave accent + iuml => chr(239), # small i, dieresis or umlaut mark + ntilde => chr(241), # small n, tilde + oacute => chr(243), # small o, acute accent + ocirc => chr(244), # small o, circumflex accent + ograve => chr(242), # small o, grave accent + oslash => chr(248), # small o, slash + otilde => chr(245), # small o, tilde + ouml => chr(246), # small o, dieresis or umlaut mark + szlig => chr(223), # small sharp s, German (sz ligature) + thorn => chr(254), # small thorn, Icelandic + uacute => chr(250), # small u, acute accent + ucirc => chr(251), # small u, circumflex accent + ugrave => chr(249), # small u, grave accent + uuml => chr(252), # small u, dieresis or umlaut mark + yacute => chr(253), # small y, acute accent + yuml => chr(255), # small y, dieresis or umlaut mark + + # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96) + copy => chr(169), # copyright sign + reg => chr(174), # registered sign + nbsp => chr(160), # non breaking space + + # Additional ISO-8859/1 entities listed in rfc1866 (section 14) + iexcl => chr(161), + cent => chr(162), + pound => chr(163), + curren => chr(164), + yen => chr(165), + brvbar => chr(166), + sect => chr(167), + uml => chr(168), + ordf => chr(170), + laquo => chr(171), +'not' => chr(172), # not is a keyword in perl + shy => chr(173), + macr => chr(175), + deg => chr(176), + plusmn => chr(177), + sup1 => chr(185), + sup2 => chr(178), + sup3 => chr(179), + acute => chr(180), + micro => chr(181), + para => chr(182), + middot => chr(183), + cedil => chr(184), + ordm => chr(186), + raquo => chr(187), + frac14 => chr(188), + frac12 => chr(189), + frac34 => chr(190), + iquest => chr(191), +'times' => chr(215), # times is a keyword in perl + divide => chr(247), + + ( $] > 5.007 ? ( + 'OElig;' => chr(338), + 'oelig;' => chr(339), + 'Scaron;' => chr(352), + 'scaron;' => chr(353), + 'Yuml;' => chr(376), + 'fnof;' => chr(402), + 'circ;' => chr(710), + 'tilde;' => chr(732), + 'Alpha;' => chr(913), + 'Beta;' => chr(914), + 'Gamma;' => chr(915), + 'Delta;' => chr(916), + 'Epsilon;' => chr(917), + 'Zeta;' => chr(918), + 'Eta;' => chr(919), + 'Theta;' => chr(920), + 'Iota;' => chr(921), + 'Kappa;' => chr(922), + 'Lambda;' => chr(923), + 'Mu;' => chr(924), + 'Nu;' => chr(925), + 'Xi;' => chr(926), + 'Omicron;' => chr(927), + 'Pi;' => chr(928), + 'Rho;' => chr(929), + 'Sigma;' => chr(931), + 'Tau;' => chr(932), + 'Upsilon;' => chr(933), + 'Phi;' => chr(934), + 'Chi;' => chr(935), + 'Psi;' => chr(936), + 'Omega;' => chr(937), + 'alpha;' => chr(945), + 'beta;' => chr(946), + 'gamma;' => chr(947), + 'delta;' => chr(948), + 'epsilon;' => chr(949), + 'zeta;' => chr(950), + 'eta;' => chr(951), + 'theta;' => chr(952), + 'iota;' => chr(953), + 'kappa;' => chr(954), + 'lambda;' => chr(955), + 'mu;' => chr(956), + 'nu;' => chr(957), + 'xi;' => chr(958), + 'omicron;' => chr(959), + 'pi;' => chr(960), + 'rho;' => chr(961), + 'sigmaf;' => chr(962), + 'sigma;' => chr(963), + 'tau;' => chr(964), + 'upsilon;' => chr(965), + 'phi;' => chr(966), + 'chi;' => chr(967), + 'psi;' => chr(968), + 'omega;' => chr(969), + 'thetasym;' => chr(977), + 'upsih;' => chr(978), + 'piv;' => chr(982), + 'ensp;' => chr(8194), + 'emsp;' => chr(8195), + 'thinsp;' => chr(8201), + 'zwnj;' => chr(8204), + 'zwj;' => chr(8205), + 'lrm;' => chr(8206), + 'rlm;' => chr(8207), + 'ndash;' => chr(8211), + 'mdash;' => chr(8212), + 'lsquo;' => chr(8216), + 'rsquo;' => chr(8217), + 'sbquo;' => chr(8218), + 'ldquo;' => chr(8220), + 'rdquo;' => chr(8221), + 'bdquo;' => chr(8222), + 'dagger;' => chr(8224), + 'Dagger;' => chr(8225), + 'bull;' => chr(8226), + 'hellip;' => chr(8230), + 'permil;' => chr(8240), + 'prime;' => chr(8242), + 'Prime;' => chr(8243), + 'lsaquo;' => chr(8249), + 'rsaquo;' => chr(8250), + 'oline;' => chr(8254), + 'frasl;' => chr(8260), + 'euro;' => chr(8364), + 'image;' => chr(8465), + 'weierp;' => chr(8472), + 'real;' => chr(8476), + 'trade;' => chr(8482), + 'alefsym;' => chr(8501), + 'larr;' => chr(8592), + 'uarr;' => chr(8593), + 'rarr;' => chr(8594), + 'darr;' => chr(8595), + 'harr;' => chr(8596), + 'crarr;' => chr(8629), + 'lArr;' => chr(8656), + 'uArr;' => chr(8657), + 'rArr;' => chr(8658), + 'dArr;' => chr(8659), + 'hArr;' => chr(8660), + 'forall;' => chr(8704), + 'part;' => chr(8706), + 'exist;' => chr(8707), + 'empty;' => chr(8709), + 'nabla;' => chr(8711), + 'isin;' => chr(8712), + 'notin;' => chr(8713), + 'ni;' => chr(8715), + 'prod;' => chr(8719), + 'sum;' => chr(8721), + 'minus;' => chr(8722), + 'lowast;' => chr(8727), + 'radic;' => chr(8730), + 'prop;' => chr(8733), + 'infin;' => chr(8734), + 'ang;' => chr(8736), + 'and;' => chr(8743), + 'or;' => chr(8744), + 'cap;' => chr(8745), + 'cup;' => chr(8746), + 'int;' => chr(8747), + 'there4;' => chr(8756), + 'sim;' => chr(8764), + 'cong;' => chr(8773), + 'asymp;' => chr(8776), + 'ne;' => chr(8800), + 'equiv;' => chr(8801), + 'le;' => chr(8804), + 'ge;' => chr(8805), + 'sub;' => chr(8834), + 'sup;' => chr(8835), + 'nsub;' => chr(8836), + 'sube;' => chr(8838), + 'supe;' => chr(8839), + 'oplus;' => chr(8853), + 'otimes;' => chr(8855), + 'perp;' => chr(8869), + 'sdot;' => chr(8901), + 'lceil;' => chr(8968), + 'rceil;' => chr(8969), + 'lfloor;' => chr(8970), + 'rfloor;' => chr(8971), + 'lang;' => chr(9001), + 'rang;' => chr(9002), + 'loz;' => chr(9674), + 'spades;' => chr(9824), + 'clubs;' => chr(9827), + 'hearts;' => chr(9829), + 'diams;' => chr(9830), + ) : ()) +); + + +# Make the opposite mapping +while (my($entity, $char) = each(%entity2char)) { + $entity =~ s/;\z//; + $char2entity{$char} = "&$entity;"; +} +delete $char2entity{"'"}; # only one-way decoding + +# Fill in missing entities +for (0 .. 255) { + next if exists $char2entity{chr($_)}; + $char2entity{chr($_)} = "&#$_;"; +} + +my %subst; # compiled encoding regexps + +sub encode_entities +{ + return undef unless defined $_[0]; + my $ref; + if (defined wantarray) { + my $x = $_[0]; + $ref = \$x; # copy + } else { + $ref = \$_[0]; # modify in-place + } + if (defined $_[1] and length $_[1]) { + unless (exists $subst{$_[1]}) { + # Because we can't compile regex we fake it with a cached sub + my $chars = $_[1]; + $chars =~ s,(?<!\\)([]/]),\\$1,g; + $chars =~ s,(?<!\\)\\\z,\\\\,; + my $code = "sub {\$_[0] =~ s/([$chars])/\$char2entity{\$1} || num_entity(\$1)/ge; }"; + $subst{$_[1]} = eval $code; + die( $@ . " while trying to turn range: \"$_[1]\"\n " + . "into code: $code\n " + ) if $@; + } + &{$subst{$_[1]}}($$ref); + } else { + # Encode control chars, high bit chars and '<', '&', '>', ''' and '"' + $$ref =~ s/([^\n\r\t !\#\$%\(-;=?-~])/$char2entity{$1} || num_entity($1)/ge; + } + $$ref; +} + +sub encode_entities_numeric { + local %char2entity; + return &encode_entities; # a goto &encode_entities wouldn't work +} + + +sub num_entity { + sprintf "&#x%X;", ord($_[0]); +} + +# Set up aliases +*encode = \&encode_entities; +*encode_numeric = \&encode_entities_numeric; +*encode_numerically = \&encode_entities_numeric; +*decode = \&decode_entities; + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Filter.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Filter.pm new file mode 100644 index 0000000000..9230e9a170 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Filter.pm @@ -0,0 +1,112 @@ +package HTML::Filter; + +use strict; +use vars qw(@ISA $VERSION); + +require HTML::Parser; +@ISA=qw(HTML::Parser); + +$VERSION = "3.72"; + +sub declaration { $_[0]->output("<!$_[1]>") } +sub process { $_[0]->output($_[2]) } +sub comment { $_[0]->output("<!--$_[1]-->") } +sub start { $_[0]->output($_[4]) } +sub end { $_[0]->output($_[2]) } +sub text { $_[0]->output($_[1]) } + +sub output { print $_[1] } + +1; + +__END__ + +=head1 NAME + +HTML::Filter - Filter HTML text through the parser + +=head1 NOTE + +B<This module is deprecated.> The C<HTML::Parser> now provides the +functionally of C<HTML::Filter> much more efficiently with the +C<default> handler. + +=head1 SYNOPSIS + + require HTML::Filter; + $p = HTML::Filter->new->parse_file("index.html"); + +=head1 DESCRIPTION + +C<HTML::Filter> is an HTML parser that by default prints the +original text of each HTML element (a slow version of cat(1) basically). +The callback methods may be overridden to modify the filtering for some +HTML elements and you can override output() method which is called to +print the HTML text. + +C<HTML::Filter> is a subclass of C<HTML::Parser>. This means that +the document should be given to the parser by calling the $p->parse() +or $p->parse_file() methods. + +=head1 EXAMPLES + +The first example is a filter that will remove all comments from an +HTML file. This is achieved by simply overriding the comment method +to do nothing. + + package CommentStripper; + require HTML::Filter; + @ISA=qw(HTML::Filter); + sub comment { } # ignore comments + +The second example shows a filter that will remove any E<lt>TABLE>s +found in the HTML file. We specialize the start() and end() methods +to count table tags and then make output not happen when inside a +table. + + package TableStripper; + require HTML::Filter; + @ISA=qw(HTML::Filter); + sub start + { + my $self = shift; + $self->{table_seen}++ if $_[0] eq "table"; + $self->SUPER::start(@_); + } + + sub end + { + my $self = shift; + $self->SUPER::end(@_); + $self->{table_seen}-- if $_[0] eq "table"; + } + + sub output + { + my $self = shift; + unless ($self->{table_seen}) { + $self->SUPER::output(@_); + } + } + +If you want to collect the parsed text internally you might want to do +something like this: + + package FilterIntoString; + require HTML::Filter; + @ISA=qw(HTML::Filter); + sub output { push(@{$_[0]->{fhtml}}, $_[1]) } + sub filtered_html { join("", @{$_[0]->{fhtml}}) } + +=head1 SEE ALSO + +L<HTML::Parser> + +=head1 COPYRIGHT + +Copyright 1997-1999 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/HeadParser.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/HeadParser.pm new file mode 100644 index 0000000000..28e9cacc40 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/HeadParser.pm @@ -0,0 +1,315 @@ +package HTML::HeadParser; + +=head1 NAME + +HTML::HeadParser - Parse <HEAD> section of a HTML document + +=head1 SYNOPSIS + + require HTML::HeadParser; + $p = HTML::HeadParser->new; + $p->parse($text) and print "not finished"; + + $p->header('Title') # to access <title>....</title> + $p->header('Content-Base') # to access <base href="http://..."> + $p->header('Foo') # to access <meta http-equiv="Foo" content="..."> + $p->header('X-Meta-Author') # to access <meta name="author" content="..."> + $p->header('X-Meta-Charset') # to access <meta charset="..."> + +=head1 DESCRIPTION + +The C<HTML::HeadParser> is a specialized (and lightweight) +C<HTML::Parser> that will only parse the E<lt>HEAD>...E<lt>/HEAD> +section of an HTML document. The parse() method +will return a FALSE value as soon as some E<lt>BODY> element or body +text are found, and should not be called again after this. + +Note that the C<HTML::HeadParser> might get confused if raw undecoded +UTF-8 is passed to the parse() method. Make sure the strings are +properly decoded before passing them on. + +The C<HTML::HeadParser> keeps a reference to a header object, and the +parser will update this header object as the various elements of the +E<lt>HEAD> section of the HTML document are recognized. The following +header fields are affected: + +=over 4 + +=item Content-Base: + +The I<Content-Base> header is initialized from the E<lt>base +href="..."> element. + +=item Title: + +The I<Title> header is initialized from the E<lt>title>...E<lt>/title> +element. + +=item Isindex: + +The I<Isindex> header will be added if there is a E<lt>isindex> +element in the E<lt>head>. The header value is initialized from the +I<prompt> attribute if it is present. If no I<prompt> attribute is +given it will have '?' as the value. + +=item X-Meta-Foo: + +All E<lt>meta> elements containing a C<name> attribute will result in +headers using the prefix C<X-Meta-> appended with the value of the +C<name> attribute as the name of the header, and the value of the +C<content> attribute as the pushed header value. + +E<lt>meta> elements containing a C<http-equiv> attribute will result +in headers as in above, but without the C<X-Meta-> prefix in the +header name. + +E<lt>meta> elements containing a C<charset> attribute will result in +an C<X-Meta-Charset> header, using the value of the C<charset> +attribute as the pushed header value. + +The ':' character can't be represented in header field names, so +if the meta element contains this char it's substituted with '-' +before forming the field name. + +=back + +=head1 METHODS + +The following methods (in addition to those provided by the +superclass) are available: + +=over 4 + +=cut + + +require HTML::Parser; +@ISA = qw(HTML::Parser); + +use HTML::Entities (); + +use strict; +use vars qw($VERSION $DEBUG); +#$DEBUG = 1; +$VERSION = "3.71"; + +=item $hp = HTML::HeadParser->new + +=item $hp = HTML::HeadParser->new( $header ) + +The object constructor. The optional $header argument should be a +reference to an object that implement the header() and push_header() +methods as defined by the C<HTTP::Headers> class. Normally it will be +of some class that is a or delegates to the C<HTTP::Headers> class. + +If no $header is given C<HTML::HeadParser> will create an +C<HTTP::Headers> object by itself (initially empty). + +=cut + +sub new +{ + my($class, $header) = @_; + unless ($header) { + require HTTP::Headers; + $header = HTTP::Headers->new; + } + + my $self = $class->SUPER::new(api_version => 3, + start_h => ["start", "self,tagname,attr"], + end_h => ["end", "self,tagname"], + text_h => ["text", "self,text"], + ignore_elements => [qw(script style)], + ); + $self->{'header'} = $header; + $self->{'tag'} = ''; # name of active element that takes textual content + $self->{'text'} = ''; # the accumulated text associated with the element + $self; +} + +=item $hp->header; + +Returns a reference to the header object. + +=item $hp->header( $key ) + +Returns a header value. It is just a shorter way to write +C<$hp-E<gt>header-E<gt>header($key)>. + +=cut + +sub header +{ + my $self = shift; + return $self->{'header'} unless @_; + $self->{'header'}->header(@_); +} + +sub as_string # legacy +{ + my $self = shift; + $self->{'header'}->as_string; +} + +sub flush_text # internal +{ + my $self = shift; + my $tag = $self->{'tag'}; + my $text = $self->{'text'}; + $text =~ s/^\s+//; + $text =~ s/\s+$//; + $text =~ s/\s+/ /g; + print "FLUSH $tag => '$text'\n" if $DEBUG; + if ($tag eq 'title') { + my $decoded; + $decoded = utf8::decode($text) if $self->utf8_mode && defined &utf8::decode; + HTML::Entities::decode($text); + utf8::encode($text) if $decoded; + $self->{'header'}->push_header(Title => $text); + } + $self->{'tag'} = $self->{'text'} = ''; +} + +# This is an quote from the HTML3.2 DTD which shows which elements +# that might be present in a <HEAD>...</HEAD>. Also note that the +# <HEAD> tags themselves might be missing: +# +# <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? & +# SCRIPT* & META* & LINK*"> +# +# <!ELEMENT HEAD O O (%head.content)> +# +# From HTML 4.01: +# +# <!ENTITY % head.misc "SCRIPT|STYLE|META|LINK|OBJECT"> +# <!ENTITY % head.content "TITLE & BASE?"> +# <!ELEMENT HEAD O O (%head.content;) +(%head.misc;)> +# +# From HTML 5 as of WD-html5-20090825: +# +# One or more elements of metadata content, [...] +# => base, command, link, meta, noscript, script, style, title + +sub start +{ + my($self, $tag, $attr) = @_; # $attr is reference to a HASH + print "START[$tag]\n" if $DEBUG; + $self->flush_text if $self->{'tag'}; + if ($tag eq 'meta') { + my $key = $attr->{'http-equiv'}; + if (!defined($key) || !length($key)) { + if ($attr->{name}) { + $key = "X-Meta-\u$attr->{name}"; + } elsif ($attr->{charset}) { # HTML 5 <meta charset="..."> + $key = "X-Meta-Charset"; + $self->{header}->push_header($key => $attr->{charset}); + return; + } else { + return; + } + } + $key =~ s/:/-/g; + $self->{'header'}->push_header($key => $attr->{content}); + } elsif ($tag eq 'base') { + return unless exists $attr->{href}; + (my $base = $attr->{href}) =~ s/^\s+//; $base =~ s/\s+$//; # HTML5 + $self->{'header'}->push_header('Content-Base' => $base); + } elsif ($tag eq 'isindex') { + # This is a non-standard header. Perhaps we should just ignore + # this element + $self->{'header'}->push_header(Isindex => $attr->{prompt} || '?'); + } elsif ($tag =~ /^(?:title|noscript|object|command)$/) { + # Just remember tag. Initialize header when we see the end tag. + $self->{'tag'} = $tag; + } elsif ($tag eq 'link') { + return unless exists $attr->{href}; + # <link href="http:..." rel="xxx" rev="xxx" title="xxx"> + my $href = delete($attr->{href}); + $href =~ s/^\s+//; $href =~ s/\s+$//; # HTML5 + my $h_val = "<$href>"; + for (sort keys %{$attr}) { + next if $_ eq "/"; # XHTML junk + $h_val .= qq(; $_="$attr->{$_}"); + } + $self->{'header'}->push_header(Link => $h_val); + } elsif ($tag eq 'head' || $tag eq 'html') { + # ignore + } else { + # stop parsing + $self->eof; + } +} + +sub end +{ + my($self, $tag) = @_; + print "END[$tag]\n" if $DEBUG; + $self->flush_text if $self->{'tag'}; + $self->eof if $tag eq 'head'; +} + +sub text +{ + my($self, $text) = @_; + print "TEXT[$text]\n" if $DEBUG; + unless ($self->{first_chunk}) { + # drop Unicode BOM if found + if ($self->utf8_mode) { + $text =~ s/^\xEF\xBB\xBF//; + } + else { + $text =~ s/^\x{FEFF}//; + } + $self->{first_chunk}++; + } + my $tag = $self->{tag}; + if (!$tag && $text =~ /\S/) { + # Normal text means start of body + $self->eof; + return; + } + return if $tag ne 'title'; + $self->{'text'} .= $text; +} + +BEGIN { + *utf8_mode = sub { 1 } unless HTML::Entities::UNICODE_SUPPORT; +} + +1; + +__END__ + +=back + +=head1 EXAMPLE + + $h = HTTP::Headers->new; + $p = HTML::HeadParser->new($h); + $p->parse(<<EOT); + <title>Stupid example</title> + <base href="http://www.linpro.no/lwp/"> + Normal text starts here. + EOT + undef $p; + print $h->title; # should print "Stupid example" + +=head1 SEE ALSO + +L<HTML::Parser>, L<HTTP::Headers> + +The C<HTTP::Headers> class is distributed as part of the +I<libwww-perl> package. If you don't have that distribution installed +you need to provide the $header argument to the C<HTML::HeadParser> +constructor with your own object that implements the documented +protocol. + +=head1 COPYRIGHT + +Copyright 1996-2001 Gisle Aas. All rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/LinkExtor.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/LinkExtor.pm new file mode 100644 index 0000000000..c2f08c62d9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/LinkExtor.pm @@ -0,0 +1,185 @@ +package HTML::LinkExtor; + +require HTML::Parser; +@ISA = qw(HTML::Parser); +$VERSION = "3.69"; + +=head1 NAME + +HTML::LinkExtor - Extract links from an HTML document + +=head1 SYNOPSIS + + require HTML::LinkExtor; + $p = HTML::LinkExtor->new(\&cb, "http://www.perl.org/"); + sub cb { + my($tag, %links) = @_; + print "$tag @{[%links]}\n"; + } + $p->parse_file("index.html"); + +=head1 DESCRIPTION + +I<HTML::LinkExtor> is an HTML parser that extracts links from an +HTML document. The I<HTML::LinkExtor> is a subclass of +I<HTML::Parser>. This means that the document should be given to the +parser by calling the $p->parse() or $p->parse_file() methods. + +=cut + +use strict; +use HTML::Tagset (); + +# legacy (some applications grabs this hash directly) +use vars qw(%LINK_ELEMENT); +*LINK_ELEMENT = \%HTML::Tagset::linkElements; + +=over 4 + +=item $p = HTML::LinkExtor->new + +=item $p = HTML::LinkExtor->new( $callback ) + +=item $p = HTML::LinkExtor->new( $callback, $base ) + +The constructor takes two optional arguments. The first is a reference +to a callback routine. It will be called as links are found. If a +callback is not provided, then links are just accumulated internally +and can be retrieved by calling the $p->links() method. + +The $base argument is an optional base URL used to absolutize all URLs found. +You need to have the I<URI> module installed if you provide $base. + +The callback is called with the lowercase tag name as first argument, +and then all link attributes as separate key/value pairs. All +non-link attributes are removed. + +=cut + +sub new +{ + my($class, $cb, $base) = @_; + my $self = $class->SUPER::new( + start_h => ["_start_tag", "self,tagname,attr"], + report_tags => [keys %HTML::Tagset::linkElements], + ); + $self->{extractlink_cb} = $cb; + if ($base) { + require URI; + $self->{extractlink_base} = URI->new($base); + } + $self; +} + +sub _start_tag +{ + my($self, $tag, $attr) = @_; + + my $base = $self->{extractlink_base}; + my $links = $HTML::Tagset::linkElements{$tag}; + $links = [$links] unless ref $links; + + my @links; + my $a; + for $a (@$links) { + next unless exists $attr->{$a}; + (my $link = $attr->{$a}) =~ s/^\s+//; $link =~ s/\s+$//; # HTML5 + push(@links, $a, $base ? URI->new($link, $base)->abs($base) : $link); + } + return unless @links; + $self->_found_link($tag, @links); +} + +sub _found_link +{ + my $self = shift; + my $cb = $self->{extractlink_cb}; + if ($cb) { + &$cb(@_); + } else { + push(@{$self->{'links'}}, [@_]); + } +} + +=item $p->links + +Returns a list of all links found in the document. The returned +values will be anonymous arrays with the following elements: + + [$tag, $attr => $url1, $attr2 => $url2,...] + +The $p->links method will also truncate the internal link list. This +means that if the method is called twice without any parsing +between them the second call will return an empty list. + +Also note that $p->links will always be empty if a callback routine +was provided when the I<HTML::LinkExtor> was created. + +=cut + +sub links +{ + my $self = shift; + exists($self->{'links'}) ? @{delete $self->{'links'}} : (); +} + +# We override the parse_file() method so that we can clear the links +# before we start a new file. +sub parse_file +{ + my $self = shift; + delete $self->{'links'}; + $self->SUPER::parse_file(@_); +} + +=back + +=head1 EXAMPLE + +This is an example showing how you can extract links from a document +received using LWP: + + use LWP::UserAgent; + use HTML::LinkExtor; + use URI::URL; + + $url = "http://www.perl.org/"; # for instance + $ua = LWP::UserAgent->new; + + # Set up a callback that collect image links + my @imgs = (); + sub callback { + my($tag, %attr) = @_; + return if $tag ne 'img'; # we only look closer at <img ...> + push(@imgs, values %attr); + } + + # Make the parser. Unfortunately, we don't know the base yet + # (it might be different from $url) + $p = HTML::LinkExtor->new(\&callback); + + # Request document and parse it as it arrives + $res = $ua->request(HTTP::Request->new(GET => $url), + sub {$p->parse($_[0])}); + + # Expand all image URLs to absolute ones + my $base = $res->base; + @imgs = map { $_ = url($_, $base)->abs; } @imgs; + + # Print them out + print join("\n", @imgs), "\n"; + +=head1 SEE ALSO + +L<HTML::Parser>, L<HTML::Tagset>, L<LWP>, L<URI::URL> + +=head1 COPYRIGHT + +Copyright 1996-2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Parser.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Parser.pm new file mode 100644 index 0000000000..9c2fc214d5 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Parser.pm @@ -0,0 +1,1234 @@ +package HTML::Parser; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = "3.72"; + +require HTML::Entities; + +require XSLoader; +XSLoader::load('HTML::Parser', $VERSION); + +sub new +{ + my $class = shift; + my $self = bless {}, $class; + return $self->init(@_); +} + + +sub init +{ + my $self = shift; + $self->_alloc_pstate; + + my %arg = @_; + my $api_version = delete $arg{api_version} || (@_ ? 3 : 2); + if ($api_version >= 4) { + require Carp; + Carp::croak("API version $api_version not supported " . + "by HTML::Parser $VERSION"); + } + + if ($api_version < 3) { + # Set up method callbacks compatible with HTML-Parser-2.xx + $self->handler(text => "text", "self,text,is_cdata"); + $self->handler(end => "end", "self,tagname,text"); + $self->handler(process => "process", "self,token0,text"); + $self->handler(start => "start", + "self,tagname,attr,attrseq,text"); + + $self->handler(comment => + sub { + my($self, $tokens) = @_; + for (@$tokens) { + $self->comment($_); + } + }, "self,tokens"); + + $self->handler(declaration => + sub { + my $self = shift; + $self->declaration(substr($_[0], 2, -1)); + }, "self,text"); + } + + if (my $h = delete $arg{handlers}) { + $h = {@$h} if ref($h) eq "ARRAY"; + while (my($event, $cb) = each %$h) { + $self->handler($event => @$cb); + } + } + + # In the end we try to assume plain attribute or handler + while (my($option, $val) = each %arg) { + if ($option =~ /^(\w+)_h$/) { + $self->handler($1 => @$val); + } + elsif ($option =~ /^(text|start|end|process|declaration|comment)$/) { + require Carp; + Carp::croak("Bad constructor option '$option'"); + } + else { + $self->$option($val); + } + } + + return $self; +} + + +sub parse_file +{ + my($self, $file) = @_; + my $opened; + if (!ref($file) && ref(\$file) ne "GLOB") { + # Assume $file is a filename + local(*F); + open(F, "<", $file) || return undef; + binmode(F); # should we? good for byte counts + $opened++; + $file = *F; + } + my $chunk = ''; + while (read($file, $chunk, 512)) { + $self->parse($chunk) || last; + } + close($file) if $opened; + $self->eof; +} + + +sub netscape_buggy_comment # legacy +{ + my $self = shift; + require Carp; + Carp::carp("netscape_buggy_comment() is deprecated. " . + "Please use the strict_comment() method instead"); + my $old = !$self->strict_comment; + $self->strict_comment(!shift) if @_; + return $old; +} + +# set up method stubs +sub text { } +*start = \&text; +*end = \&text; +*comment = \&text; +*declaration = \&text; +*process = \&text; + +1; + +__END__ + + +=head1 NAME + +HTML::Parser - HTML parser class + +=head1 SYNOPSIS + + use HTML::Parser (); + + # Create parser object + $p = HTML::Parser->new( api_version => 3, + start_h => [\&start, "tagname, attr"], + end_h => [\&end, "tagname"], + marked_sections => 1, + ); + + # Parse document text chunk by chunk + $p->parse($chunk1); + $p->parse($chunk2); + #... + $p->eof; # signal end of document + + # Parse directly from file + $p->parse_file("foo.html"); + # or + open(my $fh, "<:utf8", "foo.html") || die; + $p->parse_file($fh); + +=head1 DESCRIPTION + +Objects of the C<HTML::Parser> class will recognize markup and +separate it from plain text (alias data content) in HTML +documents. As different kinds of markup and text are recognized, the +corresponding event handlers are invoked. + +C<HTML::Parser> is not a generic SGML parser. We have tried to +make it able to deal with the HTML that is actually "out there", and +it normally parses as closely as possible to the way the popular web +browsers do it instead of strictly following one of the many HTML +specifications from W3C. Where there is disagreement, there is often +an option that you can enable to get the official behaviour. + +The document to be parsed may be supplied in arbitrary chunks. This +makes on-the-fly parsing as documents are received from the network +possible. + +If event driven parsing does not feel right for your application, you +might want to use C<HTML::PullParser>. This is an C<HTML::Parser> +subclass that allows a more conventional program structure. + + +=head1 METHODS + +The following method is used to construct a new C<HTML::Parser> object: + +=over + +=item $p = HTML::Parser->new( %options_and_handlers ) + +This class method creates a new C<HTML::Parser> object and +returns it. Key/value argument pairs may be provided to assign event +handlers or initialize parser options. The handlers and parser +options can also be set or modified later by the method calls described below. + +If a top level key is in the form "<event>_h" (e.g., "text_h") then it +assigns a handler to that event, otherwise it initializes a parser +option. The event handler specification value must be an array +reference. Multiple handlers may also be assigned with the 'handlers +=> [%handlers]' option. See examples below. + +If new() is called without any arguments, it will create a parser that +uses callback methods compatible with version 2 of C<HTML::Parser>. +See the section on "version 2 compatibility" below for details. + +The special constructor option 'api_version => 2' can be used to +initialize version 2 callbacks while still setting other options and +handlers. The 'api_version => 3' option can be used if you don't want +to set any options and don't want to fall back to v2 compatible +mode. + +Examples: + + $p = HTML::Parser->new(api_version => 3, + text_h => [ sub {...}, "dtext" ]); + +This creates a new parser object with a text event handler subroutine +that receives the original text with general entities decoded. + + $p = HTML::Parser->new(api_version => 3, + start_h => [ 'my_start', "self,tokens" ]); + +This creates a new parser object with a start event handler method +that receives the $p and the tokens array. + + $p = HTML::Parser->new(api_version => 3, + handlers => { text => [\@array, "event,text"], + comment => [\@array, "event,text"], + }); + +This creates a new parser object that stores the event type and the +original text in @array for text and comment events. + +=back + +The following methods feed the HTML document +to the C<HTML::Parser> object: + +=over + +=item $p->parse( $string ) + +Parse $string as the next chunk of the HTML document. Handlers invoked should +not attempt to modify the $string in-place until $p->parse returns. + +If an invoked event handler aborts parsing by calling $p->eof, then $p->parse() +will return a FALSE value. Otherwise the return value is a reference to the +parser object ($p). + +=item $p->parse( $code_ref ) + +If a code reference is passed as the argument to be parsed, then the +chunks to be parsed are obtained by invoking this function repeatedly. +Parsing continues until the function returns an empty (or undefined) +result. When this happens $p->eof is automatically signaled. + +Parsing will also abort if one of the event handlers calls $p->eof. + +The effect of this is the same as: + + while (1) { + my $chunk = &$code_ref(); + if (!defined($chunk) || !length($chunk)) { + $p->eof; + return $p; + } + $p->parse($chunk) || return undef; + } + +But it is more efficient as this loop runs internally in XS code. + +=item $p->parse_file( $file ) + +Parse text directly from a file. The $file argument can be a +filename, an open file handle, or a reference to an open file +handle. + +If $file contains a filename and the file can't be opened, then the +method returns an undefined value and $! tells why it failed. +Otherwise the return value is a reference to the parser object. + +If a file handle is passed as the $file argument, then the file will +normally be read until EOF, but not closed. + +If an invoked event handler aborts parsing by calling $p->eof, +then $p->parse_file() may not have read the entire file. + +On systems with multi-byte line terminators, the values passed for the +offset and length argspecs may be too low if parse_file() is called on +a file handle that is not in binary mode. + +If a filename is passed in, then parse_file() will open the file in +binary mode. + +=item $p->eof + +Signals the end of the HTML document. Calling the $p->eof method +outside a handler callback will flush any remaining buffered text +(which triggers the C<text> event if there is any remaining text). + +Calling $p->eof inside a handler will terminate parsing at that point +and cause $p->parse to return a FALSE value. This also terminates +parsing by $p->parse_file(). + +After $p->eof has been called, the parse() and parse_file() methods +can be invoked to feed new documents with the parser object. + +The return value from eof() is a reference to the parser object. + +=back + + +Most parser options are controlled by boolean attributes. +Each boolean attribute is enabled by calling the corresponding method +with a TRUE argument and disabled with a FALSE argument. The +attribute value is left unchanged if no argument is given. The return +value from each method is the old attribute value. + +Methods that can be used to get and/or set parser options are: + +=over + +=item $p->attr_encoded + +=item $p->attr_encoded( $bool ) + +By default, the C<attr> and C<@attr> argspecs will have general +entities for attribute values decoded. Enabling this attribute leaves +entities alone. + +=item $p->backquote + +=item $p->backquote( $bool ) + +By default, only ' and " are recognized as quote characters around +attribute values. MSIE also recognizes backquotes for some reason. +Enabling this attribute provides compatibility with this behaviour. + +=item $p->boolean_attribute_value( $val ) + +This method sets the value reported for boolean attributes inside HTML +start tags. By default, the name of the attribute is also used as its +value. This affects the values reported for C<tokens> and C<attr> +argspecs. + +=item $p->case_sensitive + +=item $p->case_sensitive( $bool ) + +By default, tagnames and attribute names are down-cased. Enabling this +attribute leaves them as found in the HTML source document. + +=item $p->closing_plaintext + +=item $p->closing_plaintext( $bool ) + +By default, "plaintext" element can never be closed. Everything up to +the end of the document is parsed in CDATA mode. This historical +behaviour is what at least MSIE does. Enabling this attribute makes +closing "</plaintext>" tag effective and the parsing process will resume +after seeing this tag. This emulates early gecko-based browsers. + +=item $p->empty_element_tags + +=item $p->empty_element_tags( $bool ) + +By default, empty element tags are not recognized as such and the "/" +before ">" is just treated like a normal name character (unless +C<strict_names> is enabled). Enabling this attribute make +C<HTML::Parser> recognize these tags. + +Empty element tags look like start tags, but end with the character +sequence "/>" instead of ">". When recognized by C<HTML::Parser> they +cause an artificial end event in addition to the start event. The +C<text> for the artificial end event will be empty and the C<tokenpos> +array will be undefined even though the token array will have one +element containing the tag name. + +=item $p->marked_sections + +=item $p->marked_sections( $bool ) + +By default, section markings like <![CDATA[...]]> are treated like +ordinary text. When this attribute is enabled section markings are +honoured. + +There are currently no events associated with the marked section +markup, but the text can be returned as C<skipped_text>. + +=item $p->strict_comment + +=item $p->strict_comment( $bool ) + +By default, comments are terminated by the first occurrence of "-->". +This is the behaviour of most popular browsers (like Mozilla, Opera and +MSIE), but it is not correct according to the official HTML +standard. Officially, you need an even number of "--" tokens before +the closing ">" is recognized and there may not be anything but +whitespace between an even and an odd "--". + +The official behaviour is enabled by enabling this attribute. + +Enabling of 'strict_comment' also disables recognizing these forms as +comments: + + </ comment> + <! comment> + + +=item $p->strict_end + +=item $p->strict_end( $bool ) + +By default, attributes and other junk are allowed to be present on end tags in a +manner that emulates MSIE's behaviour. + +The official behaviour is enabled with this attribute. If enabled, +only whitespace is allowed between the tagname and the final ">". + +=item $p->strict_names + +=item $p->strict_names( $bool ) + +By default, almost anything is allowed in tag and attribute names. +This is the behaviour of most popular browsers and allows us to parse +some broken tags with invalid attribute values like: + + <IMG SRC=newprevlstGr.gif ALT=[PREV LIST] BORDER=0> + +By default, "LIST]" is parsed as a boolean attribute, not as +part of the ALT value as was clearly intended. This is also what +Mozilla sees. + +The official behaviour is enabled by enabling this attribute. If +enabled, it will cause the tag above to be reported as text +since "LIST]" is not a legal attribute name. + +=item $p->unbroken_text + +=item $p->unbroken_text( $bool ) + +By default, blocks of text are given to the text handler as soon as +possible (but the parser takes care always to break text at a +boundary between whitespace and non-whitespace so single words and +entities can always be decoded safely). This might create breaks that +make it hard to do transformations on the text. When this attribute is +enabled, blocks of text are always reported in one piece. This will +delay the text event until the following (non-text) event has been +recognized by the parser. + +Note that the C<offset> argspec will give you the offset of the first +segment of text and C<length> is the combined length of the segments. +Since there might be ignored tags in between, these numbers can't be +used to directly index in the original document file. + +=item $p->utf8_mode + +=item $p->utf8_mode( $bool ) + +Enable this option when parsing raw undecoded UTF-8. This tells the +parser that the entities expanded for strings reported by C<attr>, +C<@attr> and C<dtext> should be expanded as decoded UTF-8 so they end +up compatible with the surrounding text. + +If C<utf8_mode> is enabled then it is an error to pass strings +containing characters with code above 255 to the parse() method, and +the parse() method will croak if you try. + +Example: The Unicode character "\x{2665}" is "\xE2\x99\xA5" when UTF-8 +encoded. The character can also be represented by the entity +"♥" or "♥". If we feed the parser: + + $p->parse("\xE2\x99\xA5♥"); + +then C<dtext> will be reported as "\xE2\x99\xA5\x{2665}" without +C<utf8_mode> enabled, but as "\xE2\x99\xA5\xE2\x99\xA5" when enabled. +The later string is what you want. + +This option is only available with perl-5.8 or better. + +=item $p->xml_mode + +=item $p->xml_mode( $bool ) + +Enabling this attribute changes the parser to allow some XML +constructs. This enables the behaviour controlled by individually by +the C<case_sensitive>, C<empty_element_tags>, C<strict_names> and +C<xml_pic> attributes and also suppresses special treatment of +elements that are parsed as CDATA for HTML. + +=item $p->xml_pic + +=item $p->xml_pic( $bool ) + +By default, I<processing instructions> are terminated by ">". When +this attribute is enabled, processing instructions are terminated by +"?>" instead. + +=back + +As markup and text is recognized, handlers are invoked. The following +method is used to set up handlers for different events: + +=over + +=item $p->handler( event => \&subroutine, $argspec ) + +=item $p->handler( event => $method_name, $argspec ) + +=item $p->handler( event => \@accum, $argspec ) + +=item $p->handler( event => "" ); + +=item $p->handler( event => undef ); + +=item $p->handler( event ); + +This method assigns a subroutine, method, or array to handle an event. + +Event is one of C<text>, C<start>, C<end>, C<declaration>, C<comment>, +C<process>, C<start_document>, C<end_document> or C<default>. + +The C<\&subroutine> is a reference to a subroutine which is called to handle +the event. + +The C<$method_name> is the name of a method of $p which is called to handle +the event. + +The C<@accum> is an array that will hold the event information as +sub-arrays. + +If the second argument is "", the event is ignored. +If it is undef, the default handler is invoked for the event. + +The C<$argspec> is a string that describes the information to be reported +for the event. Any requested information that does not apply to a +specific event is passed as C<undef>. If argspec is omitted, then it +is left unchanged. + +The return value from $p->handler is the old callback routine or a +reference to the accumulator array. + +Any return values from handler callback routines/methods are always +ignored. A handler callback can request parsing to be aborted by +invoking the $p->eof method. A handler callback is not allowed to +invoke the $p->parse() or $p->parse_file() method. An exception will +be raised if it tries. + +Examples: + + $p->handler(start => "start", 'self, attr, attrseq, text' ); + +This causes the "start" method of object $p to be called for 'start' events. +The callback signature is $p->start(\%attr, \@attr_seq, $text). + + $p->handler(start => \&start, 'attr, attrseq, text' ); + +This causes subroutine start() to be called for 'start' events. +The callback signature is start(\%attr, \@attr_seq, $text). + + $p->handler(start => \@accum, '"S", attr, attrseq, text' ); + +This causes 'start' event information to be saved in @accum. +The array elements will be ['S', \%attr, \@attr_seq, $text]. + + $p->handler(start => ""); + +This causes 'start' events to be ignored. It also suppresses +invocations of any default handler for start events. It is in most +cases equivalent to $p->handler(start => sub {}), but is more +efficient. It is different from the empty-sub-handler in that +C<skipped_text> is not reset by it. + + $p->handler(start => undef); + +This causes no handler to be associated with start events. +If there is a default handler it will be invoked. + +=back + +Filters based on tags can be set up to limit the number of events +reported. The main bottleneck during parsing is often the huge number +of callbacks made from the parser. Applying filters can improve +performance significantly. + +The following methods control filters: + +=over + +=item $p->ignore_elements( @tags ) + +Both the C<start> event and the C<end> event as well as any events that +would be reported in between are suppressed. The ignored elements can +contain nested occurrences of itself. Example: + + $p->ignore_elements(qw(script style)); + +The C<script> and C<style> tags will always nest properly since their +content is parsed in CDATA mode. For most other tags +C<ignore_elements> must be used with caution since HTML is often not +I<well formed>. + +=item $p->ignore_tags( @tags ) + +Any C<start> and C<end> events involving any of the tags given are +suppressed. To reset the filter (i.e. don't suppress any C<start> and +C<end> events), call C<ignore_tags> without an argument. + +=item $p->report_tags( @tags ) + +Any C<start> and C<end> events involving any of the tags I<not> given +are suppressed. To reset the filter (i.e. report all C<start> and +C<end> events), call C<report_tags> without an argument. + +=back + +Internally, the system has two filter lists, one for C<report_tags> +and one for C<ignore_tags>, and both filters are applied. This +effectively gives C<ignore_tags> precedence over C<report_tags>. + +Examples: + + $p->ignore_tags(qw(style)); + $p->report_tags(qw(script style)); + +results in only C<script> events being reported. + +=head2 Argspec + +Argspec is a string containing a comma-separated list that describes +the information reported by the event. The following argspec +identifier names can be used: + +=over + +=item C<attr> + +Attr causes a reference to a hash of attribute name/value pairs to be +passed. + +Boolean attributes' values are either the value set by +$p->boolean_attribute_value, or the attribute name if no value has been +set by $p->boolean_attribute_value. + +This passes undef except for C<start> events. + +Unless C<xml_mode> or C<case_sensitive> is enabled, the attribute +names are forced to lower case. + +General entities are decoded in the attribute values and +one layer of matching quotes enclosing the attribute values is removed. + +The Unicode character set is assumed for entity decoding. + +=item C<@attr> + +Basically the same as C<attr>, but keys and values are passed as +individual arguments and the original sequence of the attributes is +kept. The parameters passed will be the same as the @attr calculated +here: + + @attr = map { $_ => $attr->{$_} } @$attrseq; + +assuming $attr and $attrseq here are the hash and array passed as the +result of C<attr> and C<attrseq> argspecs. + +This passes no values for events besides C<start>. + +=item C<attrseq> + +Attrseq causes a reference to an array of attribute names to be +passed. This can be useful if you want to walk the C<attr> hash in +the original sequence. + +This passes undef except for C<start> events. + +Unless C<xml_mode> or C<case_sensitive> is enabled, the attribute +names are forced to lower case. + +=item C<column> + +Column causes the column number of the start of the event to be passed. +The first column on a line is 0. + +=item C<dtext> + +Dtext causes the decoded text to be passed. General entities are +automatically decoded unless the event was inside a CDATA section or +was between literal start and end tags (C<script>, C<style>, +C<xmp>, C<iframe>, C<title>, C<textarea> and C<plaintext>). + +The Unicode character set is assumed for entity decoding. With Perl +version 5.6 or earlier only the Latin-1 range is supported, and +entities for characters outside the range 0..255 are left unchanged. + +This passes undef except for C<text> events. + +=item C<event> + +Event causes the event name to be passed. + +The event name is one of C<text>, C<start>, C<end>, C<declaration>, +C<comment>, C<process>, C<start_document> or C<end_document>. + +=item C<is_cdata> + +Is_cdata causes a TRUE value to be passed if the event is inside a CDATA +section or between literal start and end tags (C<script>, +C<style>, C<xmp>, C<iframe>, C<title>, C<textarea> and C<plaintext>). + +if the flag is FALSE for a text event, then you should normally +either use C<dtext> or decode the entities yourself before the text is +processed further. + +=item C<length> + +Length causes the number of bytes of the source text of the event to +be passed. + +=item C<line> + +Line causes the line number of the start of the event to be passed. +The first line in the document is 1. Line counting doesn't start +until at least one handler requests this value to be reported. + +=item C<offset> + +Offset causes the byte position in the HTML document of the start of +the event to be passed. The first byte in the document has offset 0. + +=item C<offset_end> + +Offset_end causes the byte position in the HTML document of the end of +the event to be passed. This is the same as C<offset> + C<length>. + +=item C<self> + +Self causes the current object to be passed to the handler. If the +handler is a method, this must be the first element in the argspec. + +An alternative to passing self as an argspec is to register closures +that capture $self by themselves as handlers. Unfortunately this +creates circular references which prevent the HTML::Parser object +from being garbage collected. Using the C<self> argspec avoids this +problem. + +=item C<skipped_text> + +Skipped_text returns the concatenated text of all the events that have +been skipped since the last time an event was reported. Events might +be skipped because no handler is registered for them or because some +filter applies. Skipped text also includes marked section markup, +since there are no events that can catch it. + +If an C<"">-handler is registered for an event, then the text for this +event is not included in C<skipped_text>. Skipped text both before +and after the C<"">-event is included in the next reported +C<skipped_text>. + +=item C<tag> + +Same as C<tagname>, but prefixed with "/" if it belongs to an C<end> +event and "!" for a declaration. The C<tag> does not have any prefix +for C<start> events, and is in this case identical to C<tagname>. + +=item C<tagname> + +This is the element name (or I<generic identifier> in SGML jargon) for +start and end tags. Since HTML is case insensitive, this name is +forced to lower case to ease string matching. + +Since XML is case sensitive, the tagname case is not changed when +C<xml_mode> is enabled. The same happens if the C<case_sensitive> attribute +is set. + +The declaration type of declaration elements is also passed as a tagname, +even if that is a bit strange. +In fact, in the current implementation tagname is +identical to C<token0> except that the name may be forced to lower case. + +=item C<token0> + +Token0 causes the original text of the first token string to be +passed. This should always be the same as $tokens->[0]. + +For C<declaration> events, this is the declaration type. + +For C<start> and C<end> events, this is the tag name. + +For C<process> and non-strict C<comment> events, this is everything +inside the tag. + +This passes undef if there are no tokens in the event. + +=item C<tokenpos> + +Tokenpos causes a reference to an array of token positions to be +passed. For each string that appears in C<tokens>, this array +contains two numbers. The first number is the offset of the start of +the token in the original C<text> and the second number is the length +of the token. + +Boolean attributes in a C<start> event will have (0,0) for the +attribute value offset and length. + +This passes undef if there are no tokens in the event (e.g., C<text>) +and for artificial C<end> events triggered by empty element tags. + +If you are using these offsets and lengths to modify C<text>, you +should either work from right to left, or be very careful to calculate +the changes to the offsets. + +=item C<tokens> + +Tokens causes a reference to an array of token strings to be passed. +The strings are exactly as they were found in the original text, +no decoding or case changes are applied. + +For C<declaration> events, the array contains each word, comment, and +delimited string starting with the declaration type. + +For C<comment> events, this contains each sub-comment. If +$p->strict_comments is disabled, there will be only one sub-comment. + +For C<start> events, this contains the original tag name followed by +the attribute name/value pairs. The values of boolean attributes will +be either the value set by $p->boolean_attribute_value, or the +attribute name if no value has been set by +$p->boolean_attribute_value. + +For C<end> events, this contains the original tag name (always one token). + +For C<process> events, this contains the process instructions (always one +token). + +This passes C<undef> for C<text> events. + +=item C<text> + +Text causes the source text (including markup element delimiters) to be +passed. + +=item C<undef> + +Pass an undefined value. Useful as padding where the same handler +routine is registered for multiple events. + +=item C<'...'> + +A literal string of 0 to 255 characters enclosed +in single (') or double (") quotes is passed as entered. + +=back + +The whole argspec string can be wrapped up in C<'@{...}'> to signal +that the resulting event array should be flattened. This only makes a +difference if an array reference is used as the handler target. +Consider this example: + + $p->handler(text => [], 'text'); + $p->handler(text => [], '@{text}']); + +With two text events; C<"foo">, C<"bar">; then the first example will end +up with [["foo"], ["bar"]] and the second with ["foo", "bar"] in +the handler target array. + + +=head2 Events + +Handlers for the following events can be registered: + +=over + +=item C<comment> + +This event is triggered when a markup comment is recognized. + +Example: + + <!-- This is a comment -- -- So is this --> + +=item C<declaration> + +This event is triggered when a I<markup declaration> is recognized. + +For typical HTML documents, the only declaration you are +likely to find is <!DOCTYPE ...>. + +Example: + + <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" + "http://www.w3.org/TR/html4/strict.dtd"> + +DTDs inside <!DOCTYPE ...> will confuse HTML::Parser. + +=item C<default> + +This event is triggered for events that do not have a specific +handler. You can set up a handler for this event to catch stuff you +did not want to catch explicitly. + +=item C<end> + +This event is triggered when an end tag is recognized. + +Example: + + </A> + +=item C<end_document> + +This event is triggered when $p->eof is called and after any remaining +text is flushed. There is no document text associated with this event. + +=item C<process> + +This event is triggered when a processing instructions markup is +recognized. + +The format and content of processing instructions are system and +application dependent. + +Examples: + + <? HTML processing instructions > + <? XML processing instructions ?> + +=item C<start> + +This event is triggered when a start tag is recognized. + +Example: + + <A HREF="http://www.perl.com/"> + +=item C<start_document> + +This event is triggered before any other events for a new document. A +handler for it can be used to initialize stuff. There is no document +text associated with this event. + +=item C<text> + +This event is triggered when plain text (characters) is recognized. +The text may contain multiple lines. A sequence of text may be broken +between several text events unless $p->unbroken_text is enabled. + +The parser will make sure that it does not break a word or a sequence +of whitespace between two text events. + +=back + +=head2 Unicode + +C<HTML::Parser> can parse Unicode strings when running under +perl-5.8 or better. If Unicode is passed to $p->parse() then chunks +of Unicode will be reported to the handlers. The offset and length +argspecs will also report their position in terms of characters. + +It is safe to parse raw undecoded UTF-8 if you either avoid decoding +entities and make sure to not use I<argspecs> that do, or enable the +C<utf8_mode> for the parser. Parsing of undecoded UTF-8 might be +useful when parsing from a file where you need the reported offsets +and lengths to match the byte offsets in the file. + +If a filename is passed to $p->parse_file() then the file will be read +in binary mode. This will be fine if the file contains only ASCII or +Latin-1 characters. If the file contains UTF-8 encoded text then care +must be taken when decoding entities as described in the previous +paragraph, but better is to open the file with the UTF-8 layer so that +it is decoded properly: + + open(my $fh, "<:utf8", "index.html") || die "...: $!"; + $p->parse_file($fh); + +If the file contains text encoded in a charset besides ASCII, Latin-1 +or UTF-8 then decoding will always be needed. + +=head1 VERSION 2 COMPATIBILITY + +When an C<HTML::Parser> object is constructed with no arguments, a set +of handlers is automatically provided that is compatible with the old +HTML::Parser version 2 callback methods. + +This is equivalent to the following method calls: + + $p->handler(start => "start", "self, tagname, attr, attrseq, text"); + $p->handler(end => "end", "self, tagname, text"); + $p->handler(text => "text", "self, text, is_cdata"); + $p->handler(process => "process", "self, token0, text"); + $p->handler(comment => + sub { + my($self, $tokens) = @_; + for (@$tokens) {$self->comment($_);}}, + "self, tokens"); + $p->handler(declaration => + sub { + my $self = shift; + $self->declaration(substr($_[0], 2, -1));}, + "self, text"); + +Setting up these handlers can also be requested with the "api_version => +2" constructor option. + +=head1 SUBCLASSING + +The C<HTML::Parser> class is subclassable. Parser objects are plain +hashes and C<HTML::Parser> reserves only hash keys that start with +"_hparser". The parser state can be set up by invoking the init() +method, which takes the same arguments as new(). + +=head1 EXAMPLES + +The first simple example shows how you might strip out comments from +an HTML document. We achieve this by setting up a comment handler that +does nothing and a default handler that will print out anything else: + + use HTML::Parser; + HTML::Parser->new(default_h => [sub { print shift }, 'text'], + comment_h => [""], + )->parse_file(shift || die) || die $!; + +An alternative implementation is: + + use HTML::Parser; + HTML::Parser->new(end_document_h => [sub { print shift }, + 'skipped_text'], + comment_h => [""], + )->parse_file(shift || die) || die $!; + +This will in most cases be much more efficient since only a single +callback will be made. + +The next example prints out the text that is inside the <title> +element of an HTML document. Here we start by setting up a start +handler. When it sees the title start tag it enables a text handler +that prints any text found and an end handler that will terminate +parsing as soon as the title end tag is seen: + + use HTML::Parser (); + + sub start_handler + { + return if shift ne "title"; + my $self = shift; + $self->handler(text => sub { print shift }, "dtext"); + $self->handler(end => sub { shift->eof if shift eq "title"; }, + "tagname,self"); + } + + my $p = HTML::Parser->new(api_version => 3); + $p->handler( start => \&start_handler, "tagname,self"); + $p->parse_file(shift || die) || die $!; + print "\n"; + +More examples are found in the F<eg/> directory of the C<HTML-Parser> +distribution: the program C<hrefsub> shows how you can edit all links +found in a document; the program C<htextsub> shows how to edit the text only; the +program C<hstrip> shows how you can strip out certain tags/elements +and/or attributes; and the program C<htext> show how to obtain the +plain text, but not any script/style content. + +You can browse the F<eg/> directory online from the I<[Browse]> link on +the http://search.cpan.org/~gaas/HTML-Parser/ page. + +=head1 BUGS + +The <style> and <script> sections do not end with the first "</", but +need the complete corresponding end tag. The standard behaviour is +not really practical. + +When the I<strict_comment> option is enabled, we still recognize +comments where there is something other than whitespace between even +and odd "--" markers. + +Once $p->boolean_attribute_value has been set, there is no way to +restore the default behaviour. + +There is currently no way to get both quote characters +into the same literal argspec. + +Empty tags, e.g. "<>" and "</>", are not recognized. SGML allows them +to repeat the previous start tag or close the previous start tag +respectively. + +NET tags, e.g. "code/.../" are not recognized. This is SGML +shorthand for "<code>...</code>". + +Unclosed start or end tags, e.g. "<tt<b>...</b</tt>" are not +recognized. + +=head1 DIAGNOSTICS + +The following messages may be produced by HTML::Parser. The notation +in this listing is the same as used in L<perldiag>: + +=over + +=item Not a reference to a hash + +(F) The object blessed into or subclassed from HTML::Parser is not a +hash as required by the HTML::Parser methods. + +=item Bad signature in parser state object at %p + +(F) The _hparser_xs_state element does not refer to a valid state structure. +Something must have changed the internal value +stored in this hash element, or the memory has been overwritten. + +=item _hparser_xs_state element is not a reference + +(F) The _hparser_xs_state element has been destroyed. + +=item Can't find '_hparser_xs_state' element in HTML::Parser hash + +(F) The _hparser_xs_state element is missing from the parser hash. +It was either deleted, or not created when the object was created. + +=item API version %s not supported by HTML::Parser %s + +(F) The constructor option 'api_version' with an argument greater than +or equal to 4 is reserved for future extensions. + +=item Bad constructor option '%s' + +(F) An unknown constructor option key was passed to the new() or +init() methods. + +=item Parse loop not allowed + +(F) A handler invoked the parse() or parse_file() method. +This is not permitted. + +=item marked sections not supported + +(F) The $p->marked_sections() method was invoked in a HTML::Parser +module that was compiled without support for marked sections. + +=item Unknown boolean attribute (%d) + +(F) Something is wrong with the internal logic that set up aliases for +boolean attributes. + +=item Only code or array references allowed as handler + +(F) The second argument for $p->handler must be either a subroutine +reference, then name of a subroutine or method, or a reference to an +array. + +=item No handler for %s events + +(F) The first argument to $p->handler must be a valid event name; i.e. one +of "start", "end", "text", "process", "declaration" or "comment". + +=item Unrecognized identifier %s in argspec + +(F) The identifier is not a known argspec name. +Use one of the names mentioned in the argspec section above. + +=item Literal string is longer than 255 chars in argspec + +(F) The current implementation limits the length of literals in +an argspec to 255 characters. Make the literal shorter. + +=item Backslash reserved for literal string in argspec + +(F) The backslash character "\" is not allowed in argspec literals. +It is reserved to permit quoting inside a literal in a later version. + +=item Unterminated literal string in argspec + +(F) The terminating quote character for a literal was not found. + +=item Bad argspec (%s) + +(F) Only identifier names, literals, spaces and commas +are allowed in argspecs. + +=item Missing comma separator in argspec + +(F) Identifiers in an argspec must be separated with ",". + +=item Parsing of undecoded UTF-8 will give garbage when decoding entities + +(W) The first chunk parsed appears to contain undecoded UTF-8 and one +or more argspecs that decode entities are used for the callback +handlers. + +The result of decoding will be a mix of encoded and decoded characters +for any entities that expand to characters with code above 127. This +is not a good thing. + +The recommended solution is to apply Encode::decode_utf8() on the data before +feeding it to the $p->parse(). For $p->parse_file() pass a file that has been +opened in ":utf8" mode. + +The alternative solution is to enable the C<utf8_mode> and not decode before +passing strings to $p->parse(). The parser can process raw undecoded UTF-8 +sanely if the C<utf8_mode> is enabled, or if the "attr", "@attr" or "dtext" +argspecs are avoided. + +=item Parsing string decoded with wrong endianness + +(W) The first character in the document is U+FFFE. This is not a +legal Unicode character but a byte swapped BOM. The result of parsing +will likely be garbage. + +=item Parsing of undecoded UTF-32 + +(W) The parser found the Unicode UTF-32 BOM signature at the start +of the document. The result of parsing will likely be garbage. + +=item Parsing of undecoded UTF-16 + +(W) The parser found the Unicode UTF-16 BOM signature at the start of +the document. The result of parsing will likely be garbage. + +=back + +=head1 SEE ALSO + +L<HTML::Entities>, L<HTML::PullParser>, L<HTML::TokeParser>, L<HTML::HeadParser>, +L<HTML::LinkExtor>, L<HTML::Form> + +L<HTML::TreeBuilder> (part of the I<HTML-Tree> distribution) + +L<http://www.w3.org/TR/html4/> + +More information about marked sections and processing instructions may +be found at L<http://www.is-thought.co.uk/book/sgml-8.htm>. + +=head1 COPYRIGHT + + Copyright 1996-2016 Gisle Aas. All rights reserved. + Copyright 1999-2000 Michael A. Chase. All rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/PullParser.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/PullParser.pm new file mode 100644 index 0000000000..3083379325 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/PullParser.pm @@ -0,0 +1,209 @@ +package HTML::PullParser; + +require HTML::Parser; +@ISA=qw(HTML::Parser); +$VERSION = "3.57"; + +use strict; +use Carp (); + +sub new +{ + my($class, %cnf) = @_; + + # Construct argspecs for the various events + my %argspec; + for (qw(start end text declaration comment process default)) { + my $tmp = delete $cnf{$_}; + next unless defined $tmp; + $argspec{$_} = $tmp; + } + Carp::croak("Info not collected for any events") + unless %argspec; + + my $file = delete $cnf{file}; + my $doc = delete $cnf{doc}; + Carp::croak("Can't parse from both 'doc' and 'file' at the same time") + if defined($file) && defined($doc); + Carp::croak("No 'doc' or 'file' given to parse from") + unless defined($file) || defined($doc); + + # Create object + $cnf{api_version} = 3; + my $self = $class->SUPER::new(%cnf); + + my $accum = $self->{pullparser_accum} = []; + while (my($event, $argspec) = each %argspec) { + $self->SUPER::handler($event => $accum, $argspec); + } + + if (defined $doc) { + $self->{pullparser_str_ref} = ref($doc) ? $doc : \$doc; + $self->{pullparser_str_pos} = 0; + } + else { + if (!ref($file) && ref(\$file) ne "GLOB") { + require IO::File; + $file = IO::File->new($file, "r") || return; + } + + $self->{pullparser_file} = $file; + } + $self; +} + + +sub handler +{ + Carp::croak("Can't set handlers for HTML::PullParser"); +} + + +sub get_token +{ + my $self = shift; + while (!@{$self->{pullparser_accum}} && !$self->{pullparser_eof}) { + if (my $f = $self->{pullparser_file}) { + # must try to parse more from the file + my $buf; + if (read($f, $buf, 512)) { + $self->parse($buf); + } else { + $self->eof; + $self->{pullparser_eof}++; + delete $self->{pullparser_file}; + } + } + elsif (my $sref = $self->{pullparser_str_ref}) { + # must try to parse more from the scalar + my $pos = $self->{pullparser_str_pos}; + my $chunk = substr($$sref, $pos, 512); + $self->parse($chunk); + $pos += length($chunk); + if ($pos < length($$sref)) { + $self->{pullparser_str_pos} = $pos; + } + else { + $self->eof; + $self->{pullparser_eof}++; + delete $self->{pullparser_str_ref}; + delete $self->{pullparser_str_pos}; + } + } + else { + die; + } + } + shift @{$self->{pullparser_accum}}; +} + + +sub unget_token +{ + my $self = shift; + unshift @{$self->{pullparser_accum}}, @_; + $self; +} + +1; + + +__END__ + +=head1 NAME + +HTML::PullParser - Alternative HTML::Parser interface + +=head1 SYNOPSIS + + use HTML::PullParser; + + $p = HTML::PullParser->new(file => "index.html", + start => 'event, tagname, @attr', + end => 'event, tagname', + ignore_elements => [qw(script style)], + ) || die "Can't open: $!"; + while (my $token = $p->get_token) { + #...do something with $token + } + +=head1 DESCRIPTION + +The HTML::PullParser is an alternative interface to the HTML::Parser class. +It basically turns the HTML::Parser inside out. You associate a file +(or any IO::Handle object or string) with the parser at construction time and +then repeatedly call $parser->get_token to obtain the tags and text +found in the parsed document. + +The following methods are provided: + +=over 4 + +=item $p = HTML::PullParser->new( file => $file, %options ) + +=item $p = HTML::PullParser->new( doc => \$doc, %options ) + +A C<HTML::PullParser> can be made to parse from either a file or a +literal document based on whether the C<file> or C<doc> option is +passed to the parser's constructor. + +The C<file> passed in can either be a file name or a file handle +object. If a file name is passed, and it can't be opened for reading, +then the constructor will return an undefined value and $! will tell +you why it failed. Otherwise the argument is taken to be some object +that the C<HTML::PullParser> can read() from when it needs more data. +The stream will be read() until EOF, but not closed. + +A C<doc> can be passed plain or as a reference +to a scalar. If a reference is passed then the value of this scalar +should not be changed before all tokens have been extracted. + +Next the information to be returned for the different token types must +be set up. This is done by simply associating an argspec (as defined +in L<HTML::Parser>) with the events you have an interest in. For +instance, if you want C<start> tokens to be reported as the string +C<'S'> followed by the tagname and the attributes you might pass an +C<start>-option like this: + + $p = HTML::PullParser->new( + doc => $document_to_parse, + start => '"S", tagname, @attr', + end => '"E", tagname', + ); + +At last other C<HTML::Parser> options, like C<ignore_tags>, and +C<unbroken_text>, can be passed in. Note that you should not use the +I<event>_h options to set up parser handlers. That would confuse the +inner logic of C<HTML::PullParser>. + +=item $token = $p->get_token + +This method will return the next I<token> found in the HTML document, +or C<undef> at the end of the document. The token is returned as an +array reference. The content of this array match the argspec set up +during C<HTML::PullParser> construction. + +=item $p->unget_token( @tokens ) + +If you find out you have read too many tokens you can push them back, +so that they are returned again the next time $p->get_token is called. + +=back + +=head1 EXAMPLES + +The 'eg/hform' script shows how we might parse the form section of +HTML::Documents using HTML::PullParser. + +=head1 SEE ALSO + +L<HTML::Parser>, L<HTML::TokeParser> + +=head1 COPYRIGHT + +Copyright 1998-2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Tagset.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Tagset.pm new file mode 100644 index 0000000000..754137fd6f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/Tagset.pm @@ -0,0 +1,471 @@ +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::isBodyMarkup + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/TokeParser.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/TokeParser.pm new file mode 100644 index 0000000000..959b96f6a2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTML/TokeParser.pm @@ -0,0 +1,371 @@ +package HTML::TokeParser; + +require HTML::PullParser; +@ISA=qw(HTML::PullParser); +$VERSION = "3.69"; + +use strict; +use Carp (); +use HTML::Entities qw(decode_entities); +use HTML::Tagset (); + +my %ARGS = +( + start => "'S',tagname,attr,attrseq,text", + end => "'E',tagname,text", + text => "'T',text,is_cdata", + process => "'PI',token0,text", + comment => "'C',text", + declaration => "'D',text", + + # options that default on + unbroken_text => 1, +); + + +sub new +{ + my $class = shift; + my %cnf; + + if (@_ == 1) { + my $type = (ref($_[0]) eq "SCALAR") ? "doc" : "file"; + %cnf = ($type => $_[0]); + } + else { + unshift @_, (ref($_[0]) eq "SCALAR") ? "doc" : "file" if(scalar(@_) % 2 == 1); + %cnf = @_; + } + + my $textify = delete $cnf{textify} || {img => "alt", applet => "alt"}; + + my $self = $class->SUPER::new(%ARGS, %cnf) || return undef; + + $self->{textify} = $textify; + $self; +} + + +sub get_tag +{ + my $self = shift; + my $token; + while (1) { + $token = $self->get_token || return undef; + my $type = shift @$token; + next unless $type eq "S" || $type eq "E"; + substr($token->[0], 0, 0) = "/" if $type eq "E"; + return $token unless @_; + for (@_) { + return $token if $token->[0] eq $_; + } + } +} + + +sub _textify { + my($self, $token) = @_; + my $tag = $token->[1]; + return undef unless exists $self->{textify}{$tag}; + + my $alt = $self->{textify}{$tag}; + my $text; + if (ref($alt)) { + $text = &$alt(@$token); + } else { + $text = $token->[2]{$alt || "alt"}; + $text = "[\U$tag]" unless defined $text; + } + return $text; +} + + +sub get_text +{ + my $self = shift; + my @text; + while (my $token = $self->get_token) { + my $type = $token->[0]; + if ($type eq "T") { + my $text = $token->[1]; + decode_entities($text) unless $token->[2]; + push(@text, $text); + } elsif ($type =~ /^[SE]$/) { + my $tag = $token->[1]; + if ($type eq "S") { + if (defined(my $text = _textify($self, $token))) { + push(@text, $text); + next; + } + } else { + $tag = "/$tag"; + } + if (!@_ || grep $_ eq $tag, @_) { + $self->unget_token($token); + last; + } + push(@text, " ") + if $tag eq "br" || !$HTML::Tagset::isPhraseMarkup{$token->[1]}; + } + } + join("", @text); +} + + +sub get_trimmed_text +{ + my $self = shift; + my $text = $self->get_text(@_); + $text =~ s/^\s+//; $text =~ s/\s+$//; $text =~ s/\s+/ /g; + $text; +} + +sub get_phrase { + my $self = shift; + my @text; + while (my $token = $self->get_token) { + my $type = $token->[0]; + if ($type eq "T") { + my $text = $token->[1]; + decode_entities($text) unless $token->[2]; + push(@text, $text); + } elsif ($type =~ /^[SE]$/) { + my $tag = $token->[1]; + if ($type eq "S") { + if (defined(my $text = _textify($self, $token))) { + push(@text, $text); + next; + } + } + if (!$HTML::Tagset::isPhraseMarkup{$tag}) { + $self->unget_token($token); + last; + } + push(@text, " ") if $tag eq "br"; + } + } + my $text = join("", @text); + $text =~ s/^\s+//; $text =~ s/\s+$//; $text =~ s/\s+/ /g; + $text; +} + +1; + + +__END__ + +=head1 NAME + +HTML::TokeParser - Alternative HTML::Parser interface + +=head1 SYNOPSIS + + require HTML::TokeParser; + $p = HTML::TokeParser->new("index.html") || + die "Can't open: $!"; + $p->empty_element_tags(1); # configure its behaviour + + while (my $token = $p->get_token) { + #... + } + +=head1 DESCRIPTION + +The C<HTML::TokeParser> is an alternative interface to the +C<HTML::Parser> class. It is an C<HTML::PullParser> subclass with a +predeclared set of token types. If you wish the tokens to be reported +differently you probably want to use the C<HTML::PullParser> directly. + +The following methods are available: + +=over 4 + +=item $p = HTML::TokeParser->new( $filename, %opt ); + +=item $p = HTML::TokeParser->new( $filehandle, %opt ); + +=item $p = HTML::TokeParser->new( \$document, %opt ); + +The object constructor argument is either a file name, a file handle +object, or the complete document to be parsed. Extra options can be +provided as key/value pairs and are processed as documented by the base +classes. + +If the argument is a plain scalar, then it is taken as the name of a +file to be opened and parsed. If the file can't be opened for +reading, then the constructor will return C<undef> and $! will tell +you why it failed. + +If the argument is a reference to a plain scalar, then this scalar is +taken to be the literal document to parse. The value of this +scalar should not be changed before all tokens have been extracted. + +Otherwise the argument is taken to be some object that the +C<HTML::TokeParser> can read() from when it needs more data. Typically +it will be a filehandle of some kind. The stream will be read() until +EOF, but not closed. + +A newly constructed C<HTML::TokeParser> differ from its base classes +by having the C<unbroken_text> attribute enabled by default. See +L<HTML::Parser> for a description of this and other attributes that +influence how the document is parsed. It is often a good idea to enable +C<empty_element_tags> behaviour. + +Note that the parsing result will likely not be valid if raw undecoded +UTF-8 is used as a source. When parsing UTF-8 encoded files turn +on UTF-8 decoding: + + open(my $fh, "<:utf8", "index.html") || die "Can't open 'index.html': $!"; + my $p = HTML::TokeParser->new( $fh ); + # ... + +If a $filename is passed to the constructor the file will be opened in +raw mode and the parsing result will only be valid if its content is +Latin-1 or pure ASCII. + +If parsing from an UTF-8 encoded string buffer decode it first: + + utf8::decode($document); + my $p = HTML::TokeParser->new( \$document ); + # ... + +=item $p->get_token + +This method will return the next I<token> found in the HTML document, +or C<undef> at the end of the document. The token is returned as an +array reference. The first element of the array will be a string +denoting the type of this token: "S" for start tag, "E" for end tag, +"T" for text, "C" for comment, "D" for declaration, and "PI" for +process instructions. The rest of the token array depend on the type +like this: + + ["S", $tag, $attr, $attrseq, $text] + ["E", $tag, $text] + ["T", $text, $is_data] + ["C", $text] + ["D", $text] + ["PI", $token0, $text] + +where $attr is a hash reference, $attrseq is an array reference and +the rest are plain scalars. The L<HTML::Parser/Argspec> explains the +details. + +=item $p->unget_token( @tokens ) + +If you find you have read too many tokens you can push them back, +so that they are returned the next time $p->get_token is called. + +=item $p->get_tag + +=item $p->get_tag( @tags ) + +This method returns the next start or end tag (skipping any other +tokens), or C<undef> if there are no more tags in the document. If +one or more arguments are given, then we skip tokens until one of the +specified tag types is found. For example: + + $p->get_tag("font", "/font"); + +will find the next start or end tag for a font-element. + +The tag information is returned as an array reference in the same form +as for $p->get_token above, but the type code (first element) is +missing. A start tag will be returned like this: + + [$tag, $attr, $attrseq, $text] + +The tagname of end tags are prefixed with "/", i.e. end tag is +returned like this: + + ["/$tag", $text] + +=item $p->get_text + +=item $p->get_text( @endtags ) + +This method returns all text found at the current position. It will +return a zero length string if the next token is not text. Any +entities will be converted to their corresponding character. + +If one or more arguments are given, then we return all text occurring +before the first of the specified tags found. For example: + + $p->get_text("p", "br"); + +will return the text up to either a paragraph of linebreak element. + +The text might span tags that should be I<textified>. This is +controlled by the $p->{textify} attribute, which is a hash that +defines how certain tags can be treated as text. If the name of a +start tag matches a key in this hash then this tag is converted to +text. The hash value is used to specify which tag attribute to obtain +the text from. If this tag attribute is missing, then the upper case +name of the tag enclosed in brackets is returned, e.g. "[IMG]". The +hash value can also be a subroutine reference. In this case the +routine is called with the start tag token content as its argument and +the return value is treated as the text. + +The default $p->{textify} value is: + + {img => "alt", applet => "alt"} + +This means that <IMG> and <APPLET> tags are treated as text, and that +the text to substitute can be found in the ALT attribute. + +=item $p->get_trimmed_text + +=item $p->get_trimmed_text( @endtags ) + +Same as $p->get_text above, but will collapse any sequences of white +space to a single space character. Leading and trailing white space is +removed. + +=item $p->get_phrase + +This will return all text found at the current position ignoring any +phrasal-level tags. Text is extracted until the first non +phrasal-level tag. Textification of tags is the same as for +get_text(). This method will collapse white space in the same way as +get_trimmed_text() does. + +The definition of <i>phrasal-level tags</i> is obtained from the +HTML::Tagset module. + +=back + +=head1 EXAMPLES + +This example extracts all links from a document. It will print one +line for each link, containing the URL and the textual description +between the <A>...</A> tags: + + use HTML::TokeParser; + $p = HTML::TokeParser->new(shift||"index.html"); + + while (my $token = $p->get_tag("a")) { + my $url = $token->[1]{href} || "-"; + my $text = $p->get_trimmed_text("/a"); + print "$url\t$text\n"; + } + +This example extract the <TITLE> from the document: + + use HTML::TokeParser; + $p = HTML::TokeParser->new(shift||"index.html"); + if ($p->get_tag("title")) { + my $title = $p->get_trimmed_text; + print "Title: $title\n"; + } + +=head1 SEE ALSO + +L<HTML::PullParser>, L<HTML::Parser> + +=head1 COPYRIGHT + +Copyright 1998-2005 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Config.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Config.pm new file mode 100644 index 0000000000..0742c932fc --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Config.pm @@ -0,0 +1,454 @@ +package HTTP::Config; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +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; + return 1 if $request->header($k) eq $v; + return 1 if $response && $response->header($k) 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.18 + +=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-2017 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 + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Cookies.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Cookies.pm new file mode 100644 index 0000000000..dcbeba64d2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Cookies.pm @@ -0,0 +1,844 @@ +package HTTP::Cookies; + +use strict; +use HTTP::Date qw(str2time parse_date time2str); +use HTTP::Headers::Util qw(_split_header_words join_header_words); + +use vars qw($EPOCH_OFFSET); +our $VERSION = '6.04'; + +# Legacy: because "use "HTTP::Cookies" used be the ONLY way +# to load the class HTTP::Cookies::Netscape. +require HTTP::Cookies::Netscape; + +$EPOCH_OFFSET = 0; # difference from Unix epoch +if ($^O eq "MacOS") { + require Time::Local; + $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70); +} + +# A HTTP::Cookies object is a hash. The main attribute is the +# COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}. + +sub new +{ + my $class = shift; + my $self = bless { + COOKIES => {}, + }, $class; + my %cnf = @_; + for (keys %cnf) { + $self->{lc($_)} = $cnf{$_}; + } + $self->load; + $self; +} + + +sub add_cookie_header +{ + my $self = shift; + my $request = shift || return; + my $url = $request->uri; + my $scheme = $url->scheme; + unless ($scheme =~ /^https?\z/) { + return; + } + + my $domain = _host($request, $url); + $domain = "$domain.local" unless $domain =~ /\./; + my $secure_request = ($scheme eq "https"); + my $req_path = _url_path($url); + my $req_port = $url->port; + my $now = time(); + _normalize_path($req_path) if $req_path =~ /%/; + + my @cval; # cookie values for the "Cookie" header + my $set_ver; + my $netscape_only = 0; # An exact domain match applies to any cookie + + while ($domain =~ /\./) { + # Checking $domain for cookies" + my $cookies = $self->{COOKIES}{$domain}; + next unless $cookies; + if ($self->{delayload} && defined($cookies->{'//+delayload'})) { + my $cookie_data = $cookies->{'//+delayload'}{'cookie'}; + delete $self->{COOKIES}{$domain}; + $self->load_cookie($cookie_data->[1]); + $cookies = $self->{COOKIES}{$domain}; + next unless $cookies; # should not really happen + } + + # Want to add cookies corresponding to the most specific paths + # first (i.e. longest path first) + my $path; + for $path (sort {length($b) <=> length($a) } keys %$cookies) { + if (index($req_path, $path) != 0) { + next; + } + + my($key,$array); + while (($key,$array) = each %{$cookies->{$path}}) { + my($version,$val,$port,$path_spec,$secure,$expires) = @$array; + if ($secure && !$secure_request) { + next; + } + if ($expires && $expires < $now) { + next; + } + if ($port) { + my $found; + if ($port =~ s/^_//) { + # The corresponding Set-Cookie attribute was empty + $found++ if $port eq $req_port; + $port = ""; + } + else { + my $p; + for $p (split(/,/, $port)) { + $found++, last if $p eq $req_port; + } + } + unless ($found) { + next; + } + } + if ($version > 0 && $netscape_only) { + next; + } + + # set version number of cookie header. + # XXX: What should it be if multiple matching + # Set-Cookie headers have different versions themselves + if (!$set_ver++) { + if ($version >= 1) { + push(@cval, "\$Version=$version"); + } + elsif (!$self->{hide_cookie2}) { + $request->header(Cookie2 => '$Version="1"'); + } + } + + # do we need to quote the value + if ($val =~ /\W/ && $version) { + $val =~ s/([\\\"])/\\$1/g; + $val = qq("$val"); + } + + # and finally remember this cookie + push(@cval, "$key=$val"); + if ($version >= 1) { + push(@cval, qq(\$Path="$path")) if $path_spec; + push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./; + if (defined $port) { + my $p = '$Port'; + $p .= qq(="$port") if length $port; + push(@cval, $p); + } + } + + } + } + + } continue { + # Try with a more general domain, alternately stripping + # leading name components and leading dots. When this + # results in a domain with no leading dot, it is for + # Netscape cookie compatibility only: + # + # a.b.c.net Any cookie + # .b.c.net Any cookie + # b.c.net Netscape cookie only + # .c.net Any cookie + + if ($domain =~ s/^\.+//) { + $netscape_only = 1; + } + else { + $domain =~ s/[^.]*//; + $netscape_only = 0; + } + } + + if (@cval) { + if (my $old = $request->header("Cookie")) { + unshift(@cval, $old); + } + $request->header(Cookie => join("; ", @cval)); + if (my $hash = $request->{_http_cookies}) { + %$hash = (map split(/=/, $_, 2), @cval); + } + } + + $request; +} + + +sub get_cookies +{ + my $self = shift; + my $url = shift; + $url = "https://$url" unless $url =~ m,^[a-zA-Z][a-zA-Z0-9.+\-]*:,; + require HTTP::Request; + my $req = HTTP::Request->new(GET => $url); + my $cookies = $req->{_http_cookies} = {}; + $self->add_cookie_header($req); + if (@_) { + return map $cookies->{$_}, @_ if wantarray; + return $cookies->{$_[0]}; + } + return $cookies; +} + + +sub extract_cookies +{ + my $self = shift; + my $response = shift || return; + + my @set = _split_header_words($response->_header("Set-Cookie2")); + my @ns_set = $response->_header("Set-Cookie"); + + return $response unless @set || @ns_set; # quick exit + + my $request = $response->request; + my $url = $request->uri; + my $req_host = _host($request, $url); + $req_host = "$req_host.local" unless $req_host =~ /\./; + my $req_port = $url->port; + my $req_path = _url_path($url); + _normalize_path($req_path) if $req_path =~ /%/; + + if (@ns_set) { + # The old Netscape cookie format for Set-Cookie + # http://curl.haxx.se/rfc/cookie_spec.html + # can for instance contain an unquoted "," in the expires + # field, so we have to use this ad-hoc parser. + my $now = time(); + + # Build a hash of cookies that was present in Set-Cookie2 + # headers. We need to skip them if we also find them in a + # Set-Cookie header. + my %in_set2; + for (@set) { + $in_set2{$_->[0]}++; + } + + my $set; + for $set (@ns_set) { + $set =~ s/^\s+//; + my @cur; + my $param; + my $expires; + my $first_param = 1; + for $param (split(/;\s*/, $set)) { + next unless length($param); + my($k,$v) = split(/\s*=\s*/, $param, 2); + if (defined $v) { + $v =~ s/\s+$//; + #print "$k => $v\n"; + } + else { + $k =~ s/\s+$//; + #print "$k => undef"; + } + if (!$first_param && lc($k) eq "expires") { + my $etime = str2time($v); + if (defined $etime) { + push(@cur, "Max-Age" => $etime - $now); + $expires++; + } + else { + # parse_date can deal with years outside the range of time_t, + my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v); + if ($year) { + my $thisyear = (gmtime)[5] + 1900; + if ($year < $thisyear) { + push(@cur, "Max-Age" => -1); # any negative value will do + $expires++; + } + elsif ($year >= $thisyear + 10) { + # the date is at least 10 years into the future, just replace + # it with something approximate + push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60); + $expires++; + } + } + } + } + elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) { + # ignore + } + else { + push(@cur, $k => $v); + } + $first_param = 0; + } + next unless @cur; + next if $in_set2{$cur[0]}; + +# push(@cur, "Port" => $req_port); + push(@cur, "Discard" => undef) unless $expires; + push(@cur, "Version" => 0); + push(@cur, "ns-cookie" => 1); + push(@set, \@cur); + } + } + + SET_COOKIE: + for my $set (@set) { + next unless @$set >= 2; + + my $key = shift @$set; + my $val = shift @$set; + + my %hash; + while (@$set) { + my $k = shift @$set; + my $v = shift @$set; + my $lc = lc($k); + # don't loose case distinction for unknown fields + $k = $lc if $lc =~ /^(?:discard|domain|max-age| + path|port|secure|version)$/x; + if ($k eq "discard" || $k eq "secure") { + $v = 1 unless defined $v; + } + next if exists $hash{$k}; # only first value is significant + $hash{$k} = $v; + }; + + my %orig_hash = %hash; + my $version = delete $hash{version}; + $version = 1 unless defined($version); + my $discard = delete $hash{discard}; + my $secure = delete $hash{secure}; + my $maxage = delete $hash{'max-age'}; + my $ns_cookie = delete $hash{'ns-cookie'}; + + # Check domain + my $domain = delete $hash{domain}; + $domain = lc($domain) if defined $domain; + if (defined($domain) + && $domain ne $req_host && $domain ne ".$req_host") { + if ($domain !~ /\./ && $domain ne "local") { + next SET_COOKIE; + } + $domain = ".$domain" unless $domain =~ /^\./; + if ($domain =~ /\.\d+$/) { + next SET_COOKIE; + } + my $len = length($domain); + unless (substr($req_host, -$len) eq $domain) { + next SET_COOKIE; + } + my $hostpre = substr($req_host, 0, length($req_host) - $len); + if ($hostpre =~ /\./ && !$ns_cookie) { + next SET_COOKIE; + } + } + else { + $domain = $req_host; + } + + my $path = delete $hash{path}; + my $path_spec; + if (defined $path && $path ne '') { + $path_spec++; + _normalize_path($path) if $path =~ /%/; + if (!$ns_cookie && + substr($req_path, 0, length($path)) ne $path) { + next SET_COOKIE; + } + } + else { + $path = $req_path; + $path =~ s,/[^/]*$,,; + $path = "/" unless length($path); + } + + my $port; + if (exists $hash{port}) { + $port = delete $hash{port}; + if (defined $port) { + $port =~ s/\s+//g; + my $found; + for my $p (split(/,/, $port)) { + unless ($p =~ /^\d+$/) { + next SET_COOKIE; + } + $found++ if $p eq $req_port; + } + unless ($found) { + next SET_COOKIE; + } + } + else { + $port = "_$req_port"; + } + } + $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash) + if $self->set_cookie_ok(\%orig_hash); + } + + $response; +} + +sub set_cookie_ok +{ + 1; +} + + +sub set_cookie +{ + my $self = shift; + my($version, + $key, $val, $path, $domain, $port, + $path_spec, $secure, $maxage, $discard, $rest) = @_; + + # path and key can not be empty (key can't start with '$') + return $self if !defined($path) || $path !~ m,^/, || + !defined($key) || $key =~ m,^\$,; + + # ensure legal port + if (defined $port) { + return $self unless $port =~ /^_?\d+(?:,\d+)*$/; + } + + my $expires; + if (defined $maxage) { + if ($maxage <= 0) { + delete $self->{COOKIES}{$domain}{$path}{$key}; + return $self; + } + $expires = time() + $maxage; + } + $version = 0 unless defined $version; + + my @array = ($version, $val,$port, + $path_spec, + $secure, $expires, $discard); + push(@array, {%$rest}) if defined($rest) && %$rest; + # trim off undefined values at end + pop(@array) while !defined $array[-1]; + + $self->{COOKIES}{$domain}{$path}{$key} = \@array; + $self; +} + + +sub save +{ + my $self = shift; + my $file = shift || $self->{'file'} || return; + open(my $fh, '>', $file) or die "Can't open $file: $!"; + print {$fh} "#LWP-Cookies-1.0\n"; + print {$fh} $self->as_string(!$self->{ignore_discard}); + 1; +} + + +sub load +{ + my $self = shift; + my $file = shift || $self->{'file'} || return; + + local $/ = "\n"; # make sure we got standard record separator + open(my $fh, '<', $file) or return; + + # check that we have the proper header + my $magic = <$fh>; + chomp $magic; + unless ($magic =~ /^#LWP-Cookies-\d+\.\d+/) { + warn "$file does not seem to contain cookies"; + return; + } + + # go through the file + while (my $line = <$fh>) { + chomp $line; + next unless $line =~ s/^Set-Cookie3:\s*//; + my $cookie; + for $cookie (_split_header_words($line)) { + my($key,$val) = splice(@$cookie, 0, 2); + my %hash; + while (@$cookie) { + my $k = shift @$cookie; + my $v = shift @$cookie; + $hash{$k} = $v; + } + my $version = delete $hash{version}; + my $path = delete $hash{path}; + my $domain = delete $hash{domain}; + my $port = delete $hash{port}; + my $expires = str2time(delete $hash{expires}); + + my $path_spec = exists $hash{path_spec}; delete $hash{path_spec}; + my $secure = exists $hash{secure}; delete $hash{secure}; + my $discard = exists $hash{discard}; delete $hash{discard}; + + my @array = ($version, $val, $port, $path_spec, $secure, $expires, + $discard); + push(@array, \%hash) if %hash; + $self->{COOKIES}{$domain}{$path}{$key} = \@array; + } + } + 1; +} + + +sub revert +{ + my $self = shift; + $self->clear->load; + $self; +} + + +sub clear +{ + my $self = shift; + if (@_ == 0) { + $self->{COOKIES} = {}; + } + elsif (@_ == 1) { + delete $self->{COOKIES}{$_[0]}; + } + elsif (@_ == 2) { + delete $self->{COOKIES}{$_[0]}{$_[1]}; + } + elsif (@_ == 3) { + delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]}; + } + else { + require Carp; + Carp::carp('Usage: $c->clear([domain [,path [,key]]])'); + } + $self; +} + + +sub clear_temporary_cookies +{ + my($self) = @_; + + $self->scan(sub { + if($_[9] or # "Discard" flag set + not $_[8]) { # No expire field? + $_[8] = -1; # Set the expire/max_age field + $self->set_cookie(@_); # Clear the cookie + } + }); +} + + +sub DESTROY +{ + my $self = shift; + local($., $@, $!, $^E, $?); + $self->save if $self->{'autosave'}; +} + + +sub scan +{ + my($self, $cb) = @_; + my($domain,$path,$key); + for $domain (sort keys %{$self->{COOKIES}}) { + for $path (sort keys %{$self->{COOKIES}{$domain}}) { + for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) { + my($version,$val,$port,$path_spec, + $secure,$expires,$discard,$rest) = + @{$self->{COOKIES}{$domain}{$path}{$key}}; + $rest = {} unless defined($rest); + &$cb($version,$key,$val,$path,$domain,$port, + $path_spec,$secure,$expires,$discard,$rest); + } + } + } +} + + +sub as_string +{ + my($self, $skip_discard) = @_; + my @res; + $self->scan(sub { + my($version,$key,$val,$path,$domain,$port, + $path_spec,$secure,$expires,$discard,$rest) = @_; + return if $discard && $skip_discard; + my @h = ($key, $val); + push(@h, "path", $path); + push(@h, "domain" => $domain); + push(@h, "port" => $port) if defined $port; + push(@h, "path_spec" => undef) if $path_spec; + push(@h, "secure" => undef) if $secure; + push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires; + push(@h, "discard" => undef) if $discard; + my $k; + for $k (sort keys %$rest) { + push(@h, $k, $rest->{$k}); + } + push(@h, "version" => $version); + push(@res, "Set-Cookie3: " . join_header_words(\@h)); + }); + join("\n", @res, ""); +} + +sub _host +{ + my($request, $url) = @_; + if (my $h = $request->header("Host")) { + $h =~ s/:\d+$//; # might have a port as well + return lc($h); + } + return lc($url->host); +} + +sub _url_path +{ + my $url = shift; + my $path; + if($url->can('epath')) { + $path = $url->epath; # URI::URL method + } + else { + $path = $url->path; # URI::_generic method + } + $path = "/" unless length $path; + $path; +} + +sub _normalize_path # so that plain string compare can be used +{ + my $x; + $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/ + $x = uc($1); + $x eq "2F" || $x eq "25" ? "%$x" : + pack("C", hex($x)); + /eg; + $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Cookies - HTTP cookie jars + +=head1 VERSION + +version 6.04 + +=head1 SYNOPSIS + + use HTTP::Cookies; + $cookie_jar = HTTP::Cookies->new( + file => "$ENV{'HOME'}/lwp_cookies.dat", + autosave => 1, + ); + + use LWP; + my $browser = LWP::UserAgent->new; + $browser->cookie_jar($cookie_jar); + +Or for an empty and temporary cookie jar: + + use LWP; + my $browser = LWP::UserAgent->new; + $browser->cookie_jar( {} ); + +=head1 DESCRIPTION + +This class is for objects that represent a "cookie jar" -- that is, a +database of all the HTTP cookies that a given LWP::UserAgent object +knows about. + +Cookies are a general mechanism which server side connections can use +to both store and retrieve information on the client side of the +connection. For more information about cookies refer to +<URL:http://curl.haxx.se/rfc/cookie_spec.html> and +<URL:http://www.cookiecentral.com/>. This module also implements the +new style cookies described in L<RFC 2965|https://tools.ietf.org/html/rfc2965>. +The two variants of cookies are supposed to be able to coexist happily. + +Instances of the class I<HTTP::Cookies> are able to store a collection +of Set-Cookie2: and Set-Cookie: headers and are able to use this +information to initialize Cookie-headers in I<HTTP::Request> objects. +The state of a I<HTTP::Cookies> object can be saved in and restored from +files. + +=head1 LIMITATIONS + +This module does not support L<< Public Suffix|https://publicsuffix.org/ +>> encouraged by a more recent standard, L<< RFC +6265|https://tools.ietf.org/html/rfc6265 >>. + +This module's shortcomings mean that a malicious Web site can set +cookies to track your user agent across all sites under a top level +domain. See F<< t/publicsuffix.t >> in this module's distribution for +details. + +L<< HTTP::CookieJar::LWP >> supports Public Suffix, but only provides a +limited subset of this module's functionality and L<< does not +support|HTTP::CookieJar/LIMITATIONS-AND-CAVEATS >> standards older than +I<RFC 6265>. + +=head1 METHODS + +The following methods are provided: + +=over 4 + +=item $cookie_jar = HTTP::Cookies->new + +The constructor takes hash style parameters. The following +parameters are recognized: + + file: name of the file to restore cookies from and save cookies to + autosave: save during destruction (bool) + ignore_discard: save even cookies that are requested to be discarded (bool) + hide_cookie2: do not add Cookie2 header to requests + +Future parameters might include (not yet implemented): + + max_cookies 300 + max_cookies_per_domain 20 + max_cookie_size 4096 + + no_cookies list of domain names that we never return cookies to + +=item $cookie_jar->get_cookies( $url_or_domain ) + +=item $cookie_jar->get_cookies( $url_or_domain, $cookie_key,... ) + +Returns a hash of the cookies that applies to the given URL. If a +domainname is given as argument, then a prefix of "https://" is assumed. + +If one or more $cookie_key parameters are provided return the given values, +or C<undef> if the cookie isn't available. + +=item $cookie_jar->add_cookie_header( $request ) + +The add_cookie_header() method will set the appropriate Cookie:-header +for the I<HTTP::Request> object given as argument. The $request must +have a valid url attribute before this method is called. + +=item $cookie_jar->extract_cookies( $response ) + +The extract_cookies() method will look for Set-Cookie: and +Set-Cookie2: headers in the I<HTTP::Response> object passed as +argument. Any of these headers that are found are used to update +the state of the $cookie_jar. + +=item $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest ) + +The set_cookie() method updates the state of the $cookie_jar. The +$key, $val, $domain, $port and $path arguments are strings. The +$path_spec, $secure, $discard arguments are boolean values. The $maxage +value is a number indicating number of seconds that this cookie will +live. A value of $maxage <= 0 will delete this cookie. %rest defines +various other attributes like "Comment" and "CommentURL". + +=item $cookie_jar->save + +=item $cookie_jar->save( $file ) + +This method file saves the state of the $cookie_jar to a file. +The state can then be restored later using the load() method. If a +filename is not specified we will use the name specified during +construction. If the attribute I<ignore_discard> is set, then we +will even save cookies that are marked to be discarded. + +The default is to save a sequence of "Set-Cookie3" lines. +"Set-Cookie3" is a proprietary LWP format, not known to be compatible +with any browser. The I<HTTP::Cookies::Netscape> sub-class can +be used to save in a format compatible with Netscape. + +=item $cookie_jar->load + +=item $cookie_jar->load( $file ) + +This method reads the cookies from the file and adds them to the +$cookie_jar. The file must be in the format written by the save() +method. + +=item $cookie_jar->revert + +This method empties the $cookie_jar and re-loads the $cookie_jar +from the last save file. + +=item $cookie_jar->clear + +=item $cookie_jar->clear( $domain ) + +=item $cookie_jar->clear( $domain, $path ) + +=item $cookie_jar->clear( $domain, $path, $key ) + +Invoking this method without arguments will empty the whole +$cookie_jar. If given a single argument only cookies belonging to +that domain will be removed. If given two arguments, cookies +belonging to the specified path within that domain are removed. If +given three arguments, then the cookie with the specified key, path +and domain is removed. + +=item $cookie_jar->clear_temporary_cookies + +Discard all temporary cookies. Scans for all cookies in the jar +with either no expire field or a true C<discard> flag. To be +called when the user agent shuts down according to RFC 2965. + +=item $cookie_jar->scan( \&callback ) + +The argument is a subroutine that will be invoked for each cookie +stored in the $cookie_jar. The subroutine will be invoked with +the following arguments: + + 0 version + 1 key + 2 val + 3 path + 4 domain + 5 port + 6 path_spec + 7 secure + 8 expires + 9 discard + 10 hash + +=item $cookie_jar->as_string + +=item $cookie_jar->as_string( $skip_discardables ) + +The as_string() method will return the state of the $cookie_jar +represented as a sequence of "Set-Cookie3" header lines separated by +"\n". If $skip_discardables is TRUE, it will not return lines for +cookies with the I<Discard> attribute. + +=back + +=head1 SEE ALSO + +L<HTTP::Cookies::Netscape>, L<HTTP::Cookies::Microsoft> + +=head1 AUTHOR + +Gisle Aas <gisle@activestate.com> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2002-2017 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 cookie jars + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm new file mode 100644 index 0000000000..737da2829f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm @@ -0,0 +1,326 @@ +package HTTP::Cookies::Microsoft; + +use strict; + +use vars qw(@ISA); + +our $VERSION = '6.04'; + +require HTTP::Cookies; +@ISA=qw(HTTP::Cookies); + +sub load_cookies_from_file +{ + my ($file) = @_; + my @cookies; + + open (my $fh, '<', $file) || return; + + while (my $key = <$fh>) { + chomp $key; + my ($value, $domain_path, $flags, $lo_expire, $hi_expire); + my ($lo_create, $hi_create, $sep); + chomp($value = <$fh>); + chomp($domain_path= <$fh>); + chomp($flags = <$fh>); # 0x0001 bit is for secure + chomp($lo_expire = <$fh>); + chomp($hi_expire = <$fh>); + chomp($lo_create = <$fh>); + chomp($hi_create = <$fh>); + chomp($sep = <$fh>); + + if (!defined($key) || !defined($value) || !defined($domain_path) || + !defined($flags) || !defined($hi_expire) || !defined($lo_expire) || + !defined($hi_create) || !defined($lo_create) || !defined($sep) || + ($sep ne '*')) + { + last; + } + + if ($domain_path =~ /^([^\/]+)(\/.*)$/) { + my $domain = $1; + my $path = $2; + + push @cookies, { + KEY => $key, VALUE => $value, DOMAIN => $domain, + PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire, + LOXP => $lo_expire, HICREATE => $hi_create, + LOCREATE => $lo_create + }; + } + } + + return \@cookies; +} + +sub get_user_name +{ + use Win32; + use locale; + my $user = lc(Win32::LoginName()); + + return $user; +} + +# MSIE stores create and expire times as Win32 FILETIME, +# which is 64 bits of 100 nanosecond intervals since Jan 01 1601 +# +# But Cookies code expects time in 32-bit value expressed +# in seconds since Jan 01 1970 +# +sub epoch_time_offset_from_win32_filetime +{ + my ($high, $low) = @_; + + #-------------------------------------------------------- + # USEFUL CONSTANT + #-------------------------------------------------------- + # 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME + # + # 100 nanosecond intervals == 0.1 microsecond intervals + + my $filetime_low32_1970 = 0xd53e8000; + my $filetime_high32_1970 = 0x019db1de; + + #------------------------------------ + # ALGORITHM + #------------------------------------ + # To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970: + # + # 1. Adjust 100 nanosecond intervals to Jan 01 1970 base + # 2. Divide by 10 to get to microseconds (1/millionth second) + # 3. Divide by 1000000 (10 ^ 6) to get to seconds + # + # We can combine Step 2 & 3 into one divide. + # + # After much trial and error, I came up with the following code which + # avoids using Math::BigInt or floating pt, but still gives correct answers + + # If the filetime is before the epoch, return 0 + if (($high < $filetime_high32_1970) || + (($high == $filetime_high32_1970) && ($low < $filetime_low32_1970))) + { + return 0; + } + + # Can't multiply by 0x100000000, (1 << 32), + # without Perl issuing an integer overflow warning + # + # So use two multiplies by 0x10000 instead of one multiply by 0x100000000 + # + # The result is the same. + # + my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970; + my $time = (($high * 0x10000) * 0x10000) + $low; + + $time -= $date1970; + $time /= 10000000; + + return $time; +} + +sub load_cookie +{ + my($self, $file) = @_; + my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; + my $cookie_data; + + if (-f $file) + { + # open the cookie file and get the data + $cookie_data = load_cookies_from_file($file); + + foreach my $cookie (@{$cookie_data}) + { + my $secure = ($cookie->{FLAGS} & 1) != 0; + my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP}); + + $self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE}, + $cookie->{PATH}, $cookie->{DOMAIN}, undef, + 0, $secure, $expires-$now, 0); + } + } +} + +sub load +{ + my($self, $cookie_index) = @_; + my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; + my $cookie_dir = ''; + my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'}); + my $user_name = get_user_name(); + my $data; + + $cookie_index ||= $self->{'file'} || return; + if ($cookie_index =~ /[\\\/][^\\\/]+$/) { + $cookie_dir = $` . "\\"; + } + + open (my $fh, '<:raw', $cookie_index) || return; + if (256 != read($fh, $data, 256)) { + warn "$cookie_index file is not large enough"; + return; + } + + # Cookies' index.dat file starts with 32 bytes of signature + # followed by an offset to the first record, stored as a little-endian DWORD + my ($sig, $size) = unpack('a32 V', $data); + + # check that sig is valid (only tested in IE6.0) + if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || (0x4000 != $size)) { + warn "$cookie_index ['$sig' $size] does not seem to contain cookies"; + return; + } + + # move the file ptr to start of the first record + if (0 == seek($fh, $size, 0)) { + return; + } + + # Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes) + # so read in two 0x80 byte sectors and adjust if not a Cookie. + while (256 == read($fh, $data, 256)) { + # each record starts with a 4-byte signature + # and a count (little-endian DWORD) of 0x80 byte sectors for the record + ($sig, $size) = unpack('a4 V', $data); + + # Cookies are found in 'URL ' records + if ('URL ' ne $sig) { + # skip over uninteresting record: I've seen 'HASH' and 'LEAK' records + if (($sig eq 'HASH') || ($sig eq 'LEAK')) { + # '-2' takes into account the two 0x80 byte sectors we've just read in + if (($size > 0) && ($size != 2)) { + if (0 == seek($fh, ($size-2)*0x80, 1)) { + # Seek failed. Something's wrong. Gonna stop. + last; + } + } + } + next; + } + + #$REMOVE Need to check if URL records in Cookies' index.dat will + # ever use more than two 0x80 byte sectors + if ($size > 2) { + my $more_data = ($size-2)*0x80; + + if ($more_data != read($fh, $data, $more_data, 256)) { + last; + } + } + + (my $user_name2 = $user_name) =~ s/ /_/g; + if ($data =~ /Cookie:\Q$user_name\E@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)@[\x21-\xFF]+\.txt)/) { + my $cookie_file = $cookie_dir . $2; # form full pathname + + if (!$delay_load) { + $self->load_cookie($cookie_file); + } + else { + my $domain = $1; + + # grab only the domain name, drop everything from the first dir sep on + if ($domain =~ m{[\\/]}) { + $domain = $`; + } + + # set the delayload cookie for this domain with + # the cookie_file as cookie for later-loading info + $self->set_cookie(undef, 'cookie', $cookie_file, '//+delayload', $domain, undef, 0, 0, $now+86400, 0); + } + } + } + + 1; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Cookies::Microsoft - Access to Microsoft cookies files + +=head1 VERSION + +version 6.04 + +=head1 SYNOPSIS + + use LWP; + use HTTP::Cookies::Microsoft; + use Win32::TieRegistry(Delimiter => "/"); + my $cookies_dir = $Registry-> + {"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"}; + + $cookie_jar = HTTP::Cookies::Microsoft->new( + file => "$cookies_dir\\index.dat", + 'delayload' => 1, + ); + my $browser = LWP::UserAgent->new; + $browser->cookie_jar( $cookie_jar ); + +=head1 DESCRIPTION + +This is a subclass of C<HTTP::Cookies> which +loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE) +cookie files. + +See the documentation for L<HTTP::Cookies>. + +=head1 METHODS + +The following methods are provided: + +=over 4 + +=item $cookie_jar = HTTP::Cookies::Microsoft->new; + +The constructor takes hash style parameters. In addition +to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft +recognizes the following: + + delayload: delay loading of cookie data until a request + is actually made. This results in faster + runtime unless you use most of the cookies + since only the domain's cookie data + is loaded on demand. + +=back + +=head1 CAVEATS + +Please note that the code DOESN'T support saving to the MSIE +cookie file format. + +=head1 AUTHOR + +Johnny Lee <typo_pl@hotmail.com> + +=head1 COPYRIGHT + +Copyright 2002 Johnny Lee + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 AUTHOR + +Gisle Aas <gisle@activestate.com> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2002-2017 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: Access to Microsoft cookies files + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm new file mode 100644 index 0000000000..8fbac88849 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm @@ -0,0 +1,127 @@ +package HTTP::Cookies::Netscape; + +use strict; +use vars qw(@ISA); + +our $VERSION = '6.04'; + +require HTTP::Cookies; +@ISA=qw(HTTP::Cookies); + +sub load +{ + my ($self, $file) = @_; + $file ||= $self->{'file'} || return; + + local $/ = "\n"; # make sure we got standard record separator + open (my $fh, '<', $file) || return; + my $magic = <$fh>; + chomp $magic; + unless ($magic =~ /^#(?: Netscape)? HTTP Cookie File/) { + warn "$file does not look like a netscape cookies file"; + return; + } + + my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; + while (my $line = <$fh>) { + chomp($line); + next if $line =~ /^\s*\#/; + next if $line =~ /^\s*$/; + $line =~ tr/\n\r//d; + my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $line); + $secure = ($secure eq "TRUE"); + $self->set_cookie(undef, $key, $val, $path, $domain, undef, 0, $secure, $expires-$now, 0); + } + 1; +} + +sub save +{ + my($self, $file) = @_; + $file ||= $self->{'file'} || return; + + open(my $fh, '>', $file) || return; + + # Use old, now broken link to the old cookie spec just in case something + # else (not us!) requires the comment block exactly this way. + print {$fh} <<EOT; +# Netscape HTTP Cookie File +# http://www.netscape.com/newsref/std/cookie_spec.html +# This is a generated file! Do not edit. + +EOT + + my $now = time - $HTTP::Cookies::EPOCH_OFFSET; + $self->scan(sub { + my ($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $expires, $discard, $rest) = @_; + return if $discard && !$self->{ignore_discard}; + $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0; + return if $now > $expires; + $secure = $secure ? "TRUE" : "FALSE"; + my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE"; + print {$fh} join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n"; + }); + 1; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +HTTP::Cookies::Netscape - Access to Netscape cookies files + +=head1 VERSION + +version 6.04 + +=head1 SYNOPSIS + + use LWP; + use HTTP::Cookies::Netscape; + $cookie_jar = HTTP::Cookies::Netscape->new( + file => "c:/program files/netscape/users/ZombieCharity/cookies.txt", + ); + my $browser = LWP::UserAgent->new; + $browser->cookie_jar( $cookie_jar ); + +=head1 DESCRIPTION + +This is a subclass of C<HTTP::Cookies> that reads (and optionally +writes) Netscape/Mozilla cookie files. + +See the documentation for L<HTTP::Cookies>. + +=head1 CAVEATS + +Please note that the Netscape/Mozilla cookie file format can't store +all the information available in the Set-Cookie2 headers, so you will +probably lose some information if you save in this format. + +At time of writing, this module seems to work fine with Mozilla +Phoenix/Firebird. + +=head1 SEE ALSO + +L<HTTP::Cookies::Microsoft> + +=head1 AUTHOR + +Gisle Aas <gisle@activestate.com> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2002-2017 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: Access to Netscape cookies files + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Daemon.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Daemon.pm new file mode 100644 index 0000000000..27a7bf4e17 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Daemon.pm @@ -0,0 +1,906 @@ +package HTTP::Daemon; + +use strict; +use vars qw($VERSION @ISA $PROTO $DEBUG); + +$VERSION = "6.01"; + +use IO::Socket qw(AF_INET INADDR_ANY INADDR_LOOPBACK inet_ntoa); +@ISA=qw(IO::Socket::INET); + +$PROTO = "HTTP/1.1"; + + +sub new +{ + my($class, %args) = @_; + $args{Listen} ||= 5; + $args{Proto} ||= 'tcp'; + return $class->SUPER::new(%args); +} + + +sub accept +{ + my $self = shift; + my $pkg = shift || "HTTP::Daemon::ClientConn"; + my ($sock, $peer) = $self->SUPER::accept($pkg); + if ($sock) { + ${*$sock}{'httpd_daemon'} = $self; + return wantarray ? ($sock, $peer) : $sock; + } + else { + return; + } +} + + +sub url +{ + my $self = shift; + my $url = $self->_default_scheme . "://"; + my $addr = $self->sockaddr; + if (!$addr || $addr eq INADDR_ANY) { + require Sys::Hostname; + $url .= lc Sys::Hostname::hostname(); + } + elsif ($addr eq INADDR_LOOPBACK) { + $url .= inet_ntoa($addr); + } + else { + $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr); + } + my $port = $self->sockport; + $url .= ":$port" if $port != $self->_default_port; + $url .= "/"; + $url; +} + + +sub _default_port { + 80; +} + + +sub _default_scheme { + "http"; +} + + +sub product_tokens +{ + "libwww-perl-daemon/$HTTP::Daemon::VERSION"; +} + + + +package HTTP::Daemon::ClientConn; + +use vars qw(@ISA $DEBUG); +use IO::Socket (); +@ISA=qw(IO::Socket::INET); +*DEBUG = \$HTTP::Daemon::DEBUG; + +use HTTP::Request (); +use HTTP::Response (); +use HTTP::Status; +use HTTP::Date qw(time2str); +use LWP::MediaTypes qw(guess_media_type); +use Carp (); + +my $CRLF = "\015\012"; # "\r\n" is not portable +my $HTTP_1_0 = _http_version("HTTP/1.0"); +my $HTTP_1_1 = _http_version("HTTP/1.1"); + + +sub get_request +{ + my($self, $only_headers) = @_; + if (${*$self}{'httpd_nomore'}) { + $self->reason("No more requests from this connection"); + return; + } + + $self->reason(""); + my $buf = ${*$self}{'httpd_rbuf'}; + $buf = "" unless defined $buf; + + my $timeout = $ {*$self}{'io_socket_timeout'}; + my $fdset = ""; + vec($fdset, $self->fileno, 1) = 1; + local($_); + + READ_HEADER: + while (1) { + # loop until we have the whole header in $buf + $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines + if ($buf =~ /\012/) { # potential, has at least one line + if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) { + if ($buf =~ /\015?\012\015?\012/) { + last READ_HEADER; # we have it + } + elsif (length($buf) > 16*1024) { + $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE + $self->reason("Very long header"); + return; + } + } + else { + last READ_HEADER; # HTTP/0.9 client + } + } + elsif (length($buf) > 16*1024) { + $self->send_error(414); # REQUEST_URI_TOO_LARGE + $self->reason("Very long first line"); + return; + } + print STDERR "Need more data for complete header\n" if $DEBUG; + return unless $self->_need_more($buf, $timeout, $fdset); + } + if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) { + ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0"); + $self->send_error(400); # BAD_REQUEST + $self->reason("Bad request line: $buf"); + return; + } + my $method = $1; + my $uri = $2; + my $proto = $3 || "HTTP/0.9"; + $uri = "http://$uri" if $method eq "CONNECT"; + $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url); + my $r = HTTP::Request->new($method, $uri); + $r->protocol($proto); + ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto); + ${*$self}{'httpd_head'} = ($method eq "HEAD"); + + if ($proto >= $HTTP_1_0) { + # we expect to find some headers + my($key, $val); + HEADER: + while ($buf =~ s/^([^\012]*)\012//) { + $_ = $1; + s/\015$//; + if (/^([^:\s]+)\s*:\s*(.*)/) { + $r->push_header($key, $val) if $key; + ($key, $val) = ($1, $2); + } + elsif (/^\s+(.*)/) { + $val .= " $1"; + } + else { + last HEADER; + } + } + $r->push_header($key, $val) if $key; + } + + my $conn = $r->header('Connection'); + if ($proto >= $HTTP_1_1) { + ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/; + } + else { + ${*$self}{'httpd_nomore'}++ unless $conn && + lc($conn) =~ /\bkeep-alive\b/; + } + + if ($only_headers) { + ${*$self}{'httpd_rbuf'} = $buf; + return $r; + } + + # Find out how much content to read + my $te = $r->header('Transfer-Encoding'); + my $ct = $r->header('Content-Type'); + my $len = $r->header('Content-Length'); + + # Act on the Expect header, if it's there + for my $e ( $r->header('Expect') ) { + if( lc($e) eq '100-continue' ) { + $self->send_status_line(100); + $self->send_crlf; + } + else { + $self->send_error(417); + $self->reason("Unsupported Expect header value"); + return; + } + } + + if ($te && lc($te) eq 'chunked') { + # Handle chunked transfer encoding + my $body = ""; + CHUNK: + while (1) { + print STDERR "Chunked\n" if $DEBUG; + if ($buf =~ s/^([^\012]*)\012//) { + my $chunk_head = $1; + unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) { + $self->send_error(400); + $self->reason("Bad chunk header $chunk_head"); + return; + } + my $size = hex($1); + last CHUNK if $size == 0; + + my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end + # must read until we have a complete chunk + while ($missing > 0) { + print STDERR "Need $missing more bytes\n" if $DEBUG; + my $n = $self->_need_more($buf, $timeout, $fdset); + return unless $n; + $missing -= $n; + } + $body .= substr($buf, 0, $size); + substr($buf, 0, $size+2) = ''; + + } + else { + # need more data in order to have a complete chunk header + return unless $self->_need_more($buf, $timeout, $fdset); + } + } + $r->content($body); + + # pretend it was a normal entity body + $r->remove_header('Transfer-Encoding'); + $r->header('Content-Length', length($body)); + + my($key, $val); + FOOTER: + while (1) { + if ($buf !~ /\012/) { + # need at least one line to look at + return unless $self->_need_more($buf, $timeout, $fdset); + } + else { + $buf =~ s/^([^\012]*)\012//; + $_ = $1; + s/\015$//; + if (/^([\w\-]+)\s*:\s*(.*)/) { + $r->push_header($key, $val) if $key; + ($key, $val) = ($1, $2); + } + elsif (/^\s+(.*)/) { + $val .= " $1"; + } + elsif (!length) { + last FOOTER; + } + else { + $self->reason("Bad footer syntax"); + return; + } + } + } + $r->push_header($key, $val) if $key; + + } + elsif ($te) { + $self->send_error(501); # Unknown transfer encoding + $self->reason("Unknown transfer encoding '$te'"); + return; + + } + elsif ($len) { + # Plain body specified by "Content-Length" + my $missing = $len - length($buf); + while ($missing > 0) { + print "Need $missing more bytes of content\n" if $DEBUG; + my $n = $self->_need_more($buf, $timeout, $fdset); + return unless $n; + $missing -= $n; + } + if (length($buf) > $len) { + $r->content(substr($buf,0,$len)); + substr($buf, 0, $len) = ''; + } + else { + $r->content($buf); + $buf=''; + } + } + elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) { + # Handle multipart content type + my $boundary = "$CRLF--$2--"; + my $index; + while (1) { + $index = index($buf, $boundary); + last if $index >= 0; + # end marker not yet found + return unless $self->_need_more($buf, $timeout, $fdset); + } + $index += length($boundary); + $r->content(substr($buf, 0, $index)); + substr($buf, 0, $index) = ''; + + } + ${*$self}{'httpd_rbuf'} = $buf; + + $r; +} + + +sub _need_more +{ + my $self = shift; + #my($buf,$timeout,$fdset) = @_; + if ($_[1]) { + my($timeout, $fdset) = @_[1,2]; + print STDERR "select(,,,$timeout)\n" if $DEBUG; + my $n = select($fdset,undef,undef,$timeout); + unless ($n) { + $self->reason(defined($n) ? "Timeout" : "select: $!"); + return; + } + } + print STDERR "sysread()\n" if $DEBUG; + my $n = sysread($self, $_[0], 2048, length($_[0])); + $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n; + $n; +} + + +sub read_buffer +{ + my $self = shift; + my $old = ${*$self}{'httpd_rbuf'}; + if (@_) { + ${*$self}{'httpd_rbuf'} = shift; + } + $old; +} + + +sub reason +{ + my $self = shift; + my $old = ${*$self}{'httpd_reason'}; + if (@_) { + ${*$self}{'httpd_reason'} = shift; + } + $old; +} + + +sub proto_ge +{ + my $self = shift; + ${*$self}{'httpd_client_proto'} >= _http_version(shift); +} + + +sub _http_version +{ + local($_) = shift; + return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i; + $1 * 1000 + $2; +} + + +sub antique_client +{ + my $self = shift; + ${*$self}{'httpd_client_proto'} < $HTTP_1_0; +} + + +sub force_last_request +{ + my $self = shift; + ${*$self}{'httpd_nomore'}++; +} + +sub head_request +{ + my $self = shift; + ${*$self}{'httpd_head'}; +} + + +sub send_status_line +{ + my($self, $status, $message, $proto) = @_; + return if $self->antique_client; + $status ||= RC_OK; + $message ||= status_message($status) || ""; + $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1"; + print $self "$proto $status $message$CRLF"; +} + + +sub send_crlf +{ + my $self = shift; + print $self $CRLF; +} + + +sub send_basic_header +{ + my $self = shift; + return if $self->antique_client; + $self->send_status_line(@_); + print $self "Date: ", time2str(time), $CRLF; + my $product = $self->daemon->product_tokens; + print $self "Server: $product$CRLF" if $product; +} + + +sub send_header +{ + my $self = shift; + while (@_) { + my($k, $v) = splice(@_, 0, 2); + $v = "" unless defined($v); + print $self "$k: $v$CRLF"; + } +} + + +sub send_response +{ + my $self = shift; + my $res = shift; + if (!ref $res) { + $res ||= RC_OK; + $res = HTTP::Response->new($res, @_); + } + my $content = $res->content; + my $chunked; + unless ($self->antique_client) { + my $code = $res->code; + $self->send_basic_header($code, $res->message, $res->protocol); + if ($code =~ /^(1\d\d|[23]04)$/) { + # make sure content is empty + $res->remove_header("Content-Length"); + $content = ""; + } + elsif ($res->request && $res->request->method eq "HEAD") { + # probably OK + } + elsif (ref($content) eq "CODE") { + if ($self->proto_ge("HTTP/1.1")) { + $res->push_header("Transfer-Encoding" => "chunked"); + $chunked++; + } + else { + $self->force_last_request; + } + } + elsif (length($content)) { + $res->header("Content-Length" => length($content)); + } + else { + $self->force_last_request; + $res->header('connection','close'); + } + print $self $res->headers_as_string($CRLF); + print $self $CRLF; # separates headers and content + } + if ($self->head_request) { + # no content + } + elsif (ref($content) eq "CODE") { + while (1) { + my $chunk = &$content(); + last unless defined($chunk) && length($chunk); + if ($chunked) { + printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF; + } + else { + print $self $chunk; + } + } + print $self "0$CRLF$CRLF" if $chunked; # no trailers either + } + elsif (length $content) { + print $self $content; + } +} + + +sub send_redirect +{ + my($self, $loc, $status, $content) = @_; + $status ||= RC_MOVED_PERMANENTLY; + Carp::croak("Status '$status' is not redirect") unless is_redirect($status); + $self->send_basic_header($status); + my $base = $self->daemon->url; + $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc); + $loc = $loc->abs($base); + print $self "Location: $loc$CRLF"; + if ($content) { + my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain"; + print $self "Content-Type: $ct$CRLF"; + } + print $self $CRLF; + print $self $content if $content && !$self->head_request; + $self->force_last_request; # no use keeping the connection open +} + + +sub send_error +{ + my($self, $status, $error) = @_; + $status ||= RC_BAD_REQUEST; + Carp::croak("Status '$status' is not an error") unless is_error($status); + my $mess = status_message($status); + $error ||= ""; + $mess = <<EOT; +<title>$status $mess</title> +<h1>$status $mess</h1> +$error +EOT + unless ($self->antique_client) { + $self->send_basic_header($status); + print $self "Content-Type: text/html$CRLF"; + print $self "Content-Length: " . length($mess) . $CRLF; + print $self $CRLF; + } + print $self $mess unless $self->head_request; + $status; +} + + +sub send_file_response +{ + my($self, $file) = @_; + if (-d $file) { + $self->send_dir($file); + } + elsif (-f _) { + # plain file + local(*F); + sysopen(F, $file, 0) or + return $self->send_error(RC_FORBIDDEN); + binmode(F); + my($ct,$ce) = guess_media_type($file); + my($size,$mtime) = (stat _)[7,9]; + unless ($self->antique_client) { + $self->send_basic_header; + print $self "Content-Type: $ct$CRLF"; + print $self "Content-Encoding: $ce$CRLF" if $ce; + print $self "Content-Length: $size$CRLF" if $size; + print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime; + print $self $CRLF; + } + $self->send_file(\*F) unless $self->head_request; + return RC_OK; + } + else { + $self->send_error(RC_NOT_FOUND); + } +} + + +sub send_dir +{ + my($self, $dir) = @_; + $self->send_error(RC_NOT_FOUND) unless -d $dir; + $self->send_error(RC_NOT_IMPLEMENTED); +} + + +sub send_file +{ + my($self, $file) = @_; + my $opened = 0; + local(*FILE); + if (!ref($file)) { + open(FILE, $file) || return undef; + binmode(FILE); + $file = \*FILE; + $opened++; + } + my $cnt = 0; + my $buf = ""; + my $n; + while ($n = sysread($file, $buf, 8*1024)) { + last if !$n; + $cnt += $n; + print $self $buf; + } + close($file) if $opened; + $cnt; +} + + +sub daemon +{ + my $self = shift; + ${*$self}{'httpd_daemon'}; +} + + +1; + +__END__ + +=head1 NAME + +HTTP::Daemon - a simple http server class + +=head1 SYNOPSIS + + use HTTP::Daemon; + use HTTP::Status; + + my $d = HTTP::Daemon->new || die; + print "Please contact me at: <URL:", $d->url, ">\n"; + while (my $c = $d->accept) { + while (my $r = $c->get_request) { + if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") { + # remember, this is *not* recommended practice :-) + $c->send_file_response("/etc/passwd"); + } + else { + $c->send_error(RC_FORBIDDEN) + } + } + $c->close; + undef($c); + } + +=head1 DESCRIPTION + +Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that +listen on a socket for incoming requests. The C<HTTP::Daemon> is a +subclass of C<IO::Socket::INET>, so you can perform socket operations +directly on it too. + +The accept() method will return when a connection from a client is +available. The returned value will be an C<HTTP::Daemon::ClientConn> +object which is another C<IO::Socket::INET> subclass. Calling the +get_request() method on this object will read data from the client and +return an C<HTTP::Request> object. The ClientConn object also provide +methods to send back various responses. + +This HTTP daemon does not fork(2) for you. Your application, i.e. the +user of the C<HTTP::Daemon> is responsible for forking if that is +desirable. Also note that the user is responsible for generating +responses that conform to the HTTP/1.1 protocol. + +The following methods of C<HTTP::Daemon> are new (or enhanced) relative +to the C<IO::Socket::INET> base class: + +=over 4 + +=item $d = HTTP::Daemon->new + +=item $d = HTTP::Daemon->new( %opts ) + +The constructor method takes the same arguments as the +C<IO::Socket::INET> constructor, but unlike its base class it can also +be called without any arguments. The daemon will then set up a listen +queue of 5 connections and allocate some random port number. + +A server that wants to bind to some specific address on the standard +HTTP port will be constructed like this: + + $d = HTTP::Daemon->new( + LocalAddr => 'www.thisplace.com', + LocalPort => 80, + ); + +See L<IO::Socket::INET> for a description of other arguments that can +be used configure the daemon during construction. + +=item $c = $d->accept + +=item $c = $d->accept( $pkg ) + +=item ($c, $peer_addr) = $d->accept + +This method works the same the one provided by the base class, but it +returns an C<HTTP::Daemon::ClientConn> reference by default. If a +package name is provided as argument, then the returned object will be +blessed into the given class. It is probably a good idea to make that +class a subclass of C<HTTP::Daemon::ClientConn>. + +The accept method will return C<undef> if timeouts have been enabled +and no connection is made within the given time. The timeout() method +is described in L<IO::Socket>. + +In list context both the client object and the peer address will be +returned; see the description of the accept method L<IO::Socket> for +details. + +=item $d->url + +Returns a URL string that can be used to access the server root. + +=item $d->product_tokens + +Returns the name that this server will use to identify itself. This +is the string that is sent with the C<Server> response header. The +main reason to have this method is that subclasses can override it if +they want to use another product name. + +The default is the string "libwww-perl-daemon/#.##" where "#.##" is +replaced with the version number of this module. + +=back + +The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET> +subclass. Instances of this class are returned by the accept() method +of C<HTTP::Daemon>. The following methods are provided: + +=over 4 + +=item $c->get_request + +=item $c->get_request( $headers_only ) + +This method reads data from the client and turns it into an +C<HTTP::Request> object which is returned. It returns C<undef> +if reading fails. If it fails, then the C<HTTP::Daemon::ClientConn> +object ($c) should be discarded, and you should not try call this +method again on it. The $c->reason method might give you some +information about why $c->get_request failed. + +The get_request() method will normally not return until the whole +request has been received from the client. This might not be what you +want if the request is an upload of a large file (and with chunked +transfer encoding HTTP can even support infinite request messages - +uploading live audio for instance). If you pass a TRUE value as the +$headers_only argument, then get_request() will return immediately +after parsing the request headers and you are responsible for reading +the rest of the request content. If you are going to call +$c->get_request again on the same connection you better read the +correct number of bytes. + +=item $c->read_buffer + +=item $c->read_buffer( $new_value ) + +Bytes read by $c->get_request, but not used are placed in the I<read +buffer>. The next time $c->get_request is called it will consume the +bytes in this buffer before reading more data from the network +connection itself. The read buffer is invalid after $c->get_request +has failed. + +If you handle the reading of the request content yourself you need to +empty this buffer before you read more and you need to place +unconsumed bytes here. You also need this buffer if you implement +services like I<101 Switching Protocols>. + +This method always returns the old buffer content and can optionally +replace the buffer content if you pass it an argument. + +=item $c->reason + +When $c->get_request returns C<undef> you can obtain a short string +describing why it happened by calling $c->reason. + +=item $c->proto_ge( $proto ) + +Return TRUE if the client announced a protocol with version number +greater or equal to the given argument. The $proto argument can be a +string like "HTTP/1.1" or just "1.1". + +=item $c->antique_client + +Return TRUE if the client speaks the HTTP/0.9 protocol. No status +code and no headers should be returned to such a client. This should +be the same as !$c->proto_ge("HTTP/1.0"). + +=item $c->head_request + +Return TRUE if the last request was a C<HEAD> request. No content +body must be generated for these requests. + +=item $c->force_last_request + +Make sure that $c->get_request will not try to read more requests off +this connection. If you generate a response that is not self +delimiting, then you should signal this fact by calling this method. + +This attribute is turned on automatically if the client announces +protocol HTTP/1.0 or worse and does not include a "Connection: +Keep-Alive" header. It is also turned on automatically when HTTP/1.1 +or better clients send the "Connection: close" request header. + +=item $c->send_status_line + +=item $c->send_status_line( $code ) + +=item $c->send_status_line( $code, $mess ) + +=item $c->send_status_line( $code, $mess, $proto ) + +Send the status line back to the client. If $code is omitted 200 is +assumed. If $mess is omitted, then a message corresponding to $code +is inserted. If $proto is missing the content of the +$HTTP::Daemon::PROTO variable is used. + +=item $c->send_crlf + +Send the CRLF sequence to the client. + +=item $c->send_basic_header + +=item $c->send_basic_header( $code ) + +=item $c->send_basic_header( $code, $mess ) + +=item $c->send_basic_header( $code, $mess, $proto ) + +Send the status line and the "Date:" and "Server:" headers back to +the client. This header is assumed to be continued and does not end +with an empty CRLF line. + +See the description of send_status_line() for the description of the +accepted arguments. + +=item $c->send_header( $field, $value ) + +=item $c->send_header( $field1, $value1, $field2, $value2, ... ) + +Send one or more header lines. + +=item $c->send_response( $res ) + +Write a C<HTTP::Response> object to the +client as a response. We try hard to make sure that the response is +self delimiting so that the connection can stay persistent for further +request/response exchanges. + +The content attribute of the C<HTTP::Response> object can be a normal +string or a subroutine reference. If it is a subroutine, then +whatever this callback routine returns is written back to the +client as the response content. The routine will be called until it +return an undefined or empty value. If the client is HTTP/1.1 aware +then we will use chunked transfer encoding for the response. + +=item $c->send_redirect( $loc ) + +=item $c->send_redirect( $loc, $code ) + +=item $c->send_redirect( $loc, $code, $entity_body ) + +Send a redirect response back to the client. The location ($loc) can +be an absolute or relative URL. The $code must be one the redirect +status codes, and defaults to "301 Moved Permanently" + +=item $c->send_error + +=item $c->send_error( $code ) + +=item $c->send_error( $code, $error_message ) + +Send an error response back to the client. If the $code is missing a +"Bad Request" error is reported. The $error_message is a string that +is incorporated in the body of the HTML entity body. + +=item $c->send_file_response( $filename ) + +Send back a response with the specified $filename as content. If the +file is a directory we try to generate an HTML index of it. + +=item $c->send_file( $filename ) + +=item $c->send_file( $fd ) + +Copy the file to the client. The file can be a string (which +will be interpreted as a filename) or a reference to an C<IO::Handle> +or glob. + +=item $c->daemon + +Return a reference to the corresponding C<HTTP::Daemon> object. + +=back + +=head1 SEE ALSO + +RFC 2616 + +L<IO::Socket::INET>, L<IO::Socket> + +=head1 COPYRIGHT + +Copyright 1996-2003, Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Date.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Date.pm new file mode 100644 index 0000000000..d05d21605a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Date.pm @@ -0,0 +1,388 @@ +package HTTP::Date; + +$VERSION = "6.02"; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(time2str str2time); +@EXPORT_OK = qw(parse_date time2iso time2isoz); + +use strict; +require Time::Local; + +use vars qw(@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; + + +__END__ + +=head1 NAME + +HTTP::Date - date conversion routines + +=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 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. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers.pm new file mode 100644 index 0000000000..1c25c79982 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers.pm @@ -0,0 +1,890 @@ +package HTTP::Headers; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +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 Storable; 1 }) { + *clone = \&Storable::dclone; +} 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.18 + +=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. + +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-2017 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 + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers/Auth.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers/Auth.pm new file mode 100644 index 0000000000..462cf628da --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers/Auth.pm @@ -0,0 +1,127 @@ +package HTTP::Headers::Auth; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +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.18 + +=head1 AUTHOR + +Gisle Aas <gisle@activestate.com> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers/ETag.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers/ETag.pm new file mode 100644 index 0000000000..02d6249b06 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers/ETag.pm @@ -0,0 +1,123 @@ +package HTTP::Headers::ETag; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +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.18 + +=head1 AUTHOR + +Gisle Aas <gisle@activestate.com> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 1994-2017 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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers/Util.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers/Util.pm new file mode 100644 index 0000000000..dc07eb32ad --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Headers/Util.pm @@ -0,0 +1,213 @@ +package HTTP::Headers::Util; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +use base 'Exporter'; + +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+//) { + # 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.18 + +=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-2017 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 + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Message.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Message.pm new file mode 100644 index 0000000000..078209e8ed --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Message.pm @@ -0,0 +1,1133 @@ +package HTTP::Message; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +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; + # 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 $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 { local $Carp::Internal{+__PACKAGE__} = 1; shift->headers->$method(@_) }; + goto &$method; +} + + +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.18 + +=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 +the raw content encoded to Perl's Unicode strings. 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-2017 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) + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Negotiate.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Negotiate.pm new file mode 100644 index 0000000000..d293ce86d9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Negotiate.pm @@ -0,0 +1,528 @@ +package HTTP::Negotiate; + +$VERSION = "6.01"; +sub Version { $VERSION; } + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(choose); + +require HTTP::Headers; + +$DEBUG = 0; + +sub choose ($;$) +{ + my($variants, $request) = @_; + my(%accept); + + unless (defined $request) { + # Create a request object from the CGI environment variables + $request = HTTP::Headers->new; + $request->header('Accept', $ENV{HTTP_ACCEPT}) + if $ENV{HTTP_ACCEPT}; + $request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET}) + if $ENV{HTTP_ACCEPT_CHARSET}; + $request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING}) + if $ENV{HTTP_ACCEPT_ENCODING}; + $request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE}) + if $ENV{HTTP_ACCEPT_LANGUAGE}; + } + + # Get all Accept values from the request. Build a hash initialized + # like this: + # + # %accept = ( type => { 'audio/*' => { q => 0.2, mbx => 20000 }, + # 'audio/basic' => { q => 1 }, + # }, + # language => { 'no' => { q => 1 }, + # } + # ); + + $request->scan(sub { + my($key, $val) = @_; + + my $type; + if ($key =~ s/^Accept-//) { + $type = lc($key); + } + elsif ($key eq "Accept") { + $type = "type"; + } + else { + return; + } + + $val =~ s/\s+//g; + my $default_q = 1; + for my $name (split(/,/, $val)) { + my(%param, $param); + if ($name =~ s/;(.*)//) { + for $param (split(/;/, $1)) { + my ($pk, $pv) = split(/=/, $param, 2); + $param{lc $pk} = $pv; + } + } + $name = lc $name; + if (defined $param{'q'}) { + $param{'q'} = 1 if $param{'q'} > 1; + $param{'q'} = 0 if $param{'q'} < 0; + } + else { + $param{'q'} = $default_q; + + # This makes sure that the first ones are slightly better off + # and therefore more likely to be chosen. + $default_q -= 0.0001; + } + $accept{$type}{$name} = \%param; + } + }); + + # Check if any of the variants specify a language. We do this + # because it influences how we treat those without (they default to + # 0.5 instead of 1). + my $any_lang = 0; + for $var (@$variants) { + if ($var->[5]) { + $any_lang = 1; + last; + } + } + + if ($DEBUG) { + print "Negotiation parameters in the request\n"; + for $type (keys %accept) { + print " $type:\n"; + for $name (keys %{$accept{$type}}) { + print " $name\n"; + for $pv (keys %{$accept{$type}{$name}}) { + print " $pv = $accept{$type}{$name}{$pv}\n"; + } + } + } + } + + my @Q = (); # This is where we collect the results of the + # quality calculations + + # Calculate quality for all the variants that are available. + for (@$variants) { + my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_; + $qs = 1 unless defined $qs; + $ct = '' unless defined $ct; + $bs = 0 unless defined $bs; + $lang = lc($lang) if $lang; # lg tags are always case-insensitive + if ($DEBUG) { + print "\nEvaluating $id (ct='$ct')\n"; + printf " qs = %.3f\n", $qs; + print " enc = $enc\n" if $enc && !ref($enc); + print " enc = @$enc\n" if $enc && ref($enc); + print " cs = $cs\n" if $cs; + print " lang = $lang\n" if $lang; + print " bs = $bs\n" if $bs; + } + + # Calculate encoding quality + my $qe = 1; + # If the variant has no assigned Content-Encoding, or if no + # Accept-Encoding field is present, then the value assigned + # is "qe=1". If *all* of the variant's content encodings + # are listed in the Accept-Encoding field, then the value + # assigned is "qw=1". If *any* of the variant's content + # encodings are not listed in the provided Accept-Encoding + # field, then the value assigned is "qe=0" + if (exists $accept{'encoding'} && $enc) { + my @enc = ref($enc) ? @$enc : ($enc); + for (@enc) { + print "Is encoding $_ accepted? " if $DEBUG; + unless(exists $accept{'encoding'}{$_}) { + print "no\n" if $DEBUG; + $qe = 0; + last; + } + else { + print "yes\n" if $DEBUG; + } + } + } + + # Calculate charset quality + my $qc = 1; + # If the variant's media-type has no charset parameter, + # or the variant's charset is US-ASCII, or if no Accept-Charset + # field is present, then the value assigned is "qc=1". If the + # variant's charset is listed in the Accept-Charset field, + # then the value assigned is "qc=1. Otherwise, if the variant's + # charset is not listed in the provided Accept-Encoding field, + # then the value assigned is "qc=0". + if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) { + $qc = 0 unless $accept{'charset'}{$cs}; + } + + # Calculate language quality + my $ql = 1; + if ($lang && exists $accept{'language'}) { + my @lang = ref($lang) ? @$lang : ($lang); + # If any of the variant's content languages are listed + # in the Accept-Language field, the the value assigned is + # the largest of the "q" parameter values for those language + # tags. + my $q = undef; + for (@lang) { + next unless exists $accept{'language'}{$_}; + my $this_q = $accept{'language'}{$_}{'q'}; + $q = $this_q unless defined $q; + $q = $this_q if $this_q > $q; + } + if(defined $q) { + $DEBUG and print " -- Exact language match at q=$q\n"; + } + else { + # If there was no exact match and at least one of + # the Accept-Language field values is a complete + # subtag prefix of the content language tag(s), then + # the "q" parameter value of the largest matching + # prefix is used. + $DEBUG and print " -- No exact language match\n"; + my $selected = undef; + for $al (keys %{ $accept{'language'} }) { + if (index($al, "$lang-") == 0) { + # $lang starting with $al isn't enough, or else + # Accept-Language: hu (Hungarian) would seem + # to accept a document in hup (Hupa) + $DEBUG and print " -- $al ISA $lang\n"; + $selected = $al unless defined $selected; + $selected = $al if length($al) > length($selected); + } + else { + $DEBUG and print " -- $lang isn't a $al\n"; + } + } + $q = $accept{'language'}{$selected}{'q'} if $selected; + + # If none of the variant's content language tags or + # tag prefixes are listed in the provided + # Accept-Language field, then the value assigned + # is "ql=0.001" + $q = 0.001 unless defined $q; + } + $ql = $q; + } + else { + $ql = 0.5 if $any_lang && exists $accept{'language'}; + } + + my $q = 1; + my $mbx = undef; + # If no Accept field is given, then the value assigned is "q=1". + # If at least one listed media range matches the variant's media + # type, then the "q" parameter value assigned to the most specific + # of those matched is used (e.g. "text/html;version=3.0" is more + # specific than "text/html", which is more specific than "text/*", + # which in turn is more specific than "*/*"). If not media range + # in the provided Accept field matches the variant's media type, + # then the value assigned is "q=0". + if (exists $accept{'type'} && $ct) { + # First we clean up our content-type + $ct =~ s/\s+//g; + my $params = ""; + $params = $1 if $ct =~ s/;(.*)//; + my($type, $subtype) = split("/", $ct, 2); + my %param = (); + for $param (split(/;/, $params)) { + my($pk,$pv) = split(/=/, $param, 2); + $param{$pk} = $pv; + } + + my $sel_q = undef; + my $sel_mbx = undef; + my $sel_specificness = 0; + + ACCEPT_TYPE: + for $at (keys %{ $accept{'type'} }) { + print "Consider $at...\n" if $DEBUG; + my($at_type, $at_subtype) = split("/", $at, 2); + # Is it a match on the type + next if $at_type ne '*' && $at_type ne $type; + next if $at_subtype ne '*' && $at_subtype ne $subtype; + my $specificness = 0; + $specificness++ if $at_type ne '*'; + $specificness++ if $at_subtype ne '*'; + # Let's see if content-type parameters also match + while (($pk, $pv) = each %param) { + print "Check if $pk = $pv is true\n" if $DEBUG; + next unless exists $accept{'type'}{$at}{$pk}; + next ACCEPT_TYPE + unless $accept{'type'}{$at}{$pk} eq $pv; + print "yes it is!!\n" if $DEBUG; + $specificness++; + } + print "Hurray, type match with specificness = $specificness\n" + if $DEBUG; + + if (!defined($sel_q) || $sel_specificness < $specificness) { + $sel_q = $accept{'type'}{$at}{'q'}; + $sel_mbx = $accept{'type'}{$at}{'mbx'}; + $sel_specificness = $specificness; + } + } + $q = $sel_q || 0; + $mbx = $sel_mbx; + } + + my $Q; + if (!defined($mbx) || $mbx >= $bs) { + $Q = $qs * $qe * $qc * $ql * $q; + } + else { + $Q = 0; + print "Variant's size is too large ==> Q=0\n" if $DEBUG; + } + + if ($DEBUG) { + $mbx = "undef" unless defined $mbx; + printf "Q=%.4f", $Q; + print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n"; + } + + push(@Q, [$id, $Q, $bs]); + } + + + @Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q; + + return @Q if wantarray; + return undef unless @Q; + return undef if $Q[0][1] == 0; + $Q[0][0]; +} + +1; + +__END__ + + +=head1 NAME + +HTTP::Negotiate - choose a variant to serve + +=head1 SYNOPSIS + + use HTTP::Negotiate qw(choose); + + # ID QS Content-Type Encoding Char-Set Lang Size + $variants = + [['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000], + ['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400], + ['var3', 0.3, 'image/gif', undef, undef, undef, 43555], + ]; + + @preferred = choose($variants, $request_headers); + $the_one = choose($variants); + +=head1 DESCRIPTION + +This module provides a complete implementation of the HTTP content +negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps> +chapter 12. Content negotiation allows for the selection of a +preferred content representation based upon attributes of the +negotiable variants and the value of the various Accept* header fields +in the request. + +The variants are ordered by preference by calling the function +choose(). + +The first parameter is reference to an array of the variants to +choose among. +Each element in this array is an array with the values [$id, $qs, +$content_type, $content_encoding, $charset, $content_language, +$content_length] whose meanings are described +below. The $content_encoding and $content_language can be either a +single scalar value or an array reference if there are several values. + +The second optional parameter is either a HTTP::Headers or a HTTP::Request +object which is searched for "Accept*" headers. If this +parameter is missing, then the accept specification is initialized +from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET, +HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE. + +In an array context, choose() returns a list of [variant +identifier, calculated quality, size] tuples. The values are sorted by +quality, highest quality first. If the calculated quality is the same +for two variants, then they are sorted by size (smallest first). I<E.g.>: + + (['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]); + +Note that also zero quality variants are included in the return list +even if these should never be served to the client. + +In a scalar context, it returns the identifier of the variant with the +highest score or C<undef> if none have non-zero quality. + +If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of +noise is generated on STDOUT during evaluation of choose(). + +=head1 VARIANTS + +A variant is described by a list of the following values. If the +attribute does not make sense or is unknown for a variant, then use +C<undef> instead. + +=over 3 + +=item identifier + +This is a string that you use as the name for the variant. This +identifier for the preferred variants returned by choose(). + +=item qs + +This is a number between 0.000 and 1.000 that describes the "source +quality". This is what F<draft-ietf-http-v11-spec-00.ps> says about this +value: + +Source quality is measured by the content provider as representing the +amount of degradation from the original source. For example, a +picture in JPEG form would have a lower qs when translated to the XBM +format, and much lower qs when translated to an ASCII-art +representation. Note, however, that this is a function of the source +- an original piece of ASCII-art may degrade in quality if it is +captured in JPEG form. The qs values should be assigned to each +variant by the content provider; if no qs value has been assigned, the +default is generally "qs=1". + +=item content-type + +This is the media type of the variant. The media type does not +include a charset attribute, but might contain other parameters. +Examples are: + + text/html + text/html;version=2.0 + text/plain + image/gif + image/jpg + +=item content-encoding + +This is one or more content encodings that has been applied to the +variant. The content encoding is generally used as a modifier to the +content media type. The most common content encodings are: + + gzip + compress + +=item content-charset + +This is the character set used when the variant contains text. +The charset value should generally be C<undef> or one of these: + + us-ascii + iso-8859-1 ... iso-8859-9 + iso-2022-jp + iso-2022-jp-2 + iso-2022-kr + unicode-1-1 + unicode-1-1-utf-7 + unicode-1-1-utf-8 + +=item content-language + +This describes one or more languages that are used in the variant. +Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A +language is in this context a natural language spoken, written, or +otherwise conveyed by human beings for communication of information to +other human beings. Computer languages are explicitly excluded. + +The language tags are defined by RFC 3066. Examples +are: + + no Norwegian + en International English + en-US US English + en-cockney + +=item content-length + +This is the number of bytes used to represent the content. + +=back + +=head1 ACCEPT HEADERS + +The following Accept* headers can be used for describing content +preferences in a request (This description is an edited extract from +F<draft-ietf-http-v11-spec-00.ps>): + +=over 3 + +=item Accept + +This header can be used to indicate a list of media ranges which are +acceptable as a response to the request. The "*" character is used to +group media types into ranges, with "*/*" indicating all media types +and "type/*" indicating all subtypes of that type. + +The parameter q is used to indicate the quality factor, which +represents the user's preference for that range of media types. The +parameter mbx gives the maximum acceptable size of the response +content. The default values are: q=1 and mbx=infinity. If no Accept +header is present, then the client accepts all media types with q=1. + +For example: + + Accept: audio/*;q=0.2;mbx=200000, audio/basic + +would mean: "I prefer audio/basic (of any size), but send me any audio +type if it is the best available after an 80% mark-down in quality and +its size is less than 200000 bytes" + + +=item Accept-Charset + +Used to indicate what character sets are acceptable for the response. +The "us-ascii" character set is assumed to be acceptable for all user +agents. If no Accept-Charset field is given, the default is that any +charset is acceptable. Example: + + Accept-Charset: iso-8859-1, unicode-1-1 + + +=item Accept-Encoding + +Restricts the Content-Encoding values which are acceptable in the +response. If no Accept-Encoding field is present, the server may +assume that the client will accept any content encoding. An empty +Accept-Encoding means that no content encoding is acceptable. Example: + + Accept-Encoding: compress, gzip + + +=item Accept-Language + +This field is similar to Accept, but restricts the set of natural +languages that are preferred in a response. Each language may be +given an associated quality value which represents an estimate of the +user's comprehension of that language. For example: + + Accept-Language: no, en-gb;q=0.8, de;q=0.55 + +would mean: "I prefer Norwegian, but will accept British English (with +80% comprehension) or German (with 55% comprehension). + +=back + + +=head1 COPYRIGHT + +Copyright 1996,2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 AUTHOR + +Gisle Aas <gisle@aas.no> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Request.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Request.pm new file mode 100644 index 0000000000..8998ceda3b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Request.pm @@ -0,0 +1,344 @@ +package HTTP::Request; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +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; + return $self->{'_uri_canonical'} ||= $self->{'_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.18 + +=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 Encode qw(encode_utf8); + 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_utf8(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 Encode qw(encode_utf8); + 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_utf8(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-2017 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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Request/Common.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Request/Common.pm new file mode 100644 index 0000000000..d70a939571 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Request/Common.pm @@ -0,0 +1,560 @@ +package HTTP::Request::Common; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +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); +our @EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE); + +require HTTP::Request; +use Carp(); + +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 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 =~ s,.*/,, 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.18 + +=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]); + +=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 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-2017 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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Response.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Response.pm new file mode 100644 index 0000000000..31d7a387fe --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Response.pm @@ -0,0 +1,665 @@ +package HTTP::Response; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +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.18 + +=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-2017 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 + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Status.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Status.pm new file mode 100644 index 0000000000..8cf997464f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/HTTP/Status.pm @@ -0,0 +1,348 @@ +package HTTP::Status; + +use strict; +use warnings; + +our $VERSION = '6.18'; + +require 5.002; # because we use prototypes + +use base 'Exporter'; +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 => 'Request Entity Too Large', + 414 => 'Request-URI Too Large', + 415 => 'Unsupported Media Type', + 416 => 'Request 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 + 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 7724: 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 + 425 => 'Unordered Collection', # WebDAV Draft + 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"); + +*RC_NO_CODE = \&RC_UNORDERED_COLLECTION; +push(@EXPORT, "RC_NO_CODE"); + +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] == 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.18 + +=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_REQUEST_ENTITY_TOO_LARGE (413) + HTTP_REQUEST_URI_TOO_LARGE (414) + HTTP_UNSUPPORTED_MEDIA_TYPE (415) + HTTP_REQUEST_RANGE_NOT_SATISFIABLE (416) + HTTP_EXPECTATION_FAILED (417) + HTTP_MISDIRECTED REQUEST (421) + HTTP_UNPROCESSABLE_ENTITY (422) + HTTP_LOCKED (423) + HTTP_FAILED_DEPENDENCY (424) + 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-2017 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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/IO/HTML.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/IO/HTML.pm new file mode 100644 index 0000000000..5fdad2237e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/IO/HTML.pm @@ -0,0 +1,575 @@ +#--------------------------------------------------------------------- +package IO::HTML; +# +# Copyright 2014 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.001'; +# This file is part of IO-HTML 1.001 (June 28, 2014) + +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, 1024; + + 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 + and (/\G"([^"]*)"?/gc or + /\G'([^']*)'?/gc or + /\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 || {}; + my $stop = length > 1024 ? 1024 : length; # search first 1024 bytes + + 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.001 of +IO::HTML, released June 28, 2014. + +=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 1024 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 1024 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. + + +=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. The result of calling it in +scalar context is undefined. + + +=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. + + +=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. +Only the first 1024 bytes of the string are checked. + +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 + +IO::HTML requires no configuration files or environment variables. + +=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) 2014 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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/IO/String.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/IO/String.pm new file mode 100644 index 0000000000..4bc8e71960 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/IO/String.pm @@ -0,0 +1,551 @@ +package IO::String; + +# Copyright 1998-2005 Gisle Aas. +# +# This library is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +require 5.005_03; +use strict; +use vars qw($VERSION $DEBUG $IO_CONSTANTS); +$VERSION = "1.08"; # $Date: 2005/12/05 12:00:47 $ + +use Symbol (); + +sub new +{ + my $class = shift; + my $self = bless Symbol::gensym(), ref($class) || $class; + tie *$self, $self; + $self->open(@_); + return $self; +} + +sub open +{ + my $self = shift; + return $self->new(@_) unless ref($self); + + if (@_) { + my $bufref = ref($_[0]) ? $_[0] : \$_[0]; + $$bufref = "" unless defined $$bufref; + *$self->{buf} = $bufref; + } + else { + my $buf = ""; + *$self->{buf} = \$buf; + } + *$self->{pos} = 0; + *$self->{lno} = 0; + return $self; +} + +sub pad +{ + my $self = shift; + my $old = *$self->{pad}; + *$self->{pad} = substr($_[0], 0, 1) if @_; + return "\0" unless defined($old) && length($old); + return $old; +} + +sub dump +{ + require Data::Dumper; + my $self = shift; + print Data::Dumper->Dump([$self], ['*self']); + print Data::Dumper->Dump([*$self{HASH}], ['$self{HASH}']); + return; +} + +sub TIEHANDLE +{ + print "TIEHANDLE @_\n" if $DEBUG; + return $_[0] if ref($_[0]); + my $class = shift; + my $self = bless Symbol::gensym(), $class; + $self->open(@_); + return $self; +} + +sub DESTROY +{ + print "DESTROY @_\n" if $DEBUG; +} + +sub close +{ + my $self = shift; + delete *$self->{buf}; + delete *$self->{pos}; + delete *$self->{lno}; + undef *$self if $] eq "5.008"; # workaround for some bug + return 1; +} + +sub opened +{ + my $self = shift; + return defined *$self->{buf}; +} + +sub binmode +{ + my $self = shift; + return 1 unless @_; + # XXX don't know much about layers yet :-( + return 0; +} + +sub getc +{ + my $self = shift; + my $buf; + return $buf if $self->read($buf, 1); + return undef; +} + +sub ungetc +{ + my $self = shift; + $self->setpos($self->getpos() - 1); + return 1; +} + +sub eof +{ + my $self = shift; + return length(${*$self->{buf}}) <= *$self->{pos}; +} + +sub print +{ + my $self = shift; + if (defined $\) { + if (defined $,) { + $self->write(join($,, @_).$\); + } + else { + $self->write(join("",@_).$\); + } + } + else { + if (defined $,) { + $self->write(join($,, @_)); + } + else { + $self->write(join("",@_)); + } + } + return 1; +} +*printflush = \*print; + +sub printf +{ + my $self = shift; + print "PRINTF(@_)\n" if $DEBUG; + my $fmt = shift; + $self->write(sprintf($fmt, @_)); + return 1; +} + + +my($SEEK_SET, $SEEK_CUR, $SEEK_END); + +sub _init_seek_constants +{ + if ($IO_CONSTANTS) { + require IO::Handle; + $SEEK_SET = &IO::Handle::SEEK_SET; + $SEEK_CUR = &IO::Handle::SEEK_CUR; + $SEEK_END = &IO::Handle::SEEK_END; + } + else { + $SEEK_SET = 0; + $SEEK_CUR = 1; + $SEEK_END = 2; + } +} + + +sub seek +{ + my($self,$off,$whence) = @_; + my $buf = *$self->{buf} || return 0; + my $len = length($$buf); + my $pos = *$self->{pos}; + + _init_seek_constants() unless defined $SEEK_SET; + + if ($whence == $SEEK_SET) { $pos = $off } + elsif ($whence == $SEEK_CUR) { $pos += $off } + elsif ($whence == $SEEK_END) { $pos = $len + $off } + else { die "Bad whence ($whence)" } + print "SEEK(POS=$pos,OFF=$off,LEN=$len)\n" if $DEBUG; + + $pos = 0 if $pos < 0; + $self->truncate($pos) if $pos > $len; # extend file + *$self->{pos} = $pos; + return 1; +} + +sub pos +{ + my $self = shift; + my $old = *$self->{pos}; + if (@_) { + my $pos = shift || 0; + my $buf = *$self->{buf}; + my $len = $buf ? length($$buf) : 0; + $pos = $len if $pos > $len; + *$self->{pos} = $pos; + } + return $old; +} + +sub getpos { shift->pos; } + +*sysseek = \&seek; +*setpos = \&pos; +*tell = \&getpos; + + + +sub getline +{ + my $self = shift; + my $buf = *$self->{buf} || return; + my $len = length($$buf); + my $pos = *$self->{pos}; + return if $pos >= $len; + + unless (defined $/) { # slurp + *$self->{pos} = $len; + return substr($$buf, $pos); + } + + unless (length $/) { # paragraph mode + # XXX slow&lazy implementation using getc() + my $para = ""; + my $eol = 0; + my $c; + while (defined($c = $self->getc)) { + if ($c eq "\n") { + $eol++; + next if $eol > 2; + } + elsif ($eol > 1) { + $self->ungetc($c); + last; + } + else { + $eol = 0; + } + $para .= $c; + } + return $para; # XXX wantarray + } + + my $idx = index($$buf,$/,$pos); + if ($idx < 0) { + # return rest of it + *$self->{pos} = $len; + $. = ++ *$self->{lno}; + return substr($$buf, $pos); + } + $len = $idx - $pos + length($/); + *$self->{pos} += $len; + $. = ++ *$self->{lno}; + return substr($$buf, $pos, $len); +} + +sub getlines +{ + die "getlines() called in scalar context\n" unless wantarray; + my $self = shift; + my($line, @lines); + push(@lines, $line) while defined($line = $self->getline); + return @lines; +} + +sub READLINE +{ + goto &getlines if wantarray; + goto &getline; +} + +sub input_line_number +{ + my $self = shift; + my $old = *$self->{lno}; + *$self->{lno} = shift if @_; + return $old; +} + +sub truncate +{ + my $self = shift; + my $len = shift || 0; + my $buf = *$self->{buf}; + if (length($$buf) >= $len) { + substr($$buf, $len) = ''; + *$self->{pos} = $len if $len < *$self->{pos}; + } + else { + $$buf .= ($self->pad x ($len - length($$buf))); + } + return 1; +} + +sub read +{ + my $self = shift; + my $buf = *$self->{buf}; + return undef unless $buf; + + my $pos = *$self->{pos}; + my $rem = length($$buf) - $pos; + my $len = $_[1]; + $len = $rem if $len > $rem; + return undef if $len < 0; + if (@_ > 2) { # read offset + substr($_[0],$_[2]) = substr($$buf, $pos, $len); + } + else { + $_[0] = substr($$buf, $pos, $len); + } + *$self->{pos} += $len; + return $len; +} + +sub write +{ + my $self = shift; + my $buf = *$self->{buf}; + return unless $buf; + + my $pos = *$self->{pos}; + my $slen = length($_[0]); + my $len = $slen; + my $off = 0; + if (@_ > 1) { + $len = $_[1] if $_[1] < $len; + if (@_ > 2) { + $off = $_[2] || 0; + die "Offset outside string" if $off > $slen; + if ($off < 0) { + $off += $slen; + die "Offset outside string" if $off < 0; + } + my $rem = $slen - $off; + $len = $rem if $rem < $len; + } + } + substr($$buf, $pos, $len) = substr($_[0], $off, $len); + *$self->{pos} += $len; + return $len; +} + +*sysread = \&read; +*syswrite = \&write; + +sub stat +{ + my $self = shift; + return unless $self->opened; + return 1 unless wantarray; + my $len = length ${*$self->{buf}}; + + return ( + undef, undef, # dev, ino + 0666, # filemode + 1, # links + $>, # user id + $), # group id + undef, # device id + $len, # size + undef, # atime + undef, # mtime + undef, # ctime + 512, # blksize + int(($len+511)/512) # blocks + ); +} + +sub FILENO { + return undef; # XXX perlfunc says this means the file is closed +} + +sub blocking { + my $self = shift; + my $old = *$self->{blocking} || 0; + *$self->{blocking} = shift if @_; + return $old; +} + +my $notmuch = sub { return }; + +*fileno = $notmuch; +*error = $notmuch; +*clearerr = $notmuch; +*sync = $notmuch; +*flush = $notmuch; +*setbuf = $notmuch; +*setvbuf = $notmuch; + +*untaint = $notmuch; +*autoflush = $notmuch; +*fcntl = $notmuch; +*ioctl = $notmuch; + +*GETC = \&getc; +*PRINT = \&print; +*PRINTF = \&printf; +*READ = \&read; +*WRITE = \&write; +*SEEK = \&seek; +*TELL = \&getpos; +*EOF = \&eof; +*CLOSE = \&close; +*BINMODE = \&binmode; + + +sub string_ref +{ + my $self = shift; + return *$self->{buf}; +} +*sref = \&string_ref; + +1; + +__END__ + +=head1 NAME + +IO::String - Emulate file interface for in-core strings + +=head1 SYNOPSIS + + use IO::String; + $io = IO::String->new; + $io = IO::String->new($var); + tie *IO, 'IO::String'; + + # read data + <$io>; + $io->getline; + read($io, $buf, 100); + + # write data + print $io "string\n"; + $io->print(@data); + syswrite($io, $buf, 100); + + select $io; + printf "Some text %s\n", $str; + + # seek + $pos = $io->getpos; + $io->setpos(0); # rewind + $io->seek(-30, -1); + seek($io, 0, 0); + +=head1 DESCRIPTION + +The C<IO::String> module provides the C<IO::File> interface for in-core +strings. An C<IO::String> object can be attached to a string, and +makes it possible to use the normal file operations for reading or +writing data, as well as for seeking to various locations of the string. +This is useful when you want to use a library module that only +provides an interface to file handles on data that you have in a string +variable. + +Note that perl-5.8 and better has built-in support for "in memory" +files, which are set up by passing a reference instead of a filename +to the open() call. The reason for using this module is that it +makes the code backwards compatible with older versions of Perl. + +The C<IO::String> module provides an interface compatible with +C<IO::File> as distributed with F<IO-1.20>, but the following methods +are not available: new_from_fd, fdopen, format_write, +format_page_number, format_lines_per_page, format_lines_left, +format_name, format_top_name. + +The following methods are specific to the C<IO::String> class: + +=over 4 + +=item $io = IO::String->new + +=item $io = IO::String->new( $string ) + +The constructor returns a newly-created C<IO::String> object. It +takes an optional argument, which is the string to read from or write +into. If no $string argument is given, then an internal buffer +(initially empty) is allocated. + +The C<IO::String> object returned is tied to itself. This means +that you can use most Perl I/O built-ins on it too: readline, <>, getc, +print, printf, syswrite, sysread, close. + +=item $io->open + +=item $io->open( $string ) + +Attaches an existing IO::String object to some other $string, or +allocates a new internal buffer (if no argument is given). The +position is reset to 0. + +=item $io->string_ref + +Returns a reference to the string that is attached to +the C<IO::String> object. Most useful when you let the C<IO::String> +create an internal buffer to write into. + +=item $io->pad + +=item $io->pad( $char ) + +Specifies the padding to use if +the string is extended by either the seek() or truncate() methods. It +is a single character and defaults to "\0". + +=item $io->pos + +=item $io->pos( $newpos ) + +Yet another interface for reading and setting the current read/write +position within the string (the normal getpos/setpos/tell/seek +methods are also available). The pos() method always returns the +old position, and if you pass it an argument it sets the new +position. + +There is (deliberately) a difference between the setpos() and seek() +methods in that seek() extends the string (with the specified +padding) if you go to a location past the end, whereas setpos() +just snaps back to the end. If truncate() is used to extend the string, +then it works as seek(). + +=back + +=head1 BUGS + +In Perl versions < 5.6, the TIEHANDLE interface was incomplete. +If you use such a Perl, then seek(), tell(), eof(), fileno(), binmode() will +not do anything on an C<IO::String> handle. See L<perltie> for +details. + +=head1 SEE ALSO + +L<IO::File>, L<IO::Stringy>, L<perlfunc/open> + +=head1 COPYRIGHT + +Copyright 1998-2005 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/JSON/MaybeXS.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/JSON/MaybeXS.pm new file mode 100644 index 0000000000..302b01cb65 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/JSON/MaybeXS.pm @@ -0,0 +1,334 @@ +package JSON::MaybeXS; + +use strict; +use warnings FATAL => 'all'; +use base qw(Exporter); + +our $VERSION = '1.004000'; +$VERSION = eval $VERSION; + +sub _choose_json_module { + return 'Cpanel::JSON::XS' if $INC{'Cpanel/JSON/XS.pm'}; + return 'JSON::XS' if $INC{'JSON/XS.pm'}; + + my @err; + + return 'Cpanel::JSON::XS' if eval { require Cpanel::JSON::XS; 1; }; + push @err, "Error loading Cpanel::JSON::XS: $@"; + + return 'JSON::XS' if eval { require JSON::XS; 1; }; + push @err, "Error loading JSON::XS: $@"; + + return 'JSON::PP' if eval { require JSON::PP; 1 }; + push @err, "Error loading JSON::PP: $@"; + + die join( "\n", "Couldn't load a JSON module:", @err ); + +} + +BEGIN { + our $JSON_Class = _choose_json_module(); + $JSON_Class->import(qw(encode_json decode_json)); + no strict 'refs'; + *$_ = $JSON_Class->can($_) + for qw(true false); +} + +our @EXPORT = qw(encode_json decode_json JSON); +my @EXPORT_ALL = qw(is_bool); +our @EXPORT_OK = qw(is_bool to_json from_json); +our %EXPORT_TAGS = ( all => [ @EXPORT, @EXPORT_ALL ], + legacy => [ @EXPORT, @EXPORT_OK ], + ); + +sub JSON () { our $JSON_Class } + +sub new { + shift; + my %args = @_ == 1 ? %{$_[0]} : @_; + my $new = (our $JSON_Class)->new; + $new->$_($args{$_}) for keys %args; + return $new; +} + +use Scalar::Util (); + +sub is_bool { + die 'is_bool is not a method' if $_[1]; + + Scalar::Util::blessed($_[0]) + and ($_[0]->isa('JSON::XS::Boolean') + or $_[0]->isa('Cpanel::JSON::XS::Boolean') + or $_[0]->isa('JSON::PP::Boolean')); +} + +# (mostly) CopyPasta from JSON.pm version 2.90 +use Carp (); + +sub from_json ($@) { + if ( ref($_[0]) =~ /^JSON/ or $_[0] =~ /^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 to_json ($@) { + if ( + ref($_[0]) =~ /^JSON/ + or (@_ > 2 and $_[0] =~ /^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]); +} + +1; + +=head1 NAME + +JSON::MaybeXS - Use L<Cpanel::JSON::XS> with a fallback to L<JSON::XS> and L<JSON::PP> + +=head1 SYNOPSIS + + use JSON::MaybeXS; + + my $data_structure = decode_json($json_input); + + my $json_output = encode_json($data_structure); + + my $json = JSON()->new; + + my $json_with_args = JSON::MaybeXS->new(utf8 => 1); # or { utf8 => 1 } + +=head1 DESCRIPTION + +This module first checks to see if either L<Cpanel::JSON::XS> or +L<JSON::XS> is already loaded, in which case it uses that module. Otherwise +it tries to load L<Cpanel::JSON::XS>, then L<JSON::XS>, then L<JSON::PP> +in order, and either uses the first module it finds or throws an error. + +It then exports the C<encode_json> and C<decode_json> functions from the +loaded module, along with a C<JSON> constant that returns the class name +for calling C<new> on. + +If you're writing fresh code rather than replacing L<JSON.pm|JSON> usage, you might +want to pass options as constructor args rather than calling mutators, so +we provide our own C<new> method that supports that. + +=head1 EXPORTS + +C<encode_json>, C<decode_json> and C<JSON> are exported by default; C<is_bool> +is exported on request. + +To import only some symbols, specify them on the C<use> line: + + use JSON::MaybeXS qw(encode_json decode_json is_bool); # functions only + + use JSON::MaybeXS qw(JSON); # JSON constant only + +To import all available sensible symbols (C<encode_json>, C<decode_json>, and +C<is_bool>), use C<:all>: + + use JSON::MaybeXS ':all'; + +To import all symbols including those needed by legacy apps that use L<JSON::PP>: + + use JSON::MaybeXS ':legacy'; + +This imports the C<to_json> and C<from_json> symbols as well as everything in +C<:all>. NOTE: This is to support legacy code that makes extensive +use of C<to_json> and C<from_json> which you are not yet in a position to +refactor. DO NOT use this import tag in new code, in order to avoid +the crawling horrors of getting UTF-8 support subtly wrong. See the +documentation for L<JSON> for further details. + +=head2 encode_json + +This is the C<encode_json> function provided by the selected implementation +module, and takes a perl data structure which is serialised to JSON text. + + my $json_text = encode_json($data_structure); + +=head2 decode_json + +This is the C<decode_json> function provided by the selected implementation +module, and takes a string of JSON text to deserialise to a perl data structure. + + my $data_structure = decode_json($json_text); + +=head2 to_json, from_json + +See L<JSON> for details. These are included to support legacy code +B<only>. + +=head2 JSON + +The C<JSON> constant returns the selected implementation module's name for +use as a class name - so: + + my $json_obj = JSON()->new; # returns a Cpanel::JSON::XS or JSON::PP object + +and that object can then be used normally: + + my $data_structure = $json_obj->decode($json_text); # etc. + +The use of parentheses here is optional, and only used as a hint to the reader +that this use of C<JSON> is a I<subroutine> call, I<not> a class name. + +=head2 is_bool + + $is_boolean = is_bool($scalar) + +Returns true if the passed scalar represents either C<true> or +C<false>, two constants that act like C<1> and C<0>, respectively +and are used to represent JSON C<true> and C<false> values in Perl. + +Since this is a bare sub in the various backend classes, it cannot be called as +a class method like the other interfaces; it must be called as a function, with +no invocant. It supports the representation used in all JSON backends. + +=head1 CONSTRUCTOR + +=head2 new + +With L<JSON::PP>, L<JSON::XS> and L<Cpanel::JSON::XS> you are required to call +mutators to set options, such as: + + my $json = $class->new->utf8(1)->pretty(1); + +Since this is a trifle irritating and noticeably un-perlish, we also offer: + + my $json = JSON::MaybeXS->new(utf8 => 1, pretty => 1); + +which works equivalently to the above (and in the usual tradition will accept +a hashref instead of a hash, should you so desire). + +The resulting object is blessed into the underlying backend, which offers (at +least) the methods C<encode> and C<decode>. + +=head1 BOOLEANS + +To include JSON-aware booleans (C<true>, C<false>) in your data, just do: + + use JSON::MaybeXS; + my $true = JSON()->true; + my $false = JSON()->false; + +The booleans are also available as subs or methods on JSON::MaybeXS. + + use JSON::MaybeXS (); + my $true = JSON::MaybeXS::true; + my $true = JSON::MaybeXS->true; + my $false = JSON::MaybeXS::false; + my $false = JSON::MaybeXS->false; + +=head1 CONVERTING FROM JSON::Any + +L<JSON::Any> used to be the favoured compatibility layer above the various +JSON backends, but over time has grown a lot of extra code to deal with legacy +backends (e.g. L<JSON::Syck>) that are no longer needed. This is a rough guide of translating such code: + +Change code from: + + use JSON::Any; + my $json = JSON::Any->new->objToJson($data); # or to_json($data), or Dump($data) + +to: + + use JSON::MaybeXS; + my $json = encode_json($data); + + +Change code from: + + use JSON::Any; + my $data = JSON::Any->new->jsonToObj($json); # or from_json($json), or Load($json) + +to: + + use JSON::MaybeXS; + my $json = decode_json($data); + +=head1 CAVEATS + +The C<new()> method in this module is technically a factory, not a +constructor, because the objects it returns will I<NOT> be blessed into the +C<JSON::MaybeXS> class. + +If you are using an object returned by this module as a Moo(se) attribute, +this type constraint code: + + is 'json' => ( isa => 'JSON::MaybeXS' ); + +will I<NOT> do what you expect. Instead, either rely on the C<JSON> class +constant described above, as so: + + is 'json' => ( isa => JSON::MaybeXS::JSON() ); + +Alternatively, you can use duck typing: + + use Moose::Util::TypeConstraints 'duck_type'; + is 'json' => ( isa => Object , duck_type([qw/ encode decode /])); + +=head1 INSTALLATION + +At installation time, F<Makefile.PL> will attempt to determine if you have a +working compiler available, and therefore whether you are able to run XS code. +If so, L<Cpanel::JSON::XS> will be added to the prerequisite list, unless +L<JSON::XS> is already installed at a high enough version. L<JSON::XS> may +also be upgraded to fix any incompatibility issues. + +Because running XS code is not mandatory and L<JSON::PP> (which is in perl +core) is used as a fallback backend, this module is safe to be used in a suite +of code that is fatpacked or installed into a restricted-resource environment. + +You can also prevent any XS dependencies from being installed by setting +C<PUREPERL_ONLY=1> in F<Makefile.PL> options (or in the C<PERL_MM_OPT> +environment variable), or using the C<--pp> or C<--pureperl> flags with the +L<cpanminus client|cpanm>. + +=head1 AUTHOR + +mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk> + +=head1 CONTRIBUTORS + +=over 4 + +=item * Clinton Gormley <drtech@cpan.org> + +=item * Karen Etheridge <ether@cpan.org> + +=item * Kieren Diment <diment@gmail.com> + +=back + +=head1 COPYRIGHT + +Copyright (c) 2013 the C<JSON::MaybeXS> L</AUTHOR> and L</CONTRIBUTORS> +as listed above. + +=head1 LICENSE + +This library is free software and may be distributed under the same terms +as perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP.pm new file mode 100644 index 0000000000..12bf7a95f8 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP.pm @@ -0,0 +1,671 @@ +package LWP; + +our $VERSION = '6.37'; + +require LWP::UserAgent; # this should load everything you need + +sub Version { $VERSION; } + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +LWP - The World-Wide Web library for Perl + +=head1 SYNOPSIS + + use LWP; + print "This is libwww-perl-$LWP::VERSION\n"; + + +=head1 DESCRIPTION + +The libwww-perl collection is a set of Perl modules which provides a +simple and consistent application programming interface (API) to the +World-Wide Web. The main focus of the library is to provide classes +and functions that allow you to write WWW clients. The library also +contain modules that are of more general use and even classes that +help you implement simple HTTP servers. + +Most modules in this library provide an object oriented API. The user +agent, requests sent and responses received from the WWW server are +all represented by objects. This makes a simple and powerful +interface to these services. The interface is easy to extend +and customize for your own needs. + +The main features of the library are: + +=over 3 + +=item * + +Contains various reusable components (modules) that can be +used separately or together. + +=item * + +Provides an object oriented model of HTTP-style communication. Within +this framework we currently support access to C<http>, C<https>, C<gopher>, +C<ftp>, C<news>, C<file>, and C<mailto> resources. + +=item * + +Provides a full object oriented interface or +a very simple procedural interface. + +=item * + +Supports the basic and digest authorization schemes. + +=item * + +Supports transparent redirect handling. + +=item * + +Supports access through proxy servers. + +=item * + +Provides parser for F<robots.txt> files and a framework for constructing robots. + +=item * + +Supports parsing of HTML forms. + +=item * + +Implements HTTP content negotiation algorithm that can +be used both in protocol modules and in server scripts (like CGI +scripts). + +=item * + +Supports HTTP cookies. + +=item * + +Some simple command line clients, for instance C<lwp-request> and C<lwp-download>. + +=back + + +=head1 HTTP STYLE COMMUNICATION + + +The libwww-perl library is based on HTTP style communication. This +section tries to describe what that means. + +Let us start with this quote from the HTTP specification document +<URL:http://www.w3.org/Protocols/>: + +=over 3 + +=item * + +The HTTP protocol is based on a request/response paradigm. A client +establishes a connection with a server and sends a request to the +server in the form of a request method, URI, and protocol version, +followed by a MIME-like message containing request modifiers, client +information, and possible body content. The server responds with a +status line, including the message's protocol version and a success or +error code, followed by a MIME-like message containing server +information, entity meta-information, and possible body content. + +=back + +What this means to libwww-perl is that communication always take place +through these steps: First a I<request> object is created and +configured. This object is then passed to a server and we get a +I<response> object in return that we can examine. A request is always +independent of any previous requests, i.e. the service is stateless. +The same simple model is used for any kind of service we want to +access. + +For example, if we want to fetch a document from a remote file server, +then we send it a request that contains a name for that document and +the response will contain the document itself. If we access a search +engine, then the content of the request will contain the query +parameters and the response will contain the query result. If we want +to send a mail message to somebody then we send a request object which +contains our message to the mail server and the response object will +contain an acknowledgment that tells us that the message has been +accepted and will be forwarded to the recipient(s). + +It is as simple as that! + + +=head2 The Request Object + +The libwww-perl request object has the class name L<HTTP::Request>. +The fact that the class name uses C<HTTP::> as a +prefix only implies that we use the HTTP model of communication. It +does not limit the kind of services we can try to pass this I<request> +to. For instance, we will send L<HTTP::Request>s both to ftp and +gopher servers, as well as to the local file system. + +The main attributes of the request objects are: + +=over 3 + +=item * + +B<method> is a short string that tells what kind of +request this is. The most common methods are B<GET>, B<PUT>, +B<POST> and B<HEAD>. + +=item * + +B<uri> is a string denoting the protocol, server and +the name of the "document" we want to access. The B<uri> might +also encode various other parameters. + +=item * + +B<headers> contains additional information about the +request and can also used to describe the content. The headers +are a set of keyword/value pairs. + +=item * + +B<content> is an arbitrary amount of data. + +=back + +=head2 The Response Object + +The libwww-perl response object has the class name L<HTTP::Response>. +The main attributes of objects of this class are: + +=over 3 + +=item * + +B<code> is a numerical value that indicates the overall +outcome of the request. + +=item * + +B<message> is a short, human readable string that +corresponds to the I<code>. + +=item * + +B<headers> contains additional information about the +response and describe the content. + +=item * + +B<content> is an arbitrary amount of data. + +=back + +Since we don't want to handle all possible I<code> values directly in +our programs, a libwww-perl response object has methods that can be +used to query what kind of response this is. The most commonly used +response classification methods are: + +=over 3 + +=item is_success() + +The request was successfully received, understood or accepted. + +=item is_error() + +The request failed. The server or the resource might not be +available, access to the resource might be denied or other things might +have failed for some reason. + +=back + +=head2 The User Agent + +Let us assume that we have created a I<request> object. What do we +actually do with it in order to receive a I<response>? + +The answer is that you pass it to a I<user agent> object and this +object takes care of all the things that need to be done +(like low-level communication and error handling) and returns +a I<response> object. The user agent represents your +application on the network and provides you with an interface that +can accept I<requests> and return I<responses>. + +The user agent is an interface layer between +your application code and the network. Through this interface you are +able to access the various servers on the network. + +The class name for the user agent is L<LWP::UserAgent>. Every +libwww-perl application that wants to communicate should create at +least one object of this class. The main method provided by this +object is request(). This method takes an L<HTTP::Request> object as +argument and (eventually) returns a L<HTTP::Response> object. + +The user agent has many other attributes that let you +configure how it will interact with the network and with your +application. + +=over 3 + +=item * + +B<timeout> specifies how much time we give remote servers to +respond before the library disconnects and creates an +internal I<timeout> response. + +=item * + +B<agent> specifies the name that your application uses when it +presents itself on the network. + +=item * + +B<from> can be set to the e-mail address of the person +responsible for running the application. If this is set, then the +address will be sent to the servers with every request. + +=item * + +B<parse_head> specifies whether we should initialize response +headers from the E<lt>head> section of HTML documents. + +=item * + +B<proxy> and B<no_proxy> specify if and when to go through +a proxy server. <URL:http://www.w3.org/History/1994/WWW/Proxies/> + +=item * + +B<credentials> provides a way to set up user names and +passwords needed to access certain services. + +=back + +Many applications want even more control over how they interact +with the network and they get this by sub-classing +L<LWP::UserAgent>. The library includes a +sub-class, L<LWP::RobotUA>, for robot applications. + +=head2 An Example + +This example shows how the user agent, a request and a response are +represented in actual perl code: + + # Create a user agent object + use LWP::UserAgent; + my $ua = LWP::UserAgent->new; + $ua->agent("MyApp/0.1 "); + + # Create a request + my $req = HTTP::Request->new(POST => 'http://search.cpan.org/search'); + $req->content_type('application/x-www-form-urlencoded'); + $req->content('query=libwww-perl&mode=dist'); + + # Pass request to the user agent and get a response back + my $res = $ua->request($req); + + # Check the outcome of the response + if ($res->is_success) { + print $res->content; + } + else { + print $res->status_line, "\n"; + } + +The $ua is created once when the application starts up. New request +objects should normally created for each request sent. + + +=head1 NETWORK SUPPORT + +This section discusses the various protocol schemes and +the HTTP style methods that headers may be used for each. + +For all requests, a "User-Agent" header is added and initialized from +the $ua->agent attribute before the request is handed to the network +layer. In the same way, a "From" header is initialized from the +$ua->from attribute. + +For all responses, the library adds a header called "Client-Date". +This header holds the time when the response was received by +your application. The format and semantics of the header are the +same as the server created "Date" header. You may also encounter other +"Client-XXX" headers. They are all generated by the library +internally and are not received from the servers. + +=head2 HTTP Requests + +HTTP requests are just handed off to an HTTP server and it +decides what happens. Few servers implement methods beside the usual +"GET", "HEAD", "POST" and "PUT", but CGI-scripts may implement +any method they like. + +If the server is not available then the library will generate an +internal error response. + +The library automatically adds a "Host" and a "Content-Length" header +to the HTTP request before it is sent over the network. + +For a GET request you might want to add a "If-Modified-Since" or +"If-None-Match" header to make the request conditional. + +For a POST request you should add the "Content-Type" header. When you +try to emulate HTML E<lt>FORM> handling you should usually let the value +of the "Content-Type" header be "application/x-www-form-urlencoded". +See L<lwpcook> for examples of this. + +The libwww-perl HTTP implementation currently support the HTTP/1.1 +and HTTP/1.0 protocol. + +The library allows you to access proxy server through HTTP. This +means that you can set up the library to forward all types of request +through the HTTP protocol module. See L<LWP::UserAgent> for +documentation of this. + + +=head2 HTTPS Requests + +HTTPS requests are HTTP requests over an encrypted network connection +using the SSL protocol developed by Netscape. Everything about HTTP +requests above also apply to HTTPS requests. In addition the library +will add the headers "Client-SSL-Cipher", "Client-SSL-Cert-Subject" and +"Client-SSL-Cert-Issuer" to the response. These headers denote the +encryption method used and the name of the server owner. + +The request can contain the header "If-SSL-Cert-Subject" in order to +make the request conditional on the content of the server certificate. +If the certificate subject does not match, no request is sent to the +server and an internally generated error response is returned. The +value of the "If-SSL-Cert-Subject" header is interpreted as a Perl +regular expression. + + +=head2 FTP Requests + +The library currently supports GET, HEAD and PUT requests. GET +retrieves a file or a directory listing from an FTP server. PUT +stores a file on a ftp server. + +You can specify a ftp account for servers that want this in addition +to user name and password. This is specified by including an "Account" +header in the request. + +User name/password can be specified using basic authorization or be +encoded in the URL. Failed logins return an UNAUTHORIZED response with +"WWW-Authenticate: Basic" and can be treated like basic authorization +for HTTP. + +The library supports ftp ASCII transfer mode by specifying the "type=a" +parameter in the URL. It also supports transfer of ranges for FTP transfers +using the "Range" header. + +Directory listings are by default returned unprocessed (as returned +from the ftp server) with the content media type reported to be +"text/ftp-dir-listing". The L<File::Listing> module provides methods +for parsing of these directory listing. + +The ftp module is also able to convert directory listings to HTML and +this can be requested via the standard HTTP content negotiation +mechanisms (add an "Accept: text/html" header in the request if you +want this). + +For normal file retrievals, the "Content-Type" is guessed based on the +file name suffix. See L<LWP::MediaTypes>. + +The "If-Modified-Since" request header works for servers that implement +the C<MDTM> command. It will probably not work for directory listings though. + +Example: + + $req = HTTP::Request->new(GET => 'ftp://me:passwd@ftp.some.where.com/'); + $req->header(Accept => "text/html, */*;q=0.1"); + +=head2 News Requests + +Access to the USENET News system is implemented through the NNTP +protocol. The name of the news server is obtained from the +NNTP_SERVER environment variable and defaults to "news". It is not +possible to specify the hostname of the NNTP server in news: URLs. + +The library supports GET and HEAD to retrieve news articles through the +NNTP protocol. You can also post articles to newsgroups by using +(surprise!) the POST method. + +GET on newsgroups is not implemented yet. + +Examples: + + $req = HTTP::Request->new(GET => 'news:abc1234@a.sn.no'); + + $req = HTTP::Request->new(POST => 'news:comp.lang.perl.test'); + $req->header(Subject => 'This is a test', + From => 'me@some.where.org'); + $req->content(<<EOT); + This is the content of the message that we are sending to + the world. + EOT + + +=head2 Gopher Request + +The library supports the GET and HEAD methods for gopher requests. All +request header values are ignored. HEAD cheats and returns a +response without even talking to server. + +Gopher menus are always converted to HTML. + +The response "Content-Type" is generated from the document type +encoded (as the first letter) in the request URL path itself. + +Example: + + $req = HTTP::Request->new(GET => 'gopher://gopher.sn.no/'); + + + +=head2 File Request + +The library supports GET and HEAD methods for file requests. The +"If-Modified-Since" header is supported. All other headers are +ignored. The I<host> component of the file URL must be empty or set +to "localhost". Any other I<host> value will be treated as an error. + +Directories are always converted to an HTML document. For normal +files, the "Content-Type" and "Content-Encoding" in the response are +guessed based on the file suffix. + +Example: + + $req = HTTP::Request->new(GET => 'file:/etc/passwd'); + + +=head2 Mailto Request + +You can send (aka "POST") mail messages using the library. All +headers specified for the request are passed on to the mail system. +The "To" header is initialized from the mail address in the URL. + +Example: + + $req = HTTP::Request->new(POST => 'mailto:libwww@perl.org'); + $req->header(Subject => "subscribe"); + $req->content("Please subscribe me to the libwww-perl mailing list!\n"); + +=head2 CPAN Requests + +URLs with scheme C<cpan:> are redirected to a suitable CPAN +mirror. If you have your own local mirror of CPAN you might tell LWP +to use it for C<cpan:> URLs by an assignment like this: + + $LWP::Protocol::cpan::CPAN = "file:/local/CPAN/"; + +Suitable CPAN mirrors are also picked up from the configuration for +the CPAN.pm, so if you have used that module a suitable mirror should +be picked automatically. If neither of these apply, then a redirect +to the generic CPAN http location is issued. + +Example request to download the newest perl: + + $req = HTTP::Request->new(GET => "cpan:src/latest.tar.gz"); + + +=head1 OVERVIEW OF CLASSES AND PACKAGES + +This table should give you a quick overview of the classes provided by the +library. Indentation shows class inheritance. + + LWP::MemberMixin -- Access to member variables of Perl5 classes + LWP::UserAgent -- WWW user agent class + LWP::RobotUA -- When developing a robot applications + LWP::Protocol -- Interface to various protocol schemes + LWP::Protocol::http -- http:// access + LWP::Protocol::file -- file:// access + LWP::Protocol::ftp -- ftp:// access + ... + + LWP::Authen::Basic -- Handle 401 and 407 responses + LWP::Authen::Digest + + HTTP::Headers -- MIME/RFC822 style header (used by HTTP::Message) + HTTP::Message -- HTTP style message + HTTP::Request -- HTTP request + HTTP::Response -- HTTP response + HTTP::Daemon -- A HTTP server class + + WWW::RobotRules -- Parse robots.txt files + WWW::RobotRules::AnyDBM_File -- Persistent RobotRules + + Net::HTTP -- Low level HTTP client + +The following modules provide various functions and definitions. + + LWP -- This file. Library version number and documentation. + LWP::MediaTypes -- MIME types configuration (text/html etc.) + LWP::Simple -- Simplified procedural interface for common functions + HTTP::Status -- HTTP status code (200 OK etc) + HTTP::Date -- Date parsing module for HTTP date formats + HTTP::Negotiate -- HTTP content negotiation calculation + File::Listing -- Parse directory listings + HTML::Form -- Processing for <form>s in HTML documents + + +=head1 MORE DOCUMENTATION + +All modules contain detailed information on the interfaces they +provide. The L<lwpcook> manpage is the libwww-perl cookbook that contain +examples of typical usage of the library. You might want to take a +look at how the scripts L<lwp-request>, L<lwp-download>, L<lwp-dump> +and L<lwp-mirror> are implemented. + +=head1 ENVIRONMENT + +The following environment variables are used by LWP: + +=over + +=item HOME + +The L<LWP::MediaTypes> functions will look for the F<.media.types> and +F<.mime.types> files relative to you home directory. + +=item http_proxy + +=item ftp_proxy + +=item xxx_proxy + +=item no_proxy + +These environment variables can be set to enable communication through +a proxy server. See the description of the C<env_proxy> method in +L<LWP::UserAgent>. + +=item PERL_LWP_ENV_PROXY + +If set to a TRUE value, then the L<LWP::UserAgent> will by default call +C<env_proxy> during initialization. This makes LWP honor the proxy variables +described above. + +=item PERL_LWP_SSL_VERIFY_HOSTNAME + +The default C<verify_hostname> setting for L<LWP::UserAgent>. If +not set the default will be 1. Set it as 0 to disable hostname +verification (the default prior to libwww-perl 5.840. + +=item PERL_LWP_SSL_CA_FILE + +=item PERL_LWP_SSL_CA_PATH + +The file and/or directory +where the trusted Certificate Authority certificates +is located. See L<LWP::UserAgent> for details. + +=item PERL_HTTP_URI_CLASS + +Used to decide what URI objects to instantiate. The default is L<URI>. +You might want to set it to L<URI::URL> for compatibility with old times. + +=back + +=head1 AUTHORS + +LWP was made possible by contributions from Adam Newby, Albert +Dvornik, Alexandre Duret-Lutz, Andreas Gustafsson, Andreas König, +Andrew Pimlott, Andy Lester, Ben Coleman, Benjamin Low, Ben Low, Ben +Tilly, Blair Zajac, Bob Dalgleish, BooK, Brad Hughes, Brian +J. Murrell, Brian McCauley, Charles C. Fu, Charles Lane, Chris Nandor, +Christian Gilmore, Chris W. Unger, Craig Macdonald, Dale Couch, Dan +Kubb, Dave Dunkin, Dave W. Smith, David Coppit, David Dick, David +D. Kilzer, Doug MacEachern, Edward Avis, erik, Gary Shea, Gisle Aas, +Graham Barr, Gurusamy Sarathy, Hans de Graaff, Harald Joerg, Harry +Bochner, Hugo, Ilya Zakharevich, INOUE Yoshinari, Ivan Panchenko, Jack +Shirazi, James Tillman, Jan Dubois, Jared Rhine, Jim Stern, Joao +Lopes, John Klar, Johnny Lee, Josh Kronengold, Josh Rai, Joshua +Chamas, Joshua Hoblitt, Kartik Subbarao, Keiichiro Nagano, Ken +Williams, KONISHI Katsuhiro, Lee T Lindley, Liam Quinn, Marc Hedlund, +Marc Langheinrich, Mark D. Anderson, Marko Asplund, Mark Stosberg, +Markus B Krüger, Markus Laker, Martijn Koster, Martin Thurn, Matthew +Eldridge, Matthew.van.Eerde, Matt Sergeant, Michael A. Chase, Michael +Quaranta, Michael Thompson, Mike Schilli, Moshe Kaminsky, Nathan +Torkington, Nicolai Langfeldt, Norton Allen, Olly Betts, Paul +J. Schinder, peterm, Philip Guenther, Daniel Buenzli, Pon Hwa Lin, +Radoslaw Zielinski, Radu Greab, Randal L. Schwartz, Richard Chen, +Robin Barker, Roy Fielding, Sander van Zoest, Sean M. Burke, +shildreth, Slaven Rezic, Steve A Fink, Steve Hay, Steven Butler, +Steve_Kilbane, Takanori Ugai, Thomas Lotterer, Tim Bunce, Tom Hughes, +Tony Finch, Ville Skyttä, Ward Vandewege, William York, Yale Huang, +and Yitzchak Scott-Thoennes. + +LWP owes a lot in motivation, design, and code, to the libwww-perl +library for Perl4 by Roy Fielding, which included work from Alberto +Accomazzi, James Casey, Brooks Cutter, Martijn Koster, Oscar +Nierstrasz, Mel Melchner, Gertjan van Oosten, Jared Rhine, Jack +Shirazi, Gene Spafford, Marc VanHeyningen, Steven E. Brenner, Marion +Hakanson, Waldemar Kebsch, Tony Sanders, and Larry Wall; see the +libwww-perl-0.40 library for details. + +=head1 COPYRIGHT + + Copyright 1995-2009, Gisle Aas + Copyright 1995, Martijn Koster + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 AVAILABILITY + +The latest version of this library is likely to be available from CPAN +as well as: + + http://github.com/libwww-perl/libwww-perl + +The best place to discuss this code is on the <libwww@perl.org> +mailing list. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Authen/Basic.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Authen/Basic.pm new file mode 100644 index 0000000000..d33e4af2e4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Authen/Basic.pm @@ -0,0 +1,68 @@ +package LWP::Authen::Basic; + +use strict; + +our $VERSION = '6.37'; + +require MIME::Base64; + +sub auth_header { + my($class, $user, $pass) = @_; + return "Basic " . MIME::Base64::encode("$user:$pass", ""); +} + +sub authenticate +{ + my($class, $ua, $proxy, $auth_param, $response, + $request, $arg, $size) = @_; + + my $realm = $auth_param->{realm} || ""; + my $url = $proxy ? $request->{proxy} : $request->uri_canonical; + return $response unless $url; + my $host_port = $url->host_port; + my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization"; + + my @m = $proxy ? (m_proxy => $url) : (m_host_port => $host_port); + push(@m, realm => $realm); + + my $h = $ua->get_my_handler("request_prepare", @m, sub { + $_[0]{callback} = sub { + my($req, $ua, $h) = @_; + my($user, $pass) = $ua->credentials($host_port, $h->{realm}); + if (defined $user) { + my $auth_value = $class->auth_header($user, $pass, $req, $ua, $h); + $req->header($auth_header => $auth_value); + } + }; + }); + $h->{auth_param} = $auth_param; + + if (!$proxy && !$request->header($auth_header) && $ua->credentials($host_port, $realm)) { + # we can make sure this handler applies and retry + add_path($h, $url->path); + return $ua->request($request->clone, $arg, $size, $response); + } + + my($user, $pass) = $ua->get_basic_credentials($realm, $url, $proxy); + unless (defined $user and defined $pass) { + $ua->set_my_handler("request_prepare", undef, @m); # delete handler + return $response; + } + + # check that the password has changed + my ($olduser, $oldpass) = $ua->credentials($host_port, $realm); + return $response if (defined $olduser and defined $oldpass and + $user eq $olduser and $pass eq $oldpass); + + $ua->credentials($host_port, $realm, $user, $pass); + add_path($h, $url->path) unless $proxy; + return $ua->request($request->clone, $arg, $size, $response); +} + +sub add_path { + my($h, $path) = @_; + $path =~ s,[^/]+\z,,; + push(@{$h->{m_path_prefix}}, $path); +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Authen/Digest.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Authen/Digest.pm new file mode 100644 index 0000000000..2e11ac638b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Authen/Digest.pm @@ -0,0 +1,77 @@ +package LWP::Authen::Digest; + +use strict; +use base 'LWP::Authen::Basic'; + +our $VERSION = '6.37'; + +require Digest::MD5; + +sub auth_header { + my($class, $user, $pass, $request, $ua, $h) = @_; + + my $auth_param = $h->{auth_param}; + + my $nc = sprintf "%08X", ++$ua->{authen_md5_nonce_count}{$auth_param->{nonce}}; + my $cnonce = sprintf "%8x", time; + + my $uri = $request->uri->path_query; + $uri = "/" unless length $uri; + + my $md5 = Digest::MD5->new; + + my(@digest); + $md5->add(join(":", $user, $auth_param->{realm}, $pass)); + push(@digest, $md5->hexdigest); + $md5->reset; + + push(@digest, $auth_param->{nonce}); + + if ($auth_param->{qop}) { + push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop}); + } + + $md5->add(join(":", $request->method, $uri)); + push(@digest, $md5->hexdigest); + $md5->reset; + + $md5->add(join(":", @digest)); + my($digest) = $md5->hexdigest; + $md5->reset; + + my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque); + @resp{qw(username uri response algorithm)} = ($user, $uri, $digest, "MD5"); + + if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) { + @resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc); + } + + my(@order) = qw(username realm qop algorithm uri nonce nc cnonce response); + if($request->method =~ /^(?:POST|PUT)$/) { + $md5->add($request->content); + my $content = $md5->hexdigest; + $md5->reset; + $md5->add(join(":", @digest[0..1], $content)); + $md5->reset; + $resp{"message-digest"} = $md5->hexdigest; + push(@order, "message-digest"); + } + push(@order, "opaque"); + my @pairs; + for (@order) { + next unless defined $resp{$_}; + + # RFC2617 says that qop-value and nc-value should be unquoted. + if ( $_ eq 'qop' || $_ eq 'nc' ) { + push(@pairs, "$_=" . $resp{$_}); + } + else { + push(@pairs, "$_=" . qq("$resp{$_}")); + } + } + + my $auth_value = "Digest " . join(", ", @pairs); + return $auth_value; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Authen/Ntlm.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Authen/Ntlm.pm new file mode 100644 index 0000000000..b4eaad1eaa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Authen/Ntlm.pm @@ -0,0 +1,183 @@ +package LWP::Authen::Ntlm; + +use strict; + +our $VERSION = '6.37'; + +use Authen::NTLM "1.02"; +use MIME::Base64 "2.12"; + +sub authenticate { + my($class, $ua, $proxy, $auth_param, $response, + $request, $arg, $size) = @_; + + my($user, $pass) = $ua->get_basic_credentials($auth_param->{realm}, + $request->uri, $proxy); + + unless(defined $user and defined $pass) { + return $response; + } + + if (!$ua->conn_cache()) { + warn "The keep_alive option must be enabled for NTLM authentication to work. NTLM authentication aborted.\n"; + return $response; + } + + my($domain, $username) = split(/\\/, $user); + + ntlm_domain($domain); + ntlm_user($username); + ntlm_password($pass); + + my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization"; + + # my ($challenge) = $response->header('WWW-Authenticate'); + my $challenge; + foreach ($response->header('WWW-Authenticate')) { + last if /^NTLM/ && ($challenge=$_); + } + + if ($challenge eq 'NTLM') { + # First phase, send handshake + my $auth_value = "NTLM " . ntlm(); + ntlm_reset(); + + # Need to check this isn't a repeated fail! + my $r = $response; + my $retry_count = 0; + while ($r) { + my $auth = $r->request->header($auth_header); + ++$retry_count if ($auth && $auth eq $auth_value); + if ($retry_count > 2) { + # here we know this failed before + $response->header("Client-Warning" => + "Credentials for '$user' failed before"); + return $response; + } + $r = $r->previous; + } + + my $referral = $request->clone; + $referral->header($auth_header => $auth_value); + return $ua->request($referral, $arg, $size, $response); + } + + else { + # Second phase, use the response challenge (unless non-401 code + # was returned, in which case, we just send back the response + # object, as is + my $auth_value; + if ($response->code ne '401') { + return $response; + } + else { + my $challenge; + foreach ($response->header('WWW-Authenticate')) { + last if /^NTLM/ && ($challenge=$_); + } + $challenge =~ s/^NTLM //; + ntlm(); + $auth_value = "NTLM " . ntlm($challenge); + ntlm_reset(); + } + + my $referral = $request->clone; + $referral->header($auth_header => $auth_value); + my $response2 = $ua->request($referral, $arg, $size, $response); + return $response2; + } +} + +1; +__END__ + +=pod + +=head1 NAME + +LWP::Authen::Ntlm - Library for enabling NTLM authentication (Microsoft) in LWP + +=head1 SYNOPSIS + + use LWP::UserAgent; + use HTTP::Request::Common; + my $url = 'http://www.company.com/protected_page.html'; + + # Set up the ntlm client and then the base64 encoded ntlm handshake message + my $ua = LWP::UserAgent->new(keep_alive=>1); + $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword'); + + $request = GET $url; + print "--Performing request now...-----------\n"; + $response = $ua->request($request); + print "--Done with request-------------------\n"; + + if ($response->is_success) {print "It worked!->" . $response->code . "\n"} + else {print "It didn't work!->" . $response->code . "\n"} + +=head1 DESCRIPTION + +L<LWP::Authen::Ntlm> allows LWP to authenticate against servers that are using the +NTLM authentication scheme popularized by Microsoft. This type of authentication is +common on intranets of Microsoft-centric organizations. + +The module takes advantage of the Authen::NTLM module by Mark Bush. Since there +is also another Authen::NTLM module available from CPAN by Yee Man Chan with an +entirely different interface, it is necessary to ensure that you have the correct +NTLM module. + +In addition, there have been problems with incompatibilities between different +versions of Mime::Base64, which Bush's Authen::NTLM makes use of. Therefore, it is +necessary to ensure that your Mime::Base64 module supports exporting of the +encode_base64 and decode_base64 functions. + +=head1 USAGE + +The module is used indirectly through LWP, rather than including it directly in your +code. The LWP system will invoke the NTLM authentication when it encounters the +authentication scheme while attempting to retrieve a URL from a server. In order +for the NTLM authentication to work, you must have a few things set up in your +code prior to attempting to retrieve the URL: + +=over 4 + +=item * + +Enable persistent HTTP connections + +To do this, pass the "keep_alive=>1" option to the LWP::UserAgent when creating it, like this: + + my $ua = LWP::UserAgent->new(keep_alive=>1); + +=item * + +Set the credentials on the UserAgent object + +The credentials must be set like this: + + $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword'); + +Note that you cannot use the HTTP::Request object's authorization_basic() method to set +the credentials. Note, too, that the 'www.company.com:80' portion only sets credentials +on the specified port AND it is case-sensitive (this is due to the way LWP is coded, and +has nothing to do with LWP::Authen::Ntlm) + +=back + +=head1 AVAILABILITY + +General queries regarding LWP should be made to the LWP Mailing List. + +Questions specific to LWP::Authen::Ntlm can be forwarded to jtillman@bigfoot.com + +=head1 COPYRIGHT + +Copyright (c) 2002 James Tillman. All rights reserved. This +program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<LWP>, L<LWP::UserAgent>, L<lwpcook>. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/ConnCache.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/ConnCache.pm new file mode 100644 index 0000000000..d4cfc66e26 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/ConnCache.pm @@ -0,0 +1,350 @@ +package LWP::ConnCache; + +use strict; + +our $VERSION = '6.37'; +our $DEBUG; + +sub new { + my($class, %cnf) = @_; + + my $total_capacity = 1; + if (exists $cnf{total_capacity}) { + $total_capacity = delete $cnf{total_capacity}; + } + if (%cnf && $^W) { + require Carp; + Carp::carp("Unrecognised options: @{[sort keys %cnf]}") + } + my $self = bless { cc_conns => [] }, $class; + $self->total_capacity($total_capacity); + $self; +} + + +sub deposit { + my($self, $type, $key, $conn) = @_; + push(@{$self->{cc_conns}}, [$conn, $type, $key, time]); + $self->enforce_limits($type); + return; +} + + +sub withdraw { + my($self, $type, $key) = @_; + my $conns = $self->{cc_conns}; + for my $i (0 .. @$conns - 1) { + my $c = $conns->[$i]; + next unless $c->[1] eq $type && $c->[2] eq $key; + splice(@$conns, $i, 1); # remove it + return $c->[0]; + } + return undef; +} + + +sub total_capacity { + my $self = shift; + my $old = $self->{cc_limit_total}; + if (@_) { + $self->{cc_limit_total} = shift; + $self->enforce_limits; + } + $old; +} + + +sub capacity { + my $self = shift; + my $type = shift; + my $old = $self->{cc_limit}{$type}; + if (@_) { + $self->{cc_limit}{$type} = shift; + $self->enforce_limits($type); + } + $old; +} + + +sub enforce_limits { + my($self, $type) = @_; + my $conns = $self->{cc_conns}; + + my @types = $type ? ($type) : ($self->get_types); + for $type (@types) { + next unless $self->{cc_limit}; + my $limit = $self->{cc_limit}{$type}; + next unless defined $limit; + for my $i (reverse 0 .. @$conns - 1) { + next unless $conns->[$i][1] eq $type; + if (--$limit < 0) { + $self->dropping(splice(@$conns, $i, 1), "$type capacity exceeded"); + } + } + } + + if (defined(my $total = $self->{cc_limit_total})) { + while (@$conns > $total) { + $self->dropping(shift(@$conns), "Total capacity exceeded"); + } + } +} + + +sub dropping { + my($self, $c, $reason) = @_; + print "DROPPING @$c [$reason]\n" if $DEBUG; +} + + +sub drop { + my($self, $checker, $reason) = @_; + if (ref($checker) ne "CODE") { + # make it so + if (!defined $checker) { + $checker = sub { 1 }; # drop all of them + } + elsif (_looks_like_number($checker)) { + my $age_limit = $checker; + my $time_limit = time - $age_limit; + $reason ||= "older than $age_limit"; + $checker = sub { $_[3] < $time_limit }; + } + else { + my $type = $checker; + $reason ||= "drop $type"; + $checker = sub { $_[1] eq $type }; # match on type + } + } + $reason ||= "drop"; + + local $SIG{__DIE__}; # don't interfere with eval below + local $@; + my @c; + for (@{$self->{cc_conns}}) { + my $drop; + eval { + if (&$checker(@$_)) { + $self->dropping($_, $reason); + $drop++; + } + }; + push(@c, $_) unless $drop; + } + @{$self->{cc_conns}} = @c; +} + + +sub prune { + my $self = shift; + $self->drop(sub { !shift->ping }, "ping"); +} + + +sub get_types { + my $self = shift; + my %t; + $t{$_->[1]}++ for @{$self->{cc_conns}}; + return keys %t; +} + + +sub get_connections { + my($self, $type) = @_; + my @c; + for (@{$self->{cc_conns}}) { + push(@c, $_->[0]) if !$type || ($type && $type eq $_->[1]); + } + @c; +} + + +sub _looks_like_number { + $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; +} + +1; + + +__END__ + +=pod + +=head1 NAME + +LWP::ConnCache - Connection cache manager + +=head1 NOTE + +This module is experimental. Details of its interface is likely to +change in the future. + +=head1 SYNOPSIS + + use LWP::ConnCache; + my $cache = LWP::ConnCache->new; + $cache->deposit($type, $key, $sock); + $sock = $cache->withdraw($type, $key); + +=head1 DESCRIPTION + +The C<LWP::ConnCache> class is the standard connection cache manager +for L<LWP::UserAgent>. + +=head1 METHODS + +The following basic methods are provided: + +=head2 new + + my $cache = LWP::ConnCache->new( %options ) + +This method constructs a new L<LWP::ConnCache> object. The only +option currently accepted is C<total_capacity>. If specified it +initialize the L<LWP::ConnCache/total_capacity> option. It defaults to C<1>. + +=head2 total_capacity + + my $cap = $cache->total_capacity; + $cache->total_capacity(0); # drop all immediately + $cache->total_capacity(undef); # no limit + $cache->total_capacity($number); + +Get/sets the number of connection that will be cached. Connections +will start to be dropped when this limit is reached. If set to C<0>, +then all connections are immediately dropped. If set to C<undef>, +then there is no limit. + +=head2 capacity + + my $http_capacity = $cache->capacity('http'); + $cache->capacity('http', 2 ); + +Get/set a limit for the number of connections of the specified type +that can be cached. The first parameter is a short string like +"http" or "ftp". + +=head2 drop + + $cache->drop(); # Drop ALL connections + # which is just a synonym for: + $cache->drop(sub{1}); # Drop ALL connections + # drop all connections older than 22 seconds and add a reason for it! + $cache->drop(22, "Older than 22 secs dropped"); + # which is just a synonym for: + $cache->drop(sub { + my ($conn, $type, $key, $deposit_time) = @_; + if ($deposit_time < 22) { + # true values drop the connection + return 1; + } + # false values don't drop the connection + return 0; + }, "Older than 22 secs dropped" ); + +Drop connections by some criteria. The $checker argument is a +subroutine that is called for each connection. If the routine returns +a TRUE value then the connection is dropped. The routine is called +with ($conn, $type, $key, $deposit_time) as arguments. + +Shortcuts: If the $checker argument is absent (or C<undef>) all cached +connections are dropped. If the $checker is a number then all +connections untouched that the given number of seconds or more are +dropped. If $checker is a string then all connections of the given +type are dropped. + +The C<reason> is passed on to the L<LWP::ConnCache/dropped> method. + +=head2 prune + + $cache->prune(); + +Calling this method will drop all connections that are dead. This is +tested by calling the L<LWP::ConnCache/ping> method on the connections. If +the L<LWP::ConnCache/ping> method exists and returns a false value, then the +connection is dropped. + +=head2 get_types + + my @types = $cache->get_types(); + +This returns all the C<type> fields used for the currently cached +connections. + +=head2 get_connections + + my @conns = $cache->get_connections(); # all connections + my @conns = $cache->get_connections('http'); # connections for http + +This returns all connection objects of the specified type. If no type +is specified then all connections are returned. In scalar context the +number of cached connections of the specified type is returned. + +=head1 PROTOCOL METHODS + +The following methods are called by low-level protocol modules to +try to save away connections and to get them back. + +=head2 deposit + + $cache->deposit($type, $key, $conn); + +This method adds a new connection to the cache. As a result, other +already cached connections might be dropped. Multiple connections with +the same type/key might be added. + +=head2 withdraw + + my $conn = $cache->withdraw($type, $key); + +This method tries to fetch back a connection that was previously +deposited. If no cached connection with the specified $type/$key is +found, then C<undef> is returned. There is not guarantee that a +deposited connection can be withdrawn, as the cache manger is free to +drop connections at any time. + +=head1 INTERNAL METHODS + +The following methods are called internally. Subclasses might want to +override them. + +=head2 enforce_limits + + $conn->enforce_limits([$type]) + +This method is called with after a new connection is added (deposited) +in the cache or capacity limits are adjusted. The default +implementation drops connections until the specified capacity limits +are not exceeded. + +=head2 dropping + + $conn->dropping($conn_record, $reason) + +This method is called when a connection is dropped. The record +belonging to the dropped connection is passed as the first argument +and a string describing the reason for the drop is passed as the +second argument. The default implementation makes some noise if the +C<$LWP::ConnCache::DEBUG> variable is set and nothing more. + +=head1 SUBCLASSING + +For specialized cache policy it makes sense to subclass +C<LWP::ConnCache> and perhaps override the L<LWP::ConnCache/deposit>, +L<LWP::ConnCache/enforce_limits>, and L<LWP::ConnCache/dropping> methods. + +The object itself is a hash. Keys prefixed with C<cc_> are reserved +for the base class. + +=head1 SEE ALSO + +L<LWP::UserAgent> + +=head1 COPYRIGHT + +Copyright 2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Debug.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Debug.pm new file mode 100644 index 0000000000..c93a80ade3 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Debug.pm @@ -0,0 +1,112 @@ +package LWP::Debug; # legacy + +our $VERSION = '6.37'; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(level trace debug conns); + +use Carp (); + +my @levels = qw(trace debug conns); +our %current_level = (); + +sub import { + my $pack = shift; + my $callpkg = caller(0); + my @symbols = (); + my @levels = (); + for (@_) { + if (/^[-+]/) { + push(@levels, $_); + } + else { + push(@symbols, $_); + } + } + Exporter::export($pack, $callpkg, @symbols); + level(@levels); +} + +sub level { + for (@_) { + if ($_ eq '+') { # all on + # switch on all levels + %current_level = map { $_ => 1 } @levels; + } + elsif ($_ eq '-') { # all off + %current_level = (); + } + elsif (/^([-+])(\w+)$/) { + $current_level{$2} = $1 eq '+'; + } + else { + Carp::croak("Illegal level format $_"); + } + } +} + +sub trace { _log(@_) if $current_level{'trace'}; } +sub debug { _log(@_) if $current_level{'debug'}; } +sub conns { _log(@_) if $current_level{'conns'}; } + +sub _log { + my $msg = shift; + $msg .= "\n" unless $msg =~ /\n$/; # ensure trailing "\n" + + my ($package, $filename, $line, $sub) = caller(2); + print STDERR "$sub: $msg"; +} + +1; + +__END__ + +=pod + +=head1 NAME + +LWP::Debug - deprecated + +=head1 DESCRIPTION + +This module has been deprecated. Please see L<LWP::ConsoleLogger> for your +debugging needs. + +LWP::Debug is used to provide tracing facilities, but these are not used +by LWP any more. The code in this module is kept around +(undocumented) so that 3rd party code that happens to use the old +interfaces continue to run. + +One useful feature that LWP::Debug provided (in an imprecise and +troublesome way) was network traffic monitoring. The following +section provides some hints about recommended replacements. + +=head2 Network traffic monitoring + +The best way to monitor the network traffic that LWP generates is to +use an external TCP monitoring program. The +L<WireShark|http://www.wireshark.org/> program is highly recommended for this. + +Another approach it to use a debugging HTTP proxy server and make +LWP direct all its traffic via this one. Call C<< $ua->proxy >> to +set it up and then just use LWP as before. + +For less precise monitoring needs just setting up a few simple +handlers might do. The following example sets up handlers to dump the +request and response objects that pass through LWP: + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable()); + + $ua->add_handler("request_send", sub { shift->dump; return }); + $ua->add_handler("response_done", sub { shift->dump; return }); + + $ua->get("http://www.example.com"); + +=head1 SEE ALSO + +L<LWP::ConsoleLogger>, L<LWP::ConsoleLogger::Everywhere>, L<LWP::UserAgent> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Debug/TraceHTTP.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Debug/TraceHTTP.pm new file mode 100644 index 0000000000..0644644616 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Debug/TraceHTTP.pm @@ -0,0 +1,29 @@ +package LWP::Debug::TraceHTTP; + +# Just call: +# +# require LWP::Debug::TraceHTTP; +# LWP::Protocol::implementor('http', 'LWP::Debug::TraceHTTP'); +# +# to use this module to trace all calls to the HTTP socket object in +# programs that use LWP. + +use strict; +use base 'LWP::Protocol::http'; + +our $VERSION = '6.37'; + +package # hide from PAUSE + LWP::Debug::TraceHTTP::Socket; + +use Data::Dump 1.13; +use Data::Dump::Trace qw(autowrap mcall); + +autowrap("LWP::Protocol::http::Socket" => "sock"); + +sub new { + my $class = shift; + return mcall("LWP::Protocol::http::Socket" => "new", undef, @_); +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/DebugFile.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/DebugFile.pm new file mode 100644 index 0000000000..f35cdf3426 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/DebugFile.pm @@ -0,0 +1,7 @@ +package LWP::DebugFile; + +our $VERSION = '6.37'; + +# legacy stub + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/MediaTypes.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/MediaTypes.pm new file mode 100644 index 0000000000..8c2a8aee33 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/MediaTypes.pm @@ -0,0 +1,280 @@ +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); +$VERSION = "6.02"; + +use strict; + +# 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)) { + # assume URI object + $file = $file->path; + #XXX should handle non http:, file: or ftp: URIs differently + } + 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_uri, $header_to_modify ) + +This function tries to guess media type and encoding for a file or a URI. +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. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/MemberMixin.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/MemberMixin.pm new file mode 100644 index 0000000000..4ed9053cbc --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/MemberMixin.pm @@ -0,0 +1,48 @@ +package LWP::MemberMixin; + +our $VERSION = '6.37'; + +sub _elem { + my $self = shift; + my $elem = shift; + my $old = $self->{$elem}; + $self->{$elem} = shift if @_; + return $old; +} + +1; + +__END__ + +=pod + +=head1 NAME + +LWP::MemberMixin - Member access mixin class + +=head1 SYNOPSIS + + package Foo; + use base qw(LWP::MemberMixin); + +=head1 DESCRIPTION + +A mixin class to get methods that provide easy access to member +variables in the C<%$self>. +Ideally there should be better Perl language support for this. + +=head1 METHODS + +There is only one method provided: + +=head2 _elem + + _elem($elem [, $val]) + +Internal method to get/set the value of member variable +C<$elem>. If C<$val> is present it is used as the new value +for the member variable. If it is not present the current +value is not touched. In both cases the previous value of +the member variable is returned. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol.pm new file mode 100644 index 0000000000..f5966ab1c1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol.pm @@ -0,0 +1,313 @@ +package LWP::Protocol; + +use base 'LWP::MemberMixin'; + +our $VERSION = '6.37'; + +use strict; +use Carp (); +use HTTP::Status (); +use HTTP::Response (); +use Try::Tiny qw(try catch); + +my %ImplementedBy = (); # scheme => classname + +sub new +{ + my($class, $scheme, $ua) = @_; + + my $self = bless { + scheme => $scheme, + ua => $ua, + + # historical/redundant + max_size => $ua->{max_size}, + }, $class; + + $self; +} + + +sub create +{ + my($scheme, $ua) = @_; + my $impclass = LWP::Protocol::implementor($scheme) or + Carp::croak("Protocol scheme '$scheme' is not supported"); + + # hand-off to scheme specific implementation sub-class + my $protocol = $impclass->new($scheme, $ua); + + return $protocol; +} + + +sub implementor +{ + my($scheme, $impclass) = @_; + + if ($impclass) { + $ImplementedBy{$scheme} = $impclass; + } + my $ic = $ImplementedBy{$scheme}; + return $ic if $ic; + + return '' unless $scheme =~ /^([.+\-\w]+)$/; # check valid URL schemes + $scheme = $1; # untaint + $scheme =~ tr/.+-/_/; # make it a legal module name + + # scheme not yet known, look for a 'use'd implementation + $ic = "LWP::Protocol::$scheme"; # default location + $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack + no strict 'refs'; + # check we actually have one for the scheme: + unless (@{"${ic}::ISA"}) { + # try to autoload it + try { + (my $class = $ic) =~ s{::}{/}g; + $class .= '.pm' unless $class =~ /\.pm$/; + require $class; + } + catch { + my $error = $_; + if ($error =~ /Can't locate/) { + $ic = ''; + } + else { + die "$error\n"; + } + }; + } + $ImplementedBy{$scheme} = $ic if $ic; + $ic; +} + + +sub request +{ + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses'); +} + + +# legacy +sub timeout { shift->_elem('timeout', @_); } +sub max_size { shift->_elem('max_size', @_); } + + +sub collect +{ + my ($self, $arg, $response, $collector) = @_; + my $content; + my($ua, $max_size) = @{$self}{qw(ua max_size)}; + + # This can't be moved to Try::Tiny due to the closures within causing + # leaks on any version of Perl prior to 5.18. + # https://perl5.git.perl.org/perl.git/commitdiff/a0d2bbd5c + my $error = do { #catch + local $@; + local $\; # protect the print below from surprises + eval { # try + if (!defined($arg) || !$response->is_success) { + $response->{default_add_content} = 1; + } + elsif (!ref($arg) && length($arg)) { + open(my $fh, ">", $arg) or die "Can't write to '$arg': $!"; + binmode($fh); + push(@{$response->{handlers}{response_data}}, { + callback => sub { + print $fh $_[3] or die "Can't write to '$arg': $!"; + 1; + }, + }); + push(@{$response->{handlers}{response_done}}, { + callback => sub { + close($fh) or die "Can't write to '$arg': $!"; + undef($fh); + }, + }); + } + elsif (ref($arg) eq 'CODE') { + push(@{$response->{handlers}{response_data}}, { + callback => sub { + &$arg($_[3], $_[0], $self); + 1; + }, + }); + } + else { + die "Unexpected collect argument '$arg'"; + } + + $ua->run_handlers("response_header", $response); + + if (delete $response->{default_add_content}) { + push(@{$response->{handlers}{response_data}}, { + callback => sub { + $_[0]->add_content($_[3]); + 1; + }, + }); + } + + + my $content_size = 0; + my $length = $response->content_length; + my %skip_h; + + while ($content = &$collector, length $$content) { + for my $h ($ua->handlers("response_data", $response)) { + next if $skip_h{$h}; + unless ($h->{callback}->($response, $ua, $h, $$content)) { + # XXX remove from $response->{handlers}{response_data} if present + $skip_h{$h}++; + } + } + $content_size += length($$content); + $ua->progress(($length ? ($content_size / $length) : "tick"), $response); + if (defined($max_size) && $content_size > $max_size) { + $response->push_header("Client-Aborted", "max_size"); + last; + } + } + 1; + }; + $@; + }; + + if ($error) { + chomp($error); + $response->push_header('X-Died' => $error); + $response->push_header("Client-Aborted", "die"); + }; + delete $response->{handlers}{response_data}; + delete $response->{handlers} unless %{$response->{handlers}}; + return $response; +} + + +sub collect_once +{ + my($self, $arg, $response) = @_; + my $content = \ $_[3]; + my $first = 1; + $self->collect($arg, $response, sub { + return $content if $first--; + return \ ""; + }); +} + +1; + + +__END__ + +=pod + +=head1 NAME + +LWP::Protocol - Base class for LWP protocols + +=head1 SYNOPSIS + + package LWP::Protocol::foo; + use base qw(LWP::Protocol); + +=head1 DESCRIPTION + +This class is used as the base class for all protocol implementations +supported by the LWP library. + +When creating an instance of this class using +C<LWP::Protocol::create($url)>, and you get an initialized subclass +appropriate for that access method. In other words, the +L<LWP::Protocol/create> function calls the constructor for one of its +subclasses. + +All derived C<LWP::Protocol> classes need to override the request() +method which is used to service a request. The overridden method can +make use of the collect() function to collect together chunks of data +as it is received. + +=head1 METHODS + +The following methods and functions are provided: + +=head2 new + + my $prot = LWP::Protocol->new(); + +The LWP::Protocol constructor is inherited by subclasses. As this is a +virtual base class this method should B<not> be called directly. + +=head2 create + + my $prot = LWP::Protocol::create($scheme) + +Create an object of the class implementing the protocol to handle the +given scheme. This is a function, not a method. It is more an object +factory than a constructor. This is the function user agents should +use to access protocols. + +=head2 implementor + + my $class = LWP::Protocol::implementor($scheme, [$class]) + +Get and/or set implementor class for a scheme. Returns C<''> if the +specified scheme is not supported. + +=head2 request + + $response = $protocol->request($request, $proxy, undef); + $response = $protocol->request($request, $proxy, '/tmp/sss'); + $response = $protocol->request($request, $proxy, \&callback, 1024); + +Dispatches a request over the protocol, and returns a response +object. This method needs to be overridden in subclasses. Refer to +L<LWP::UserAgent> for description of the arguments. + +=head2 collect + + my $res = $prot->collect(undef, $response, $collector); # stored in $response + my $res = $prot->collect($filename, $response, $collector); + my $res = $prot->collect(sub { ... }, $response, $collector); + +Collect the content of a request, and process it appropriately into a scalar, +file, or by calling a callback. If the first parameter is undefined, then the +content is stored within the C<$response>. If it's a simple scalar, then it's +interpreted as a file name and the content is written to this file. If it's a +code reference, then content is passed to this routine. + +The collector is a routine that will be called and which is +responsible for returning pieces (as ref to scalar) of the content to +process. The C<$collector> signals C<EOF> by returning a reference to an +empty string. + +The return value is the L<HTTP::Response> object reference. + +B<Note:> We will only use the callback or file argument if +C<< $response->is_success() >>. This avoids sending content data for +redirects and authentication responses to the callback which would be +confusing. + +=head2 collect_once + + $prot->collect_once($arg, $response, $content) + +Can be called when the whole response content is available as content. This +will invoke L<LWP::Protocol/collect> with a collector callback that +returns a reference to C<$content> the first time and an empty string the +next. + +=head1 SEE ALSO + +Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files +for examples of usage. + +=head1 COPYRIGHT + +Copyright 1995-2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm new file mode 100644 index 0000000000..1f6bd0d91b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm @@ -0,0 +1,72 @@ +package LWP::Protocol::cpan; + +use strict; + +use base qw(LWP::Protocol); + +our $VERSION = '6.37'; + +require URI; +require HTTP::Status; +require HTTP::Response; + +our $CPAN; + +unless ($CPAN) { + # Try to find local CPAN mirror via $CPAN::Config + eval { + require CPAN::Config; + if($CPAN::Config) { + my $urls = $CPAN::Config->{urllist}; + if (ref($urls) eq "ARRAY") { + my $file; + for (@$urls) { + if (/^file:/) { + $file = $_; + last; + } + } + + if ($file) { + $CPAN = $file; + } + else { + $CPAN = $urls->[0]; + } + } + } + }; + + $CPAN ||= "http://cpan.org/"; # last resort +} + +# ensure that we don't chop of last part +$CPAN .= "/" unless $CPAN =~ m,/$,; + + +sub request { + my($self, $request, $proxy, $arg, $size) = @_; + # check proxy + if (defined $proxy) + { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy with cpan'); + } + + # check method + my $method = $request->method; + unless ($method eq 'GET' || $method eq 'HEAD') { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'cpan:' URLs"); + } + + my $path = $request->uri->path; + $path =~ s,^/,,; + + my $response = HTTP::Response->new(HTTP::Status::RC_FOUND); + $response->header("Location" => URI->new_abs($path, $CPAN)); + $response; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm new file mode 100644 index 0000000000..8460f05be9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm @@ -0,0 +1,52 @@ +package LWP::Protocol::data; + +# Implements access to data:-URLs as specified in RFC 2397 + +use strict; + +our $VERSION = '6.37'; + +require HTTP::Response; +require HTTP::Status; + +use base qw(LWP::Protocol); + +use HTTP::Date qw(time2str); +require LWP; # needs version number + +sub request +{ + my($self, $request, $proxy, $arg, $size) = @_; + + # check proxy + if (defined $proxy) + { + return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy with data'); + } + + # check method + my $method = $request->method; + unless ($method eq 'GET' || $method eq 'HEAD') { + return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'data:' URLs"); + } + + my $url = $request->uri; + my $response = HTTP::Response->new( HTTP::Status::RC_OK, "Document follows"); + + my $media_type = $url->media_type; + + my $data = $url->data; + $response->header('Content-Type' => $media_type, + 'Content-Length' => length($data), + 'Date' => time2str(time), + 'Server' => "libwww-perl-internal/$LWP::VERSION" + ); + + $data = "" if $method eq "HEAD"; + return $self->collect_once($arg, $response, $data); +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm new file mode 100644 index 0000000000..01c14eeafa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm @@ -0,0 +1,147 @@ +package LWP::Protocol::file; + +use base qw(LWP::Protocol); + +use strict; + +our $VERSION = '6.37'; + +require LWP::MediaTypes; +require HTTP::Request; +require HTTP::Response; +require HTTP::Status; +require HTTP::Date; + + +sub request +{ + my($self, $request, $proxy, $arg, $size) = @_; + + $size = 4096 unless defined $size and $size > 0; + + # check proxy + if (defined $proxy) + { + return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy through the filesystem'); + } + + # check method + my $method = $request->method; + unless ($method eq 'GET' || $method eq 'HEAD') { + return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'file:' URLs"); + } + + # check url + my $url = $request->uri; + + my $scheme = $url->scheme; + if ($scheme ne 'file') { + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "LWP::Protocol::file::request called for '$scheme'"); + } + + # URL OK, look at file + my $path = $url->file; + + # test file exists and is readable + unless (-e $path) { + return HTTP::Response->new( HTTP::Status::RC_NOT_FOUND, + "File `$path' does not exist"); + } + unless (-r _) { + return HTTP::Response->new( HTTP::Status::RC_FORBIDDEN, + 'User does not have read permission'); + } + + # looks like file exists + my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize, + $atime,$mtime,$ctime,$blksize,$blocks) + = stat(_); + + # XXX should check Accept headers? + + # check if-modified-since + my $ims = $request->header('If-Modified-Since'); + if (defined $ims) { + my $time = HTTP::Date::str2time($ims); + if (defined $time and $time >= $mtime) { + return HTTP::Response->new( HTTP::Status::RC_NOT_MODIFIED, + "$method $path"); + } + } + + # Ok, should be an OK response by now... + my $response = HTTP::Response->new( HTTP::Status::RC_OK ); + + # fill in response headers + $response->header('Last-Modified', HTTP::Date::time2str($mtime)); + + if (-d _) { # If the path is a directory, process it + # generate the HTML for directory + opendir(D, $path) or + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Cannot read directory '$path': $!"); + my(@files) = sort readdir(D); + closedir(D); + + # Make directory listing + require URI::Escape; + require HTML::Entities; + my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/'); + for (@files) { + my $furl = URI::Escape::uri_escape($_); + if ( -d "$pathe$_" ) { + $furl .= '/'; + $_ .= '/'; + } + my $desc = HTML::Entities::encode($_); + $_ = qq{<LI><A HREF="$furl">$desc</A>}; + } + # Ensure that the base URL is "/" terminated + my $base = $url->clone; + unless ($base->path =~ m|/$|) { + $base->path($base->path . "/"); + } + my $html = join("\n", + "<HTML>\n<HEAD>", + "<TITLE>Directory $path</TITLE>", + "<BASE HREF=\"$base\">", + "</HEAD>\n<BODY>", + "<H1>Directory listing of $path</H1>", + "<UL>", @files, "</UL>", + "</BODY>\n</HTML>\n"); + + $response->header('Content-Type', 'text/html'); + $response->header('Content-Length', length $html); + $html = "" if $method eq "HEAD"; + + return $self->collect_once($arg, $response, $html); + + } + + # path is a regular file + $response->header('Content-Length', $filesize); + LWP::MediaTypes::guess_media_type($path, $response); + + # read the file + if ($method ne "HEAD") { + open(my $fh, '<', $path) or return new + HTTP::Response(HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Cannot read file '$path': $!"); + binmode($fh); + $response = $self->collect($arg, $response, sub { + my $content = ""; + my $bytes = sysread($fh, $content, $size); + return \$content if $bytes > 0; + return \ ""; + }); + close($fh); + } + + $response; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm new file mode 100644 index 0000000000..d45a877f59 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm @@ -0,0 +1,555 @@ +package LWP::Protocol::ftp; + +# Implementation of the ftp protocol (RFC 959). We let the Net::FTP +# package do all the dirty work. +use base qw(LWP::Protocol); +use strict; + +our $VERSION = '6.37'; + +use Carp (); +use HTTP::Status (); +use HTTP::Negotiate (); +use HTTP::Response (); +use LWP::MediaTypes (); +use File::Listing (); + + +{ + + package # hide from PAUSE + LWP::Protocol::MyFTP; + + use strict; + use base qw(Net::FTP); + + sub new { + my $class = shift; + + my $self = $class->SUPER::new(@_) || return undef; + + my $mess = $self->message; # welcome message + $mess =~ s|\n.*||s; # only first line left + $mess =~ s|\s*ready\.?$||; + + # Make the version number more HTTP like + $mess =~ s|\s*\(Version\s*|/| and $mess =~ s|\)$||; + ${*$self}{myftp_server} = $mess; + + #$response->header("Server", $mess); + + $self; + } + + sub http_server { + my $self = shift; + ${*$self}{myftp_server}; + } + + sub home { + my $self = shift; + my $old = ${*$self}{myftp_home}; + if (@_) { + ${*$self}{myftp_home} = shift; + } + $old; + } + + sub go_home { + my $self = shift; + $self->cwd(${*$self}{myftp_home}); + } + + sub request_count { + my $self = shift; + ++${*$self}{myftp_reqcount}; + } + + sub ping { + my $self = shift; + return $self->go_home; + } +} + +sub _connect { + my ($self, $host, $port, $user, $account, $password, $timeout) = @_; + + my $key; + my $conn_cache = $self->{ua}{conn_cache}; + if ($conn_cache) { + $key = "$host:$port:$user"; + $key .= ":$account" if defined($account); + if (my $ftp = $conn_cache->withdraw("ftp", $key)) { + if ($ftp->ping) { + + # save it again + $conn_cache->deposit("ftp", $key, $ftp); + return $ftp; + } + } + } + + # try to make a connection + my $ftp = LWP::Protocol::MyFTP->new( + $host, + Port => $port, + Timeout => $timeout, + LocalAddr => $self->{ua}{local_address}, + ); + + # XXX Should be some what to pass on 'Passive' (header??) + unless ($ftp) { + $@ =~ s/^Net::FTP: //; + return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@); + } + + unless ($ftp->login($user, $password, $account)) { + + # Unauthorized. Let's fake a RC_UNAUTHORIZED response + my $mess = scalar($ftp->message); + $mess =~ s/\n$//; + my $res = HTTP::Response->new(HTTP::Status::RC_UNAUTHORIZED, $mess); + $res->header("Server", $ftp->http_server); + $res->header("WWW-Authenticate", qq(Basic Realm="FTP login")); + return $res; + } + + my $home = $ftp->pwd; + $ftp->home($home); + + $conn_cache->deposit("ftp", $key, $ftp) if $conn_cache; + + return $ftp; +} + + +sub request { + my ($self, $request, $proxy, $arg, $size, $timeout) = @_; + + $size = 4096 unless $size; + + # check proxy + if (defined $proxy) { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy through the ftp'); + } + + my $url = $request->uri; + if ($url->scheme ne 'ftp') { + my $scheme = $url->scheme; + return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "LWP::Protocol::ftp::request called for '$scheme'"); + } + + # check method + my $method = $request->method; + + unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'PUT') { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . "$method for 'ftp:' URLs"); + } + + my $host = $url->host; + my $port = $url->port; + my $user = $url->user; + my $password = $url->password; + + # If a basic authorization header is present than we prefer these over + # the username/password specified in the URL. + { + my ($u, $p) = $request->authorization_basic; + if (defined $u) { + $user = $u; + $password = $p; + } + } + + # We allow the account to be specified in the "Account" header + my $account = $request->header('Account'); + + my $ftp + = $self->_connect($host, $port, $user, $account, $password, $timeout); + return $ftp if ref($ftp) eq "HTTP::Response"; # ugh! + + # Create an initial response object + my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK"); + $response->header(Server => $ftp->http_server); + $response->header('Client-Request-Num' => $ftp->request_count); + $response->request($request); + + # Get & fix the path + my @path = grep {length} $url->path_segments; + my $remote_file = pop(@path); + $remote_file = '' unless defined $remote_file; + + my $type; + if (ref $remote_file) { + my @params; + ($remote_file, @params) = @$remote_file; + for (@params) { + $type = $_ if s/^type=//; + } + } + + if ($type && $type eq 'a') { + $ftp->ascii; + } + else { + $ftp->binary; + } + + for (@path) { + unless ($ftp->cwd($_)) { + return HTTP::Response->new(HTTP::Status::RC_NOT_FOUND, + "Can't chdir to $_"); + } + } + + if ($method eq 'GET' || $method eq 'HEAD') { + if (my $mod_time = $ftp->mdtm($remote_file)) { + $response->last_modified($mod_time); + if (my $ims = $request->if_modified_since) { + if ($mod_time <= $ims) { + $response->code(HTTP::Status::RC_NOT_MODIFIED); + $response->message("Not modified"); + return $response; + } + } + } + + # We'll use this later to abort the transfer if necessary. + # if $max_size is defined, we need to abort early. Otherwise, it's + # a normal transfer + my $max_size = undef; + + # Set resume location, if the client requested it + if ($request->header('Range') && $ftp->supported('REST')) { + my $range_info = $request->header('Range'); + + # Change bytes=2772992-6781209 to just 2772992 + my ($start_byte, $end_byte) = $range_info =~ /.*=\s*(\d+)-(\d+)?/; + if (defined $start_byte && !defined $end_byte) { + + # open range -- only the start is specified + + $ftp->restart($start_byte); + + # don't define $max_size, we don't want to abort early + } + elsif (defined $start_byte + && defined $end_byte + && $start_byte >= 0 + && $end_byte >= $start_byte) + { + + $ftp->restart($start_byte); + $max_size = $end_byte - $start_byte; + } + else { + + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'Incorrect syntax for Range request'); + } + } + elsif ($request->header('Range') && !$ftp->supported('REST')) { + return HTTP::Response->new(HTTP::Status::RC_NOT_IMPLEMENTED, + "Server does not support resume." + ); + } + + my $data; # the data handle + if (length($remote_file) and $data = $ftp->retr($remote_file)) { + my ($type, @enc) = LWP::MediaTypes::guess_media_type($remote_file); + $response->header('Content-Type', $type) if $type; + for (@enc) { + $response->push_header('Content-Encoding', $_); + } + my $mess = $ftp->message; + if ($mess =~ /\((\d+)\s+bytes\)/) { + $response->header('Content-Length', "$1"); + } + + if ($method ne 'HEAD') { + + # Read data from server + $response = $self->collect( + $arg, + $response, + sub { + my $content = ''; + my $result = $data->read($content, $size); + + # Stop early if we need to. + if (defined $max_size) { + + # We need an interface to Net::FTP::dataconn for getting + # the number of bytes already read + my $bytes_received = $data->bytes_read(); + + # We were already over the limit. (Should only happen + # once at the end.) + if ($bytes_received - length($content) > $max_size) + { + $content = ''; + } + + # We just went over the limit + elsif ($bytes_received > $max_size) { + + # Trim content + $content = substr($content, 0, + $max_size + - ($bytes_received - length($content))); + } + + # We're under the limit + else { + } + } + + return \$content; + } + ); + } + + # abort is needed for HEAD, it's == close if the transfer has + # already completed. + unless ($data->abort) { + + # Something did not work too well. Note that we treat + # responses to abort() with code 0 in case of HEAD as ok + # (at least wu-ftpd 2.6.1(1) does that). + if ($method ne 'HEAD' || $ftp->code != 0) { + $response->code(HTTP::Status::RC_INTERNAL_SERVER_ERROR); + $response->message("FTP close response: " + . $ftp->code . " " + . $ftp->message); + } + } + } + elsif (!length($remote_file) || ($ftp->code >= 400 && $ftp->code < 600)) + { + # not a plain file, try to list instead + if (length($remote_file) && !$ftp->cwd($remote_file)) { + return HTTP::Response->new(HTTP::Status::RC_NOT_FOUND, + "File '$remote_file' not found" + ); + } + + # It should now be safe to try to list the directory + my @lsl = $ftp->dir; + + # Try to figure out if the user want us to convert the + # directory listing to HTML. + my @variants = ( + ['html', 0.60, 'text/html'], + ['dir', 1.00, 'text/ftp-dir-listing'] + ); + + #$HTTP::Negotiate::DEBUG=1; + my $prefer = HTTP::Negotiate::choose(\@variants, $request); + + my $content = ''; + + if (!defined($prefer)) { + return HTTP::Response->new(HTTP::Status::RC_NOT_ACCEPTABLE, + "Neither HTML nor directory listing wanted"); + } + elsif ($prefer eq 'html') { + $response->header('Content-Type' => 'text/html'); + $content = "<HEAD><TITLE>File Listing</TITLE>\n"; + my $base = $request->uri->clone; + my $path = $base->path; + $base->path("$path/") unless $path =~ m|/$|; + $content .= qq(<BASE HREF="$base">\n</HEAD>\n); + $content .= "<BODY>\n<UL>\n"; + for (File::Listing::parse_dir(\@lsl, 'GMT')) { + my ($name, $type, $size, $mtime, $mode) = @$_; + $content .= qq( <LI> <a href="$name">$name</a>); + $content .= " $size bytes" if $type eq 'f'; + $content .= "\n"; + } + $content .= "</UL></body>\n"; + } + else { + $response->header('Content-Type', 'text/ftp-dir-listing'); + $content = join("\n", @lsl, ''); + } + + $response->header('Content-Length', length($content)); + + if ($method ne 'HEAD') { + $response = $self->collect_once($arg, $response, $content); + } + } + else { + my $res = HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + "FTP return code " . $ftp->code); + $res->content_type("text/plain"); + $res->content($ftp->message); + return $res; + } + } + elsif ($method eq 'PUT') { + + # method must be PUT + unless (length($remote_file)) { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + "Must have a file name to PUT to" + ); + } + my $data; + if ($data = $ftp->stor($remote_file)) { + my $content = $request->content; + my $bytes = 0; + if (defined $content) { + if (ref($content) eq 'SCALAR') { + $bytes = $data->write($$content, length($$content)); + } + elsif (ref($content) eq 'CODE') { + my ($buf, $n); + while (length($buf = &$content)) { + $n = $data->write($buf, length($buf)); + last unless $n; + $bytes += $n; + } + } + elsif (!ref($content)) { + if (defined $content && length($content)) { + $bytes = $data->write($content, length($content)); + } + } + else { + die "Bad content"; + } + } + $data->close; + + $response->code(HTTP::Status::RC_CREATED); + $response->header('Content-Type', 'text/plain'); + $response->content("$bytes bytes stored as $remote_file on $host\n") + + } + else { + my $res = HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + "FTP return code " . $ftp->code); + $res->content_type("text/plain"); + $res->content($ftp->message); + return $res; + } + } + else { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + "Illegal method $method"); + } + + $response; +} + +1; + +__END__ + +# This is what RFC 1738 has to say about FTP access: +# -------------------------------------------------- +# +# 3.2. FTP +# +# The FTP URL scheme is used to designate files and directories on +# Internet hosts accessible using the FTP protocol (RFC959). +# +# A FTP URL follow the syntax described in Section 3.1. If :<port> is +# omitted, the port defaults to 21. +# +# 3.2.1. FTP Name and Password +# +# A user name and password may be supplied; they are used in the ftp +# "USER" and "PASS" commands after first making the connection to the +# FTP server. If no user name or password is supplied and one is +# requested by the FTP server, the conventions for "anonymous" FTP are +# to be used, as follows: +# +# The user name "anonymous" is supplied. +# +# The password is supplied as the Internet e-mail address +# of the end user accessing the resource. +# +# If the URL supplies a user name but no password, and the remote +# server requests a password, the program interpreting the FTP URL +# should request one from the user. +# +# 3.2.2. FTP url-path +# +# The url-path of a FTP URL has the following syntax: +# +# <cwd1>/<cwd2>/.../<cwdN>/<name>;type=<typecode> +# +# Where <cwd1> through <cwdN> and <name> are (possibly encoded) strings +# and <typecode> is one of the characters "a", "i", or "d". The part +# ";type=<typecode>" may be omitted. The <cwdx> and <name> parts may be +# empty. The whole url-path may be omitted, including the "/" +# delimiting it from the prefix containing user, password, host, and +# port. +# +# The url-path is interpreted as a series of FTP commands as follows: +# +# Each of the <cwd> elements is to be supplied, sequentially, as the +# argument to a CWD (change working directory) command. +# +# If the typecode is "d", perform a NLST (name list) command with +# <name> as the argument, and interpret the results as a file +# directory listing. +# +# Otherwise, perform a TYPE command with <typecode> as the argument, +# and then access the file whose name is <name> (for example, using +# the RETR command.) +# +# Within a name or CWD component, the characters "/" and ";" are +# reserved and must be encoded. The components are decoded prior to +# their use in the FTP protocol. In particular, if the appropriate FTP +# sequence to access a particular file requires supplying a string +# containing a "/" as an argument to a CWD or RETR command, it is +# necessary to encode each "/". +# +# For example, the URL <URL:ftp://myname@host.dom/%2Fetc/motd> is +# interpreted by FTP-ing to "host.dom", logging in as "myname" +# (prompting for a password if it is asked for), and then executing +# "CWD /etc" and then "RETR motd". This has a different meaning from +# <URL:ftp://myname@host.dom/etc/motd> which would "CWD etc" and then +# "RETR motd"; the initial "CWD" might be executed relative to the +# default directory for "myname". On the other hand, +# <URL:ftp://myname@host.dom//etc/motd>, would "CWD " with a null +# argument, then "CWD etc", and then "RETR motd". +# +# FTP URLs may also be used for other operations; for example, it is +# possible to update a file on a remote file server, or infer +# information about it from the directory listings. The mechanism for +# doing so is not spelled out here. +# +# 3.2.3. FTP Typecode is Optional +# +# The entire ;type=<typecode> part of a FTP URL is optional. If it is +# omitted, the client program interpreting the URL must guess the +# appropriate mode to use. In general, the data content type of a file +# can only be guessed from the name, e.g., from the suffix of the name; +# the appropriate type code to be used for transfer of the file can +# then be deduced from the data content of the file. +# +# 3.2.4 Hierarchy +# +# For some file systems, the "/" used to denote the hierarchical +# structure of the URL corresponds to the delimiter used to construct a +# file name hierarchy, and thus, the filename will look similar to the +# URL path. This does NOT mean that the URL is a Unix filename. +# +# 3.2.5. Optimization +# +# Clients accessing resources via FTP may employ additional heuristics +# to optimize the interaction. For some FTP servers, for example, it +# may be reasonable to keep the control connection open while accessing +# multiple URLs from the same server. However, there is no common +# hierarchical model to the FTP protocol, so if a directory change +# command has been given, it is impossible in general to deduce what +# sequence should be given to navigate to another directory for a +# second retrieval, if the paths are different. The only reliable +# algorithm is to disconnect and reestablish the control connection. diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm new file mode 100644 index 0000000000..6fd6ff710b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm @@ -0,0 +1,213 @@ +package LWP::Protocol::gopher; + +# Implementation of the gopher protocol (RFC 1436) +# +# This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden' +# which in turn is a vastly modified version of Oscar's http'get() +# dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl> +# including contributions from Marc van Heyningen and Martijn Koster. + +use strict; + +our $VERSION = '6.37'; + +require HTTP::Response; +require HTTP::Status; +require IO::Socket; +require IO::Select; + +use base qw(LWP::Protocol); + + +my %gopher2mimetype = ( + '0' => 'text/plain', # 0 file + '1' => 'text/html', # 1 menu + # 2 CSO phone-book server + # 3 Error + '4' => 'application/mac-binhex40', # 4 BinHexed Macintosh file + '5' => 'application/zip', # 5 DOS binary archive of some sort + '6' => 'application/octet-stream', # 6 UNIX uuencoded file. + '7' => 'text/html', # 7 Index-Search server + # 8 telnet session + '9' => 'application/octet-stream', # 9 binary file + 'h' => 'text/html', # html + 'g' => 'image/gif', # gif + 'I' => 'image/*', # some kind of image +); + +my %gopher2encoding = ( + '6' => 'x_uuencode', # 6 UNIX uuencoded file. +); + +sub request +{ + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + + $size = 4096 unless $size; + + # check proxy + if (defined $proxy) { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy through the gopher'); + } + + my $url = $request->uri; + die "bad scheme" if $url->scheme ne 'gopher'; + + + my $method = $request->method; + unless ($method eq 'GET' || $method eq 'HEAD') { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'gopher:' URLs"); + } + + my $gophertype = $url->gopher_type; + unless (exists $gopher2mimetype{$gophertype}) { + return HTTP::Response->new(HTTP::Status::RC_NOT_IMPLEMENTED, + 'Library does not support gophertype ' . + $gophertype); + } + + my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK"); + $response->header('Content-type' => $gopher2mimetype{$gophertype} + || 'text/plain'); + $response->header('Content-Encoding' => $gopher2encoding{$gophertype}) + if exists $gopher2encoding{$gophertype}; + + if ($method eq 'HEAD') { + # XXX: don't even try it so we set this header + $response->header('Client-Warning' => 'Client answer only'); + return $response; + } + + if ($gophertype eq '7' && ! $url->search) { + # the url is the prompt for a gopher search; supply boiler-plate + return $self->collect_once($arg, $response, <<"EOT"); +<HEAD> +<TITLE>Gopher Index</TITLE> +<ISINDEX> +</HEAD> +<BODY> +<H1>$url<BR>Gopher Search</H1> +This is a searchable Gopher index. +Use the search function of your browser to enter search terms. +</BODY> +EOT + } + + my $host = $url->host; + my $port = $url->port; + + my $requestLine = ""; + + my $selector = $url->selector; + if (defined $selector) { + $requestLine .= $selector; + my $search = $url->search; + if (defined $search) { + $requestLine .= "\t$search"; + my $string = $url->string; + if (defined $string) { + $requestLine .= "\t$string"; + } + } + } + $requestLine .= "\015\012"; + + # potential request headers are just ignored + + # Ok, lets make the request + my $socket = IO::Socket::INET->new(PeerAddr => $host, + PeerPort => $port, + LocalAddr => $self->{ua}{local_address}, + Proto => 'tcp', + Timeout => $timeout); + die "Can't connect to $host:$port" unless $socket; + my $sel = IO::Select->new($socket); + + { + die "write timeout" if $timeout && !$sel->can_write($timeout); + my $n = syswrite($socket, $requestLine, length($requestLine)); + die $! unless defined($n); + die "short write" if $n != length($requestLine); + } + + my $user_arg = $arg; + + # must handle menus in a special way since they are to be + # converted to HTML. Undefing $arg ensures that the user does + # not see the data before we get a change to convert it. + $arg = undef if $gophertype eq '1' || $gophertype eq '7'; + + # collect response + my $buf = ''; + $response = $self->collect($arg, $response, sub { + die "read timeout" if $timeout && !$sel->can_read($timeout); + my $n = sysread($socket, $buf, $size); + die $! unless defined($n); + return \$buf; + } ); + + # Convert menu to HTML and return data to user. + if ($gophertype eq '1' || $gophertype eq '7') { + my $content = menu2html($response->content); + if (defined $user_arg) { + $response = $self->collect_once($user_arg, $response, $content); + } + else { + $response->content($content); + } + } + + $response; +} + + +sub gopher2url +{ + my($gophertype, $path, $host, $port) = @_; + + my $url; + + if ($gophertype eq '8' || $gophertype eq 'T') { + # telnet session + $url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:'); + $url->user($path) if defined $path; + } + else { + $path = URI::Escape::uri_escape($path); + $url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path"); + } + $url->host($host); + $url->port($port); + $url; +} + +sub menu2html { + my($menu) = @_; + + $menu =~ tr/\015//d; # remove carriage return + my $tmp = <<"EOT"; +<HTML> +<HEAD> + <TITLE>Gopher menu</TITLE> +</HEAD> +<BODY> +<H1>Gopher menu</H1> +EOT + for (split("\n", $menu)) { + last if /^\./; + my($pretty, $path, $host, $port) = split("\t"); + + $pretty =~ s/^(.)//; + my $type = $1; + + my $url = gopher2url($type, $path, $host, $port)->as_string; + $tmp .= qq{<A HREF="$url">$pretty</A><BR>\n}; + } + $tmp .= "</BODY>\n</HTML>\n"; + $tmp; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm new file mode 100644 index 0000000000..ec53e23d95 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm @@ -0,0 +1,523 @@ +package LWP::Protocol::http; + +use strict; + +our $VERSION = '6.37'; + +require HTTP::Response; +require HTTP::Status; +require Net::HTTP; + +use base qw(LWP::Protocol); + +our @EXTRA_SOCK_OPTS; +my $CRLF = "\015\012"; + +sub _new_socket +{ + my($self, $host, $port, $timeout) = @_; + + # IPv6 literal IP address should be [bracketed] to remove + # ambiguity between ip address and port number. + if ( ($host =~ /:/) && ($host !~ /^\[/) ) { + $host = "[$host]"; + } + + local($^W) = 0; # IO::Socket::INET can be noisy + my $sock = $self->socket_class->new(PeerAddr => $host, + PeerPort => $port, + LocalAddr => $self->{ua}{local_address}, + Proto => 'tcp', + Timeout => $timeout, + KeepAlive => !!$self->{ua}{conn_cache}, + SendTE => $self->{ua}{send_te}, + $self->_extra_sock_opts($host, $port), + ); + + unless ($sock) { + # IO::Socket::INET leaves additional error messages in $@ + my $status = "Can't connect to $host:$port"; + if ($@ =~ /\bconnect: (.*)/ || + $@ =~ /\b(Bad hostname)\b/ || + $@ =~ /\b(nodename nor servname provided, or not known)\b/ || + $@ =~ /\b(certificate verify failed)\b/ || + $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/ + ) { + $status .= " ($1)"; + } elsif ($@) { + $status .= " ($@)"; + } + die "$status\n\n$@"; + } + + # perl 5.005's IO::Socket does not have the blocking method. + eval { $sock->blocking(0); }; + + $sock; +} + +sub socket_type +{ + return "http"; +} + +sub socket_class +{ + my $self = shift; + (ref($self) || $self) . "::Socket"; +} + +sub _extra_sock_opts # to be overridden by subclass +{ + return @EXTRA_SOCK_OPTS; +} + +sub _check_sock +{ + #my($self, $req, $sock) = @_; +} + +sub _get_sock_info +{ + my($self, $res, $sock) = @_; + if (defined(my $peerhost = $sock->peerhost)) { + $res->header("Client-Peer" => "$peerhost:" . $sock->peerport); + } +} + +sub _fixup_header +{ + my($self, $h, $url, $proxy) = @_; + + # Extract 'Host' header + my $hhost = $url->authority; + if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@" + # add authorization header if we need them. HTTP URLs do + # not really support specification of user and password, but + # we allow it. + if (defined($1) && not $h->header('Authorization')) { + require URI::Escape; + $h->authorization_basic(map URI::Escape::uri_unescape($_), + split(":", $1, 2)); + } + } + $h->init_header('Host' => $hhost); + + if ($proxy && $url->scheme ne 'https') { + # Check the proxy URI's userinfo() for proxy credentials + # export http_proxy="http://proxyuser:proxypass@proxyhost:port". + # For https only the initial CONNECT requests needs authorization. + my $p_auth = $proxy->userinfo(); + if(defined $p_auth) { + require URI::Escape; + $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_), + split(":", $p_auth, 2)) + } + } +} + +sub hlist_remove { + my($hlist, $k) = @_; + $k = lc $k; + for (my $i = @$hlist - 2; $i >= 0; $i -= 2) { + next unless lc($hlist->[$i]) eq $k; + splice(@$hlist, $i, 2); + } +} + +sub request +{ + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + + $size ||= 4096; + + # check method + my $method = $request->method; + unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token + return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'http:' URLs"); + } + + my $url = $request->uri; + + # Proxying SSL with a http proxy needs issues a CONNECT request to build a + # tunnel and then upgrades the tunnel to SSL. But when doing keep-alive the + # https request does not need to be the first request in the connection, so + # we need to distinguish between + # - not yet connected (create socket and ssl upgrade) + # - connected but not inside ssl tunnel (ssl upgrade) + # - inside ssl tunnel to the target - once we are in the tunnel to the + # target we cannot only reuse the tunnel for more https requests with the + # same target + + my $ssl_tunnel = $proxy && $url->scheme eq 'https' + && $url->host.":".$url->port; + + my ($host,$port) = $proxy + ? ($proxy->host,$proxy->port) + : ($url->host,$url->port); + my $fullpath = + $method eq 'CONNECT' ? $url->host . ":" . $url->port : + $proxy && ! $ssl_tunnel ? $url->as_string : + do { + my $path = $url->path_query; + $path = "/$path" if $path !~m{^/}; + $path + }; + + my $socket; + my $conn_cache = $self->{ua}{conn_cache}; + my $cache_key; + if ( $conn_cache ) { + $cache_key = "$host:$port"; + # For https we reuse the socket immediately only if it has an established + # tunnel to the target. Otherwise a CONNECT request followed by an SSL + # upgrade need to be done first. The request itself might reuse an + # existing non-ssl connection to the proxy + $cache_key .= "!".$ssl_tunnel if $ssl_tunnel; + if ( $socket = $conn_cache->withdraw($self->socket_type,$cache_key)) { + if ($socket->can_read(0)) { + # if the socket is readable, then either the peer has closed the + # connection or there are some garbage bytes on it. In either + # case we abandon it. + $socket->close; + $socket = undef; + } # else use $socket + else { + $socket->timeout($timeout); + } + } + } + + if ( ! $socket && $ssl_tunnel ) { + my $proto_https = LWP::Protocol::create('https',$self->{ua}) + or die "no support for scheme https found"; + + # only if ssl socket class is IO::Socket::SSL we can upgrade + # a plain socket to SSL. In case of Net::SSL we fall back to + # the old version + if ( my $upgrade_sub = $proto_https->can('_upgrade_sock')) { + my $response = $self->request( + HTTP::Request->new('CONNECT',"http://$ssl_tunnel"), + $proxy, + undef,$size,$timeout + ); + $response->is_success or die + "establishing SSL tunnel failed: ".$response->status_line; + $socket = $upgrade_sub->($proto_https, + $response->{client_socket},$url) + or die "SSL upgrade failed: $@"; + } else { + $socket = $proto_https->_new_socket($url->host,$url->port,$timeout); + } + } + + if ( ! $socket ) { + # connect to remote site w/o reusing established socket + $socket = $self->_new_socket($host, $port, $timeout ); + } + + my $http_version = ""; + if (my $proto = $request->protocol) { + if ($proto =~ /^(?:HTTP\/)?(1.\d+)$/) { + $http_version = $1; + $socket->http_version($http_version); + $socket->send_te(0) if $http_version eq "1.0"; + } + } + + $self->_check_sock($request, $socket); + + my @h; + my $request_headers = $request->headers->clone; + $self->_fixup_header($request_headers, $url, $proxy); + + $request_headers->scan(sub { + my($k, $v) = @_; + $k =~ s/^://; + $v =~ tr/\n/ /; + push(@h, $k, $v); + }); + + my $content_ref = $request->content_ref; + $content_ref = $$content_ref if ref($$content_ref); + my $chunked; + my $has_content; + + if (ref($content_ref) eq 'CODE') { + my $clen = $request_headers->header('Content-Length'); + $has_content++ if $clen; + unless (defined $clen) { + push(@h, "Transfer-Encoding" => "chunked"); + $has_content++; + $chunked++; + } + } + else { + # Set (or override) Content-Length header + my $clen = $request_headers->header('Content-Length'); + if (defined($$content_ref) && length($$content_ref)) { + $has_content = length($$content_ref); + if (!defined($clen) || $clen ne $has_content) { + if (defined $clen) { + warn "Content-Length header value was wrong, fixed"; + hlist_remove(\@h, 'Content-Length'); + } + push(@h, 'Content-Length' => $has_content); + } + } + elsif ($clen) { + warn "Content-Length set when there is no content, fixed"; + hlist_remove(\@h, 'Content-Length'); + } + } + + my $write_wait = 0; + $write_wait = 2 + if ($request_headers->header("Expect") || "") =~ /100-continue/; + + my $req_buf = $socket->format_request($method, $fullpath, @h); + #print "------\n$req_buf\n------\n"; + + if (!$has_content || $write_wait || $has_content > 8*1024) { + WRITE: + { + # Since this just writes out the header block it should almost + # always succeed to send the whole buffer in a single write call. + my $n = $socket->syswrite($req_buf, length($req_buf)); + unless (defined $n) { + redo WRITE if $!{EINTR}; + if ($!{EWOULDBLOCK} || $!{EAGAIN}) { + select(undef, undef, undef, 0.1); + redo WRITE; + } + die "write failed: $!"; + } + if ($n) { + substr($req_buf, 0, $n, ""); + } + else { + select(undef, undef, undef, 0.5); + } + redo WRITE if length $req_buf; + } + } + + my($code, $mess, @junk); + my $drop_connection; + + if ($has_content) { + my $eof; + my $wbuf; + my $woffset = 0; + INITIAL_READ: + if ($write_wait) { + # skip filling $wbuf when waiting for 100-continue + # because if the response is a redirect or auth required + # the request will be cloned and there is no way + # to reset the input stream + # return here via the label after the 100-continue is read + } + elsif (ref($content_ref) eq 'CODE') { + my $buf = &$content_ref(); + $buf = "" unless defined($buf); + $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF + if $chunked; + substr($buf, 0, 0) = $req_buf if $req_buf; + $wbuf = \$buf; + } + else { + if ($req_buf) { + my $buf = $req_buf . $$content_ref; + $wbuf = \$buf; + } + else { + $wbuf = $content_ref; + } + $eof = 1; + } + + my $fbits = ''; + vec($fbits, fileno($socket), 1) = 1; + + WRITE: + while ($write_wait || $woffset < length($$wbuf)) { + + my $sel_timeout = $timeout; + if ($write_wait) { + $sel_timeout = $write_wait if $write_wait < $sel_timeout; + } + my $time_before; + $time_before = time if $sel_timeout; + + my $rbits = $fbits; + my $wbits = $write_wait ? undef : $fbits; + my $sel_timeout_before = $sel_timeout; + SELECT: + { + my $nfound = select($rbits, $wbits, undef, $sel_timeout); + if ($nfound < 0) { + if ($!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN}) { + if ($time_before) { + $sel_timeout = $sel_timeout_before - (time - $time_before); + $sel_timeout = 0 if $sel_timeout < 0; + } + redo SELECT; + } + die "select failed: $!"; + } + } + + if ($write_wait) { + $write_wait -= time - $time_before; + $write_wait = 0 if $write_wait < 0; + } + + if (defined($rbits) && $rbits =~ /[^\0]/) { + # readable + my $buf = $socket->_rbuf; + my $n = $socket->sysread($buf, 1024, length($buf)); + unless (defined $n) { + die "read failed: $!" unless $!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN}; + # if we get here the rest of the block will do nothing + # and we will retry the read on the next round + } + elsif ($n == 0) { + # the server closed the connection before we finished + # writing all the request content. No need to write any more. + $drop_connection++; + last WRITE; + } + $socket->_rbuf($buf); + if (!$code && $buf =~ /\015?\012\015?\012/) { + # a whole response header is present, so we can read it without blocking + ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, + junk_out => \@junk, + ); + if ($code eq "100") { + $write_wait = 0; + undef($code); + goto INITIAL_READ; + } + else { + $drop_connection++; + last WRITE; + # XXX should perhaps try to abort write in a nice way too + } + } + } + if (defined($wbits) && $wbits =~ /[^\0]/) { + my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset); + unless (defined $n) { + die "write failed: $!" unless $!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN}; + $n = 0; # will retry write on the next round + } + elsif ($n == 0) { + die "write failed: no bytes written"; + } + $woffset += $n; + + if (!$eof && $woffset >= length($$wbuf)) { + # need to refill buffer from $content_ref code + my $buf = &$content_ref(); + $buf = "" unless defined($buf); + $eof++ unless length($buf); + $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF + if $chunked; + $wbuf = \$buf; + $woffset = 0; + } + } + } # WRITE + } + + ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk) + unless $code; + ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk) + if $code eq "100"; + + my $response = HTTP::Response->new($code, $mess); + my $peer_http_version = $socket->peer_http_version; + $response->protocol("HTTP/$peer_http_version"); + { + local $HTTP::Headers::TRANSLATE_UNDERSCORE; + $response->push_header(@h); + } + $response->push_header("Client-Junk" => \@junk) if @junk; + + $response->request($request); + $self->_get_sock_info($response, $socket); + + if ($method eq "CONNECT") { + $response->{client_socket} = $socket; # so it can be picked up + return $response; + } + + if (my @te = $response->remove_header('Transfer-Encoding')) { + $response->push_header('Client-Transfer-Encoding', \@te); + } + $response->push_header('Client-Response-Num', scalar $socket->increment_response_count); + + my $complete; + $response = $self->collect($arg, $response, sub { + my $buf = ""; #prevent use of uninitialized value in SSLeay.xs + my $n; + READ: + { + $n = $socket->read_entity_body($buf, $size); + unless (defined $n) { + redo READ if $!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN} || $!{ENOTTY}; + die "read failed: $!"; + } + redo READ if $n == -1; + } + $complete++ if !$n; + return \$buf; + } ); + $drop_connection++ unless $complete; + + @h = $socket->get_trailers; + if (@h) { + local $HTTP::Headers::TRANSLATE_UNDERSCORE; + $response->push_header(@h); + } + + # keep-alive support + unless ($drop_connection) { + if ($cache_key) { + my %connection = map { (lc($_) => 1) } + split(/\s*,\s*/, ($response->header("Connection") || "")); + if (($peer_http_version eq "1.1" && !$connection{close}) || + $connection{"keep-alive"}) + { + $conn_cache->deposit($self->socket_type, $cache_key, $socket); + } + } + } + + $response; +} + + +#----------------------------------------------------------- +package # hide from PAUSE + LWP::Protocol::http::SocketMethods; + +sub ping { + my $self = shift; + !$self->can_read(0); +} + +sub increment_response_count { + my $self = shift; + return ++${*$self}{'myhttp_response_count'}; +} + +#----------------------------------------------------------- +package # hide from PAUSE + LWP::Protocol::http::Socket; + +use parent -norequire, qw(LWP::Protocol::http::SocketMethods Net::HTTP); + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm new file mode 100644 index 0000000000..b7645deee6 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm @@ -0,0 +1,27 @@ +package LWP::Protocol::loopback; + +use strict; + +our $VERSION = '6.37'; + +require HTTP::Response; + +use base qw(LWP::Protocol); + +sub request { + my($self, $request, $proxy, $arg, $size, $timeout) = @_; + + my $response = HTTP::Response->new(200, "OK"); + $response->content_type("message/http; msgtype=request"); + + $response->header("Via", "loopback/1.0 $proxy") + if $proxy; + + $response->header("X-Arg", $arg); + $response->header("X-Read-Size", $size); + $response->header("X-Timeout", $timeout); + + return $self->collect_once($arg, $response, $request->as_string); +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm new file mode 100644 index 0000000000..d970edafbe --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm @@ -0,0 +1,184 @@ +package LWP::Protocol::mailto; + +# This module implements the mailto protocol. It is just a simple +# frontend to the Unix sendmail program except on MacOS, where it uses +# Mail::Internet. + +require HTTP::Request; +require HTTP::Response; +require HTTP::Status; + +use Carp; +use strict; + +our $VERSION = '6.37'; + +use base qw(LWP::Protocol); +our $SENDMAIL; + +unless ($SENDMAIL = $ENV{SENDMAIL}) { + for my $sm (qw(/usr/sbin/sendmail + /usr/lib/sendmail + /usr/ucblib/sendmail + )) + { + if (-x $sm) { + $SENDMAIL = $sm; + last; + } + } + die "Can't find the 'sendmail' program" unless $SENDMAIL; +} + +sub request +{ + my($self, $request, $proxy, $arg, $size) = @_; + + my ($mail, $addr) if $^O eq "MacOS"; + my @text = () if $^O eq "MacOS"; + + # check proxy + if (defined $proxy) + { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy with mail'); + } + + # check method + my $method = $request->method; + + if ($method ne 'POST') { + return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'mailto:' URLs"); + } + + # check url + my $url = $request->uri; + + my $scheme = $url->scheme; + if ($scheme ne 'mailto') { + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "LWP::Protocol::mailto::request called for '$scheme'"); + } + if ($^O eq "MacOS") { + eval { + require Mail::Internet; + }; + if($@) { + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "You don't have MailTools installed"); + } + unless ($ENV{SMTPHOSTS}) { + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "You don't have SMTPHOSTS defined"); + } + } + else { + unless (-x $SENDMAIL) { + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "You don't have $SENDMAIL"); + } + } + if ($^O eq "MacOS") { + $mail = Mail::Internet->new or + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Can't get a Mail::Internet object"); + } + else { + open(SENDMAIL, "| $SENDMAIL -oi -t") or + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Can't run $SENDMAIL: $!"); + } + if ($^O eq "MacOS") { + $addr = $url->encoded822addr; + } + else { + $request = $request->clone; # we modify a copy + my @h = $url->headers; # URL headers override those in the request + while (@h) { + my $k = shift @h; + my $v = shift @h; + next unless defined $v; + if (lc($k) eq "body") { + $request->content($v); + } + else { + $request->push_header($k => $v); + } + } + } + if ($^O eq "MacOS") { + $mail->add(To => $addr); + $mail->add(split(/[:\n]/,$request->headers_as_string)); + } + else { + print SENDMAIL $request->headers_as_string; + print SENDMAIL "\n"; + } + my $content = $request->content; + if (defined $content) { + my $contRef = ref($content) ? $content : \$content; + if (ref($contRef) eq 'SCALAR') { + if ($^O eq "MacOS") { + @text = split("\n",$$contRef); + foreach (@text) { + $_ .= "\n"; + } + } + else { + print SENDMAIL $$contRef; + } + + } + elsif (ref($contRef) eq 'CODE') { + # Callback provides data + my $d; + if ($^O eq "MacOS") { + my $stuff = ""; + while (length($d = &$contRef)) { + $stuff .= $d; + } + @text = split("\n",$stuff); + foreach (@text) { + $_ .= "\n"; + } + } + else { + print SENDMAIL $d; + } + } + } + if ($^O eq "MacOS") { + $mail->body(\@text); + unless ($mail->smtpsend) { + return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Mail::Internet->smtpsend unable to send message to <$addr>"); + } + } + else { + unless (close(SENDMAIL)) { + my $err = $! ? "$!" : "Exit status $?"; + return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "$SENDMAIL: $err"); + } + } + + + my $response = HTTP::Response->new(HTTP::Status::RC_ACCEPTED, + "Mail accepted"); + $response->header('Content-Type', 'text/plain'); + if ($^O eq "MacOS") { + $response->header('Server' => "Mail::Internet $Mail::Internet::VERSION"); + $response->content("Message sent to <$addr>\n"); + } + else { + $response->header('Server' => $SENDMAIL); + my $to = $request->header("To"); + $response->content("Message sent to <$to>\n"); + } + + return $response; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm new file mode 100644 index 0000000000..3cbde3f4e0 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm @@ -0,0 +1,150 @@ +package LWP::Protocol::nntp; + +# Implementation of the Network News Transfer Protocol (RFC 977) + +use base qw(LWP::Protocol); + +our $VERSION = '6.37'; + +require HTTP::Response; +require HTTP::Status; +require Net::NNTP; + +use strict; + + +sub request { + my ($self, $request, $proxy, $arg, $size, $timeout) = @_; + + $size = 4096 unless $size; + + # Check for proxy + if (defined $proxy) { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy through NNTP'); + } + + # Check that the scheme is as expected + my $url = $request->uri; + my $scheme = $url->scheme; + unless ($scheme eq 'news' || $scheme eq 'nntp') { + return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "LWP::Protocol::nntp::request called for '$scheme'"); + } + + # check for a valid method + my $method = $request->method; + unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . "$method for '$scheme:' URLs"); + } + + # extract the identifier and check against posting to an article + my $groupart = $url->_group; + my $is_art = $groupart =~ /@/; + + if ($is_art && $method eq 'POST') { + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + "Can't post to an article <$groupart>"); + } + + my $nntp = Net::NNTP->new( + $url->host, + + #Port => 18574, + Timeout => $timeout, + + #Debug => 1, + ); + die "Can't connect to nntp server" unless $nntp; + + # Check the initial welcome message from the NNTP server + if ($nntp->status != 2) { + return HTTP::Response->new(HTTP::Status::RC_SERVICE_UNAVAILABLE, + $nntp->message); + } + my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK"); + + my $mess = $nntp->message; + + # Try to extract server name from greeting message. + # Don't know if this works well for a large class of servers, but + # this works for our server. + $mess =~ s/\s+ready\b.*//; + $mess =~ s/^\S+\s+//; + $response->header(Server => $mess); + + # First we handle posting of articles + if ($method eq 'POST') { + $nntp->quit; + $nntp = undef; + $response->code(HTTP::Status::RC_NOT_IMPLEMENTED); + $response->message("POST not implemented yet"); + return $response; + } + + # The method must be "GET" or "HEAD" by now + if (!$is_art) { + if (!$nntp->group($groupart)) { + $response->code(HTTP::Status::RC_NOT_FOUND); + $response->message($nntp->message); + } + $nntp->quit; + $nntp = undef; + + # HEAD: just check if the group exists + if ($method eq 'GET' && $response->is_success) { + $response->code(HTTP::Status::RC_NOT_IMPLEMENTED); + $response->message("GET newsgroup not implemented yet"); + } + return $response; + } + + # Send command to server to retrieve an article (or just the headers) + my $get = $method eq 'HEAD' ? "head" : "article"; + my $art = $nntp->$get("<$groupart>"); + unless ($art) { + $nntp->quit; + $response->code(HTTP::Status::RC_NOT_FOUND); + $response->message($nntp->message); + $nntp = undef; + return $response; + } + + # Parse headers + my ($key, $val); + local $_; + while ($_ = shift @$art) { + if (/^\s+$/) { + last; # end of headers + } + elsif (/^(\S+):\s*(.*)/) { + $response->push_header($key, $val) if $key; + ($key, $val) = ($1, $2); + } + elsif (/^\s+(.*)/) { + next unless $key; + $val .= $1; + } + else { + unshift(@$art, $_); + last; + } + } + $response->push_header($key, $val) if $key; + + # Ensure that there is a Content-Type header + $response->header("Content-Type", "text/plain") + unless $response->header("Content-Type"); + + # Collect the body + $response = $self->collect_once($arg, $response, join("", @$art)) if @$art; + + # Say goodbye to the server + $nntp->quit; + $nntp = undef; + + $response; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm new file mode 100644 index 0000000000..32f09579bf --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm @@ -0,0 +1,25 @@ +package LWP::Protocol::nogo; +# If you want to disable access to a particular scheme, use this +# class and then call +# LWP::Protocol::implementor(that_scheme, 'LWP::Protocol::nogo'); +# For then on, attempts to access URLs with that scheme will generate +# a 500 error. + +use strict; + +our $VERSION = '6.37'; + +require HTTP::Response; +require HTTP::Status; +use base qw(LWP::Protocol); + +sub request { + my($self, $request) = @_; + my $scheme = $request->uri->scheme; + + return HTTP::Response->new( + HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Access to \'$scheme\' URIs has been disabled" + ); +} +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/RobotUA.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/RobotUA.pm new file mode 100644 index 0000000000..a418fe32fe --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/RobotUA.pm @@ -0,0 +1,312 @@ +package LWP::RobotUA; + +use base qw(LWP::UserAgent); + +our $VERSION = '6.37'; + +require WWW::RobotRules; +require HTTP::Request; +require HTTP::Response; + +use Carp (); +use HTTP::Status (); +use HTTP::Date qw(time2str); +use strict; + + +# +# Additional attributes in addition to those found in LWP::UserAgent: +# +# $self->{'delay'} Required delay between request to the same +# server in minutes. +# +# $self->{'rules'} A WWW::RobotRules object +# + +sub new +{ + my $class = shift; + my %cnf; + if (@_ < 4) { + # legacy args + @cnf{qw(agent from rules)} = @_; + } + else { + %cnf = @_; + } + + Carp::croak('LWP::RobotUA agent required') unless $cnf{agent}; + Carp::croak('LWP::RobotUA from address required') + unless $cnf{from} && $cnf{from} =~ m/\@/; + + my $delay = delete $cnf{delay} || 1; + my $use_sleep = delete $cnf{use_sleep}; + $use_sleep = 1 unless defined($use_sleep); + my $rules = delete $cnf{rules}; + + my $self = LWP::UserAgent->new(%cnf); + $self = bless $self, $class; + + $self->{'delay'} = $delay; # minutes + $self->{'use_sleep'} = $use_sleep; + + if ($rules) { + $rules->agent($cnf{agent}); + $self->{'rules'} = $rules; + } + else { + $self->{'rules'} = WWW::RobotRules->new($cnf{agent}); + } + + $self; +} + + +sub delay { shift->_elem('delay', @_); } +sub use_sleep { shift->_elem('use_sleep', @_); } + + +sub agent +{ + my $self = shift; + my $old = $self->SUPER::agent(@_); + if (@_) { + # Changing our name means to start fresh + $self->{'rules'}->agent($self->{'agent'}); + } + $old; +} + + +sub rules { + my $self = shift; + my $old = $self->_elem('rules', @_); + $self->{'rules'}->agent($self->{'agent'}) if @_; + $old; +} + + +sub no_visits +{ + my($self, $netloc) = @_; + $self->{'rules'}->no_visits($netloc) || 0; +} + +*host_count = \&no_visits; # backwards compatibility with LWP-5.02 + + +sub host_wait +{ + my($self, $netloc) = @_; + return undef unless defined $netloc; + my $last = $self->{'rules'}->last_visit($netloc); + if ($last) { + my $wait = int($self->{'delay'} * 60 - (time - $last)); + $wait = 0 if $wait < 0; + return $wait; + } + return 0; +} + + +sub simple_request +{ + my($self, $request, $arg, $size) = @_; + + # Do we try to access a new server? + my $allowed = $self->{'rules'}->allowed($request->uri); + + if ($allowed < 0) { + # Host is not visited before, or robots.txt expired; fetch "robots.txt" + my $robot_url = $request->uri->clone; + $robot_url->path("robots.txt"); + $robot_url->query(undef); + + # make access to robot.txt legal since this will be a recursive call + $self->{'rules'}->parse($robot_url, ""); + + my $robot_req = HTTP::Request->new('GET', $robot_url); + my $parse_head = $self->parse_head(0); + my $robot_res = $self->request($robot_req); + $self->parse_head($parse_head); + my $fresh_until = $robot_res->fresh_until; + my $content = ""; + if ($robot_res->is_success && $robot_res->content_is_text) { + $content = $robot_res->decoded_content; + $content = "" unless $content && $content =~ /^\s*Disallow\s*:/mi; + } + $self->{'rules'}->parse($robot_url, $content, $fresh_until); + + # recalculate allowed... + $allowed = $self->{'rules'}->allowed($request->uri); + } + + # Check rules + unless ($allowed) { + my $res = HTTP::Response->new( + HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt'); + $res->request( $request ); # bind it to that request + return $res; + } + + my $netloc = eval { local $SIG{__DIE__}; $request->uri->host_port; }; + my $wait = $self->host_wait($netloc); + + if ($wait) { + if ($self->{'use_sleep'}) { + sleep($wait) + } + else { + my $res = HTTP::Response->new( + HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down'); + $res->header('Retry-After', time2str(time + $wait)); + $res->request( $request ); # bind it to that request + return $res; + } + } + + # Perform the request + my $res = $self->SUPER::simple_request($request, $arg, $size); + + $self->{'rules'}->visit($netloc); + + $res; +} + + +sub as_string +{ + my $self = shift; + my @s; + push(@s, "Robot: $self->{'agent'} operated by $self->{'from'} [$self]"); + push(@s, " Minimum delay: " . int($self->{'delay'}*60) . "s"); + push(@s, " Will sleep if too early") if $self->{'use_sleep'}; + push(@s, " Rules = $self->{'rules'}"); + join("\n", @s, ''); +} + +1; + + +__END__ + +=pod + +=head1 NAME + +LWP::RobotUA - a class for well-behaved Web robots + +=head1 SYNOPSIS + + use LWP::RobotUA; + my $ua = LWP::RobotUA->new('my-robot/0.1', 'me@foo.com'); + $ua->delay(10); # be very nice -- max one hit every ten minutes! + ... + + # Then just use it just like a normal LWP::UserAgent: + my $response = $ua->get('http://whatever.int/...'); + ... + +=head1 DESCRIPTION + +This class implements a user agent that is suitable for robot +applications. Robots should be nice to the servers they visit. They +should consult the F</robots.txt> file to ensure that they are welcomed +and they should not make requests too frequently. + +But before you consider writing a robot, take a look at +L<URL:http://www.robotstxt.org/>. + +When you use an I<LWP::RobotUA> object as your user agent, then you do not +really have to think about these things yourself; C<robots.txt> files +are automatically consulted and obeyed, the server isn't queried +too rapidly, and so on. Just send requests +as you do when you are using a normal I<LWP::UserAgent> +object (using C<< $ua->get(...) >>, C<< $ua->head(...) >>, +C<< $ua->request(...) >>, etc.), and this +special agent will make sure you are nice. + +=head1 METHODS + +The LWP::RobotUA is a sub-class of L<LWP::UserAgent> and implements the +same methods. In addition the following methods are provided: + +=head2 new + + my $ua = LWP::RobotUA->new( %options ) + my $ua = LWP::RobotUA->new( $agent, $from ) + my $ua = LWP::RobotUA->new( $agent, $from, $rules ) + +The LWP::UserAgent options C<agent> and C<from> are mandatory. The +options C<delay>, C<use_sleep> and C<rules> initialize attributes +private to the RobotUA. If C<rules> are not provided, then +C<WWW::RobotRules> is instantiated providing an internal database of +F<robots.txt>. + +It is also possible to just pass the value of C<agent>, C<from> and +optionally C<rules> as plain positional arguments. + +=head2 delay + + my $delay = $ua->delay; + $ua->delay( $minutes ); + +Get/set the minimum delay between requests to the same server, in +I<minutes>. The default is C<1> minute. Note that this number doesn't +have to be an integer; for example, this sets the delay to C<10> seconds: + + $ua->delay(10/60); + +=head2 use_sleep + + my $bool = $ua->use_sleep; + $ua->use_sleep( $boolean ); + +Get/set a value indicating whether the UA should L<LWP::RobotUA/sleep> if +requests arrive too fast, defined as C<< $ua->delay >> minutes not passed since +last request to the given server. The default is true. If this value is +false then an internal C<SERVICE_UNAVAILABLE> response will be generated. +It will have a C<Retry-After> header that indicates when it is OK to +send another request to this server. + +=head2 rules + + my $rules = $ua->rules; + $ua->rules( $rules ); + +Set/get which I<WWW::RobotRules> object to use. + +=head2 no_visits + + my $num = $ua->no_visits( $netloc ) + +Returns the number of documents fetched from this server host. Yeah I +know, this method should probably have been named C<num_visits> or +something like that. :-( + +=head2 host_wait + + my $num = $ua->host_wait( $netloc ) + +Returns the number of I<seconds> (from now) you must wait before you can +make a new request to this host. + +=head2 as_string + + my $string = $ua->as_string; + +Returns a string that describes the state of the UA. +Mainly useful for debugging. + +=head1 SEE ALSO + +L<LWP::UserAgent>, L<WWW::RobotRules> + +=head1 COPYRIGHT + +Copyright 1996-2004 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Simple.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Simple.pm new file mode 100644 index 0000000000..f1b91b13ca --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Simple.pm @@ -0,0 +1,267 @@ +package LWP::Simple; + +use strict; + +our $VERSION = '6.37'; + +require Exporter; + +our @EXPORT = qw(get head getprint getstore mirror); +our @EXPORT_OK = qw($ua); + +# I really hate this. It was a bad idea to do it in the first place. +# Wonder how to get rid of it??? (It even makes LWP::Simple 7% slower +# for trivial tests) +use HTTP::Status; +push(@EXPORT, @HTTP::Status::EXPORT); + +sub import +{ + my $pkg = shift; + my $callpkg = caller; + Exporter::export($pkg, $callpkg, @_); +} + +use LWP::UserAgent (); +use HTTP::Date (); + +our $ua = LWP::UserAgent->new; # we create a global UserAgent object +$ua->agent("LWP::Simple/$VERSION "); +$ua->env_proxy; + +sub get ($) +{ + my $response = $ua->get(shift); + return $response->decoded_content if $response->is_success; + return undef; +} + + +sub head ($) +{ + my($url) = @_; + my $request = HTTP::Request->new(HEAD => $url); + my $response = $ua->request($request); + + if ($response->is_success) { + return $response unless wantarray; + return (scalar $response->header('Content-Type'), + scalar $response->header('Content-Length'), + HTTP::Date::str2time($response->header('Last-Modified')), + HTTP::Date::str2time($response->header('Expires')), + scalar $response->header('Server'), + ); + } + return; +} + + +sub getprint ($) +{ + my($url) = @_; + my $request = HTTP::Request->new(GET => $url); + local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR + my $callback = sub { print $_[0] }; + if ($^O eq "MacOS") { + $callback = sub { $_[0] =~ s/\015?\012/\n/g; print $_[0] } + } + my $response = $ua->request($request, $callback); + unless ($response->is_success) { + print STDERR $response->status_line, " <URL:$url>\n"; + } + $response->code; +} + + +sub getstore ($$) +{ + my($url, $file) = @_; + my $request = HTTP::Request->new(GET => $url); + my $response = $ua->request($request, $file); + + $response->code; +} + + +sub mirror ($$) +{ + my($url, $file) = @_; + my $response = $ua->mirror($url, $file); + $response->code; +} + + +1; + +__END__ + +=pod + +=head1 NAME + +LWP::Simple - simple procedural interface to LWP + +=head1 SYNOPSIS + + perl -MLWP::Simple -e 'getprint "http://www.sn.no"' + + use LWP::Simple; + $content = get("http://www.sn.no/"); + die "Couldn't get it!" unless defined $content; + + if (mirror("http://www.sn.no/", "foo") == RC_NOT_MODIFIED) { + ... + } + + if (is_success(getprint("http://www.sn.no/"))) { + ... + } + +=head1 DESCRIPTION + +This module is meant for people who want a simplified view of the +libwww-perl library. It should also be suitable for one-liners. If +you need more control or access to the header fields in the requests +sent and responses received, then you should use the full object-oriented +interface provided by the L<LWP::UserAgent> module. + +The module will also export the L<LWP::UserAgent> object as C<$ua> if you +ask for it explicitly. + +The user agent created by this module will identify itself as +C<LWP::Simple/#.##> +and will initialize its proxy defaults from the environment (by +calling C<< $ua->env_proxy >>). + +=head1 FUNCTIONS + +The following functions are provided (and exported) by this module: + +=head2 get + + my $res = get($url); + +The get() function will fetch the document identified by the given URL +and return it. It returns C<undef> if it fails. The C<$url> argument can +be either a string or a reference to a L<URI> object. + +You will not be able to examine the response code or response headers +(like C<Content-Type>) when you are accessing the web using this +function. If you need that information you should use the full OO +interface (see L<LWP::UserAgent>). + +=head2 head + + my $res = head($url); + +Get document headers. Returns the following 5 values if successful: +($content_type, $document_length, $modified_time, $expires, $server) + +Returns an empty list if it fails. In scalar context returns TRUE if +successful. + +=head2 getprint + + my $code = getprint($url); + +Get and print a document identified by a URL. The document is printed +to the selected default filehandle for output (normally STDOUT) as +data is received from the network. If the request fails, then the +status code and message are printed on STDERR. The return value is +the HTTP response code. + +=head2 getstore + + my $code = getstore($url, $file) + +Gets a document identified by a URL and stores it in the file. The +return value is the HTTP response code. + +=head2 mirror + + my $code = mirror($url, $file); + +Get and store a document identified by a URL, using +I<If-modified-since>, and checking the I<Content-Length>. Returns +the HTTP response code. + +=head1 STATUS CONSTANTS + +This module also exports the L<HTTP::Status> constants and procedures. +You can use them when you check the response code from L<LWP::Simple/getprint>, +L<LWP::Simple/getstore> or L<LWP::Simple/mirror>. The constants are: + + RC_CONTINUE + RC_SWITCHING_PROTOCOLS + RC_OK + RC_CREATED + RC_ACCEPTED + RC_NON_AUTHORITATIVE_INFORMATION + RC_NO_CONTENT + RC_RESET_CONTENT + RC_PARTIAL_CONTENT + RC_MULTIPLE_CHOICES + RC_MOVED_PERMANENTLY + RC_MOVED_TEMPORARILY + RC_SEE_OTHER + RC_NOT_MODIFIED + RC_USE_PROXY + RC_BAD_REQUEST + RC_UNAUTHORIZED + RC_PAYMENT_REQUIRED + RC_FORBIDDEN + RC_NOT_FOUND + RC_METHOD_NOT_ALLOWED + RC_NOT_ACCEPTABLE + RC_PROXY_AUTHENTICATION_REQUIRED + RC_REQUEST_TIMEOUT + RC_CONFLICT + RC_GONE + RC_LENGTH_REQUIRED + RC_PRECONDITION_FAILED + RC_REQUEST_ENTITY_TOO_LARGE + RC_REQUEST_URI_TOO_LARGE + RC_UNSUPPORTED_MEDIA_TYPE + RC_INTERNAL_SERVER_ERROR + RC_NOT_IMPLEMENTED + RC_BAD_GATEWAY + RC_SERVICE_UNAVAILABLE + RC_GATEWAY_TIMEOUT + RC_HTTP_VERSION_NOT_SUPPORTED + +=head1 CLASSIFICATION FUNCTIONS + +The L<HTTP::Status> classification functions are: + +=head2 is_success + + my $bool = is_success($rc); + +True if response code indicated a successful request. + +=head2 is_error + + my $bool = is_error($rc) + +True if response code indicated that an error occurred. + +=head1 CAVEAT + +Note that if you are using both LWP::Simple and the very popular L<CGI> +module, you may be importing a C<head> function from each module, +producing a warning like C<Prototype mismatch: sub main::head ($) vs none>. +Get around this problem by just not importing LWP::Simple's +C<head> function, like so: + + use LWP::Simple qw(!head); + use CGI qw(:standard); # then only CGI.pm defines a head() + +Then if you do need LWP::Simple's C<head> function, you can just call +it as C<LWP::Simple::head($url)>. + +=head1 SEE ALSO + +L<LWP>, L<lwpcook>, L<LWP::UserAgent>, L<HTTP::Status>, L<lwp-request>, +L<lwp-mirror> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/UserAgent.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/UserAgent.pm new file mode 100644 index 0000000000..58f09e0b2a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/UserAgent.pm @@ -0,0 +1,2011 @@ +package LWP::UserAgent; + +use strict; + +use base qw(LWP::MemberMixin); + +use Carp (); +use HTTP::Request (); +use HTTP::Response (); +use HTTP::Date (); + +use LWP (); +use LWP::Protocol (); + +use Scalar::Util qw(blessed); +use Try::Tiny qw(try catch); + +our $VERSION = '6.37'; + +sub new +{ + # Check for common user mistake + Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference") + if ref($_[1]) eq 'HASH'; + + my($class, %cnf) = @_; + + my $agent = delete $cnf{agent}; + my $from = delete $cnf{from}; + my $def_headers = delete $cnf{default_headers}; + my $timeout = delete $cnf{timeout}; + $timeout = 3*60 unless defined $timeout; + my $local_address = delete $cnf{local_address}; + my $ssl_opts = delete $cnf{ssl_opts} || {}; + unless (exists $ssl_opts->{verify_hostname}) { + # The processing of HTTPS_CA_* below is for compatibility with Crypt::SSLeay + if (exists $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME}) { + $ssl_opts->{verify_hostname} = $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME}; + } + elsif ($ENV{HTTPS_CA_FILE} || $ENV{HTTPS_CA_DIR}) { + # Crypt-SSLeay compatibility (verify peer certificate; but not the hostname) + $ssl_opts->{verify_hostname} = 0; + $ssl_opts->{SSL_verify_mode} = 1; + } + else { + $ssl_opts->{verify_hostname} = 1; + } + } + unless (exists $ssl_opts->{SSL_ca_file}) { + if (my $ca_file = $ENV{PERL_LWP_SSL_CA_FILE} || $ENV{HTTPS_CA_FILE}) { + $ssl_opts->{SSL_ca_file} = $ca_file; + } + } + unless (exists $ssl_opts->{SSL_ca_path}) { + if (my $ca_path = $ENV{PERL_LWP_SSL_CA_PATH} || $ENV{HTTPS_CA_DIR}) { + $ssl_opts->{SSL_ca_path} = $ca_path; + } + } + my $use_eval = delete $cnf{use_eval}; + $use_eval = 1 unless defined $use_eval; + my $parse_head = delete $cnf{parse_head}; + $parse_head = 1 unless defined $parse_head; + my $send_te = delete $cnf{send_te}; + $send_te = 1 unless defined $send_te; + my $show_progress = delete $cnf{show_progress}; + my $max_size = delete $cnf{max_size}; + my $max_redirect = delete $cnf{max_redirect}; + $max_redirect = 7 unless defined $max_redirect; + my $env_proxy = exists $cnf{env_proxy} ? delete $cnf{env_proxy} : $ENV{PERL_LWP_ENV_PROXY}; + my $no_proxy = exists $cnf{no_proxy} ? delete $cnf{no_proxy} : []; + Carp::croak(qq{no_proxy must be an arrayref, not $no_proxy!}) if ref $no_proxy ne 'ARRAY'; + + my $cookie_jar = delete $cnf{cookie_jar}; + my $conn_cache = delete $cnf{conn_cache}; + my $keep_alive = delete $cnf{keep_alive}; + + Carp::croak("Can't mix conn_cache and keep_alive") + if $conn_cache && $keep_alive; + + my $protocols_allowed = delete $cnf{protocols_allowed}; + my $protocols_forbidden = delete $cnf{protocols_forbidden}; + + my $requests_redirectable = delete $cnf{requests_redirectable}; + $requests_redirectable = ['GET', 'HEAD'] + unless defined $requests_redirectable; + + # Actually ""s are just as good as 0's, but for concision we'll just say: + Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!") + if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY'; + Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!") + if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY'; + Carp::croak("requests_redirectable has to be an arrayref or 0, not \"$requests_redirectable\"!") + if $requests_redirectable and ref($requests_redirectable) ne 'ARRAY'; + + if (%cnf && $^W) { + Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}"); + } + + my $self = bless { + def_headers => $def_headers, + timeout => $timeout, + local_address => $local_address, + ssl_opts => $ssl_opts, + use_eval => $use_eval, + show_progress => $show_progress, + max_size => $max_size, + max_redirect => $max_redirect, + # We set proxy later as we do validation on the values + proxy => {}, + no_proxy => [ @{ $no_proxy } ], + protocols_allowed => $protocols_allowed, + protocols_forbidden => $protocols_forbidden, + requests_redirectable => $requests_redirectable, + send_te => $send_te, + }, $class; + + $self->agent(defined($agent) ? $agent : $class->_agent) + if defined($agent) || !$def_headers || !$def_headers->header("User-Agent"); + $self->from($from) if $from; + $self->cookie_jar($cookie_jar) if $cookie_jar; + $self->parse_head($parse_head); + $self->env_proxy if $env_proxy; + + if (exists $cnf{proxy}) { + Carp::croak(qq{proxy must be an arrayref, not $cnf{proxy}!}) + if ref $cnf{proxy} ne 'ARRAY'; + $self->proxy($cnf{proxy}); + } + + $self->protocols_allowed( $protocols_allowed ) if $protocols_allowed; + $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden; + + if ($keep_alive) { + $conn_cache ||= { total_capacity => $keep_alive }; + } + $self->conn_cache($conn_cache) if $conn_cache; + + return $self; +} + + +sub send_request +{ + my($self, $request, $arg, $size) = @_; + my($method, $url) = ($request->method, $request->uri); + my $scheme = $url->scheme; + + local($SIG{__DIE__}); # protect against user defined die handlers + + $self->progress("begin", $request); + + my $response = $self->run_handlers("request_send", $request); + + unless ($response) { + my $protocol; + + { + # Honor object-specific restrictions by forcing protocol objects + # into class LWP::Protocol::nogo. + my $x; + if($x = $self->protocols_allowed) { + if (grep lc($_) eq $scheme, @$x) { + } + else { + require LWP::Protocol::nogo; + $protocol = LWP::Protocol::nogo->new; + } + } + elsif ($x = $self->protocols_forbidden) { + if(grep lc($_) eq $scheme, @$x) { + require LWP::Protocol::nogo; + $protocol = LWP::Protocol::nogo->new; + } + } + # else fall thru and create the protocol object normally + } + + # Locate protocol to use + my $proxy = $request->{proxy}; + if ($proxy) { + $scheme = $proxy->scheme; + } + + unless ($protocol) { + try { + $protocol = LWP::Protocol::create($scheme, $self); + } + catch { + my $error = $_; + $error =~ s/ at .* line \d+.*//s; # remove file/line number + $response = _new_response($request, HTTP::Status::RC_NOT_IMPLEMENTED, $error); + if ($scheme eq "https") { + $response->message($response->message . " (LWP::Protocol::https not installed)"); + $response->content_type("text/plain"); + $response->content(<<EOT); +LWP will support https URLs if the LWP::Protocol::https module +is installed. +EOT + } + }; + } + + if (!$response && $self->{use_eval}) { + # we eval, and turn dies into responses below + try { + $response = $protocol->request($request, $proxy, $arg, $size, $self->{timeout}) || die "No response returned by $protocol"; + } + catch { + my $error = $_; + if (blessed($error) && $error->isa("HTTP::Response")) { + $response = $error; + $response->request($request); + } + else { + my $full = $error; + (my $status = $error) =~ s/\n.*//s; + $status =~ s/ at .* line \d+.*//s; # remove file/line number + my $code = ($status =~ s/^(\d\d\d)\s+//) ? $1 : HTTP::Status::RC_INTERNAL_SERVER_ERROR; + $response = _new_response($request, $code, $status, $full); + } + }; + } + elsif (!$response) { + $response = $protocol->request($request, $proxy, + $arg, $size, $self->{timeout}); + # XXX: Should we die unless $response->is_success ??? + } + } + + $response->request($request); # record request for reference + $response->header("Client-Date" => HTTP::Date::time2str(time)); + + $self->run_handlers("response_done", $response); + + $self->progress("end", $response); + return $response; +} + + +sub prepare_request +{ + my($self, $request) = @_; + die "Method missing" unless $request->method; + my $url = $request->uri; + die "URL missing" unless $url; + die "URL must be absolute" unless $url->scheme; + + $self->run_handlers("request_preprepare", $request); + + if (my $def_headers = $self->{def_headers}) { + for my $h ($def_headers->header_field_names) { + $request->init_header($h => [$def_headers->header($h)]); + } + } + + $self->run_handlers("request_prepare", $request); + + return $request; +} + + +sub simple_request +{ + my($self, $request, $arg, $size) = @_; + + # sanity check the request passed in + if (defined $request) { + if (ref $request) { + Carp::croak("You need a request object, not a " . ref($request) . " object") + if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or + !$request->can('method') or !$request->can('uri'); + } + else { + Carp::croak("You need a request object, not '$request'"); + } + } + else { + Carp::croak("No request object passed in"); + } + + my $error; + try { + $request = $self->prepare_request($request); + } + catch { + $error = $_; + $error =~ s/ at .* line \d+.*//s; # remove file/line number + }; + + if ($error) { + return _new_response($request, HTTP::Status::RC_BAD_REQUEST, $error); + } + return $self->send_request($request, $arg, $size); +} + + +sub request { + my ($self, $request, $arg, $size, $previous) = @_; + + my $response = $self->simple_request($request, $arg, $size); + $response->previous($previous) if $previous; + + if ($response->redirects >= $self->{max_redirect}) { + $response->header("Client-Warning" => + "Redirect loop detected (max_redirect = $self->{max_redirect})" + ); + return $response; + } + + if (my $req = $self->run_handlers("response_redirect", $response)) { + return $self->request($req, $arg, $size, $response); + } + + my $code = $response->code; + + if ( $code == HTTP::Status::RC_MOVED_PERMANENTLY + or $code == HTTP::Status::RC_FOUND + or $code == HTTP::Status::RC_SEE_OTHER + or $code == HTTP::Status::RC_TEMPORARY_REDIRECT) + { + my $referral = $request->clone; + + # These headers should never be forwarded + $referral->remove_header('Host', 'Cookie'); + + if ( $referral->header('Referer') + && $request->uri->scheme eq 'https' + && $referral->uri->scheme eq 'http') + { + # RFC 2616, section 15.1.3. + # https -> http redirect, suppressing Referer + $referral->remove_header('Referer'); + } + + if ( $code == HTTP::Status::RC_SEE_OTHER + || $code == HTTP::Status::RC_FOUND) + { + my $method = uc($referral->method); + unless ($method eq "GET" || $method eq "HEAD") { + $referral->method("GET"); + $referral->content(""); + $referral->remove_content_headers; + } + } + + # And then we update the URL based on the Location:-header. + my $referral_uri = $response->header('Location'); + { + # Some servers erroneously return a relative URL for redirects, + # so make it absolute if it not already is. + local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; + my $base = $response->base; + $referral_uri = "" unless defined $referral_uri; + $referral_uri + = $HTTP::URI_CLASS->new($referral_uri, $base)->abs($base); + } + $referral->uri($referral_uri); + + return $response unless $self->redirect_ok($referral, $response); + return $self->request($referral, $arg, $size, $response); + + } + elsif ($code == HTTP::Status::RC_UNAUTHORIZED + || $code == HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED) + { + my $proxy = ($code == HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED); + my $ch_header + = $proxy || $request->method eq 'CONNECT' + ? "Proxy-Authenticate" + : "WWW-Authenticate"; + my @challenges = $response->header($ch_header); + unless (@challenges) { + $response->header( + "Client-Warning" => "Missing Authenticate header"); + return $response; + } + + require HTTP::Headers::Util; + CHALLENGE: for my $challenge (@challenges) { + $challenge =~ tr/,/;/; # "," is used to separate auth-params!! + ($challenge) = HTTP::Headers::Util::split_header_words($challenge); + my $scheme = shift(@$challenge); + shift(@$challenge); # no value + $challenge = {@$challenge}; # make rest into a hash + + unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) { + $response->header( + "Client-Warning" => "Bad authentication scheme '$scheme'"); + return $response; + } + $scheme = $1; # untainted now + my $class = "LWP::Authen::\u$scheme"; + $class =~ tr/-/_/; + + no strict 'refs'; + unless (%{"$class\::"}) { + # try to load it + my $error; + try { + (my $req = $class) =~ s{::}{/}g; + $req .= '.pm' unless $req =~ /\.pm$/; + require $req; + } + catch { + $error = $_; + }; + if ($error) { + if ($error =~ /^Can\'t locate/) { + $response->header("Client-Warning" => + "Unsupported authentication scheme '$scheme'"); + } + else { + $response->header("Client-Warning" => $error); + } + next CHALLENGE; + } + } + unless ($class->can("authenticate")) { + $response->header("Client-Warning" => + "Unsupported authentication scheme '$scheme'"); + next CHALLENGE; + } + return $class->authenticate($self, $proxy, $challenge, $response, + $request, $arg, $size); + } + return $response; + } + return $response; +} + +# +# Now the shortcuts... +# +sub get { + require HTTP::Request::Common; + my($self, @parameters) = @_; + my @suff = $self->_process_colonic_headers(\@parameters,1); + return $self->request( HTTP::Request::Common::GET( @parameters ), @suff ); +} + +sub _has_raw_content { + my $self = shift; + shift; # drop url + + # taken from HTTP::Request::Common::request_type_with_data + my $content; + $content = shift if @_ and ref $_[0]; + my($k, $v); + while (($k,$v) = splice(@_, 0, 2)) { + if (lc($k) eq 'content') { + $content = $v; + } + } + + # We were given Content => 'string' ... + if (defined $content && ! ref ($content)) { + return 1; + } + + return; +} + +sub _maybe_copy_default_content_type { + my ($self, $req, @parameters) = @_; + + # If we have a default Content-Type and someone passes in a POST/PUT + # with Content => 'some-string-value', use that Content-Type instead + # of x-www-form-urlencoded + my $ct = $self->default_header('Content-Type'); + return unless defined $ct && $self->_has_raw_content(@parameters); + + $req->header('Content-Type' => $ct); +} + +sub post { + require HTTP::Request::Common; + my($self, @parameters) = @_; + my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1)); + my $req = HTTP::Request::Common::POST(@parameters); + $self->_maybe_copy_default_content_type($req, @parameters); + return $self->request($req, @suff); +} + + +sub head { + require HTTP::Request::Common; + my($self, @parameters) = @_; + my @suff = $self->_process_colonic_headers(\@parameters,1); + return $self->request( HTTP::Request::Common::HEAD( @parameters ), @suff ); +} + + +sub put { + require HTTP::Request::Common; + my($self, @parameters) = @_; + my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1)); + my $req = HTTP::Request::Common::PUT(@parameters); + $self->_maybe_copy_default_content_type($req, @parameters); + return $self->request($req, @suff); +} + + +sub delete { + require HTTP::Request::Common; + my($self, @parameters) = @_; + my @suff = $self->_process_colonic_headers(\@parameters,1); + return $self->request( HTTP::Request::Common::DELETE( @parameters ), @suff ); +} + + +sub _process_colonic_headers { + # Process :content_cb / :content_file / :read_size_hint headers. + my($self, $args, $start_index) = @_; + + my($arg, $size); + for(my $i = $start_index; $i < @$args; $i += 2) { + next unless defined $args->[$i]; + + #printf "Considering %s => %s\n", $args->[$i], $args->[$i + 1]; + + if($args->[$i] eq ':content_cb') { + # Some sanity-checking... + $arg = $args->[$i + 1]; + Carp::croak("A :content_cb value can't be undef") unless defined $arg; + Carp::croak("A :content_cb value must be a coderef") + unless ref $arg and UNIVERSAL::isa($arg, 'CODE'); + + } + elsif ($args->[$i] eq ':content_file') { + $arg = $args->[$i + 1]; + + # Some sanity-checking... + Carp::croak("A :content_file value can't be undef") + unless defined $arg; + Carp::croak("A :content_file value can't be a reference") + if ref $arg; + Carp::croak("A :content_file value can't be \"\"") + unless length $arg; + + } + elsif ($args->[$i] eq ':read_size_hint') { + $size = $args->[$i + 1]; + # Bother checking it? + + } + else { + next; + } + splice @$args, $i, 2; + $i -= 2; + } + + # And return a suitable suffix-list for request(REQ,...) + + return unless defined $arg; + return $arg, $size if defined $size; + return $arg; +} + + +sub is_online { + my $self = shift; + return 1 if $self->get("http://www.msftncsi.com/ncsi.txt")->content eq "Microsoft NCSI"; + return 1 if $self->get("http://www.apple.com")->content =~ m,<title>Apple</title>,; + return 0; +} + + +my @ANI = qw(- \ | /); + +sub progress { + my($self, $status, $m) = @_; + return unless $self->{show_progress}; + + local($,, $\); + if ($status eq "begin") { + print STDERR "** ", $m->method, " ", $m->uri, " ==> "; + $self->{progress_start} = time; + $self->{progress_lastp} = ""; + $self->{progress_ani} = 0; + } + elsif ($status eq "end") { + delete $self->{progress_lastp}; + delete $self->{progress_ani}; + print STDERR $m->status_line; + my $t = time - delete $self->{progress_start}; + print STDERR " (${t}s)" if $t; + print STDERR "\n"; + } + elsif ($status eq "tick") { + print STDERR "$ANI[$self->{progress_ani}++]\b"; + $self->{progress_ani} %= @ANI; + } + else { + my $p = sprintf "%3.0f%%", $status * 100; + return if $p eq $self->{progress_lastp}; + print STDERR "$p\b\b\b\b"; + $self->{progress_lastp} = $p; + } + STDERR->flush; +} + + +# +# This whole allow/forbid thing is based on man 1 at's way of doing things. +# +sub is_protocol_supported +{ + my($self, $scheme) = @_; + if (ref $scheme) { + # assume we got a reference to an URI object + $scheme = $scheme->scheme; + } + else { + Carp::croak("Illegal scheme '$scheme' passed to is_protocol_supported") + if $scheme =~ /\W/; + $scheme = lc $scheme; + } + + my $x; + if(ref($self) and $x = $self->protocols_allowed) { + return 0 unless grep lc($_) eq $scheme, @$x; + } + elsif (ref($self) and $x = $self->protocols_forbidden) { + return 0 if grep lc($_) eq $scheme, @$x; + } + + local($SIG{__DIE__}); # protect against user defined die handlers + $x = LWP::Protocol::implementor($scheme); + return 1 if $x and $x ne 'LWP::Protocol::nogo'; + return 0; +} + + +sub protocols_allowed { shift->_elem('protocols_allowed' , @_) } +sub protocols_forbidden { shift->_elem('protocols_forbidden' , @_) } +sub requests_redirectable { shift->_elem('requests_redirectable', @_) } + + +sub redirect_ok +{ + # RFC 2616, section 10.3.2 and 10.3.3 say: + # If the 30[12] status code is received in response to a request other + # than GET or HEAD, the user agent MUST NOT automatically redirect the + # request unless it can be confirmed by the user, since this might + # change the conditions under which the request was issued. + + # Note that this routine used to be just: + # return 0 if $_[1]->method eq "POST"; return 1; + + my($self, $new_request, $response) = @_; + my $method = $response->request->method; + return 0 unless grep $_ eq $method, + @{ $self->requests_redirectable || [] }; + + if ($new_request->uri->scheme eq 'file') { + $response->header("Client-Warning" => + "Can't redirect to a file:// URL!"); + return 0; + } + + # Otherwise it's apparently okay... + return 1; +} + +sub credentials { + my $self = shift; + my $netloc = lc(shift || ''); + my $realm = shift || ""; + my $old = $self->{basic_authentication}{$netloc}{$realm}; + if (@_) { + $self->{basic_authentication}{$netloc}{$realm} = [@_]; + } + return unless $old; + return @$old if wantarray; + return join(":", @$old); +} + +sub get_basic_credentials +{ + my($self, $realm, $uri, $proxy) = @_; + return if $proxy; + return $self->credentials($uri->host_port, $realm); +} + + +sub timeout { shift->_elem('timeout', @_); } +sub local_address{ shift->_elem('local_address',@_); } +sub max_size { shift->_elem('max_size', @_); } +sub max_redirect { shift->_elem('max_redirect', @_); } +sub show_progress{ shift->_elem('show_progress', @_); } +sub send_te { shift->_elem('send_te', @_); } + +sub ssl_opts { + my $self = shift; + if (@_ == 1) { + my $k = shift; + return $self->{ssl_opts}{$k}; + } + if (@_) { + my $old; + while (@_) { + my($k, $v) = splice(@_, 0, 2); + $old = $self->{ssl_opts}{$k} unless @_; + if (defined $v) { + $self->{ssl_opts}{$k} = $v; + } + else { + delete $self->{ssl_opts}{$k}; + } + } + %{$self->{ssl_opts}} = (%{$self->{ssl_opts}}, @_); + return $old; + } + + return keys %{$self->{ssl_opts}}; +} + +sub parse_head { + my $self = shift; + if (@_) { + my $flag = shift; + my $parser; + my $old = $self->set_my_handler("response_header", $flag ? sub { + my($response, $ua) = @_; + require HTML::HeadParser; + $parser = HTML::HeadParser->new; + $parser->xml_mode(1) if $response->content_is_xhtml; + $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40; + + push(@{$response->{handlers}{response_data}}, { + callback => sub { + return unless $parser; + unless ($parser->parse($_[3])) { + my $h = $parser->header; + my $r = $_[0]; + for my $f ($h->header_field_names) { + $r->init_header($f, [$h->header($f)]); + } + undef($parser); + } + }, + }); + + } : undef, + m_media_type => "html", + ); + return !!$old; + } + else { + return !!$self->get_my_handler("response_header"); + } +} + +sub cookie_jar { + my $self = shift; + my $old = $self->{cookie_jar}; + if (@_) { + my $jar = shift; + if (ref($jar) eq "HASH") { + require HTTP::Cookies; + $jar = HTTP::Cookies->new(%$jar); + } + $self->{cookie_jar} = $jar; + $self->set_my_handler("request_prepare", + $jar ? sub { $jar->add_cookie_header($_[0]); } : undef, + ); + $self->set_my_handler("response_done", + $jar ? sub { $jar->extract_cookies($_[0]); } : undef, + ); + } + $old; +} + +sub default_headers { + my $self = shift; + my $old = $self->{def_headers} ||= HTTP::Headers->new; + if (@_) { + Carp::croak("default_headers not set to HTTP::Headers compatible object") + unless @_ == 1 && $_[0]->can("header_field_names"); + $self->{def_headers} = shift; + } + return $old; +} + +sub default_header { + my $self = shift; + return $self->default_headers->header(@_); +} + +sub _agent { "libwww-perl/$VERSION" } + +sub agent { + my $self = shift; + if (@_) { + my $agent = shift; + if ($agent) { + $agent .= $self->_agent if $agent =~ /\s+$/; + } + else { + undef($agent) + } + return $self->default_header("User-Agent", $agent); + } + return $self->default_header("User-Agent"); +} + +sub from { # legacy + my $self = shift; + return $self->default_header("From", @_); +} + + +sub conn_cache { + my $self = shift; + my $old = $self->{conn_cache}; + if (@_) { + my $cache = shift; + if (ref($cache) eq "HASH") { + require LWP::ConnCache; + $cache = LWP::ConnCache->new(%$cache); + } + $self->{conn_cache} = $cache; + } + $old; +} + + +sub add_handler { + my($self, $phase, $cb, %spec) = @_; + $spec{line} ||= join(":", (caller)[1,2]); + my $conf = $self->{handlers}{$phase} ||= do { + require HTTP::Config; + HTTP::Config->new; + }; + $conf->add(%spec, callback => $cb); +} + +sub set_my_handler { + my($self, $phase, $cb, %spec) = @_; + $spec{owner} = (caller(1))[3] unless exists $spec{owner}; + $self->remove_handler($phase, %spec); + $spec{line} ||= join(":", (caller)[1,2]); + $self->add_handler($phase, $cb, %spec) if $cb; +} + +sub get_my_handler { + my $self = shift; + my $phase = shift; + my $init = pop if @_ % 2; + my %spec = @_; + my $conf = $self->{handlers}{$phase}; + unless ($conf) { + return unless $init; + require HTTP::Config; + $conf = $self->{handlers}{$phase} = HTTP::Config->new; + } + $spec{owner} = (caller(1))[3] unless exists $spec{owner}; + my @h = $conf->find(%spec); + if (!@h && $init) { + if (ref($init) eq "CODE") { + $init->(\%spec); + } + elsif (ref($init) eq "HASH") { + while (my($k, $v) = each %$init) { + $spec{$k} = $v; + } + } + $spec{callback} ||= sub {}; + $spec{line} ||= join(":", (caller)[1,2]); + $conf->add(\%spec); + return \%spec; + } + return wantarray ? @h : $h[0]; +} + +sub remove_handler { + my($self, $phase, %spec) = @_; + if ($phase) { + my $conf = $self->{handlers}{$phase} || return; + my @h = $conf->remove(%spec); + delete $self->{handlers}{$phase} if $conf->empty; + return @h; + } + + return unless $self->{handlers}; + return map $self->remove_handler($_), sort keys %{$self->{handlers}}; +} + +sub handlers { + my($self, $phase, $o) = @_; + my @h; + if ($o->{handlers} && $o->{handlers}{$phase}) { + push(@h, @{$o->{handlers}{$phase}}); + } + if (my $conf = $self->{handlers}{$phase}) { + push(@h, $conf->matching($o)); + } + return @h; +} + +sub run_handlers { + my($self, $phase, $o) = @_; + + # here we pass $_[2] to the callbacks, instead of $o, so that they + # can assign to it; e.g. request_prepare is documented to allow + # that + if (defined(wantarray)) { + for my $h ($self->handlers($phase, $o)) { + my $ret = $h->{callback}->($_[2], $self, $h); + return $ret if $ret; + } + return undef; + } + + for my $h ($self->handlers($phase, $o)) { + $h->{callback}->($_[2], $self, $h); + } +} + + +# deprecated +sub use_eval { shift->_elem('use_eval', @_); } +sub use_alarm +{ + Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op") + if @_ > 1 && $^W; + ""; +} + + +sub clone +{ + my $self = shift; + my $copy = bless { %$self }, ref $self; # copy most fields + + delete $copy->{handlers}; + delete $copy->{conn_cache}; + + # copy any plain arrays and hashes; known not to need recursive copy + for my $k (qw(proxy no_proxy requests_redirectable ssl_opts)) { + next unless $copy->{$k}; + if (ref($copy->{$k}) eq "ARRAY") { + $copy->{$k} = [ @{$copy->{$k}} ]; + } + elsif (ref($copy->{$k}) eq "HASH") { + $copy->{$k} = { %{$copy->{$k}} }; + } + } + + if ($self->{def_headers}) { + $copy->{def_headers} = $self->{def_headers}->clone; + } + + # re-enable standard handlers + $copy->parse_head($self->parse_head); + + # no easy way to clone the cookie jar; so let's just remove it for now + $copy->cookie_jar(undef); + + $copy; +} + + +sub mirror +{ + my($self, $url, $file) = @_; + + my $request = HTTP::Request->new('GET', $url); + + # If the file exists, add a cache-related header + if ( -e $file ) { + my ($mtime) = ( stat($file) )[9]; + if ($mtime) { + $request->header( 'If-Modified-Since' => HTTP::Date::time2str($mtime) ); + } + } + my $tmpfile = "$file-$$"; + + my $response = $self->request($request, $tmpfile); + if ( $response->header('X-Died') ) { + die $response->header('X-Died'); + } + + # Only fetching a fresh copy of the would be considered success. + # If the file was not modified, "304" would returned, which + # is considered by HTTP::Status to be a "redirect", /not/ "success" + if ( $response->is_success ) { + my @stat = stat($tmpfile) or die "Could not stat tmpfile '$tmpfile': $!"; + my $file_length = $stat[7]; + my ($content_length) = $response->header('Content-length'); + + if ( defined $content_length and $file_length < $content_length ) { + unlink($tmpfile); + die "Transfer truncated: " . "only $file_length out of $content_length bytes received\n"; + } + elsif ( defined $content_length and $file_length > $content_length ) { + unlink($tmpfile); + die "Content-length mismatch: " . "expected $content_length bytes, got $file_length\n"; + } + # The file was the expected length. + else { + # Replace the stale file with a fresh copy + if ( -e $file ) { + # Some DOSish systems fail to rename if the target exists + chmod 0777, $file; + unlink $file; + } + rename( $tmpfile, $file ) + or die "Cannot rename '$tmpfile' to '$file': $!\n"; + + # make sure the file has the same last modification time + if ( my $lm = $response->last_modified ) { + utime $lm, $lm, $file; + } + } + } + # The local copy is fresh enough, so just delete the temp file + else { + unlink($tmpfile); + } + return $response; +} + + +sub _need_proxy { + my($req, $ua) = @_; + return if exists $req->{proxy}; + my $proxy = $ua->{proxy}{$req->uri->scheme} || return; + if ($ua->{no_proxy}) { + if (my $host = eval { $req->uri->host }) { + for my $domain (@{$ua->{no_proxy}}) { + if ($host =~ /\Q$domain\E$/) { + return; + } + } + } + } + $req->{proxy} = $HTTP::URI_CLASS->new($proxy); +} + + +sub proxy { + my $self = shift; + my $key = shift; + if (!@_ && ref $key eq 'ARRAY') { + die 'odd number of items in proxy arrayref!' unless @{$key} % 2 == 0; + + # This map reads the elements of $key 2 at a time + return + map { $self->proxy($key->[2 * $_], $key->[2 * $_ + 1]) } + (0 .. @{$key} / 2 - 1); + } + return map { $self->proxy($_, @_) } @$key if ref $key; + + Carp::croak("'$key' is not a valid URI scheme") unless $key =~ /^$URI::scheme_re\z/; + my $old = $self->{'proxy'}{$key}; + if (@_) { + my $url = shift; + if (defined($url) && length($url)) { + Carp::croak("Proxy must be specified as absolute URI; '$url' is not") unless $url =~ /^$URI::scheme_re:/; + Carp::croak("Bad http proxy specification '$url'") if $url =~ /^https?:/ && $url !~ m,^https?://[\w[],; + } + $self->{proxy}{$key} = $url; + $self->set_my_handler("request_preprepare", \&_need_proxy) + } + return $old; +} + + +sub env_proxy { + my ($self) = @_; + require Encode; + require Encode::Locale; + my($k,$v); + while(($k, $v) = each %ENV) { + if ($ENV{REQUEST_METHOD}) { + # Need to be careful when called in the CGI environment, as + # the HTTP_PROXY variable is under control of that other guy. + next if $k =~ /^HTTP_/; + $k = "HTTP_PROXY" if $k eq "CGI_HTTP_PROXY"; + } + $k = lc($k); + next unless $k =~ /^(.*)_proxy$/; + $k = $1; + if ($k eq 'no') { + $self->no_proxy(split(/\s*,\s*/, $v)); + } + else { + # Ignore random _proxy variables, allow only valid schemes + next unless $k =~ /^$URI::scheme_re\z/; + # Ignore xxx_proxy variables if xxx isn't a supported protocol + next unless LWP::Protocol::implementor($k); + $self->proxy($k, Encode::decode(locale => $v)); + } + } +} + + +sub no_proxy { + my($self, @no) = @_; + if (@no) { + push(@{ $self->{'no_proxy'} }, @no); + } + else { + $self->{'no_proxy'} = []; + } +} + + +sub _new_response { + my($request, $code, $message, $content) = @_; + $message ||= HTTP::Status::status_message($code); + my $response = HTTP::Response->new($code, $message); + $response->request($request); + $response->header("Client-Date" => HTTP::Date::time2str(time)); + $response->header("Client-Warning" => "Internal response"); + $response->header("Content-Type" => "text/plain"); + $response->content($content || "$code $message\n"); + return $response; +} + + +1; + +__END__ + +=pod + +=head1 NAME + +LWP::UserAgent - Web user agent class + +=head1 SYNOPSIS + + use strict; + use warnings; + use LWP::UserAgent (); + + my $ua = LWP::UserAgent->new; + $ua->timeout(10); + $ua->env_proxy; + + my $response = $ua->get('http://search.cpan.org/'); + + if ($response->is_success) { + print $response->decoded_content; # or whatever + } + else { + die $response->status_line; + } + +=head1 DESCRIPTION + +The L<LWP::UserAgent> is a class implementing a web user agent. +L<LWP::UserAgent> objects can be used to dispatch web requests. + +In normal use the application creates an L<LWP::UserAgent> object, and +then configures it with values for timeouts, proxies, name, etc. It +then creates an instance of L<HTTP::Request> for the request that +needs to be performed. This request is then passed to one of the +request method the UserAgent, which dispatches it using the relevant +protocol, and returns a L<HTTP::Response> object. There are +convenience methods for sending the most common request types: +L<LWP::UserAgent/get>, L<LWP::UserAgent/head>, L<LWP::UserAgent/post>, +L<LWP::UserAgent/put> and L<LWP::UserAgent/delete>. When using these +methods, the creation of the request object is hidden as shown in the +synopsis above. + +The basic approach of the library is to use HTTP-style communication +for all protocol schemes. This means that you will construct +L<HTTP::Request> objects and receive L<HTTP::Response> objects even +for non-HTTP resources like I<gopher> and I<ftp>. In order to achieve +even more similarity to HTTP-style communications, I<gopher> menus and +file directories are converted to HTML documents. + +=head1 CONSTRUCTOR METHODS + +The following constructor methods are available: + +=head2 clone + + my $ua2 = $ua->clone; + +Returns a copy of the L<LWP::UserAgent> object. + +B<CAVEAT>: Please be aware that the clone method does not copy or clone your +C<cookie_jar> attribute. Due to the limited restrictions on what can be used +for your cookie jar, there is no way to clone the attribute. The C<cookie_jar> +attribute will be C<undef> in the new object instance. + +=head2 new + + my $ua = LWP::UserAgent->new( %options ) + +This method constructs a new L<LWP::UserAgent> object and returns it. +Key/value pair arguments may be provided to set up the initial state. +The following options correspond to attribute methods described below: + + KEY DEFAULT + ----------- -------------------- + agent "libwww-perl/#.###" + from undef + conn_cache undef + cookie_jar undef + default_headers HTTP::Headers->new + local_address undef + ssl_opts { verify_hostname => 1 } + max_size undef + max_redirect 7 + parse_head 1 + protocols_allowed undef + protocols_forbidden undef + requests_redirectable ['GET', 'HEAD'] + timeout 180 + proxy undef + no_proxy [] + +The following additional options are also accepted: If the C<env_proxy> option +is passed in with a true value, then proxy settings are read from environment +variables (see L<LWP::UserAgent/env_proxy>). If C<env_proxy> isn't provided, the +C<PERL_LWP_ENV_PROXY> environment variable controls if +L<LWP::UserAgent/env_proxy> is called during initialization. If the +C<keep_alive> option is passed in, then a C<LWP::ConnCache> is set up (see +L<LWP::UserAgent/conn_cache>). The C<keep_alive> value is passed on as the +C<total_capacity> for the connection cache. + +C<proxy> must be set as an arrayref of key/value pairs. C<no_proxy> takes an +arrayref of domains. + +=head1 ATTRIBUTES + +The settings of the configuration attributes modify the behaviour of the +L<LWP::UserAgent> when it dispatches requests. Most of these can also +be initialized by options passed to the constructor method. + +The following attribute methods are provided. The attribute value is +left unchanged if no argument is given. The return value from each +method is the old attribute value. + +=head2 agent + + my $agent = $ua->agent; + $ua->agent('Checkbot/0.4 '); # append the default to the end + $ua->agent('Mozilla/5.0'); + $ua->agent(""); # don't identify + +Get/set the product token that is used to identify the user agent on +the network. The agent value is sent as the C<User-Agent> header in +the requests. + +The default is a string of the form C<libwww-perl/#.###>, where C<#.###> is +substituted with the version number of this library. + +If the provided string ends with space, the default C<libwww-perl/#.###> +string is appended to it. + +The user agent string should be one or more simple product identifiers +with an optional version number separated by the C</> character. + +=head2 conn_cache + + my $cache_obj = $ua->conn_cache; + $ua->conn_cache( $cache_obj ); + +Get/set the L<LWP::ConnCache> object to use. See L<LWP::ConnCache> +for details. + +=head2 cookie_jar + + my $jar = $ua->cookie_jar; + $ua->cookie_jar( $cookie_jar_obj ); + +Get/set the cookie jar object to use. The only requirement is that +the cookie jar object must implement the C<extract_cookies($response)> and +C<add_cookie_header($request)> methods. These methods will then be +invoked by the user agent as requests are sent and responses are +received. Normally this will be a L<HTTP::Cookies> object or some +subclass. + +The default is to have no cookie jar, i.e. never automatically add +C<Cookie> headers to the requests. + +Shortcut: If a reference to a plain hash is passed in, it is replaced with an +instance of L<HTTP::Cookies> that is initialized based on the hash. This form +also automatically loads the L<HTTP::Cookies> module. It means that: + + $ua->cookie_jar({ file => "$ENV{HOME}/.cookies.txt" }); + +is really just a shortcut for: + + require HTTP::Cookies; + $ua->cookie_jar(HTTP::Cookies->new(file => "$ENV{HOME}/.cookies.txt")); + +=head2 credentials + + my $creds = $ua->credentials(); + $ua->credentials( $netloc, $realm ); + $ua->credentials( $netloc, $realm, $uname, $pass ); + $ua->credentials("www.example.com:80", "Some Realm", "foo", "secret"); + +Get/set the user name and password to be used for a realm. + +The C<$netloc> is a string of the form C<< <host>:<port> >>. The username and +password will only be passed to this server. + +=head2 default_header + + $ua->default_header( $field ); + $ua->default_header( $field => $value ); + $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable()); + $ua->default_header('Accept-Language' => "no, en"); + +This is just a shortcut for +C<< $ua->default_headers->header( $field => $value ) >>. + +=head2 default_headers + + my $headers = $ua->default_headers; + $ua->default_headers( $headers_obj ); + +Get/set the headers object that will provide default header values for +any requests sent. By default this will be an empty L<HTTP::Headers> +object. + +=head2 from + + my $from = $ua->from; + $ua->from('foo@bar.com'); + +Get/set the email address for the human user who controls +the requesting user agent. The address should be machine-usable, as +defined in L<RFC2822|https://tools.ietf.org/html/rfc2822>. The C<from> value +is sent as the C<From> header in the requests. + +The default is to not send a C<From> header. See +L<LWP::UserAgent/default_headers> for the more general interface that allow +any header to be defaulted. + + +=head2 local_address + + my $address = $ua->local_address; + $ua->local_address( $address ); + +Get/set the local interface to bind to for network connections. The interface +can be specified as a hostname or an IP address. This value is passed as the +C<LocalAddr> argument to L<IO::Socket::INET>. + +=head2 max_redirect + + my $max = $ua->max_redirect; + $ua->max_redirect( $n ); + +This reads or sets the object's limit of how many times it will obey +redirection responses in a given request cycle. + +By default, the value is C<7>. This means that if you call L<LWP::UserAgent/request> +and the response is a redirect elsewhere which is in turn a +redirect, and so on seven times, then LWP gives up after that seventh +request. + +=head2 max_size + + my $size = $ua->max_size; + $ua->max_size( $bytes ); + +Get/set the size limit for response content. The default is C<undef>, +which means that there is no limit. If the returned response content +is only partial, because the size limit was exceeded, then a +C<Client-Aborted> header will be added to the response. The content +might end up longer than C<max_size> as we abort once appending a +chunk of data makes the length exceed the limit. The C<Content-Length> +header, if present, will indicate the length of the full content and +will normally not be the same as C<< length($res->content) >>. + +=head2 parse_head + + my $bool = $ua->parse_head; + $ua->parse_head( $boolean ); + +Get/set a value indicating whether we should initialize response +headers from the E<lt>head> section of HTML documents. The default is +true. I<Do not turn this off> unless you know what you are doing. + +=head2 protocols_allowed + + my $aref = $ua->protocols_allowed; # get allowed protocols + $ua->protocols_allowed( \@protocols ); # allow ONLY these + $ua->protocols_allowed(undef); # delete the list + $ua->protocols_allowed(['http',]); # ONLY allow http + +By default, an object has neither a C<protocols_allowed> list, nor a +L<LWP::UserAgent/protocols_forbidden> list. + +This reads (or sets) this user agent's list of protocols that the +request methods will exclusively allow. The protocol names are case +insensitive. + +For example: C<< $ua->protocols_allowed( [ 'http', 'https'] ); >> +means that this user agent will I<allow only> those protocols, +and attempts to use this user agent to access URLs with any other +schemes (like C<ftp://...>) will result in a 500 error. + +Note that having a C<protocols_allowed> list causes any +L<LWP::UserAgent/protocols_forbidden> list to be ignored. + +=head2 protocols_forbidden + + my $aref = $ua->protocols_forbidden; # get the forbidden list + $ua->protocols_forbidden(\@protocols); # do not allow these + $ua->protocols_forbidden(['http',]); # All http reqs get a 500 + $ua->protocols_forbidden(undef); # delete the list + +This reads (or sets) this user agent's list of protocols that the +request method will I<not> allow. The protocol names are case +insensitive. + +For example: C<< $ua->protocols_forbidden( [ 'file', 'mailto'] ); >> +means that this user agent will I<not> allow those protocols, and +attempts to use this user agent to access URLs with those schemes +will result in a 500 error. + +=head2 requests_redirectable + + my $aref = $ua->requests_redirectable; + $ua->requests_redirectable( \@requests ); + $ua->requests_redirectable(['GET', 'HEAD',]); # the default + +This reads or sets the object's list of request names that +L<LWP::UserAgent/redirect_ok> will allow redirection for. By default, this +is C<['GET', 'HEAD']>, as per L<RFC 2616|https://tools.ietf.org/html/rfc2616>. +To change to include C<POST>, consider: + + push @{ $ua->requests_redirectable }, 'POST'; + +=head2 send_te + + my $bool = $ua->send_te; + $ua->send_te( $boolean ); + +If true, will send a C<TE> header along with the request. The default is +true. Set it to false to disable the C<TE> header for systems who can't +handle it. + +=head2 show_progress + + my $bool = $ua->show_progress; + $ua->show_progress( $boolean ); + +Get/set a value indicating whether a progress bar should be displayed +on the terminal as requests are processed. The default is false. + +=head2 ssl_opts + + my @keys = $ua->ssl_opts; + my $val = $ua->ssl_opts( $key ); + $ua->ssl_opts( $key => $value ); + +Get/set the options for SSL connections. Without argument return the list +of options keys currently set. With a single argument return the current +value for the given option. With 2 arguments set the option value and return +the old. Setting an option to the value C<undef> removes this option. + +The options that LWP relates to are: + +=over + +=item C<verify_hostname> => $bool + +When TRUE LWP will for secure protocol schemes ensure it connects to servers +that have a valid certificate matching the expected hostname. If FALSE no +checks are made and you can't be sure that you communicate with the expected peer. +The no checks behaviour was the default for libwww-perl-5.837 and earlier releases. + +This option is initialized from the C<PERL_LWP_SSL_VERIFY_HOSTNAME> environment +variable. If this environment variable isn't set; then C<verify_hostname> +defaults to 1. + +=item C<SSL_ca_file> => $path + +The path to a file containing Certificate Authority certificates. +A default setting for this option is provided by checking the environment +variables C<PERL_LWP_SSL_CA_FILE> and C<HTTPS_CA_FILE> in order. + +=item C<SSL_ca_path> => $path + +The path to a directory containing files containing Certificate Authority +certificates. +A default setting for this option is provided by checking the environment +variables C<PERL_LWP_SSL_CA_PATH> and C<HTTPS_CA_DIR> in order. + +=back + +Other options can be set and are processed directly by the SSL Socket implementation +in use. See L<IO::Socket::SSL> or L<Net::SSL> for details. + +The libwww-perl core no longer bundles protocol plugins for SSL. You will need +to install L<LWP::Protocol::https> separately to enable support for processing +https-URLs. + +=head2 timeout + + my $secs = $ua->timeout; + $ua->timeout( $secs ); + +Get/set the timeout value in seconds. The default value is +180 seconds, i.e. 3 minutes. + +The request is aborted if no activity on the connection to the server +is observed for C<timeout> seconds. This means that the time it takes +for the complete transaction and the L<LWP::UserAgent/request> method to +actually return might be longer. + +When a request times out, a response object is still returned. The response +will have a standard HTTP Status Code (500). This response will have the +"Client-Warning" header set to the value of "Internal response". See the +L<LWP::UserAgent/get> method description below for further details. + +=head1 PROXY ATTRIBUTES + +The following methods set up when requests should be passed via a +proxy server. + +=head2 env_proxy + + $ua->env_proxy; + +Load proxy settings from C<*_proxy> environment variables. You might +specify proxies like this (sh-syntax): + + gopher_proxy=http://proxy.my.place/ + wais_proxy=http://proxy.my.place/ + no_proxy="localhost,example.com" + export gopher_proxy wais_proxy no_proxy + +csh or tcsh users should use the C<setenv> command to define these +environment variables. + +On systems with case insensitive environment variables there exists a +name clash between the CGI environment variables and the C<HTTP_PROXY> +environment variable normally picked up by C<env_proxy>. Because of +this C<HTTP_PROXY> is not honored for CGI scripts. The +C<CGI_HTTP_PROXY> environment variable can be used instead. + +=head2 no_proxy + + $ua->no_proxy( @domains ); + $ua->no_proxy('localhost', 'example.com'); + $ua->no_proxy(); # clear the list + +Do not proxy requests to the given domains. Calling C<no_proxy> without +any domains clears the list of domains. + +=head2 proxy + + $ua->proxy(\@schemes, $proxy_url) + $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/'); + + # For a single scheme: + $ua->proxy($scheme, $proxy_url) + $ua->proxy('gopher', 'http://proxy.sn.no:8001/'); + + # To set multiple proxies at once: + $ua->proxy([ + ftp => 'http://ftp.example.com:8001/', + [ 'http', 'https' ] => 'http://http.example.com:8001/', + ]); + +Set/retrieve proxy URL for a scheme. + +The first form specifies that the URL is to be used as a proxy for +access methods listed in the list in the first method argument, +i.e. C<http> and C<ftp>. + +The second form shows a shorthand form for specifying +proxy URL for a single access scheme. + +The third form demonstrates setting multiple proxies at once. This is also +the only form accepted by the constructor. + +=head1 HANDLERS + +Handlers are code that injected at various phases during the +processing of requests. The following methods are provided to manage +the active handlers: + +=head2 add_handler + + $ua->add_handler( $phase => \&cb, %matchspec ) + +Add handler to be invoked in the given processing phase. For how to +specify C<%matchspec> see L<HTTP::Config/"Matching">. + +The possible values C<$phase> and the corresponding callback signatures are: + +=over + +=item response_data => sub { my($response, $ua, $handler, $data) = @_; ... } + +This handler is called for each chunk of data received for the +response. The handler might croak to abort the request. + +This handler needs to return a TRUE value to be called again for +subsequent chunks for the same request. + +=item response_done => sub { my($response, $ua, $handler) = @_; ... } + +The handler is called after the response has been fully received, but +before any redirect handling is attempted. The handler can be used to +extract information or modify the response. + +=item response_header => sub { my($response, $ua, $handler) = @_; ... } + +This handler is called right after the response headers have been +received, but before any content data. The handler might set up +handlers for data and might croak to abort the request. + +The handler might set the C<< $response->{default_add_content} >> value to +control if any received data should be added to the response object +directly. This will initially be false if the C<< $ua->request() >> method +was called with a C<$content_file> or C<$content_cb argument>; otherwise true. + +=item request_prepare => sub { my($request, $ua, $handler) = @_; ... } + +The handler is called before the request is sent and can modify the +request any way it see fit. This can for instance be used to add +certain headers to specific requests. + +The method can assign a new request object to C<$_[0]> to replace the +request that is sent fully. + +The return value from the callback is ignored. If an exception is +raised it will abort the request and make the request method return a +"400 Bad request" response. + +=item request_preprepare => sub { my($request, $ua, $handler) = @_; ... } + +The handler is called before the C<request_prepare> and other standard +initialization of the request. This can be used to set up headers +and attributes that the C<request_prepare> handler depends on. Proxy +initialization should take place here; but in general don't register +handlers for this phase. + +=item request_send => sub { my($request, $ua, $handler) = @_; ... } + +This handler gets a chance of handling requests before they're sent to the +protocol handlers. It should return an L<HTTP::Response> object if it +wishes to terminate the processing; otherwise it should return nothing. + +The C<response_header> and C<response_data> handlers will not be +invoked for this response, but the C<response_done> will be. + +=item response_redirect => sub { my($response, $ua, $handler) = @_; ... } + +The handler is called in C<< $ua->request >> after C<response_done>. If the +handler returns an L<HTTP::Request> object we'll start over with processing +this request instead. + +=back + +For all of these, C<$handler> is a code reference to the handler that +is currently being run. + +=head2 get_my_handler + + $ua->get_my_handler( $phase, %matchspec ); + $ua->get_my_handler( $phase, %matchspec, $init ); + +Will retrieve the matching handler as hash ref. + +If C<$init> is passed as a true value, create and add the +handler if it's not found. If C<$init> is a subroutine reference, then +it's called with the created handler hash as argument. This sub might +populate the hash with extra fields; especially the callback. If +C<$init> is a hash reference, merge the hashes. + +=head2 handlers + + $ua->handlers( $phase, $request ) + $ua->handlers( $phase, $response ) + +Returns the handlers that apply to the given request or response at +the given processing phase. + +=head2 remove_handler + + $ua->remove_handler( undef, %matchspec ); + $ua->remove_handler( $phase, %matchspec ); + $ua->remove_handlers(); # REMOVE ALL HANDLERS IN ALL PHASES + +Remove handlers that match the given C<%matchspec>. If C<$phase> is not +provided, remove handlers from all phases. + +Be careful as calling this function with C<%matchspec> that is not +specific enough can remove handlers not owned by you. It's probably +better to use the L<LWP::UserAgent/set_my_handler> method instead. + +The removed handlers are returned. + +=head2 set_my_handler + + $ua->set_my_handler( $phase, $cb, %matchspec ); + $ua->set_my_handler($phase, undef); # remove handler for phase + +Set handlers private to the executing subroutine. Works by defaulting +an C<owner> field to the C<%matchspec> that holds the name of the called +subroutine. You might pass an explicit C<owner> to override this. + +If $cb is passed as C<undef>, remove the handler. + +=head1 REQUEST METHODS + +The methods described in this section are used to dispatch requests +via the user agent. The following request methods are provided: + +=head2 delete + + my $res = $ua->delete( $url ); + my $res = $ua->delete( $url, $field_name => $value, ... ); + +This method will dispatch a C<DELETE> request on the given URL. Additional +headers and content options are the same as for the L<LWP::UserAgent/get> +method. + +This method will use the DELETE() function from L<HTTP::Request::Common> +to build the request. See L<HTTP::Request::Common> for a details on +how to pass form content and other advanced features. + +=head2 get + + my $res = $ua->get( $url ); + my $res = $ua->get( $url , $field_name => $value, ... ); + +This method will dispatch a C<GET> request on the given URL. Further +arguments can be given to initialize the headers of the request. These +are given as separate name/value pairs. The return value is a +response object. See L<HTTP::Response> for a description of the +interface it provides. + +There will still be a response object returned when LWP can't connect to the +server specified in the URL or when other failures in protocol handlers occur. +These internal responses use the standard HTTP status codes, so the responses +can't be differentiated by testing the response status code alone. Error +responses that LWP generates internally will have the "Client-Warning" header +set to the value "Internal response". If you need to differentiate these +internal responses from responses that a remote server actually generates, you +need to test this header value. + +Fields names that start with ":" are special. These will not +initialize headers of the request but will determine how the response +content is treated. The following special field names are recognized: + + :content_file => $filename + :content_cb => \&callback + :read_size_hint => $bytes + +If a $filename is provided with the C<:content_file> option, then the +response content will be saved here instead of in the response +object. If a callback is provided with the C<:content_cb> option then +this function will be called for each chunk of the response content as +it is received from the server. If neither of these options are +given, then the response content will accumulate in the response +object itself. This might not be suitable for very large response +bodies. Only one of C<:content_file> or C<:content_cb> can be +specified. The content of unsuccessful responses will always +accumulate in the response object itself, regardless of the +C<:content_file> or C<:content_cb> options passed in. Note that errors +writing to the content file (for example due to permission denied +or the filesystem being full) will be reported via the C<Client-Aborted> +or C<X-Died> response headers, and not the C<is_success> method. + +The C<:read_size_hint> option is passed to the protocol module which +will try to read data from the server in chunks of this size. A +smaller value for the C<:read_size_hint> will result in a higher +number of callback invocations. + +The callback function is called with 3 arguments: a chunk of data, a +reference to the response object, and a reference to the protocol +object. The callback can abort the request by invoking die(). The +exception message will show up as the "X-Died" header field in the +response returned by the get() function. + +=head2 head + + my $res = $ua->head( $url ); + my $res = $ua->head( $url , $field_name => $value, ... ); + +This method will dispatch a C<HEAD> request on the given URL. +Otherwise it works like the L<LWP::UserAgent/get> method described above. + +=head2 is_protocol_supported + + my $bool = $ua->is_protocol_supported( $scheme ); + +You can use this method to test whether this user agent object supports the +specified C<scheme>. (The C<scheme> might be a string (like C<http> or +C<ftp>) or it might be an L<URI> object reference.) + +Whether a scheme is supported is determined by the user agent's +C<protocols_allowed> or C<protocols_forbidden> lists (if any), and by +the capabilities of LWP. I.e., this will return true only if LWP +supports this protocol I<and> it's permitted for this particular +object. + +=head2 is_online + + my $bool = $ua->is_online; + +Tries to determine if you have access to the Internet. Returns C<1> (true) +if the built-in heuristics determine that the user agent is +able to access the Internet (over HTTP) or C<0> (false). + +See also L<LWP::Online>. + +=head2 mirror + + my $res = $ua->mirror( $url, $filename ); + +This method will get the document identified by URL and store it in +file called C<$filename>. If the file already exists, then the request +will contain an C<If-Modified-Since> header matching the modification +time of the file. If the document on the server has not changed since +this time, then nothing happens. If the document has been updated, it +will be downloaded again. The modification time of the file will be +forced to match that of the server. + +The return value is an L<HTTP::Response> object. + +=head2 post + + my $res = $ua->post( $url, \%form ); + my $res = $ua->post( $url, \@form ); + my $res = $ua->post( $url, \%form, $field_name => $value, ... ); + my $res = $ua->post( $url, $field_name => $value, Content => \%form ); + my $res = $ua->post( $url, $field_name => $value, Content => \@form ); + my $res = $ua->post( $url, $field_name => $value, Content => $content ); + +This method will dispatch a C<POST> request on the given URL, with +C<%form> or C<@form> providing the key/value pairs for the fill-in form +content. Additional headers and content options are the same as for +the L<LWP::UserAgent/get> method. + +This method will use the C<POST> function from L<HTTP::Request::Common> +to build the request. See L<HTTP::Request::Common> for a details on +how to pass form content and other advanced features. + +=head2 put + + # Any version of HTTP::Message works with this form: + my $res = $ua->put( $url, $field_name => $value, Content => $content ); + + # Using hash or array references requires HTTP::Message >= 6.07 + use HTTP::Request 6.07; + my $res = $ua->put( $url, \%form ); + my $res = $ua->put( $url, \@form ); + my $res = $ua->put( $url, \%form, $field_name => $value, ... ); + my $res = $ua->put( $url, $field_name => $value, Content => \%form ); + my $res = $ua->put( $url, $field_name => $value, Content => \@form ); + +This method will dispatch a C<PUT> request on the given URL, with +C<%form> or C<@form> providing the key/value pairs for the fill-in form +content. Additional headers and content options are the same as for +the L<LWP::UserAgent/get> method. + +CAVEAT: + +This method can only accept content that is in key-value pairs when using +L<HTTP::Request::Common> prior to version C<6.07>. Any use of hash or array +references will result in an error prior to version C<6.07>. + +This method will use the C<PUT> function from L<HTTP::Request::Common> +to build the request. See L<HTTP::Request::Common> for a details on +how to pass form content and other advanced features. + +=head2 request + + my $res = $ua->request( $request ); + my $res = $ua->request( $request, $content_file ); + my $res = $ua->request( $request, $content_cb ); + my $res = $ua->request( $request, $content_cb, $read_size_hint ); + +This method will dispatch the given C<$request> object. Normally this +will be an instance of the L<HTTP::Request> class, but any object with +a similar interface will do. The return value is an L<HTTP::Response> object. + +The C<request> method will process redirects and authentication +responses transparently. This means that it may actually send several +simple requests via the L<LWP::UserAgent/simple_request> method described below. + +The request methods described above; L<LWP::UserAgent/get>, L<LWP::UserAgent/head>, +L<LWP::UserAgent/post> and L<LWP::UserAgent/mirror> will all dispatch the request +they build via this method. They are convenience methods that simply hide the +creation of the request object for you. + +The C<$content_file>, C<$content_cb> and C<$read_size_hint> all correspond to +options described with the L<LWP::UserAgent/get> method above. Note that errors +writing to the content file (for example due to permission denied +or the filesystem being full) will be reported via the C<Client-Aborted> +or C<X-Died> response headers, and not the C<is_success> method. + +You are allowed to use a CODE reference as C<content> in the request +object passed in. The C<content> function should return the content +when called. The content can be returned in chunks. The content +function will be invoked repeatedly until it return an empty string to +signal that there is no more content. + +=head2 simple_request + + my $request = HTTP::Request->new( ... ); + my $res = $ua->simple_request( $request ); + my $res = $ua->simple_request( $request, $content_file ); + my $res = $ua->simple_request( $request, $content_cb ); + my $res = $ua->simple_request( $request, $content_cb, $read_size_hint ); + +This method dispatches a single request and returns the response +received. Arguments are the same as for the L<LWP::UserAgent/request> described above. + +The difference from L<LWP::UserAgent/request> is that C<simple_request> will not try to +handle redirects or authentication responses. The L<LWP::UserAgent/request> method +will, in fact, invoke this method for each simple request it sends. + +=head1 CALLBACK METHODS + +The following methods will be invoked as requests are processed. These +methods are documented here because subclasses of L<LWP::UserAgent> +might want to override their behaviour. + +=head2 get_basic_credentials + + # This checks wantarray and can either return an array: + my ($user, $pass) = $ua->get_basic_credentials( $realm, $uri, $isproxy ); + # or a string that looks like "user:pass" + my $creds = $ua->get_basic_credentials($realm, $uri, $isproxy); + +This is called by L<LWP::UserAgent/request> to retrieve credentials for documents +protected by Basic or Digest Authentication. The arguments passed in +is the C<$realm> provided by the server, the C<$uri> requested and a +C<boolean flag> to indicate if this is authentication against a proxy server. + +The method should return a username and password. It should return an +empty list to abort the authentication resolution attempt. Subclasses +can override this method to prompt the user for the information. An +example of this can be found in C<lwp-request> program distributed +with this library. + +The base implementation simply checks a set of pre-stored member +variables, set up with the L<LWP::UserAgent/credentials> method. + +=head2 prepare_request + + $request = $ua->prepare_request( $request ); + +This method is invoked by L<LWP::UserAgent/simple_request>. Its task is +to modify the given C<$request> object by setting up various headers based +on the attributes of the user agent. The return value should normally be the +C<$request> object passed in. If a different request object is returned +it will be the one actually processed. + +The headers affected by the base implementation are; C<User-Agent>, +C<From>, C<Range> and C<Cookie>. + +=head2 progress + + my $prog = $ua->progress( $status, $request_or_response ); + +This is called frequently as the response is received regardless of +how the content is processed. The method is called with C<$status> +"begin" at the start of processing the request and with C<$state> "end" +before the request method returns. In between these C<$status> will be +the fraction of the response currently received or the string "tick" +if the fraction can't be calculated. + +When C<$status> is "begin" the second argument is the L<HTTP::Request> object, +otherwise it is the L<HTTP::Response> object. + +=head2 redirect_ok + + my $bool = $ua->redirect_ok( $prospective_request, $response ); + +This method is called by L<LWP::UserAgent/request> before it tries to follow a +redirection to the request in C<$response>. This should return a true +value if this redirection is permissible. The C<$prospective_request> +will be the request to be sent if this method returns true. + +The base implementation will return false unless the method +is in the object's C<requests_redirectable> list, +false if the proposed redirection is to a C<file://...> +URL, and true otherwise. + +=head1 SEE ALSO + +See L<LWP> for a complete overview of libwww-perl5. See L<lwpcook> +and the scripts F<lwp-request> and F<lwp-download> for examples of +usage. + +See L<HTTP::Request> and L<HTTP::Response> for a description of the +message objects dispatched and received. See L<HTTP::Request::Common> +and L<HTML::Form> for other ways to build request objects. + +See L<WWW::Mechanize> and L<WWW::Search> for examples of more +specialized user agents based on L<LWP::UserAgent>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 1995-2009 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/media.types b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/media.types new file mode 100644 index 0000000000..6a90929c0d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/media.types @@ -0,0 +1,1479 @@ +# 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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/Int64.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/Int64.pm new file mode 100644 index 0000000000..5cb6f5a45c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/Int64.pm @@ -0,0 +1,589 @@ +package Math::Int64; + +use strict; +use warnings; + +BEGIN { +our $VERSION = '0.54'; +require XSLoader; +XSLoader::load('Math::Int64', $VERSION); +} + +use warnings::register; + +use constant MAX_INT64 => string_to_int64 ( '0x7fff_ffff_ffff_ffff'); +use constant MIN_INT64 => string_to_int64 ('-0x8000_0000_0000_0000'); +use constant MAX_UINT64 => string_to_uint64( '0xffff_ffff_ffff_ffff'); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(int64 + int64_to_number + net_to_int64 int64_to_net + native_to_int64 int64_to_native + string_to_int64 hex_to_int64 + BER_to_int64 int64_to_BER + int64_to_string int64_to_hex + int64_rand + int64_srand + uint64 + uint64_to_number + net_to_uint64 uint64_to_net + native_to_uint64 uint64_to_native + string_to_uint64 hex_to_uint64 + BER_to_uint64 uint64_to_BER + uint64_to_string uint64_to_hex + uint64_rand + BER_length + MAX_INT64 MIN_INT64 MAX_UINT64 + ); + +my %available_pragmas = map { $_ => 1 } qw(native_if_available + die_on_overflow); + +sub import { + my $pkg = shift; + my (%pragmas, @subs, %native); + for (@_) { + if ($_ =~ /^:(.*)/ and $available_pragmas{$1}) { + $pragmas{$1} = 1 + } + else { + push @subs, $_; + } + } + + if ($pragmas{die_on_overflow}) { + require Math::Int64::die_on_overflow; + Math::Int64::die_on_overflow->import; + } + + if ($pragmas{native_if_available}) { + require Math::Int64::native_if_available; + Math::Int64::native_if_available->import; + } + + Math::Int64->export_to_level(1, $pkg, @subs); +} + +sub _check_pragma_compatibility { + if ($^H{'Math::Int64::native_if_available'} and + $^H{'Math::Int64::die_on_overflow'} and + warnings::enabled()) { + warnings::warn("Math::Int64::die_on_overflow pragma is useless when Math::Int64::native_if_available is also active"); + } + 1; +} + +use overload ( '+' => \&_add, + '+=' => \&_add, + '-' => \&_sub, + '-=' => \&_sub, + '*' => \&_mul, + '*=' => \&_mul, + '**' => \&_pow, + '**=' => \&_pow, + '/' => \&_div, + '/=' => \&_div, + '%' => \&_rest, + '%=' => \&_rest, + 'neg' => \&_neg, + '++' => \&_inc, + '--' => \&_dec, + '!' => \&_not, + '~' => \&_bnot, + '&' => \&_and, + '|' => \&_or, + '^' => \&_xor, + '<<' => \&_left, + '>>' => \&_right, + '<=>' => \&_spaceship, + '>' => \&_gtn, + '<' => \&_ltn, + '>=' => \&_gen, + '<=' => \&_len, + '==' => \&_eqn, + '!=' => \&_nen, + 'bool' => \&_bool, + '0+' => \&_number, + '""' => \&_string, + '=' => \&_clone, + fallback => 1 ); + +package # hide from PAUSE since it also has its own .pm file + Math::UInt64; +use overload ( '+' => \&_add, + '+=' => \&_add, + '-' => \&_sub, + '-=' => \&_sub, + '*' => \&_mul, + '*=' => \&_mul, + '**' => \&_pow, + '**=' => \&_pow, + '/' => \&_div, + '/=' => \&_div, + '%' => \&_rest, + '%=' => \&_rest, + 'neg' => \&_neg, + '++' => \&_inc, + '--' => \&_dec, + '!' => \&_not, + '~' => \&_bnot, + '&' => \&_and, + '|' => \&_or, + '^' => \&_xor, + '<<' => \&_left, + '>>' => \&_right, + '<=>' => \&_spaceship, + '>' => \&_gtn, + '<' => \&_ltn, + '>=' => \&_gen, + '<=' => \&_len, + '==' => \&_eqn, + '!=' => \&_nen, + 'bool' => \&_bool, + '0+' => \&_number, + '""' => \&_string, + '=' => \&_clone, + fallback => 1 ); + +1; + +# ABSTRACT: Manipulate 64 bits integers in Perl + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Math::Int64 - Manipulate 64 bits integers in Perl + +=head1 SYNOPSIS + + use Math::Int64 qw(int64 uint64); + + my $i = int64(1); + my $j = $i << 40; + print($i + $j * 1000000); + + my $k = uint64("12345678901234567890"); + +=head1 DESCRIPTION + +This module adds support for 64 bit integers, signed and unsigned, to +Perl. + +=head2 Exportable functions + +=over 4 + +=item int64() + +=item int64($value) + +Creates a new int64 value and initializes it to C<$value>, where +$value can be a Perl number or a string containing a number. + +For instance: + + $i = int64(34); + $j = int64("-123454321234543212345"); + + $k = int64(1234567698478483938988988); # wrong!!! + # the unquoted number would + # be converted first to a + # real number causing it to + # loose some precision. + +Once the int64 number is created it can be manipulated as any other +Perl value supporting all the standard operations (addition, negation, +multiplication, postincrement, etc.). + + +=item net_to_int64($str) + +Converts an 8 bytes string containing an int64 in network order to the +internal representation used by this module. + +=item int64_to_net($int64) + +Returns an 8 bytes string with the representation of the int64 value +in network order. + +=item native_to_int64($str) + +=item int64_to_native($int64) + +similar to net_to_int64 and int64_to_net, but using the native CPU +order. + +=item int64_to_number($int64) + +returns the optimum representation of the int64 value using Perl +internal types (IV, UV or NV). Precision may be lost. + +For instance: + + for my $l (10, 20, 30, 40, 50, 60) { + my $i = int64(1) << $l; + my $n = int64_to_number($i); + print "int64:$i => perl:$n\n"; + } + +=item string_to_int64($str, $base) + +Converts the string to a int64 value. The conversion is done according +to the given base, which must be a number between 2 and 36 inclusive +or the special value 0. C<$base> defaults to 0. + +The string may begin with an arbitrary amount of white space followed +by a single optional C<+> or C<-> sign. If base is zero or 16, the +string may then include a "0x" prefix, and the number will be read in +base 16; otherwise, a zero base is taken as 10 (decimal) unless the +next character is '0', in which case it is taken as 8 (octal). + +Underscore characters (C<_>) between the digits are ignored. + +No overflow checks are performed by this function unless the +C<die_on_overflow> pragma is used (see L</Die on overflow> below). + +See also L<strtoll(3)>. + +=item hex_to_int64($i64) + +Shortcut for string_to_int64($str, 16) + +=item int64_to_string($i64, $base) + +Converts the int64 value to its string representation in the given +base (defaults to 10). + +=item int64_to_hex($i64) + +Shortcut for C<int64_to_string($i64, 16)>. + +=item int64_to_BER($i64) + +Converts the int64 value to its BER representation (see +L<perlfunc/pack> for a description of the BER format). + +In the case of signed numbers, they are transformed into unsigned +numbers before encoding them in the BER format with the following +rule: + + $neg = ($i64 < 0 ? 1 : 0); + $u64 = (($neg ? ~$i64 : $i64) << 1) | $neg; + +That way, positive and negative integers are interleaved as 0, -1, 1, +2, -2, .... The format is similar to that used by Google protocol +buffers to encode signed variants but with the most significant groups +first (protocol buffers uses the least significant groups first +variant). + +If you don't want that preprocessing for signed numbers, just use the +C<uint64_to_BER> function instead. + +=item BER_to_int64($str) + +Decodes the int64 number in BER format from the given string. + +There must not be any extra bytes on the string after the encoded number. + +=item BER_length($str) + +Given a string with a BER encoded number at the beginning, this +function returns the number of bytes it uses. + +The right way to shift a BER encoded number from the beginning of some +string is as follows: + + $i64 = BER_to_int64(substr($str, 0, BER_length($str), '')); + +=item int64_rand + +Generates a 64 bit random number using ISAAC-64 algorithm. + +=item int64_srand($seed) + +=item int64_srand() + +Sets the seed for the random number generator. + +C<$seed>, if given, should be a 2KB long string. + +=item uint64 + +=item uint64_to_number + +=item net_to_uint64 + +=item uint64_to_net + +=item native_to_uint64 + +=item uint64_to_native + +=item string_to_uint64 + +=item hex_to_uint64 + +=item uint64_to_string + +=item uint64_to_hex + +These functions are similar to their int64 counterparts, but +manipulate 64 bit unsigned integers. + +=item uint64_to_BER($u64) + +Encodes the given unsigned integer in BER format (see L<perlfunc/pack>). + +=item BER_to_uint64($str) + +Decodes from the given string an unsigned number in BER format. + +=item uint64_rand + +Generates a 64 bit random unsigned number using ISAAC-64 algorithm. + +=back + +=head2 Die on overflow + +The lexical pragma C<Math::Int64::die_on_overflow> configures the +module to throw an error when some operation results in integer +overflow. + +For instance: + + use Math::Int64 qw(uint64); + use Math::Int64::die_on_overflow; + + my $zero = uint64(0); + say ($zero - 1); # dies as -1 falls outside + # the uint64_t range + + no Math::Int64::die_on_overflow; # deactivates lexical pragma + say ($zero - 1); # no error is detected here! + +The pragma can also be activated as follows: + + use Math::Int64 ':die_on_overflow'; + +Once this pragma is used, several Math::Int64 operations may become +slower. Deactivating the pragma will not make them fast again. + +On Perl 5.8.x, as lexical pragmas support is not available, the pragma +C<die_on_overflow> pragma is global and can not be deactivated. + +=head2 Fallback to native 64bit support if available + +If the lexical pragma C<Math::Int64::native_if_available> is used in +your program and the version of perl in use has native support for +64bit integers, the functions imported from the module that create +64bit integers (i.e. C<uint64>, C<int64>, C<string_to_int64>, +C<native_to_int64>, etc.) will return regular perl scalars. + +For instance: + + use Math::Int64 qw(int64); + + $a = int64(34); # always returns an object of the class Math::Int64 + + use Math::Int64::native_if_available; + $a = int64(34); # returns a regular scalar on perls compiled with + # 64bit support + +This feature is not enabled by default because the semantics for perl +scalars and for 64 bit integers as implemented in this module are not +identical. + +Perl is prone to coerce integers into floats while this module keeps +then always as 64bit integers. Specifically, the division operation +and overflows are the most problematic cases. Also, when using native +integers, the signed/unsigned division blurs. + +Besides that, in most situations it is safe to use the native fallback. + +As happens with the C<die_on_overflow> pragma, on Perl 5.8.x it is +global. + +The pragma can also be activated as follows: + + use Math::Int64 ':native_if_available'; + +=head2 Transparent conversion of objects to int64/uint64 + +When in some operation involving int64/uint64 numbers, a blessed +object is passed as an operand, the module would try to coerce the +object into an int64/uint64 number calling the methods +C<as_int64>/C<as_uint64> respectively. + +If the corresponding method is not implemented, the object will be +stringified and then parsed as a base 10 number. + +=head2 Storable integration + +Objects of classes Math::Int64 and Math::UInt64 implement the +STORABLE_freeze and STORABLE_thaw methods for a transparent +integration with L<Storable>. + +=head2 C API + +This module provides a native C API that can be used to create and +read Math::Int64 int64 and uint64 SVs from your own XS modules. + +In order to use it you need to follow these steps: + +=over 4 + +=item * + +Import the files C<perl_math_int64.c>, C<perl_math_int64.h> and +optionally C<typemaps> from Math::Int64 C<c_api_client> directory into +your project directory. + +=item * + +Include the file C<perl_math_int64.h> in the C or XS source files +where you want to convert 64bit integers to/from Perl SVs. + +Note that this header file requires the types int64_t and uint64_t to +be defined beforehand. + +=item * + +Add the file C<perl_math_int64.c> to your compilation targets (see the +sample Makefile.PL below). + +=item * + +Add a call to the macro C<PERL_MATH_INT64_LOAD_OR_CROAK> into the +C<BOOT> section of your XS file. + +=back + +For instance: + + --- Foo64.xs --------- + + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + #include "ppport.h" + + /* #define MATH_INT64_NATIVE_IF_AVAILABLE */ + #include "math_int64.h" + + MODULE = Foo64 PACKAGE = Foo64 + BOOT: + PERL_MATH_INT64_LOAD_OR_CROAK; + + int64_t + some_int64() + CODE: + RETVAL = -42; + OUTPUT: + RETVAL + + + --- Makefile.PL ----- + + use ExtUtils::MakeMaker; + WriteMakefile( NAME => 'Foo64', + VERSION_FROM => 'lib/Foo64.pm', + OBJECT => '$(O_FILES)' ); + + +If the macro C<MATH_INT64_NATIVE_IF_AVAILABLE> is defined before +including C<perl_math_int64.h> and the perl interpreter is compiled +with native 64bit integer support, IVs will be used to represent 64bit +integers instead of the object representation provided by Math::Int64. + +These are the C macros available from Math::Int64 C API: + +=over 4 + +=item SV *newSVi64(int64_t i64) + +Returns an SV representing the given int64_t value. + +=item SV *newSVu64(uint64_t 64) + +Returns an SV representing the given uint64_t value. + +=item int64_t SvI64(SV *sv) + +Extracts the int64_t value from the given SV. + +=item uint64_t SvU64(SV *sv) + +Extracts the uint64_t value from the given SV. + +=item int SvI64OK(SV *sv) + +Returns true is the given SV contains a valid int64_t value. + +=item int SvU64OK(SV *sv) + +Returns true is the given SV contains a valid uint64_t value. + +=item uint64_t randU64(void) + +Returns a random 64 bits unsigned integer. + +=item SV sv_seti64(SV *sv, uint64_t i64) + +Sets the value of the perl scalar to the given int64_t value. + +=item SV sv_setu64(SV *sv, uint64_t i64) + +Sets the value of the perl scalar to the given uint64_t value. + +=back + +If you require any other function available through the C API don't +hesitate to ask for it! + +=head1 BUGS AND SUPPORT + +The Storable integration feature is experimental. + +The C API feature is experimental. + +This module requires int64 support from the C compiler. + +In order to report bugs you can send me and email to the address that +appears below or use the CPAN RT bug tracking system available at +L<http://rt.cpan.org>. + +The source for the development version of the module is hosted at +GitHub: L<https://github.com/salva/p5-Math-Int64>. + +=head2 My wishlist + +If you like this module and you're feeling generous, take a look at my +Amazon Wish List: L<http://amzn.com/w/1WU1P6IR5QZ42> + +=head1 SEE ALSO + +The C API usage sample module L<Math::Int64::C_API::Sample>. + +Other modules providing support for larger integers or numbers are +L<Math::BigInt>, L<Math::BigRat> and L<Math::Big>, +L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and +L<Math::BigInt::GMP>. + +=head1 COPYRIGHT AND LICENSE + +Copyright E<copy> 2007, 2009, 2011-2015 by Salvador Fandiño +(sfandino@yahoo.com) + +Copyright E<copy> 2014-2015 by Dave Rolsky (autarch@urth.org) + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.8 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/Int64/die_on_overflow.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/Int64/die_on_overflow.pm new file mode 100644 index 0000000000..5212cc9384 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/Int64/die_on_overflow.pm @@ -0,0 +1,45 @@ +package Math::Int64::die_on_overflow; + +use strict; +use warnings; + +use Math::Int64 (); + +sub import { + require Math::Int64; + Math::Int64::_set_may_die_on_overflow(1); + $^H{'Math::Int64::die_on_overflow'} = 1; + goto &Math::Int64::_check_pragma_compatibility; +} + + +sub unimport { + undef $^H{'Math::Int64::die_on_overflow'} +} + +1; + +# ABSTRACT: catch overflows when using Math::Int64 + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Math::Int64::die_on_overflow - catch overflows when using Math::Int64 + +=head1 SYNOPSIS + + use Math::Int64 qw(uint64); + use Math::Int64::die_on_overflow; + + my $number = uint64(2**32); + say($number * $number); # overflow error! + + +=head1 SEE ALSO + +L<Math::Int64>. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/Int64/native_if_available.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/Int64/native_if_available.pm new file mode 100644 index 0000000000..34776b92c1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/Int64/native_if_available.pm @@ -0,0 +1,43 @@ +package Math::Int64::native_if_available; + +use strict; +use warnings; + +use Math::Int64 (); + +sub import { + if (Math::Int64::_backend() eq 'IV' and $] >= 5.008) { + Math::Int64::_set_may_use_native(1); + $^H{'Math::Int64::native_if_available'} = 1; + goto &Math::Int64::_check_pragma_compatibility; + } +} + +sub unimport { + undef $^H{'Math::Int64::native_if_available'}; +} + +1; + +# ABSTRACT: Use the native Perl 64-bit integer implementation when available + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Math::Int64::native_if_available - Use the native Perl 64-bit integer implementation when available + +=head1 SYNOPSIS + + use Math::Int64 qw(uint64); + use Math::Int64::native_if_available; + +=head1 SEE ALSO + +L<Math::Int64>. + +=cut + + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/UInt64.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/UInt64.pm new file mode 100644 index 0000000000..6fc6d03ef2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Math/UInt64.pm @@ -0,0 +1,32 @@ +package Math::UInt64; + +use strict; +use warnings; + +use Math::Int64; + +sub import { goto &Math::Int64::import } + +1; + +# ABSTRACT: Manipulate 64 bit unsigned integers from Perl + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Math::UInt64 - Manipulate 64 bit unsigned integers from Perl + +=head1 DESCRIPTION + +Math::UInt64 is just an alias for Math::Int64, the only reason it +exists as an independent package is to allow L<Storable> to load it on +demand. + +=head1 SEE ALSO + +L<Math::Int64>. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Mozilla/CA.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Mozilla/CA.pm new file mode 100644 index 0000000000..c2f35b5f4c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Mozilla/CA.pm @@ -0,0 +1,74 @@ +package Mozilla::CA; + +use strict; +our $VERSION = '20180117'; + +use Cwd (); +use File::Spec (); +use File::Basename qw(dirname); + +sub SSL_ca_file { + my $file = File::Spec->catfile(dirname(__FILE__), "CA", "cacert.pem"); + if (!File::Spec->file_name_is_absolute($file)) { + $file = File::Spec->catfile(Cwd::cwd(), $file); + } + return $file; +} + +1; + +__END__ + +=head1 NAME + +Mozilla::CA - Mozilla's CA cert bundle in PEM format + +=head1 SYNOPSIS + + use IO::Socket::SSL; + use Mozilla::CA; + + my $host = "www.paypal.com"; + my $client = IO::Socket::SSL->new( + PeerHost => "$host:443", + SSL_verify_mode => 0x02, + SSL_ca_file => Mozilla::CA::SSL_ca_file(), + ) + || die "Can't connect: $@"; + + $client->verify_hostname($host, "http") + || die "hostname verification failure"; + +=head1 DESCRIPTION + +Mozilla::CA provides a copy of Mozilla's bundle of Certificate Authority +certificates in a form that can be consumed by modules and libraries +based on OpenSSL. + +The module provide a single function: + +=over + +=item SSL_ca_file() + +Returns the absolute path to the Mozilla's CA cert bundle PEM file. + +=back + +=head1 SEE ALSO + +L<http://curl.haxx.se/docs/caextract.html> + +=head1 LICENSE + +For the bundled Mozilla CA PEM file the following applies: + +=over + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/. + +=back + +The Mozilla::CA distribution itself is available under the same license. diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Mozilla/CA/cacert.pem b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Mozilla/CA/cacert.pem new file mode 100644 index 0000000000..6e88a2cfd2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Mozilla/CA/cacert.pem @@ -0,0 +1,3467 @@ +## +## Bundle of CA Root Certificates +## +## Certificate data from Mozilla as of: Wed Jan 17 04:12:05 2018 GMT +## +## This is a bundle of X.509 certificates of public Certificate Authorities +## (CA). These were automatically extracted from Mozilla's root certificates +## file (certdata.txt). This file can be found in the mozilla source tree: +## https://hg.mozilla.org/releases/mozilla-release/raw-file/default/security/nss/lib/ckfw/builtins/certdata.txt +## +## It contains the certificates in PEM format and therefore +## can be directly used with curl / libcurl / php_curl, or with +## an Apache+mod_ssl webserver for SSL client authentication. +## Just configure this file as the SSLCACertificateFile. +## +## Conversion done with mk-ca-bundle.pl version 1.27. +## SHA256: a3ac15b98179dd2f3c5de076d10b1d53048754372f7207c2f327510cdd78fbd8 +## + + +GlobalSign Root CA +================== +-----BEGIN CERTIFICATE----- +MIIDdTCCAl2gAwIBAgILBAAAAAABFUtaw5QwDQYJKoZIhvcNAQEFBQAwVzELMAkGA1UEBhMCQkUx +GTAXBgNVBAoTEEdsb2JhbFNpZ24gbnYtc2ExEDAOBgNVBAsTB1Jvb3QgQ0ExGzAZBgNVBAMTEkds +b2JhbFNpZ24gUm9vdCBDQTAeFw05ODA5MDExMjAwMDBaFw0yODAxMjgxMjAwMDBaMFcxCzAJBgNV +BAYTAkJFMRkwFwYDVQQKExBHbG9iYWxTaWduIG52LXNhMRAwDgYDVQQLEwdSb290IENBMRswGQYD +VQQDExJHbG9iYWxTaWduIFJvb3QgQ0EwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDa +DuaZjc6j40+Kfvvxi4Mla+pIH/EqsLmVEQS98GPR4mdmzxzdzxtIK+6NiY6arymAZavpxy0Sy6sc +THAHoT0KMM0VjU/43dSMUBUc71DuxC73/OlS8pF94G3VNTCOXkNz8kHp1Wrjsok6Vjk4bwY8iGlb +Kk3Fp1S4bInMm/k8yuX9ifUSPJJ4ltbcdG6TRGHRjcdGsnUOhugZitVtbNV4FpWi6cgKOOvyJBNP +c1STE4U6G7weNLWLBYy5d4ux2x8gkasJU26Qzns3dLlwR5EiUWMWea6xrkEmCMgZK9FGqkjWZCrX +gzT/LCrBbBlDSgeF59N89iFo7+ryUp9/k5DPAgMBAAGjQjBAMA4GA1UdDwEB/wQEAwIBBjAPBgNV +HRMBAf8EBTADAQH/MB0GA1UdDgQWBBRge2YaRQ2XyolQL30EzTSo//z9SzANBgkqhkiG9w0BAQUF +AAOCAQEA1nPnfE920I2/7LqivjTFKDK1fPxsnCwrvQmeU79rXqoRSLblCKOzyj1hTdNGCbM+w6Dj +Y1Ub8rrvrTnhQ7k4o+YviiY776BQVvnGCv04zcQLcFGUl5gE38NflNUVyRRBnMRddWQVDf9VMOyG +j/8N7yy5Y0b2qvzfvGn9LhJIZJrglfCm7ymPAbEVtQwdpf5pLGkkeB6zpxxxYu7KyJesF12KwvhH +hm4qxFYxldBniYUr+WymXUadDKqC5JlR3XC321Y9YeRq4VzW9v493kHMB65jUr9TU/Qr6cf9tveC +X4XSQRjbgbMEHMUfpIBvFSDJ3gyICh3WZlXi/EjJKSZp4A== +-----END CERTIFICATE----- + +GlobalSign Root CA - R2 +======================= +-----BEGIN CERTIFICATE----- +MIIDujCCAqKgAwIBAgILBAAAAAABD4Ym5g0wDQYJKoZIhvcNAQEFBQAwTDEgMB4GA1UECxMXR2xv +YmFsU2lnbiBSb290IENBIC0gUjIxEzARBgNVBAoTCkdsb2JhbFNpZ24xEzARBgNVBAMTCkdsb2Jh +bFNpZ24wHhcNMDYxMjE1MDgwMDAwWhcNMjExMjE1MDgwMDAwWjBMMSAwHgYDVQQLExdHbG9iYWxT +aWduIFJvb3QgQ0EgLSBSMjETMBEGA1UEChMKR2xvYmFsU2lnbjETMBEGA1UEAxMKR2xvYmFsU2ln +bjCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAKbPJA6+Lm8omUVCxKs+IVSbC9N/hHD6 +ErPLv4dfxn+G07IwXNb9rfF73OX4YJYJkhD10FPe+3t+c4isUoh7SqbKSaZeqKeMWhG8eoLrvozp +s6yWJQeXSpkqBy+0Hne/ig+1AnwblrjFuTosvNYSuetZfeLQBoZfXklqtTleiDTsvHgMCJiEbKjN +S7SgfQx5TfC4LcshytVsW33hoCmEofnTlEnLJGKRILzdC9XZzPnqJworc5HGnRusyMvo4KD0L5CL +TfuwNhv2GXqF4G3yYROIXJ/gkwpRl4pazq+r1feqCapgvdzZX99yqWATXgAByUr6P6TqBwMhAo6C +ygPCm48CAwEAAaOBnDCBmTAOBgNVHQ8BAf8EBAMCAQYwDwYDVR0TAQH/BAUwAwEB/zAdBgNVHQ4E +FgQUm+IHV2ccHsBqBt5ZtJot39wZhi4wNgYDVR0fBC8wLTAroCmgJ4YlaHR0cDovL2NybC5nbG9i +YWxzaWduLm5ldC9yb290LXIyLmNybDAfBgNVHSMEGDAWgBSb4gdXZxwewGoG3lm0mi3f3BmGLjAN +BgkqhkiG9w0BAQUFAAOCAQEAmYFThxxol4aR7OBKuEQLq4GsJ0/WwbgcQ3izDJr86iw8bmEbTUsp +9Z8FHSbBuOmDAGJFtqkIk7mpM0sYmsL4h4hO291xNBrBVNpGP+DTKqttVCL1OmLNIG+6KYnX3ZHu +01yiPqFbQfXf5WRDLenVOavSot+3i9DAgBkcRcAtjOj4LaR0VknFBbVPFd5uRHg5h6h+u/N5GJG7 +9G+dwfCMNYxdAfvDbbnvRG15RjF+Cv6pgsH/76tuIMRQyV+dTZsXjAzlAcmgQWpzU/qlULRuJQ/7 +TBj0/VLZjmmx6BEP3ojY+x1J96relc8geMJgEtslQIxq/H5COEBkEveegeGTLg== +-----END CERTIFICATE----- + +Verisign Class 3 Public Primary Certification Authority - G3 +============================================================ +-----BEGIN CERTIFICATE----- +MIIEGjCCAwICEQCbfgZJoz5iudXukEhxKe9XMA0GCSqGSIb3DQEBBQUAMIHKMQswCQYDVQQGEwJV +UzEXMBUGA1UEChMOVmVyaVNpZ24sIEluYy4xHzAdBgNVBAsTFlZlcmlTaWduIFRydXN0IE5ldHdv +cmsxOjA4BgNVBAsTMShjKSAxOTk5IFZlcmlTaWduLCBJbmMuIC0gRm9yIGF1dGhvcml6ZWQgdXNl +IG9ubHkxRTBDBgNVBAMTPFZlcmlTaWduIENsYXNzIDMgUHVibGljIFByaW1hcnkgQ2VydGlmaWNh +dGlvbiBBdXRob3JpdHkgLSBHMzAeFw05OTEwMDEwMDAwMDBaFw0zNjA3MTYyMzU5NTlaMIHKMQsw +CQYDVQQGEwJVUzEXMBUGA1UEChMOVmVyaVNpZ24sIEluYy4xHzAdBgNVBAsTFlZlcmlTaWduIFRy +dXN0IE5ldHdvcmsxOjA4BgNVBAsTMShjKSAxOTk5IFZlcmlTaWduLCBJbmMuIC0gRm9yIGF1dGhv +cml6ZWQgdXNlIG9ubHkxRTBDBgNVBAMTPFZlcmlTaWduIENsYXNzIDMgUHVibGljIFByaW1hcnkg +Q2VydGlmaWNhdGlvbiBBdXRob3JpdHkgLSBHMzCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoC +ggEBAMu6nFL8eB8aHm8bN3O9+MlrlBIwT/A2R/XQkQr1F8ilYcEWQE37imGQ5XYgwREGfassbqb1 +EUGO+i2tKmFZpGcmTNDovFJbcCAEWNF6yaRpvIMXZK0Fi7zQWM6NjPXr8EJJC52XJ2cybuGukxUc +cLwgTS8Y3pKI6GyFVxEa6X7jJhFUokWWVYPKMIno3Nij7SqAP395ZVc+FSBmCC+Vk7+qRy+oRpfw +EuL+wgorUeZ25rdGt+INpsyow0xZVYnm6FNcHOqd8GIWC6fJXwzw3sJ2zq/3avL6QaaiMxTJ5Xpj +055iN9WFZZ4O5lMkdBteHRJTW8cs54NJOxWuimi5V5cCAwEAATANBgkqhkiG9w0BAQUFAAOCAQEA +ERSWwauSCPc/L8my/uRan2Te2yFPhpk0djZX3dAVL8WtfxUfN2JzPtTnX84XA9s1+ivbrmAJXx5f +j267Cz3qWhMeDGBvtcC1IyIuBwvLqXTLR7sdwdela8wv0kL9Sd2nic9TutoAWii/gt/4uhMdUIaC +/Y4wjylGsB49Ndo4YhYYSq3mtlFs3q9i6wHQHiT+eo8SGhJouPtmmRQURVyu565pF4ErWjfJXir0 +xuKhXFSbplQAz/DxwceYMBo7Nhbbo27q/a2ywtrvAkcTisDxszGtTxzhT5yvDwyd93gN2PQ1VoDa +t20Xj50egWTh/sVFuq1ruQp6Tk9LhO5L8X3dEQ== +-----END CERTIFICATE----- + +Entrust.net Premium 2048 Secure Server CA +========================================= +-----BEGIN CERTIFICATE----- +MIIEKjCCAxKgAwIBAgIEOGPe+DANBgkqhkiG9w0BAQUFADCBtDEUMBIGA1UEChMLRW50cnVzdC5u +ZXQxQDA+BgNVBAsUN3d3dy5lbnRydXN0Lm5ldC9DUFNfMjA0OCBpbmNvcnAuIGJ5IHJlZi4gKGxp +bWl0cyBsaWFiLikxJTAjBgNVBAsTHChjKSAxOTk5IEVudHJ1c3QubmV0IExpbWl0ZWQxMzAxBgNV +BAMTKkVudHJ1c3QubmV0IENlcnRpZmljYXRpb24gQXV0aG9yaXR5ICgyMDQ4KTAeFw05OTEyMjQx +NzUwNTFaFw0yOTA3MjQxNDE1MTJaMIG0MRQwEgYDVQQKEwtFbnRydXN0Lm5ldDFAMD4GA1UECxQ3 +d3d3LmVudHJ1c3QubmV0L0NQU18yMDQ4IGluY29ycC4gYnkgcmVmLiAobGltaXRzIGxpYWIuKTEl +MCMGA1UECxMcKGMpIDE5OTkgRW50cnVzdC5uZXQgTGltaXRlZDEzMDEGA1UEAxMqRW50cnVzdC5u +ZXQgQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkgKDIwNDgpMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8A +MIIBCgKCAQEArU1LqRKGsuqjIAcVFmQqK0vRvwtKTY7tgHalZ7d4QMBzQshowNtTK91euHaYNZOL +Gp18EzoOH1u3Hs/lJBQesYGpjX24zGtLA/ECDNyrpUAkAH90lKGdCCmziAv1h3edVc3kw37XamSr +hRSGlVuXMlBvPci6Zgzj/L24ScF2iUkZ/cCovYmjZy/Gn7xxGWC4LeksyZB2ZnuU4q941mVTXTzW +nLLPKQP5L6RQstRIzgUyVYr9smRMDuSYB3Xbf9+5CFVghTAp+XtIpGmG4zU/HoZdenoVve8AjhUi +VBcAkCaTvA5JaJG/+EfTnZVCwQ5N328mz8MYIWJmQ3DW1cAH4QIDAQABo0IwQDAOBgNVHQ8BAf8E +BAMCAQYwDwYDVR0TAQH/BAUwAwEB/zAdBgNVHQ4EFgQUVeSB0RGAvtiJuQijMfmhJAkWuXAwDQYJ +KoZIhvcNAQEFBQADggEBADubj1abMOdTmXx6eadNl9cZlZD7Bh/KM3xGY4+WZiT6QBshJ8rmcnPy +T/4xmf3IDExoU8aAghOY+rat2l098c5u9hURlIIM7j+VrxGrD9cv3h8Dj1csHsm7mhpElesYT6Yf +zX1XEC+bBAlahLVu2B064dae0Wx5XnkcFMXj0EyTO2U87d89vqbllRrDtRnDvV5bu/8j72gZyxKT +J1wDLW8w0B62GqzeWvfRqqgnpv55gcR5mTNXuhKwqeBCbJPKVt7+bYQLCIt+jerXmCHG8+c8eS9e +nNFMFY3h7CI3zJpDC5fcgJCNs2ebb0gIFVbPv/ErfF6adulZkMV8gzURZVE= +-----END CERTIFICATE----- + +Baltimore CyberTrust Root +========================= +-----BEGIN CERTIFICATE----- +MIIDdzCCAl+gAwIBAgIEAgAAuTANBgkqhkiG9w0BAQUFADBaMQswCQYDVQQGEwJJRTESMBAGA1UE +ChMJQmFsdGltb3JlMRMwEQYDVQQLEwpDeWJlclRydXN0MSIwIAYDVQQDExlCYWx0aW1vcmUgQ3li +ZXJUcnVzdCBSb290MB4XDTAwMDUxMjE4NDYwMFoXDTI1MDUxMjIzNTkwMFowWjELMAkGA1UEBhMC +SUUxEjAQBgNVBAoTCUJhbHRpbW9yZTETMBEGA1UECxMKQ3liZXJUcnVzdDEiMCAGA1UEAxMZQmFs +dGltb3JlIEN5YmVyVHJ1c3QgUm9vdDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAKME +uyKrmD1X6CZymrV51Cni4eiVgLGw41uOKymaZN+hXe2wCQVt2yguzmKiYv60iNoS6zjrIZ3AQSsB +UnuId9Mcj8e6uYi1agnnc+gRQKfRzMpijS3ljwumUNKoUMMo6vWrJYeKmpYcqWe4PwzV9/lSEy/C +G9VwcPCPwBLKBsua4dnKM3p31vjsufFoREJIE9LAwqSuXmD+tqYF/LTdB1kC1FkYmGP1pWPgkAx9 +XbIGevOF6uvUA65ehD5f/xXtabz5OTZydc93Uk3zyZAsuT3lySNTPx8kmCFcB5kpvcY67Oduhjpr +l3RjM71oGDHweI12v/yejl0qhqdNkNwnGjkCAwEAAaNFMEMwHQYDVR0OBBYEFOWdWTCCR1jMrPoI +VDaGezq1BE3wMBIGA1UdEwEB/wQIMAYBAf8CAQMwDgYDVR0PAQH/BAQDAgEGMA0GCSqGSIb3DQEB +BQUAA4IBAQCFDF2O5G9RaEIFoN27TyclhAO992T9Ldcw46QQF+vaKSm2eT929hkTI7gQCvlYpNRh +cL0EYWoSihfVCr3FvDB81ukMJY2GQE/szKN+OMY3EU/t3WgxjkzSswF07r51XgdIGn9w/xZchMB5 +hbgF/X++ZRGjD8ACtPhSNzkE1akxehi/oCr0Epn3o0WC4zxe9Z2etciefC7IpJ5OCBRLbf1wbWsa +Y71k5h+3zvDyny67G7fyUIhzksLi4xaNmjICq44Y3ekQEe5+NauQrz4wlHrQMz2nZQ/1/I6eYs9H +RCwBXbsdtTLSR9I4LtD+gdwyah617jzV/OeBHRnDJELqYzmp +-----END CERTIFICATE----- + +AddTrust External Root +====================== +-----BEGIN CERTIFICATE----- +MIIENjCCAx6gAwIBAgIBATANBgkqhkiG9w0BAQUFADBvMQswCQYDVQQGEwJTRTEUMBIGA1UEChML +QWRkVHJ1c3QgQUIxJjAkBgNVBAsTHUFkZFRydXN0IEV4dGVybmFsIFRUUCBOZXR3b3JrMSIwIAYD +VQQDExlBZGRUcnVzdCBFeHRlcm5hbCBDQSBSb290MB4XDTAwMDUzMDEwNDgzOFoXDTIwMDUzMDEw +NDgzOFowbzELMAkGA1UEBhMCU0UxFDASBgNVBAoTC0FkZFRydXN0IEFCMSYwJAYDVQQLEx1BZGRU +cnVzdCBFeHRlcm5hbCBUVFAgTmV0d29yazEiMCAGA1UEAxMZQWRkVHJ1c3QgRXh0ZXJuYWwgQ0Eg +Um9vdDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBALf3GjPm8gAELTngTlvtH7xsD821 ++iO2zt6bETOXpClMfZOfvUq8k+0DGuOPz+VtUFrWlymUWoCwSXrbLpX9uMq/NzgtHj6RQa1wVsfw +Tz/oMp50ysiQVOnGXw94nZpAPA6sYapeFI+eh6FqUNzXmk6vBbOmcZSccbNQYArHE504B4YCqOmo +aSYYkKtMsE8jqzpPhNjfzp/haW+710LXa0Tkx63ubUFfclpxCDezeWWkWaCUN/cALw3CknLa0Dhy +2xSoRcRdKn23tNbE7qzNE0S3ySvdQwAl+mG5aWpYIxG3pzOPVnVZ9c0p10a3CitlttNCbxWyuHv7 +7+ldU9U0WicCAwEAAaOB3DCB2TAdBgNVHQ4EFgQUrb2YejS0Jvf6xCZU7wO94CTLVBowCwYDVR0P +BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wgZkGA1UdIwSBkTCBjoAUrb2YejS0Jvf6xCZU7wO94CTL +VBqhc6RxMG8xCzAJBgNVBAYTAlNFMRQwEgYDVQQKEwtBZGRUcnVzdCBBQjEmMCQGA1UECxMdQWRk +VHJ1c3QgRXh0ZXJuYWwgVFRQIE5ldHdvcmsxIjAgBgNVBAMTGUFkZFRydXN0IEV4dGVybmFsIENB +IFJvb3SCAQEwDQYJKoZIhvcNAQEFBQADggEBALCb4IUlwtYj4g+WBpKdQZic2YR5gdkeWxQHIzZl +j7DYd7usQWxHYINRsPkyPef89iYTx4AWpb9a/IfPeHmJIZriTAcKhjW88t5RxNKWt9x+Tu5w/Rw5 +6wwCURQtjr0W4MHfRnXnJK3s9EK0hZNwEGe6nQY1ShjTK3rMUUKhemPR5ruhxSvCNr4TDea9Y355 +e6cJDUCrat2PisP29owaQgVR1EX1n6diIWgVIEM8med8vSTYqZEXc4g/VhsxOBi0cQ+azcgOno4u +G+GMmIPLHzHxREzGBHNJdmAPx/i9F4BrLunMTA5amnkPIAou1Z5jJh5VkpTYghdae9C8x49OhgQ= +-----END CERTIFICATE----- + +Entrust Root Certification Authority +==================================== +-----BEGIN CERTIFICATE----- +MIIEkTCCA3mgAwIBAgIERWtQVDANBgkqhkiG9w0BAQUFADCBsDELMAkGA1UEBhMCVVMxFjAUBgNV +BAoTDUVudHJ1c3QsIEluYy4xOTA3BgNVBAsTMHd3dy5lbnRydXN0Lm5ldC9DUFMgaXMgaW5jb3Jw +b3JhdGVkIGJ5IHJlZmVyZW5jZTEfMB0GA1UECxMWKGMpIDIwMDYgRW50cnVzdCwgSW5jLjEtMCsG +A1UEAxMkRW50cnVzdCBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5MB4XDTA2MTEyNzIwMjM0 +MloXDTI2MTEyNzIwNTM0MlowgbAxCzAJBgNVBAYTAlVTMRYwFAYDVQQKEw1FbnRydXN0LCBJbmMu +MTkwNwYDVQQLEzB3d3cuZW50cnVzdC5uZXQvQ1BTIGlzIGluY29ycG9yYXRlZCBieSByZWZlcmVu +Y2UxHzAdBgNVBAsTFihjKSAyMDA2IEVudHJ1c3QsIEluYy4xLTArBgNVBAMTJEVudHJ1c3QgUm9v +dCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEB +ALaVtkNC+sZtKm9I35RMOVcF7sN5EUFoNu3s/poBj6E4KPz3EEZmLk0eGrEaTsbRwJWIsMn/MYsz +A9u3g3s+IIRe7bJWKKf44LlAcTfFy0cOlypowCKVYhXbR9n10Cv/gkvJrT7eTNuQgFA/CYqEAOww +Cj0Yzfv9KlmaI5UXLEWeH25DeW0MXJj+SKfFI0dcXv1u5x609mhF0YaDW6KKjbHjKYD+JXGIrb68 +j6xSlkuqUY3kEzEZ6E5Nn9uss2rVvDlUccp6en+Q3X0dgNmBu1kmwhH+5pPi94DkZfs0Nw4pgHBN +rziGLp5/V6+eF67rHMsoIV+2HNjnogQi+dPa2MsCAwEAAaOBsDCBrTAOBgNVHQ8BAf8EBAMCAQYw +DwYDVR0TAQH/BAUwAwEB/zArBgNVHRAEJDAigA8yMDA2MTEyNzIwMjM0MlqBDzIwMjYxMTI3MjA1 +MzQyWjAfBgNVHSMEGDAWgBRokORnpKZTgMeGZqTx90tD+4S9bTAdBgNVHQ4EFgQUaJDkZ6SmU4DH +hmak8fdLQ/uEvW0wHQYJKoZIhvZ9B0EABBAwDhsIVjcuMTo0LjADAgSQMA0GCSqGSIb3DQEBBQUA +A4IBAQCT1DCw1wMgKtD5Y+iRDAUgqV8ZyntyTtSx29CW+1RaGSwMCPeyvIWonX9tO1KzKtvn1ISM +Y/YPyyYBkVBs9F8U4pN0wBOeMDpQ47RgxRzwIkSNcUesyBrJ6ZuaAGAT/3B+XxFNSRuzFVJ7yVTa +v52Vr2ua2J7p8eRDjeIRRDq/r72DQnNSi6q7pynP9WQcCk3RvKqsnyrQ/39/2n3qse0wJcGE2jTS +W3iDVuycNsMm4hH2Z0kdkquM++v/eu6FSqdQgPCnXEqULl8FmTxSQeDNtGPPAUO6nIPcj2A781q0 +tHuu2guQOHXvgR1m0vdXcDazv/wor3ElhVsT/h5/WrQ8 +-----END CERTIFICATE----- + +GeoTrust Global CA +================== +-----BEGIN CERTIFICATE----- +MIIDVDCCAjygAwIBAgIDAjRWMA0GCSqGSIb3DQEBBQUAMEIxCzAJBgNVBAYTAlVTMRYwFAYDVQQK +Ew1HZW9UcnVzdCBJbmMuMRswGQYDVQQDExJHZW9UcnVzdCBHbG9iYWwgQ0EwHhcNMDIwNTIxMDQw +MDAwWhcNMjIwNTIxMDQwMDAwWjBCMQswCQYDVQQGEwJVUzEWMBQGA1UEChMNR2VvVHJ1c3QgSW5j +LjEbMBkGA1UEAxMSR2VvVHJ1c3QgR2xvYmFsIENBMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIB +CgKCAQEA2swYYzD99BcjGlZ+W988bDjkcbd4kdS8odhM+KhDtgPpTSEHCIjaWC9mOSm9BXiLnTjo +BbdqfnGk5sRgprDvgOSJKA+eJdbtg/OtppHHmMlCGDUUna2YRpIuT8rxh0PBFpVXLVDviS2Aelet +8u5fa9IAjbkU+BQVNdnARqN7csiRv8lVK83Qlz6cJmTM386DGXHKTubU1XupGc1V3sjs0l44U+Vc +T4wt/lAjNvxm5suOpDkZALeVAjmRCw7+OC7RHQWa9k0+bw8HHa8sHo9gOeL6NlMTOdReJivbPagU +vTLrGAMoUgRx5aszPeE4uwc2hGKceeoWMPRfwCvocWvk+QIDAQABo1MwUTAPBgNVHRMBAf8EBTAD +AQH/MB0GA1UdDgQWBBTAephojYn7qwVkDBF9qn1luMrMTjAfBgNVHSMEGDAWgBTAephojYn7qwVk +DBF9qn1luMrMTjANBgkqhkiG9w0BAQUFAAOCAQEANeMpauUvXVSOKVCUn5kaFOSPeCpilKInZ57Q +zxpeR+nBsqTP3UEaBU6bS+5Kb1VSsyShNwrrZHYqLizz/Tt1kL/6cdjHPTfStQWVYrmm3ok9Nns4 +d0iXrKYgjy6myQzCsplFAMfOEVEiIuCl6rYVSAlk6l5PdPcFPseKUgzbFbS9bZvlxrFUaKnjaZC2 +mqUPuLk/IH2uSrW4nOQdtqvmlKXBx4Ot2/Unhw4EbNX/3aBd7YdStysVAq45pmp06drE57xNNB6p +XE0zX5IJL4hmXXeXxx12E6nV5fEWCRE11azbJHFwLJhWC9kXtNHjUStedejV0NxPNO3CBWaAocvm +Mw== +-----END CERTIFICATE----- + +GeoTrust Universal CA +===================== +-----BEGIN CERTIFICATE----- +MIIFaDCCA1CgAwIBAgIBATANBgkqhkiG9w0BAQUFADBFMQswCQYDVQQGEwJVUzEWMBQGA1UEChMN +R2VvVHJ1c3QgSW5jLjEeMBwGA1UEAxMVR2VvVHJ1c3QgVW5pdmVyc2FsIENBMB4XDTA0MDMwNDA1 +MDAwMFoXDTI5MDMwNDA1MDAwMFowRTELMAkGA1UEBhMCVVMxFjAUBgNVBAoTDUdlb1RydXN0IElu +Yy4xHjAcBgNVBAMTFUdlb1RydXN0IFVuaXZlcnNhbCBDQTCCAiIwDQYJKoZIhvcNAQEBBQADggIP +ADCCAgoCggIBAKYVVaCjxuAfjJ0hUNfBvitbtaSeodlyWL0AG0y/YckUHUWCq8YdgNY96xCcOq9t +JPi8cQGeBvV8Xx7BDlXKg5pZMK4ZyzBIle0iN430SppyZj6tlcDgFgDgEB8rMQ7XlFTTQjOgNB0e +RXbdT8oYN+yFFXoZCPzVx5zw8qkuEKmS5j1YPakWaDwvdSEYfyh3peFhF7em6fgemdtzbvQKoiFs +7tqqhZJmr/Z6a4LauiIINQ/PQvE1+mrufislzDoR5G2vc7J2Ha3QsnhnGqQ5HFELZ1aD/ThdDc7d +8Lsrlh/eezJS/R27tQahsiFepdaVaH/wmZ7cRQg+59IJDTWU3YBOU5fXtQlEIGQWFwMCTFMNaN7V +qnJNk22CDtucvc+081xdVHppCZbW2xHBjXWotM85yM48vCR85mLK4b19p71XZQvk/iXttmkQ3Cga +Rr0BHdCXteGYO8A3ZNY9lO4L4fUorgtWv3GLIylBjobFS1J72HGrH4oVpjuDWtdYAVHGTEHZf9hB +Z3KiKN9gg6meyHv8U3NyWfWTehd2Ds735VzZC1U0oqpbtWpU5xPKV+yXbfReBi9Fi1jUIxaS5BZu +KGNZMN9QAZxjiRqf2xeUgnA3wySemkfWWspOqGmJch+RbNt+nhutxx9z3SxPGWX9f5NAEC7S8O08 +ni4oPmkmM8V7AgMBAAGjYzBhMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYEFNq7LqqwDLiIJlF0 +XG0D08DYj3rWMB8GA1UdIwQYMBaAFNq7LqqwDLiIJlF0XG0D08DYj3rWMA4GA1UdDwEB/wQEAwIB +hjANBgkqhkiG9w0BAQUFAAOCAgEAMXjmx7XfuJRAyXHEqDXsRh3ChfMoWIawC/yOsjmPRFWrZIRc +aanQmjg8+uUfNeVE44B5lGiku8SfPeE0zTBGi1QrlaXv9z+ZhP015s8xxtxqv6fXIwjhmF7DWgh2 +qaavdy+3YL1ERmrvl/9zlcGO6JP7/TG37FcREUWbMPEaiDnBTzynANXH/KttgCJwpQzgXQQpAvvL +oJHRfNbDflDVnVi+QTjruXU8FdmbyUqDWcDaU/0zuzYYm4UPFd3uLax2k7nZAY1IEKj79TiG8dsK +xr2EoyNB3tZ3b4XUhRxQ4K5RirqNPnbiucon8l+f725ZDQbYKxek0nxru18UGkiPGkzns0ccjkxF +KyDuSN/n3QmOGKjaQI2SJhFTYXNd673nxE0pN2HrrDktZy4W1vUAg4WhzH92xH3kt0tm7wNFYGm2 +DFKWkoRepqO1pD4r2czYG0eq8kTaT/kD6PAUyz/zg97QwVTjt+gKN02LIFkDMBmhLMi9ER/frslK +xfMnZmaGrGiR/9nmUxwPi1xpZQomyB40w11Re9epnAahNt3ViZS82eQtDF4JbAiXfKM9fJP/P6EU +p8+1Xevb2xzEdt+Iub1FBZUbrvxGakyvSOPOrg/SfuvmbJxPgWp6ZKy7PtXny3YuxadIwVyQD8vI +P/rmMuGNG2+k5o7Y+SlIis5z/iw= +-----END CERTIFICATE----- + +GeoTrust Universal CA 2 +======================= +-----BEGIN CERTIFICATE----- +MIIFbDCCA1SgAwIBAgIBATANBgkqhkiG9w0BAQUFADBHMQswCQYDVQQGEwJVUzEWMBQGA1UEChMN +R2VvVHJ1c3QgSW5jLjEgMB4GA1UEAxMXR2VvVHJ1c3QgVW5pdmVyc2FsIENBIDIwHhcNMDQwMzA0 +MDUwMDAwWhcNMjkwMzA0MDUwMDAwWjBHMQswCQYDVQQGEwJVUzEWMBQGA1UEChMNR2VvVHJ1c3Qg +SW5jLjEgMB4GA1UEAxMXR2VvVHJ1c3QgVW5pdmVyc2FsIENBIDIwggIiMA0GCSqGSIb3DQEBAQUA +A4ICDwAwggIKAoICAQCzVFLByT7y2dyxUxpZKeexw0Uo5dfR7cXFS6GqdHtXr0om/Nj1XqduGdt0 +DE81WzILAePb63p3NeqqWuDW6KFXlPCQo3RWlEQwAx5cTiuFJnSCegx2oG9NzkEtoBUGFF+3Qs17 +j1hhNNwqCPkuwwGmIkQcTAeC5lvO0Ep8BNMZcyfwqph/Lq9O64ceJHdqXbboW0W63MOhBW9Wjo8Q +JqVJwy7XQYci4E+GymC16qFjwAGXEHm9ADwSbSsVsaxLse4YuU6W3Nx2/zu+z18DwPw76L5GG//a +QMJS9/7jOvdqdzXQ2o3rXhhqMcceujwbKNZrVMaqW9eiLBsZzKIC9ptZvTdrhrVtgrrY6slWvKk2 +WP0+GfPtDCapkzj4T8FdIgbQl+rhrcZV4IErKIM6+vR7IVEAvlI4zs1meaj0gVbi0IMJR1FbUGrP +20gaXT73y/Zl92zxlfgCOzJWgjl6W70viRu/obTo/3+NjN8D8WBOWBFM66M/ECuDmgFz2ZRthAAn +ZqzwcEAJQpKtT5MNYQlRJNiS1QuUYbKHsu3/mjX/hVTK7URDrBs8FmtISgocQIgfksILAAX/8sgC +SqSqqcyZlpwvWOB94b67B9xfBHJcMTTD7F8t4D1kkCLm0ey4Lt1ZrtmhN79UNdxzMk+MBB4zsslG +8dhcyFVQyWi9qLo2CQIDAQABo2MwYTAPBgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBR281Xh+qQ2 ++/CfXGJx7Tz0RzgQKzAfBgNVHSMEGDAWgBR281Xh+qQ2+/CfXGJx7Tz0RzgQKzAOBgNVHQ8BAf8E +BAMCAYYwDQYJKoZIhvcNAQEFBQADggIBAGbBxiPz2eAubl/oz66wsCVNK/g7WJtAJDday6sWSf+z +dXkzoS9tcBc0kf5nfo/sm+VegqlVHy/c1FEHEv6sFj4sNcZj/NwQ6w2jqtB8zNHQL1EuxBRa3ugZ +4T7GzKQp5y6EqgYweHZUcyiYWTjgAA1i00J9IZ+uPTqM1fp3DRgrFg5fNuH8KrUwJM/gYwx7WBr+ +mbpCErGR9Hxo4sjoryzqyX6uuyo9DRXcNJW2GHSoag/HtPQTxORb7QrSpJdMKu0vbBKJPfEncKpq +A1Ihn0CoZ1Dy81of398j9tx4TuaYT1U6U+Pv8vSfx3zYWK8pIpe44L2RLrB27FcRz+8pRPPphXpg +Y+RdM4kX2TGq2tbzGDVyz4crL2MjhF2EjD9XoIj8mZEoJmmZ1I+XRL6O1UixpCgp8RW04eWe3fiP +pm8m1wk8OhwRDqZsN/etRIcsKMfYdIKz0G9KV7s1KSegi+ghp4dkNl3M2Basx7InQJJVOCiNUW7d +FGdTbHFcJoRNdVq2fmBWqU2t+5sel/MN2dKXVHfaPRK34B7vCAas+YWH6aLcr34YEoP9VhdBLtUp +gn2Z9DH2canPLAEnpQW5qrJITirvn5NSUZU8UnOOVkwXQMAJKOSLakhT2+zNVVXxxvjpoixMptEm +X36vWkzaH6byHCx+rgIW0lbQL1dTR+iS +-----END CERTIFICATE----- + +Visa eCommerce Root +=================== +-----BEGIN CERTIFICATE----- +MIIDojCCAoqgAwIBAgIQE4Y1TR0/BvLB+WUF1ZAcYjANBgkqhkiG9w0BAQUFADBrMQswCQYDVQQG +EwJVUzENMAsGA1UEChMEVklTQTEvMC0GA1UECxMmVmlzYSBJbnRlcm5hdGlvbmFsIFNlcnZpY2Ug +QXNzb2NpYXRpb24xHDAaBgNVBAMTE1Zpc2EgZUNvbW1lcmNlIFJvb3QwHhcNMDIwNjI2MDIxODM2 +WhcNMjIwNjI0MDAxNjEyWjBrMQswCQYDVQQGEwJVUzENMAsGA1UEChMEVklTQTEvMC0GA1UECxMm +VmlzYSBJbnRlcm5hdGlvbmFsIFNlcnZpY2UgQXNzb2NpYXRpb24xHDAaBgNVBAMTE1Zpc2EgZUNv +bW1lcmNlIFJvb3QwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCvV95WHm6h2mCxlCfL +F9sHP4CFT8icttD0b0/Pmdjh28JIXDqsOTPHH2qLJj0rNfVIsZHBAk4ElpF7sDPwsRROEW+1QK8b +RaVK7362rPKgH1g/EkZgPI2h4H3PVz4zHvtH8aoVlwdVZqW1LS7YgFmypw23RuwhY/81q6UCzyr0 +TP579ZRdhE2o8mCP2w4lPJ9zcc+U30rq299yOIzzlr3xF7zSujtFWsan9sYXiwGd/BmoKoMWuDpI +/k4+oKsGGelT84ATB+0tvz8KPFUgOSwsAGl0lUq8ILKpeeUYiZGo3BxN77t+Nwtd/jmliFKMAGzs +GHxBvfaLdXe6YJ2E5/4tAgMBAAGjQjBAMA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEG +MB0GA1UdDgQWBBQVOIMPPyw/cDMezUb+B4wg4NfDtzANBgkqhkiG9w0BAQUFAAOCAQEAX/FBfXxc +CLkr4NWSR/pnXKUTwwMhmytMiUbPWU3J/qVAtmPN3XEolWcRzCSs00Rsca4BIGsDoo8Ytyk6feUW +YFN4PMCvFYP3j1IzJL1kk5fui/fbGKhtcbP3LBfQdCVp9/5rPJS+TUtBjE7ic9DjkCJzQ83z7+pz +zkWKsKZJ/0x9nXGIxHYdkFsd7v3M9+79YKWxehZx0RbQfBI8bGmX265fOZpwLwU8GUYEmSA20GBu +YQa7FkKMcPcw++DbZqMAAb3mLNqRX6BGi01qnD093QVG/na/oAo85ADmJ7f/hC3euiInlhBx6yLt +398znM/jra6O1I7mT1GvFpLgXPYHDw== +-----END CERTIFICATE----- + +Comodo AAA Services root +======================== +-----BEGIN CERTIFICATE----- +MIIEMjCCAxqgAwIBAgIBATANBgkqhkiG9w0BAQUFADB7MQswCQYDVQQGEwJHQjEbMBkGA1UECAwS +R3JlYXRlciBNYW5jaGVzdGVyMRAwDgYDVQQHDAdTYWxmb3JkMRowGAYDVQQKDBFDb21vZG8gQ0Eg +TGltaXRlZDEhMB8GA1UEAwwYQUFBIENlcnRpZmljYXRlIFNlcnZpY2VzMB4XDTA0MDEwMTAwMDAw +MFoXDTI4MTIzMTIzNTk1OVowezELMAkGA1UEBhMCR0IxGzAZBgNVBAgMEkdyZWF0ZXIgTWFuY2hl +c3RlcjEQMA4GA1UEBwwHU2FsZm9yZDEaMBgGA1UECgwRQ29tb2RvIENBIExpbWl0ZWQxITAfBgNV +BAMMGEFBQSBDZXJ0aWZpY2F0ZSBTZXJ2aWNlczCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoC +ggEBAL5AnfRu4ep2hxxNRUSOvkbIgwadwSr+GB+O5AL686tdUIoWMQuaBtDFcCLNSS1UY8y2bmhG +C1Pqy0wkwLxyTurxFa70VJoSCsN6sjNg4tqJVfMiWPPe3M/vg4aijJRPn2jymJBGhCfHdr/jzDUs +i14HZGWCwEiwqJH5YZ92IFCokcdmtet4YgNW8IoaE+oxox6gmf049vYnMlhvB/VruPsUK6+3qszW +Y19zjNoFmag4qMsXeDZRrOme9Hg6jc8P2ULimAyrL58OAd7vn5lJ8S3frHRNG5i1R8XlKdH5kBjH +Ypy+g8cmez6KJcfA3Z3mNWgQIJ2P2N7Sw4ScDV7oL8kCAwEAAaOBwDCBvTAdBgNVHQ4EFgQUoBEK +Iz6W8Qfs4q8p74Klf9AwpLQwDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wewYDVR0f +BHQwcjA4oDagNIYyaHR0cDovL2NybC5jb21vZG9jYS5jb20vQUFBQ2VydGlmaWNhdGVTZXJ2aWNl +cy5jcmwwNqA0oDKGMGh0dHA6Ly9jcmwuY29tb2RvLm5ldC9BQUFDZXJ0aWZpY2F0ZVNlcnZpY2Vz +LmNybDANBgkqhkiG9w0BAQUFAAOCAQEACFb8AvCb6P+k+tZ7xkSAzk/ExfYAWMymtrwUSWgEdujm +7l3sAg9g1o1QGE8mTgHj5rCl7r+8dFRBv/38ErjHT1r0iWAFf2C3BUrz9vHCv8S5dIa2LX1rzNLz +Rt0vxuBqw8M0Ayx9lt1awg6nCpnBBYurDC/zXDrPbDdVCYfeU0BsWO/8tqtlbgT2G9w84FoVxp7Z +8VlIMCFlA2zs6SFz7JsDoeA3raAVGI/6ugLOpyypEBMs1OUIJqsil2D4kF501KKaU73yqWjgom7C +12yxow+ev+to51byrvLjKzg6CYG1a4XXvi3tPxq3smPi9WIsgtRqAEFQ8TmDn5XpNpaYbg== +-----END CERTIFICATE----- + +QuoVadis Root CA +================ +-----BEGIN CERTIFICATE----- +MIIF0DCCBLigAwIBAgIEOrZQizANBgkqhkiG9w0BAQUFADB/MQswCQYDVQQGEwJCTTEZMBcGA1UE +ChMQUXVvVmFkaXMgTGltaXRlZDElMCMGA1UECxMcUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0 +eTEuMCwGA1UEAxMlUXVvVmFkaXMgUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAeFw0wMTAz +MTkxODMzMzNaFw0yMTAzMTcxODMzMzNaMH8xCzAJBgNVBAYTAkJNMRkwFwYDVQQKExBRdW9WYWRp +cyBMaW1pdGVkMSUwIwYDVQQLExxSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5MS4wLAYDVQQD +EyVRdW9WYWRpcyBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5MIIBIjANBgkqhkiG9w0BAQEF +AAOCAQ8AMIIBCgKCAQEAv2G1lVO6V/z68mcLOhrfEYBklbTRvM16z/Ypli4kVEAkOPcahdxYTMuk +J0KX0J+DisPkBgNbAKVRHnAEdOLB1Dqr1607BxgFjv2DrOpm2RgbaIr1VxqYuvXtdj182d6UajtL +F8HVj71lODqV0D1VNk7feVcxKh7YWWVJWCCYfqtffp/p1k3sg3Spx2zY7ilKhSoGFPlU5tPaZQeL +YzcS19Dsw3sgQUSj7cugF+FxZc4dZjH3dgEZyH0DWLaVSR2mEiboxgx24ONmy+pdpibu5cxfvWen +AScOospUxbF6lR1xHkopigPcakXBpBlebzbNw6Kwt/5cOOJSvPhEQ+aQuwIDAQABo4ICUjCCAk4w +PQYIKwYBBQUHAQEEMTAvMC0GCCsGAQUFBzABhiFodHRwczovL29jc3AucXVvdmFkaXNvZmZzaG9y +ZS5jb20wDwYDVR0TAQH/BAUwAwEB/zCCARoGA1UdIASCAREwggENMIIBCQYJKwYBBAG+WAABMIH7 +MIHUBggrBgEFBQcCAjCBxxqBxFJlbGlhbmNlIG9uIHRoZSBRdW9WYWRpcyBSb290IENlcnRpZmlj +YXRlIGJ5IGFueSBwYXJ0eSBhc3N1bWVzIGFjY2VwdGFuY2Ugb2YgdGhlIHRoZW4gYXBwbGljYWJs +ZSBzdGFuZGFyZCB0ZXJtcyBhbmQgY29uZGl0aW9ucyBvZiB1c2UsIGNlcnRpZmljYXRpb24gcHJh +Y3RpY2VzLCBhbmQgdGhlIFF1b1ZhZGlzIENlcnRpZmljYXRlIFBvbGljeS4wIgYIKwYBBQUHAgEW +Fmh0dHA6Ly93d3cucXVvdmFkaXMuYm0wHQYDVR0OBBYEFItLbe3TKbkGGew5Oanwl4Rqy+/fMIGu +BgNVHSMEgaYwgaOAFItLbe3TKbkGGew5Oanwl4Rqy+/foYGEpIGBMH8xCzAJBgNVBAYTAkJNMRkw +FwYDVQQKExBRdW9WYWRpcyBMaW1pdGVkMSUwIwYDVQQLExxSb290IENlcnRpZmljYXRpb24gQXV0 +aG9yaXR5MS4wLAYDVQQDEyVRdW9WYWRpcyBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5ggQ6 +tlCLMA4GA1UdDwEB/wQEAwIBBjANBgkqhkiG9w0BAQUFAAOCAQEAitQUtf70mpKnGdSkfnIYj9lo +fFIk3WdvOXrEql494liwTXCYhGHoG+NpGA7O+0dQoE7/8CQfvbLO9Sf87C9TqnN7Az10buYWnuul +LsS/VidQK2K6vkscPFVcQR0kvoIgR13VRH56FmjffU1RcHhXHTMe/QKZnAzNCgVPx7uOpHX6Sm2x +gI4JVrmcGmD+XcHXetwReNDWXcG31a0ymQM6isxUJTkxgXsTIlG6Rmyhu576BGxJJnSP0nPrzDCi +5upZIof4l/UO/erMkqQWxFIY6iHOsfHmhIHluqmGKPJDWl0Snawe2ajlCmqnf6CHKc/yiU3U7MXi +5nrQNiOKSnQ2+Q== +-----END CERTIFICATE----- + +QuoVadis Root CA 2 +================== +-----BEGIN CERTIFICATE----- +MIIFtzCCA5+gAwIBAgICBQkwDQYJKoZIhvcNAQEFBQAwRTELMAkGA1UEBhMCQk0xGTAXBgNVBAoT +EFF1b1ZhZGlzIExpbWl0ZWQxGzAZBgNVBAMTElF1b1ZhZGlzIFJvb3QgQ0EgMjAeFw0wNjExMjQx +ODI3MDBaFw0zMTExMjQxODIzMzNaMEUxCzAJBgNVBAYTAkJNMRkwFwYDVQQKExBRdW9WYWRpcyBM +aW1pdGVkMRswGQYDVQQDExJRdW9WYWRpcyBSb290IENBIDIwggIiMA0GCSqGSIb3DQEBAQUAA4IC +DwAwggIKAoICAQCaGMpLlA0ALa8DKYrwD4HIrkwZhR0In6spRIXzL4GtMh6QRr+jhiYaHv5+HBg6 +XJxgFyo6dIMzMH1hVBHL7avg5tKifvVrbxi3Cgst/ek+7wrGsxDp3MJGF/hd/aTa/55JWpzmM+Yk +lvc/ulsrHHo1wtZn/qtmUIttKGAr79dgw8eTvI02kfN/+NsRE8Scd3bBrrcCaoF6qUWD4gXmuVbB +lDePSHFjIuwXZQeVikvfj8ZaCuWw419eaxGrDPmF60Tp+ARz8un+XJiM9XOva7R+zdRcAitMOeGy +lZUtQofX1bOQQ7dsE/He3fbE+Ik/0XX1ksOR1YqI0JDs3G3eicJlcZaLDQP9nL9bFqyS2+r+eXyt +66/3FsvbzSUr5R/7mp/iUcw6UwxI5g69ybR2BlLmEROFcmMDBOAENisgGQLodKcftslWZvB1Jdxn +wQ5hYIizPtGo/KPaHbDRsSNU30R2be1B2MGyIrZTHN81Hdyhdyox5C315eXbyOD/5YDXC2Og/zOh +D7osFRXql7PSorW+8oyWHhqPHWykYTe5hnMz15eWniN9gqRMgeKh0bpnX5UHoycR7hYQe7xFSkyy +BNKr79X9DFHOUGoIMfmR2gyPZFwDwzqLID9ujWc9Otb+fVuIyV77zGHcizN300QyNQliBJIWENie +J0f7OyHj+OsdWwIDAQABo4GwMIGtMA8GA1UdEwEB/wQFMAMBAf8wCwYDVR0PBAQDAgEGMB0GA1Ud +DgQWBBQahGK8SEwzJQTU7tD2A8QZRtGUazBuBgNVHSMEZzBlgBQahGK8SEwzJQTU7tD2A8QZRtGU +a6FJpEcwRTELMAkGA1UEBhMCQk0xGTAXBgNVBAoTEFF1b1ZhZGlzIExpbWl0ZWQxGzAZBgNVBAMT +ElF1b1ZhZGlzIFJvb3QgQ0EgMoICBQkwDQYJKoZIhvcNAQEFBQADggIBAD4KFk2fBluornFdLwUv +Z+YTRYPENvbzwCYMDbVHZF34tHLJRqUDGCdViXh9duqWNIAXINzng/iN/Ae42l9NLmeyhP3ZRPx3 +UIHmfLTJDQtyU/h2BwdBR5YM++CCJpNVjP4iH2BlfF/nJrP3MpCYUNQ3cVX2kiF495V5+vgtJodm +VjB3pjd4M1IQWK4/YY7yarHvGH5KWWPKjaJW1acvvFYfzznB4vsKqBUsfU16Y8Zsl0Q80m/DShcK ++JDSV6IZUaUtl0HaB0+pUNqQjZRG4T7wlP0QADj1O+hA4bRuVhogzG9Yje0uRY/W6ZM/57Es3zrW +IozchLsib9D45MY56QSIPMO661V6bYCZJPVsAfv4l7CUW+v90m/xd2gNNWQjrLhVoQPRTUIZ3Ph1 +WVaj+ahJefivDrkRoHy3au000LYmYjgahwz46P0u05B/B5EqHdZ+XIWDmbA4CD/pXvk1B+TJYm5X +f6dQlfe6yJvmjqIBxdZmv3lh8zwc4bmCXF2gw+nYSL0ZohEUGW6yhhtoPkg3Goi3XZZenMfvJ2II +4pEZXNLxId26F0KCl3GBUzGpn/Z9Yr9y4aOTHcyKJloJONDO1w2AFrR4pTqHTI2KpdVGl/IsELm8 +VCLAAVBpQ570su9t+Oza8eOx79+Rj1QqCyXBJhnEUhAFZdWCEOrCMc0u +-----END CERTIFICATE----- + +QuoVadis Root CA 3 +================== +-----BEGIN CERTIFICATE----- +MIIGnTCCBIWgAwIBAgICBcYwDQYJKoZIhvcNAQEFBQAwRTELMAkGA1UEBhMCQk0xGTAXBgNVBAoT +EFF1b1ZhZGlzIExpbWl0ZWQxGzAZBgNVBAMTElF1b1ZhZGlzIFJvb3QgQ0EgMzAeFw0wNjExMjQx +OTExMjNaFw0zMTExMjQxOTA2NDRaMEUxCzAJBgNVBAYTAkJNMRkwFwYDVQQKExBRdW9WYWRpcyBM +aW1pdGVkMRswGQYDVQQDExJRdW9WYWRpcyBSb290IENBIDMwggIiMA0GCSqGSIb3DQEBAQUAA4IC +DwAwggIKAoICAQDMV0IWVJzmmNPTTe7+7cefQzlKZbPoFog02w1ZkXTPkrgEQK0CSzGrvI2RaNgg +DhoB4hp7Thdd4oq3P5kazethq8Jlph+3t723j/z9cI8LoGe+AaJZz3HmDyl2/7FWeUUrH556VOij +KTVopAFPD6QuN+8bv+OPEKhyq1hX51SGyMnzW9os2l2ObjyjPtr7guXd8lyyBTNvijbO0BNO/79K +DDRMpsMhvVAEVeuxu537RR5kFd5VAYwCdrXLoT9CabwvvWhDFlaJKjdhkf2mrk7AyxRllDdLkgbv +BNDInIjbC3uBr7E9KsRlOni27tyAsdLTmZw67mtaa7ONt9XOnMK+pUsvFrGeaDsGb659n/je7Mwp +p5ijJUMv7/FfJuGITfhebtfZFG4ZM2mnO4SJk8RTVROhUXhA+LjJou57ulJCg54U7QVSWllWp5f8 +nT8KKdjcT5EOE7zelaTfi5m+rJsziO+1ga8bxiJTyPbH7pcUsMV8eFLI8M5ud2CEpukqdiDtWAEX +MJPpGovgc2PZapKUSU60rUqFxKMiMPwJ7Wgic6aIDFUhWMXhOp8q3crhkODZc6tsgLjoC2SToJyM +Gf+z0gzskSaHirOi4XCPLArlzW1oUevaPwV/izLmE1xr/l9A4iLItLRkT9a6fUg+qGkM17uGcclz +uD87nSVL2v9A6wIDAQABo4IBlTCCAZEwDwYDVR0TAQH/BAUwAwEB/zCB4QYDVR0gBIHZMIHWMIHT +BgkrBgEEAb5YAAMwgcUwgZMGCCsGAQUFBwICMIGGGoGDQW55IHVzZSBvZiB0aGlzIENlcnRpZmlj +YXRlIGNvbnN0aXR1dGVzIGFjY2VwdGFuY2Ugb2YgdGhlIFF1b1ZhZGlzIFJvb3QgQ0EgMyBDZXJ0 +aWZpY2F0ZSBQb2xpY3kgLyBDZXJ0aWZpY2F0aW9uIFByYWN0aWNlIFN0YXRlbWVudC4wLQYIKwYB +BQUHAgEWIWh0dHA6Ly93d3cucXVvdmFkaXNnbG9iYWwuY29tL2NwczALBgNVHQ8EBAMCAQYwHQYD +VR0OBBYEFPLAE+CCQz777i9nMpY1XNu4ywLQMG4GA1UdIwRnMGWAFPLAE+CCQz777i9nMpY1XNu4 +ywLQoUmkRzBFMQswCQYDVQQGEwJCTTEZMBcGA1UEChMQUXVvVmFkaXMgTGltaXRlZDEbMBkGA1UE +AxMSUXVvVmFkaXMgUm9vdCBDQSAzggIFxjANBgkqhkiG9w0BAQUFAAOCAgEAT62gLEz6wPJv92ZV +qyM07ucp2sNbtrCD2dDQ4iH782CnO11gUyeim/YIIirnv6By5ZwkajGxkHon24QRiSemd1o417+s +hvzuXYO8BsbRd2sPbSQvS3pspweWyuOEn62Iix2rFo1bZhfZFvSLgNLd+LJ2w/w4E6oM3kJpK27z +POuAJ9v1pkQNn1pVWQvVDVJIxa6f8i+AxeoyUDUSly7B4f/xI4hROJ/yZlZ25w9Rl6VSDE1JUZU2 +Pb+iSwwQHYaZTKrzchGT5Or2m9qoXadNt54CrnMAyNojA+j56hl0YgCUyyIgvpSnWbWCar6ZeXqp +8kokUvd0/bpO5qgdAm6xDYBEwa7TIzdfu4V8K5Iu6H6li92Z4b8nby1dqnuH/grdS/yO9SbkbnBC +bjPsMZ57k8HkyWkaPcBrTiJt7qtYTcbQQcEr6k8Sh17rRdhs9ZgC06DYVYoGmRmioHfRMJ6szHXu +g/WwYjnPbFfiTNKRCw51KBuav/0aQ/HKd/s7j2G4aSgWQgRecCocIdiP4b0jWy10QJLZYxkNc91p +vGJHvOB0K7Lrfb5BG7XARsWhIstfTsEokt4YutUqKLsRixeTmJlglFwjz1onl14LBQaTNx47aTbr +qZ5hHY8y2o4M1nQ+ewkk2gF3R8Q7zTSMmfXK4SVhM7JZG+Ju1zdXtg2pEto= +-----END CERTIFICATE----- + +Security Communication Root CA +============================== +-----BEGIN CERTIFICATE----- +MIIDWjCCAkKgAwIBAgIBADANBgkqhkiG9w0BAQUFADBQMQswCQYDVQQGEwJKUDEYMBYGA1UEChMP +U0VDT00gVHJ1c3QubmV0MScwJQYDVQQLEx5TZWN1cml0eSBDb21tdW5pY2F0aW9uIFJvb3RDQTEw +HhcNMDMwOTMwMDQyMDQ5WhcNMjMwOTMwMDQyMDQ5WjBQMQswCQYDVQQGEwJKUDEYMBYGA1UEChMP +U0VDT00gVHJ1c3QubmV0MScwJQYDVQQLEx5TZWN1cml0eSBDb21tdW5pY2F0aW9uIFJvb3RDQTEw +ggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCzs/5/022x7xZ8V6UMbXaKL0u/ZPtM7orw +8yl89f/uKuDp6bpbZCKamm8sOiZpUQWZJtzVHGpxxpp9Hp3dfGzGjGdnSj74cbAZJ6kJDKaVv0uM +DPpVmDvY6CKhS3E4eayXkmmziX7qIWgGmBSWh9JhNrxtJ1aeV+7AwFb9Ms+k2Y7CI9eNqPPYJayX +5HA49LY6tJ07lyZDo6G8SVlyTCMwhwFY9k6+HGhWZq/NQV3Is00qVUarH9oe4kA92819uZKAnDfd +DJZkndwi92SL32HeFZRSFaB9UslLqCHJxrHty8OVYNEP8Ktw+N/LTX7s1vqr2b1/VPKl6Xn62dZ2 +JChzAgMBAAGjPzA9MB0GA1UdDgQWBBSgc0mZaNyFW2XjmygvV5+9M7wHSDALBgNVHQ8EBAMCAQYw +DwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQUFAAOCAQEAaECpqLvkT115swW1F7NgE+vGkl3g +0dNq/vu+m22/xwVtWSDEHPC32oRYAmP6SBbvT6UL90qY8j+eG61Ha2POCEfrUj94nK9NrvjVT8+a +mCoQQTlSxN3Zmw7vkwGusi7KaEIkQmywszo+zenaSMQVy+n5Bw+SUEmK3TGXX8npN6o7WWWXlDLJ +s58+OmJYxUmtYg5xpTKqL8aJdkNAExNnPaJUJRDL8Try2frbSVa7pv6nQTXD4IhhyYjH3zYQIphZ +6rBK+1YWc26sTfcioU+tHXotRSflMMFe8toTyyVCUZVHA4xsIcx0Qu1T/zOLjw9XARYvz6buyXAi +FL39vmwLAw== +-----END CERTIFICATE----- + +Sonera Class 2 Root CA +====================== +-----BEGIN CERTIFICATE----- +MIIDIDCCAgigAwIBAgIBHTANBgkqhkiG9w0BAQUFADA5MQswCQYDVQQGEwJGSTEPMA0GA1UEChMG +U29uZXJhMRkwFwYDVQQDExBTb25lcmEgQ2xhc3MyIENBMB4XDTAxMDQwNjA3Mjk0MFoXDTIxMDQw +NjA3Mjk0MFowOTELMAkGA1UEBhMCRkkxDzANBgNVBAoTBlNvbmVyYTEZMBcGA1UEAxMQU29uZXJh +IENsYXNzMiBDQTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAJAXSjWdyvANlsdE+hY3 +/Ei9vX+ALTU74W+oZ6m/AxxNjG8yR9VBaKQTBME1DJqEQ/xcHf+Js+gXGM2RX/uJ4+q/Tl18GybT +dXnt5oTjV+WtKcT0OijnpXuENmmz/V52vaMtmdOQTiMofRhj8VQ7Jp12W5dCsv+u8E7s3TmVToMG +f+dJQMjFAbJUWmYdPfz56TwKnoG4cPABi+QjVHzIrviQHgCWctRUz2EjvOr7nQKV0ba5cTppCD8P +tOFCx4j1P5iop7oc4HFx71hXgVB6XGt0Rg6DA5jDjqhu8nYybieDwnPz3BjotJPqdURrBGAgcVeH +nfO+oJAjPYok4doh28MCAwEAAaMzMDEwDwYDVR0TAQH/BAUwAwEB/zARBgNVHQ4ECgQISqCqWITT +XjwwCwYDVR0PBAQDAgEGMA0GCSqGSIb3DQEBBQUAA4IBAQBazof5FnIVV0sd2ZvnoiYw7JNn39Yt +0jSv9zilzqsWuasvfDXLrNAPtEwr/IDva4yRXzZ299uzGxnq9LIR/WFxRL8oszodv7ND6J+/3DEI +cbCdjdY0RzKQxmUk96BKfARzjzlvF4xytb1LyHr4e4PDKE6cCepnP7JnBBvDFNr450kkkdAdavph +Oe9r5yF1BgfYErQhIHBCcYHaPJo2vqZbDWpsmh+Re/n570K6Tk6ezAyNlNzZRZxe7EJQY670XcSx +EtzKO6gunRRaBXW37Ndj4ro1tgQIkejanZz2ZrUYrAqmVCY0M9IbwdR/GjqOC6oybtv8TyWf2TLH +llpwrN9M +-----END CERTIFICATE----- + +Camerfirma Chambers of Commerce Root +==================================== +-----BEGIN CERTIFICATE----- +MIIEvTCCA6WgAwIBAgIBADANBgkqhkiG9w0BAQUFADB/MQswCQYDVQQGEwJFVTEnMCUGA1UEChMe +QUMgQ2FtZXJmaXJtYSBTQSBDSUYgQTgyNzQzMjg3MSMwIQYDVQQLExpodHRwOi8vd3d3LmNoYW1i +ZXJzaWduLm9yZzEiMCAGA1UEAxMZQ2hhbWJlcnMgb2YgQ29tbWVyY2UgUm9vdDAeFw0wMzA5MzAx +NjEzNDNaFw0zNzA5MzAxNjEzNDRaMH8xCzAJBgNVBAYTAkVVMScwJQYDVQQKEx5BQyBDYW1lcmZp +cm1hIFNBIENJRiBBODI3NDMyODcxIzAhBgNVBAsTGmh0dHA6Ly93d3cuY2hhbWJlcnNpZ24ub3Jn +MSIwIAYDVQQDExlDaGFtYmVycyBvZiBDb21tZXJjZSBSb290MIIBIDANBgkqhkiG9w0BAQEFAAOC +AQ0AMIIBCAKCAQEAtzZV5aVdGDDg2olUkfzIx1L4L1DZ77F1c2VHfRtbunXF/KGIJPov7coISjlU +xFF6tdpg6jg8gbLL8bvZkSM/SAFwdakFKq0fcfPJVD0dBmpAPrMMhe5cG3nCYsS4No41XQEMIwRH +NaqbYE6gZj3LJgqcQKH0XZi/caulAGgq7YN6D6IUtdQis4CwPAxaUWktWBiP7Zme8a7ileb2R6jW +DA+wWFjbw2Y3npuRVDM30pQcakjJyfKl2qUMI/cjDpwyVV5xnIQFUZot/eZOKjRa3spAN2cMVCFV +d9oKDMyXroDclDZK9D7ONhMeU+SsTjoF7Nuucpw4i9A5O4kKPnf+dQIBA6OCAUQwggFAMBIGA1Ud +EwEB/wQIMAYBAf8CAQwwPAYDVR0fBDUwMzAxoC+gLYYraHR0cDovL2NybC5jaGFtYmVyc2lnbi5v +cmcvY2hhbWJlcnNyb290LmNybDAdBgNVHQ4EFgQU45T1sU3p26EpW1eLTXYGduHRooowDgYDVR0P +AQH/BAQDAgEGMBEGCWCGSAGG+EIBAQQEAwIABzAnBgNVHREEIDAegRxjaGFtYmVyc3Jvb3RAY2hh +bWJlcnNpZ24ub3JnMCcGA1UdEgQgMB6BHGNoYW1iZXJzcm9vdEBjaGFtYmVyc2lnbi5vcmcwWAYD +VR0gBFEwTzBNBgsrBgEEAYGHLgoDATA+MDwGCCsGAQUFBwIBFjBodHRwOi8vY3BzLmNoYW1iZXJz +aWduLm9yZy9jcHMvY2hhbWJlcnNyb290Lmh0bWwwDQYJKoZIhvcNAQEFBQADggEBAAxBl8IahsAi +fJ/7kPMa0QOx7xP5IV8EnNrJpY0nbJaHkb5BkAFyk+cefV/2icZdp0AJPaxJRUXcLo0waLIJuvvD +L8y6C98/d3tGfToSJI6WjzwFCm/SlCgdbQzALogi1djPHRPH8EjX1wWnz8dHnjs8NMiAT9QUu/wN +UPf6s+xCX6ndbcj0dc97wXImsQEcXCz9ek60AcUFV7nnPKoF2YjpB0ZBzu9Bga5Y34OirsrXdx/n +ADydb47kMgkdTXg0eDQ8lJsm7U9xxhl6vSAiSFr+S30Dt+dYvsYyTnQeaN2oaFuzPu5ifdmA6Ap1 +erfutGWaIZDgqtCYvDi1czyL+Nw= +-----END CERTIFICATE----- + +Camerfirma Global Chambersign Root +================================== +-----BEGIN CERTIFICATE----- +MIIExTCCA62gAwIBAgIBADANBgkqhkiG9w0BAQUFADB9MQswCQYDVQQGEwJFVTEnMCUGA1UEChMe +QUMgQ2FtZXJmaXJtYSBTQSBDSUYgQTgyNzQzMjg3MSMwIQYDVQQLExpodHRwOi8vd3d3LmNoYW1i +ZXJzaWduLm9yZzEgMB4GA1UEAxMXR2xvYmFsIENoYW1iZXJzaWduIFJvb3QwHhcNMDMwOTMwMTYx +NDE4WhcNMzcwOTMwMTYxNDE4WjB9MQswCQYDVQQGEwJFVTEnMCUGA1UEChMeQUMgQ2FtZXJmaXJt +YSBTQSBDSUYgQTgyNzQzMjg3MSMwIQYDVQQLExpodHRwOi8vd3d3LmNoYW1iZXJzaWduLm9yZzEg +MB4GA1UEAxMXR2xvYmFsIENoYW1iZXJzaWduIFJvb3QwggEgMA0GCSqGSIb3DQEBAQUAA4IBDQAw +ggEIAoIBAQCicKLQn0KuWxfH2H3PFIP8T8mhtxOviteePgQKkotgVvq0Mi+ITaFgCPS3CU6gSS9J +1tPfnZdan5QEcOw/Wdm3zGaLmFIoCQLfxS+EjXqXd7/sQJ0lcqu1PzKY+7e3/HKE5TWH+VX6ox8O +by4o3Wmg2UIQxvi1RMLQQ3/bvOSiPGpVeAp3qdjqGTK3L/5cPxvusZjsyq16aUXjlg9V9ubtdepl +6DJWk0aJqCWKZQbua795B9Dxt6/tLE2Su8CoX6dnfQTyFQhwrJLWfQTSM/tMtgsL+xrJxI0DqX5c +8lCrEqWhz0hQpe/SyBoT+rB/sYIcd2oPX9wLlY/vQ37mRQklAgEDo4IBUDCCAUwwEgYDVR0TAQH/ +BAgwBgEB/wIBDDA/BgNVHR8EODA2MDSgMqAwhi5odHRwOi8vY3JsLmNoYW1iZXJzaWduLm9yZy9j +aGFtYmVyc2lnbnJvb3QuY3JsMB0GA1UdDgQWBBRDnDafsJ4wTcbOX60Qq+UDpfqpFDAOBgNVHQ8B +Af8EBAMCAQYwEQYJYIZIAYb4QgEBBAQDAgAHMCoGA1UdEQQjMCGBH2NoYW1iZXJzaWducm9vdEBj +aGFtYmVyc2lnbi5vcmcwKgYDVR0SBCMwIYEfY2hhbWJlcnNpZ25yb290QGNoYW1iZXJzaWduLm9y +ZzBbBgNVHSAEVDBSMFAGCysGAQQBgYcuCgEBMEEwPwYIKwYBBQUHAgEWM2h0dHA6Ly9jcHMuY2hh +bWJlcnNpZ24ub3JnL2Nwcy9jaGFtYmVyc2lnbnJvb3QuaHRtbDANBgkqhkiG9w0BAQUFAAOCAQEA +PDtwkfkEVCeR4e3t/mh/YV3lQWVPMvEYBZRqHN4fcNs+ezICNLUMbKGKfKX0j//U2K0X1S0E0T9Y +gOKBWYi+wONGkyT+kL0mojAt6JcmVzWJdJYY9hXiryQZVgICsroPFOrGimbBhkVVi76SvpykBMdJ +PJ7oKXqJ1/6v/2j1pReQvayZzKWGVwlnRtvWFsJG8eSpUPWP0ZIV018+xgBJOm5YstHRJw0lyDL4 +IBHNfTIzSJRUTN3cecQwn+uOuFW114hcxWokPbLTBQNRxgfvzBRydD1ucs4YKIxKoHflCStFREes +t2d/AYoFWpO+ocH/+OcOZ6RHSXZddZAa9SaP8A== +-----END CERTIFICATE----- + +XRamp Global CA Root +==================== +-----BEGIN CERTIFICATE----- +MIIEMDCCAxigAwIBAgIQUJRs7Bjq1ZxN1ZfvdY+grTANBgkqhkiG9w0BAQUFADCBgjELMAkGA1UE +BhMCVVMxHjAcBgNVBAsTFXd3dy54cmFtcHNlY3VyaXR5LmNvbTEkMCIGA1UEChMbWFJhbXAgU2Vj +dXJpdHkgU2VydmljZXMgSW5jMS0wKwYDVQQDEyRYUmFtcCBHbG9iYWwgQ2VydGlmaWNhdGlvbiBB +dXRob3JpdHkwHhcNMDQxMTAxMTcxNDA0WhcNMzUwMTAxMDUzNzE5WjCBgjELMAkGA1UEBhMCVVMx +HjAcBgNVBAsTFXd3dy54cmFtcHNlY3VyaXR5LmNvbTEkMCIGA1UEChMbWFJhbXAgU2VjdXJpdHkg +U2VydmljZXMgSW5jMS0wKwYDVQQDEyRYUmFtcCBHbG9iYWwgQ2VydGlmaWNhdGlvbiBBdXRob3Jp +dHkwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCYJB69FbS638eMpSe2OAtp87ZOqCwu +IR1cRN8hXX4jdP5efrRKt6atH67gBhbim1vZZ3RrXYCPKZ2GG9mcDZhtdhAoWORlsH9KmHmf4MMx +foArtYzAQDsRhtDLooY2YKTVMIJt2W7QDxIEM5dfT2Fa8OT5kavnHTu86M/0ay00fOJIYRyO82FE +zG+gSqmUsE3a56k0enI4qEHMPJQRfevIpoy3hsvKMzvZPTeL+3o+hiznc9cKV6xkmxnr9A8ECIqs +AxcZZPRaJSKNNCyy9mgdEm3Tih4U2sSPpuIjhdV6Db1q4Ons7Be7QhtnqiXtRYMh/MHJfNViPvry +xS3T/dRlAgMBAAGjgZ8wgZwwEwYJKwYBBAGCNxQCBAYeBABDAEEwCwYDVR0PBAQDAgGGMA8GA1Ud +EwEB/wQFMAMBAf8wHQYDVR0OBBYEFMZPoj0GY4QJnM5i5ASsjVy16bYbMDYGA1UdHwQvMC0wK6Ap +oCeGJWh0dHA6Ly9jcmwueHJhbXBzZWN1cml0eS5jb20vWEdDQS5jcmwwEAYJKwYBBAGCNxUBBAMC +AQEwDQYJKoZIhvcNAQEFBQADggEBAJEVOQMBG2f7Shz5CmBbodpNl2L5JFMn14JkTpAuw0kbK5rc +/Kh4ZzXxHfARvbdI4xD2Dd8/0sm2qlWkSLoC295ZLhVbO50WfUfXN+pfTXYSNrsf16GBBEYgoyxt +qZ4Bfj8pzgCT3/3JknOJiWSe5yvkHJEs0rnOfc5vMZnT5r7SHpDwCRR5XCOrTdLaIR9NmXmd4c8n +nxCbHIgNsIpkQTG4DmyQJKSbXHGPurt+HBvbaoAPIbzp26a3QPSyi6mx5O+aGtA9aZnuqCij4Tyz +8LIRnM98QObd50N9otg6tamN8jSZxNQQ4Qb9CYQQO+7ETPTsJ3xCwnR8gooJybQDJbw= +-----END CERTIFICATE----- + +Go Daddy Class 2 CA +=================== +-----BEGIN CERTIFICATE----- +MIIEADCCAuigAwIBAgIBADANBgkqhkiG9w0BAQUFADBjMQswCQYDVQQGEwJVUzEhMB8GA1UEChMY +VGhlIEdvIERhZGR5IEdyb3VwLCBJbmMuMTEwLwYDVQQLEyhHbyBEYWRkeSBDbGFzcyAyIENlcnRp +ZmljYXRpb24gQXV0aG9yaXR5MB4XDTA0MDYyOTE3MDYyMFoXDTM0MDYyOTE3MDYyMFowYzELMAkG +A1UEBhMCVVMxITAfBgNVBAoTGFRoZSBHbyBEYWRkeSBHcm91cCwgSW5jLjExMC8GA1UECxMoR28g +RGFkZHkgQ2xhc3MgMiBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTCCASAwDQYJKoZIhvcNAQEBBQAD +ggENADCCAQgCggEBAN6d1+pXGEmhW+vXX0iG6r7d/+TvZxz0ZWizV3GgXne77ZtJ6XCAPVYYYwhv +2vLM0D9/AlQiVBDYsoHUwHU9S3/Hd8M+eKsaA7Ugay9qK7HFiH7Eux6wwdhFJ2+qN1j3hybX2C32 +qRe3H3I2TqYXP2WYktsqbl2i/ojgC95/5Y0V4evLOtXiEqITLdiOr18SPaAIBQi2XKVlOARFmR6j +YGB0xUGlcmIbYsUfb18aQr4CUWWoriMYavx4A6lNf4DD+qta/KFApMoZFv6yyO9ecw3ud72a9nmY +vLEHZ6IVDd2gWMZEewo+YihfukEHU1jPEX44dMX4/7VpkI+EdOqXG68CAQOjgcAwgb0wHQYDVR0O +BBYEFNLEsNKR1EwRcbNhyz2h/t2oatTjMIGNBgNVHSMEgYUwgYKAFNLEsNKR1EwRcbNhyz2h/t2o +atTjoWekZTBjMQswCQYDVQQGEwJVUzEhMB8GA1UEChMYVGhlIEdvIERhZGR5IEdyb3VwLCBJbmMu +MTEwLwYDVQQLEyhHbyBEYWRkeSBDbGFzcyAyIENlcnRpZmljYXRpb24gQXV0aG9yaXR5ggEAMAwG +A1UdEwQFMAMBAf8wDQYJKoZIhvcNAQEFBQADggEBADJL87LKPpH8EsahB4yOd6AzBhRckB4Y9wim +PQoZ+YeAEW5p5JYXMP80kWNyOO7MHAGjHZQopDH2esRU1/blMVgDoszOYtuURXO1v0XJJLXVggKt +I3lpjbi2Tc7PTMozI+gciKqdi0FuFskg5YmezTvacPd+mSYgFFQlq25zheabIZ0KbIIOqPjCDPoQ +HmyW74cNxA9hi63ugyuV+I6ShHI56yDqg+2DzZduCLzrTia2cyvk0/ZM/iZx4mERdEr/VxqHD3VI +Ls9RaRegAhJhldXRQLIQTO7ErBBDpqWeCtWVYpoNz4iCxTIM5CufReYNnyicsbkqWletNw+vHX/b +vZ8= +-----END CERTIFICATE----- + +Starfield Class 2 CA +==================== +-----BEGIN CERTIFICATE----- +MIIEDzCCAvegAwIBAgIBADANBgkqhkiG9w0BAQUFADBoMQswCQYDVQQGEwJVUzElMCMGA1UEChMc +U3RhcmZpZWxkIFRlY2hub2xvZ2llcywgSW5jLjEyMDAGA1UECxMpU3RhcmZpZWxkIENsYXNzIDIg +Q2VydGlmaWNhdGlvbiBBdXRob3JpdHkwHhcNMDQwNjI5MTczOTE2WhcNMzQwNjI5MTczOTE2WjBo +MQswCQYDVQQGEwJVUzElMCMGA1UEChMcU3RhcmZpZWxkIFRlY2hub2xvZ2llcywgSW5jLjEyMDAG +A1UECxMpU3RhcmZpZWxkIENsYXNzIDIgQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkwggEgMA0GCSqG +SIb3DQEBAQUAA4IBDQAwggEIAoIBAQC3Msj+6XGmBIWtDBFk385N78gDGIc/oav7PKaf8MOh2tTY +bitTkPskpD6E8J7oX+zlJ0T1KKY/e97gKvDIr1MvnsoFAZMej2YcOadN+lq2cwQlZut3f+dZxkqZ +JRRU6ybH838Z1TBwj6+wRir/resp7defqgSHo9T5iaU0X9tDkYI22WY8sbi5gv2cOj4QyDvvBmVm +epsZGD3/cVE8MC5fvj13c7JdBmzDI1aaK4UmkhynArPkPw2vCHmCuDY96pzTNbO8acr1zJ3o/WSN +F4Azbl5KXZnJHoe0nRrA1W4TNSNe35tfPe/W93bC6j67eA0cQmdrBNj41tpvi/JEoAGrAgEDo4HF +MIHCMB0GA1UdDgQWBBS/X7fRzt0fhvRbVazc1xDCDqmI5zCBkgYDVR0jBIGKMIGHgBS/X7fRzt0f +hvRbVazc1xDCDqmI56FspGowaDELMAkGA1UEBhMCVVMxJTAjBgNVBAoTHFN0YXJmaWVsZCBUZWNo +bm9sb2dpZXMsIEluYy4xMjAwBgNVBAsTKVN0YXJmaWVsZCBDbGFzcyAyIENlcnRpZmljYXRpb24g +QXV0aG9yaXR5ggEAMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQEFBQADggEBAAWdP4id0ckaVaGs +afPzWdqbAYcaT1epoXkJKtv3L7IezMdeatiDh6GX70k1PncGQVhiv45YuApnP+yz3SFmH8lU+nLM +PUxA2IGvd56Deruix/U0F47ZEUD0/CwqTRV/p2JdLiXTAAsgGh1o+Re49L2L7ShZ3U0WixeDyLJl +xy16paq8U4Zt3VekyvggQQto8PT7dL5WXXp59fkdheMtlb71cZBDzI0fmgAKhynpVSJYACPq4xJD +KVtHCN2MQWplBqjlIapBtJUhlbl90TSrE9atvNziPTnNvT51cKEYWQPJIrSPnNVeKtelttQKbfi3 +QBFGmh95DmK/D5fs4C8fF5Q= +-----END CERTIFICATE----- + +Taiwan GRCA +=========== +-----BEGIN CERTIFICATE----- +MIIFcjCCA1qgAwIBAgIQH51ZWtcvwgZEpYAIaeNe9jANBgkqhkiG9w0BAQUFADA/MQswCQYDVQQG +EwJUVzEwMC4GA1UECgwnR292ZXJubWVudCBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5MB4X +DTAyMTIwNTEzMjMzM1oXDTMyMTIwNTEzMjMzM1owPzELMAkGA1UEBhMCVFcxMDAuBgNVBAoMJ0dv +dmVybm1lbnQgUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTCCAiIwDQYJKoZIhvcNAQEBBQAD +ggIPADCCAgoCggIBAJoluOzMonWoe/fOW1mKydGGEghU7Jzy50b2iPN86aXfTEc2pBsBHH8eV4qN +w8XRIePaJD9IK/ufLqGU5ywck9G/GwGHU5nOp/UKIXZ3/6m3xnOUT0b3EEk3+qhZSV1qgQdW8or5 +BtD3cCJNtLdBuTK4sfCxw5w/cP1T3YGq2GN49thTbqGsaoQkclSGxtKyyhwOeYHWtXBiCAEuTk8O +1RGvqa/lmr/czIdtJuTJV6L7lvnM4T9TjGxMfptTCAtsF/tnyMKtsc2AtJfcdgEWFelq16TheEfO +htX7MfP6Mb40qij7cEwdScevLJ1tZqa2jWR+tSBqnTuBto9AAGdLiYa4zGX+FVPpBMHWXx1E1wov +J5pGfaENda1UhhXcSTvxls4Pm6Dso3pdvtUqdULle96ltqqvKKyskKw4t9VoNSZ63Pc78/1Fm9G7 +Q3hub/FCVGqY8A2tl+lSXunVanLeavcbYBT0peS2cWeqH+riTcFCQP5nRhc4L0c/cZyu5SHKYS1t +B6iEfC3uUSXxY5Ce/eFXiGvviiNtsea9P63RPZYLhY3Naye7twWb7LuRqQoHEgKXTiCQ8P8NHuJB +O9NAOueNXdpm5AKwB1KYXA6OM5zCppX7VRluTI6uSw+9wThNXo+EHWbNxWCWtFJaBYmOlXqYwZE8 +lSOyDvR5tMl8wUohAgMBAAGjajBoMB0GA1UdDgQWBBTMzO/MKWCkO7GStjz6MmKPrCUVOzAMBgNV +HRMEBTADAQH/MDkGBGcqBwAEMTAvMC0CAQAwCQYFKw4DAhoFADAHBgVnKgMAAAQUA5vwIhP/lSg2 +09yewDL7MTqKUWUwDQYJKoZIhvcNAQEFBQADggIBAECASvomyc5eMN1PhnR2WPWus4MzeKR6dBcZ +TulStbngCnRiqmjKeKBMmo4sIy7VahIkv9Ro04rQ2JyftB8M3jh+Vzj8jeJPXgyfqzvS/3WXy6Tj +Zwj/5cAWtUgBfen5Cv8b5Wppv3ghqMKnI6mGq3ZW6A4M9hPdKmaKZEk9GhiHkASfQlK3T8v+R0F2 +Ne//AHY2RTKbxkaFXeIksB7jSJaYV0eUVXoPQbFEJPPB/hprv4j9wabak2BegUqZIJxIZhm1AHlU +D7gsL0u8qV1bYH+Mh6XgUmMqvtg7hUAV/h62ZT/FS9p+tXo1KaMuephgIqP0fSdOLeq0dDzpD6Qz +DxARvBMB1uUO07+1EqLhRSPAzAhuYbeJq4PjJB7mXQfnHyA+z2fI56wwbSdLaG5LKlwCCDTb+Hbk +Z6MmnD+iMsJKxYEYMRBWqoTvLQr/uB930r+lWKBi5NdLkXWNiYCYfm3LU05er/ayl4WXudpVBrkk +7tfGOB5jGxI7leFYrPLfhNVfmS8NVVvmONsuP3LpSIXLuykTjx44VbnzssQwmSNOXfJIoRIM3BKQ +CZBUkQM8R+XVyWXgt0t97EfTsws+rZ7QdAAO671RrcDeLMDDav7v3Aun+kbfYNucpllQdSNpc5Oy ++fwC00fmcc4QAu4njIT/rEUNE1yDMuAlpYYsfPQS +-----END CERTIFICATE----- + +DigiCert Assured ID Root CA +=========================== +-----BEGIN CERTIFICATE----- +MIIDtzCCAp+gAwIBAgIQDOfg5RfYRv6P5WD8G/AwOTANBgkqhkiG9w0BAQUFADBlMQswCQYDVQQG +EwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3d3cuZGlnaWNlcnQuY29tMSQw +IgYDVQQDExtEaWdpQ2VydCBBc3N1cmVkIElEIFJvb3QgQ0EwHhcNMDYxMTEwMDAwMDAwWhcNMzEx +MTEwMDAwMDAwWjBlMQswCQYDVQQGEwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQL +ExB3d3cuZGlnaWNlcnQuY29tMSQwIgYDVQQDExtEaWdpQ2VydCBBc3N1cmVkIElEIFJvb3QgQ0Ew +ggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCtDhXO5EOAXLGH87dg+XESpa7cJpSIqvTO +9SA5KFhgDPiA2qkVlTJhPLWxKISKityfCgyDF3qPkKyK53lTXDGEKvYPmDI2dsze3Tyoou9q+yHy +UmHfnyDXH+Kx2f4YZNISW1/5WBg1vEfNoTb5a3/UsDg+wRvDjDPZ2C8Y/igPs6eD1sNuRMBhNZYW +/lmci3Zt1/GiSw0r/wty2p5g0I6QNcZ4VYcgoc/lbQrISXwxmDNsIumH0DJaoroTghHtORedmTpy +oeb6pNnVFzF1roV9Iq4/AUaG9ih5yLHa5FcXxH4cDrC0kqZWs72yl+2qp/C3xag/lRbQ/6GW6whf +GHdPAgMBAAGjYzBhMA4GA1UdDwEB/wQEAwIBhjAPBgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBRF +66Kv9JLLgjEtUYunpyGd823IDzAfBgNVHSMEGDAWgBRF66Kv9JLLgjEtUYunpyGd823IDzANBgkq +hkiG9w0BAQUFAAOCAQEAog683+Lt8ONyc3pklL/3cmbYMuRCdWKuh+vy1dneVrOfzM4UKLkNl2Bc +EkxY5NM9g0lFWJc1aRqoR+pWxnmrEthngYTffwk8lOa4JiwgvT2zKIn3X/8i4peEH+ll74fg38Fn +SbNd67IJKusm7Xi+fT8r87cmNW1fiQG2SVufAQWbqz0lwcy2f8Lxb4bG+mRo64EtlOtCt/qMHt1i +8b5QZ7dsvfPxH2sMNgcWfzd8qVttevESRmCD1ycEvkvOl77DZypoEd+A5wwzZr8TDRRu838fYxAe ++o0bJW1sj6W3YQGx0qMmoRBxna3iw/nDmVG3KwcIzi7mULKn+gpFL6Lw8g== +-----END CERTIFICATE----- + +DigiCert Global Root CA +======================= +-----BEGIN CERTIFICATE----- +MIIDrzCCApegAwIBAgIQCDvgVpBCRrGhdWrJWZHHSjANBgkqhkiG9w0BAQUFADBhMQswCQYDVQQG +EwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3d3cuZGlnaWNlcnQuY29tMSAw +HgYDVQQDExdEaWdpQ2VydCBHbG9iYWwgUm9vdCBDQTAeFw0wNjExMTAwMDAwMDBaFw0zMTExMTAw +MDAwMDBaMGExCzAJBgNVBAYTAlVTMRUwEwYDVQQKEwxEaWdpQ2VydCBJbmMxGTAXBgNVBAsTEHd3 +dy5kaWdpY2VydC5jb20xIDAeBgNVBAMTF0RpZ2lDZXJ0IEdsb2JhbCBSb290IENBMIIBIjANBgkq +hkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA4jvhEXLeqKTTo1eqUKKPC3eQyaKl7hLOllsBCSDMAZOn +TjC3U/dDxGkAV53ijSLdhwZAAIEJzs4bg7/fzTtxRuLWZscFs3YnFo97nh6Vfe63SKMI2tavegw5 +BmV/Sl0fvBf4q77uKNd0f3p4mVmFaG5cIzJLv07A6Fpt43C/dxC//AH2hdmoRBBYMql1GNXRor5H +4idq9Joz+EkIYIvUX7Q6hL+hqkpMfT7PT19sdl6gSzeRntwi5m3OFBqOasv+zbMUZBfHWymeMr/y +7vrTC0LUq7dBMtoM1O/4gdW7jVg/tRvoSSiicNoxBN33shbyTApOB6jtSj1etX+jkMOvJwIDAQAB +o2MwYTAOBgNVHQ8BAf8EBAMCAYYwDwYDVR0TAQH/BAUwAwEB/zAdBgNVHQ4EFgQUA95QNVbRTLtm +8KPiGxvDl7I90VUwHwYDVR0jBBgwFoAUA95QNVbRTLtm8KPiGxvDl7I90VUwDQYJKoZIhvcNAQEF +BQADggEBAMucN6pIExIK+t1EnE9SsPTfrgT1eXkIoyQY/EsrhMAtudXH/vTBH1jLuG2cenTnmCmr +EbXjcKChzUyImZOMkXDiqw8cvpOp/2PV5Adg06O/nVsJ8dWO41P0jmP6P6fbtGbfYmbW0W5BjfIt +tep3Sp+dWOIrWcBAI+0tKIJFPnlUkiaY4IBIqDfv8NZ5YBberOgOzW6sRBc4L0na4UU+Krk2U886 +UAb3LujEV0lsYSEY1QSteDwsOoBrp+uvFRTp2InBuThs4pFsiv9kuXclVzDAGySj4dzp30d8tbQk +CAUw7C29C79Fv1C5qfPrmAESrciIxpg0X40KPMbp1ZWVbd4= +-----END CERTIFICATE----- + +DigiCert High Assurance EV Root CA +================================== +-----BEGIN CERTIFICATE----- +MIIDxTCCAq2gAwIBAgIQAqxcJmoLQJuPC3nyrkYldzANBgkqhkiG9w0BAQUFADBsMQswCQYDVQQG +EwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3d3cuZGlnaWNlcnQuY29tMSsw +KQYDVQQDEyJEaWdpQ2VydCBIaWdoIEFzc3VyYW5jZSBFViBSb290IENBMB4XDTA2MTExMDAwMDAw +MFoXDTMxMTExMDAwMDAwMFowbDELMAkGA1UEBhMCVVMxFTATBgNVBAoTDERpZ2lDZXJ0IEluYzEZ +MBcGA1UECxMQd3d3LmRpZ2ljZXJ0LmNvbTErMCkGA1UEAxMiRGlnaUNlcnQgSGlnaCBBc3N1cmFu +Y2UgRVYgUm9vdCBDQTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAMbM5XPm+9S75S0t +Mqbf5YE/yc0lSbZxKsPVlDRnogocsF9ppkCxxLeyj9CYpKlBWTrT3JTWPNt0OKRKzE0lgvdKpVMS +OO7zSW1xkX5jtqumX8OkhPhPYlG++MXs2ziS4wblCJEMxChBVfvLWokVfnHoNb9Ncgk9vjo4UFt3 +MRuNs8ckRZqnrG0AFFoEt7oT61EKmEFBIk5lYYeBQVCmeVyJ3hlKV9Uu5l0cUyx+mM0aBhakaHPQ +NAQTXKFx01p8VdteZOE3hzBWBOURtCmAEvF5OYiiAhF8J2a3iLd48soKqDirCmTCv2ZdlYTBoSUe +h10aUAsgEsxBu24LUTi4S8sCAwEAAaNjMGEwDgYDVR0PAQH/BAQDAgGGMA8GA1UdEwEB/wQFMAMB +Af8wHQYDVR0OBBYEFLE+w2kD+L9HAdSYJhoIAu9jZCvDMB8GA1UdIwQYMBaAFLE+w2kD+L9HAdSY +JhoIAu9jZCvDMA0GCSqGSIb3DQEBBQUAA4IBAQAcGgaX3NecnzyIZgYIVyHbIUf4KmeqvxgydkAQ +V8GK83rZEWWONfqe/EW1ntlMMUu4kehDLI6zeM7b41N5cdblIZQB2lWHmiRk9opmzN6cN82oNLFp +myPInngiK3BD41VHMWEZ71jFhS9OMPagMRYjyOfiZRYzy78aG6A9+MpeizGLYAiJLQwGXFK3xPkK +mNEVX58Svnw2Yzi9RKR/5CYrCsSXaQ3pjOLAEFe4yHYSkVXySGnYvCoCWw9E1CAx2/S6cCZdkGCe +vEsXCS+0yx5DaMkHJ8HSXPfqIbloEpw8nL+e/IBcm2PN7EeqJSdnoDfzAIJ9VNep+OkuE6N36B9K +-----END CERTIFICATE----- + +Certplus Class 2 Primary CA +=========================== +-----BEGIN CERTIFICATE----- +MIIDkjCCAnqgAwIBAgIRAIW9S/PY2uNp9pTXX8OlRCMwDQYJKoZIhvcNAQEFBQAwPTELMAkGA1UE +BhMCRlIxETAPBgNVBAoTCENlcnRwbHVzMRswGQYDVQQDExJDbGFzcyAyIFByaW1hcnkgQ0EwHhcN +OTkwNzA3MTcwNTAwWhcNMTkwNzA2MjM1OTU5WjA9MQswCQYDVQQGEwJGUjERMA8GA1UEChMIQ2Vy +dHBsdXMxGzAZBgNVBAMTEkNsYXNzIDIgUHJpbWFyeSBDQTCCASIwDQYJKoZIhvcNAQEBBQADggEP +ADCCAQoCggEBANxQltAS+DXSCHh6tlJw/W/uz7kRy1134ezpfgSN1sxvc0NXYKwzCkTsA18cgCSR +5aiRVhKC9+Ar9NuuYS6JEI1rbLqzAr3VNsVINyPi8Fo3UjMXEuLRYE2+L0ER4/YXJQyLkcAbmXuZ +Vg2v7tK8R1fjeUl7NIknJITesezpWE7+Tt9avkGtrAjFGA7v0lPubNCdEgETjdyAYveVqUSISnFO +YFWe2yMZeVYHDD9jC1yw4r5+FfyUM1hBOHTE4Y+L3yasH7WLO7dDWWuwJKZtkIvEcupdM5i3y95e +e++U8Rs+yskhwcWYAqqi9lt3m/V+llU0HGdpwPFC40es/CgcZlUCAwEAAaOBjDCBiTAPBgNVHRME +CDAGAQH/AgEKMAsGA1UdDwQEAwIBBjAdBgNVHQ4EFgQU43Mt38sOKAze3bOkynm4jrvoMIkwEQYJ +YIZIAYb4QgEBBAQDAgEGMDcGA1UdHwQwMC4wLKAqoCiGJmh0dHA6Ly93d3cuY2VydHBsdXMuY29t +L0NSTC9jbGFzczIuY3JsMA0GCSqGSIb3DQEBBQUAA4IBAQCnVM+IRBnL39R/AN9WM2K191EBkOvD +P9GIROkkXe/nFL0gt5o8AP5tn9uQ3Nf0YtaLcF3n5QRIqWh8yfFC82x/xXp8HVGIutIKPidd3i1R +TtMTZGnkLuPT55sJmabglZvOGtd/vjzOUrMRFcEPF80Du5wlFbqidon8BvEY0JNLDnyCt6X09l/+ +7UCmnYR0ObncHoUW2ikbhiMAybuJfm6AiB4vFLQDJKgybwOaRywwvlbGp0ICcBvqQNi6BQNwB6SW +//1IMwrh3KWBkJtN3X3n57LNXMhqlfil9o3EXXgIvnsG1knPGTZQIy4I5p4FTUcY1Rbpsda2ENW7 +l7+ijrRU +-----END CERTIFICATE----- + +DST Root CA X3 +============== +-----BEGIN CERTIFICATE----- +MIIDSjCCAjKgAwIBAgIQRK+wgNajJ7qJMDmGLvhAazANBgkqhkiG9w0BAQUFADA/MSQwIgYDVQQK +ExtEaWdpdGFsIFNpZ25hdHVyZSBUcnVzdCBDby4xFzAVBgNVBAMTDkRTVCBSb290IENBIFgzMB4X +DTAwMDkzMDIxMTIxOVoXDTIxMDkzMDE0MDExNVowPzEkMCIGA1UEChMbRGlnaXRhbCBTaWduYXR1 +cmUgVHJ1c3QgQ28uMRcwFQYDVQQDEw5EU1QgUm9vdCBDQSBYMzCCASIwDQYJKoZIhvcNAQEBBQAD +ggEPADCCAQoCggEBAN+v6ZdQCINXtMxiZfaQguzH0yxrMMpb7NnDfcdAwRgUi+DoM3ZJKuM/IUmT +rE4Orz5Iy2Xu/NMhD2XSKtkyj4zl93ewEnu1lcCJo6m67XMuegwGMoOifooUMM0RoOEqOLl5CjH9 +UL2AZd+3UWODyOKIYepLYYHsUmu5ouJLGiifSKOeDNoJjj4XLh7dIN9bxiqKqy69cK3FCxolkHRy +xXtqqzTWMIn/5WgTe1QLyNau7Fqckh49ZLOMxt+/yUFw7BZy1SbsOFU5Q9D8/RhcQPGX69Wam40d +utolucbY38EVAjqr2m7xPi71XAicPNaDaeQQmxkqtilX4+U9m5/wAl0CAwEAAaNCMEAwDwYDVR0T +AQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0OBBYEFMSnsaR7LHH62+FLkHX/xBVghYkQ +MA0GCSqGSIb3DQEBBQUAA4IBAQCjGiybFwBcqR7uKGY3Or+Dxz9LwwmglSBd49lZRNI+DT69ikug +dB/OEIKcdBodfpga3csTS7MgROSR6cz8faXbauX+5v3gTt23ADq1cEmv8uXrAvHRAosZy5Q6XkjE +GB5YGV8eAlrwDPGxrancWYaLbumR9YbK+rlmM6pZW87ipxZzR8srzJmwN0jP41ZL9c8PDHIyh8bw +RLtTcm1D9SZImlJnt1ir/md2cXjbDaJWFBM5JDGFoqgCWjBH4d1QB7wCCZAA62RjYJsWvIjJEubS +fZGL+T0yjWW06XyxV3bqxbYoOb8VZRzI9neWagqNdwvYkQsEjgfbKbYK7p2CNTUQ +-----END CERTIFICATE----- + +DST ACES CA X6 +============== +-----BEGIN CERTIFICATE----- +MIIECTCCAvGgAwIBAgIQDV6ZCtadt3js2AdWO4YV2TANBgkqhkiG9w0BAQUFADBbMQswCQYDVQQG +EwJVUzEgMB4GA1UEChMXRGlnaXRhbCBTaWduYXR1cmUgVHJ1c3QxETAPBgNVBAsTCERTVCBBQ0VT +MRcwFQYDVQQDEw5EU1QgQUNFUyBDQSBYNjAeFw0wMzExMjAyMTE5NThaFw0xNzExMjAyMTE5NTha +MFsxCzAJBgNVBAYTAlVTMSAwHgYDVQQKExdEaWdpdGFsIFNpZ25hdHVyZSBUcnVzdDERMA8GA1UE +CxMIRFNUIEFDRVMxFzAVBgNVBAMTDkRTVCBBQ0VTIENBIFg2MIIBIjANBgkqhkiG9w0BAQEFAAOC +AQ8AMIIBCgKCAQEAuT31LMmU3HWKlV1j6IR3dma5WZFcRt2SPp/5DgO0PWGSvSMmtWPuktKe1jzI +DZBfZIGxqAgNTNj50wUoUrQBJcWVHAx+PhCEdc/BGZFjz+iokYi5Q1K7gLFViYsx+tC3dr5BPTCa +pCIlF3PoHuLTrCq9Wzgh1SpL11V94zpVvddtawJXa+ZHfAjIgrrep4c9oW24MFbCswKBXy314pow +GCi4ZtPLAZZv6opFVdbgnf9nKxcCpk4aahELfrd755jWjHZvwTvbUJN+5dCOHze4vbrGn2zpfDPy +MjwmR/onJALJfh1biEITajV8fTXpLmaRcpPVMibEdPVTo7NdmvYJywIDAQABo4HIMIHFMA8GA1Ud +EwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgHGMB8GA1UdEQQYMBaBFHBraS1vcHNAdHJ1c3Rkc3Qu +Y29tMGIGA1UdIARbMFkwVwYKYIZIAWUDAgEBATBJMEcGCCsGAQUFBwIBFjtodHRwOi8vd3d3LnRy +dXN0ZHN0LmNvbS9jZXJ0aWZpY2F0ZXMvcG9saWN5L0FDRVMtaW5kZXguaHRtbDAdBgNVHQ4EFgQU +CXIGThhDD+XWzMNqizF7eI+og7gwDQYJKoZIhvcNAQEFBQADggEBAKPYjtay284F5zLNAdMEA+V2 +5FYrnJmQ6AgwbN99Pe7lv7UkQIRJ4dEorsTCOlMwiPH1d25Ryvr/ma8kXxug/fKshMrfqfBfBC6t +Fr8hlxCBPeP/h40y3JTlR4peahPJlJU90u7INJXQgNStMgiAVDzgvVJT11J8smk/f3rPanTK+gQq +nExaBqXpIK1FZg9p8d2/6eMyi/rgwYZNcjwu2JN4Cir42NInPRmJX1p7ijvMDNpRrscL9yuwNwXs +vFcj4jjSm2jzVhKIT0J8uDHEtdvkyCE06UgRNe76x5JXxZ805Mf29w4LTJxoeHtxMcfrHuBnQfO3 +oKfN5XozNmr6mis= +-----END CERTIFICATE----- + +SwissSign Gold CA - G2 +====================== +-----BEGIN CERTIFICATE----- +MIIFujCCA6KgAwIBAgIJALtAHEP1Xk+wMA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNVBAYTAkNIMRUw +EwYDVQQKEwxTd2lzc1NpZ24gQUcxHzAdBgNVBAMTFlN3aXNzU2lnbiBHb2xkIENBIC0gRzIwHhcN +MDYxMDI1MDgzMDM1WhcNMzYxMDI1MDgzMDM1WjBFMQswCQYDVQQGEwJDSDEVMBMGA1UEChMMU3dp +c3NTaWduIEFHMR8wHQYDVQQDExZTd2lzc1NpZ24gR29sZCBDQSAtIEcyMIICIjANBgkqhkiG9w0B +AQEFAAOCAg8AMIICCgKCAgEAr+TufoskDhJuqVAtFkQ7kpJcyrhdhJJCEyq8ZVeCQD5XJM1QiyUq +t2/876LQwB8CJEoTlo8jE+YoWACjR8cGp4QjK7u9lit/VcyLwVcfDmJlD909Vopz2q5+bbqBHH5C +jCA12UNNhPqE21Is8w4ndwtrvxEvcnifLtg+5hg3Wipy+dpikJKVyh+c6bM8K8vzARO/Ws/BtQpg +vd21mWRTuKCWs2/iJneRjOBiEAKfNA+k1ZIzUd6+jbqEemA8atufK+ze3gE/bk3lUIbLtK/tREDF +ylqM2tIrfKjuvqblCqoOpd8FUrdVxyJdMmqXl2MT28nbeTZ7hTpKxVKJ+STnnXepgv9VHKVxaSvR +AiTysybUa9oEVeXBCsdtMDeQKuSeFDNeFhdVxVu1yzSJkvGdJo+hB9TGsnhQ2wwMC3wLjEHXuend +jIj3o02yMszYF9rNt85mndT9Xv+9lz4pded+p2JYryU0pUHHPbwNUMoDAw8IWh+Vc3hiv69yFGkO +peUDDniOJihC8AcLYiAQZzlG+qkDzAQ4embvIIO1jEpWjpEA/I5cgt6IoMPiaG59je883WX0XaxR +7ySArqpWl2/5rX3aYT+YdzylkbYcjCbaZaIJbcHiVOO5ykxMgI93e2CaHt+28kgeDrpOVG2Y4OGi +GqJ3UM/EY5LsRxmd6+ZrzsECAwEAAaOBrDCBqTAOBgNVHQ8BAf8EBAMCAQYwDwYDVR0TAQH/BAUw +AwEB/zAdBgNVHQ4EFgQUWyV7lqRlUX64OfPAeGZe6Drn8O4wHwYDVR0jBBgwFoAUWyV7lqRlUX64 +OfPAeGZe6Drn8O4wRgYDVR0gBD8wPTA7BglghXQBWQECAQEwLjAsBggrBgEFBQcCARYgaHR0cDov +L3JlcG9zaXRvcnkuc3dpc3NzaWduLmNvbS8wDQYJKoZIhvcNAQEFBQADggIBACe645R88a7A3hfm +5djV9VSwg/S7zV4Fe0+fdWavPOhWfvxyeDgD2StiGwC5+OlgzczOUYrHUDFu4Up+GC9pWbY9ZIEr +44OE5iKHjn3g7gKZYbge9LgriBIWhMIxkziWMaa5O1M/wySTVltpkuzFwbs4AOPsF6m43Md8AYOf +Mke6UiI0HTJ6CVanfCU2qT1L2sCCbwq7EsiHSycR+R4tx5M/nttfJmtS2S6K8RTGRI0Vqbe/vd6m +Gu6uLftIdxf+u+yvGPUqUfA5hJeVbG4bwyvEdGB5JbAKJ9/fXtI5z0V9QkvfsywexcZdylU6oJxp +mo/a77KwPJ+HbBIrZXAVUjEaJM9vMSNQH4xPjyPDdEFjHFWoFN0+4FFQz/EbMFYOkrCChdiDyyJk +vC24JdVUorgG6q2SpCSgwYa1ShNqR88uC1aVVMvOmttqtKay20EIhid392qgQmwLOM7XdVAyksLf +KzAiSNDVQTglXaTpXZ/GlHXQRf0wl0OPkKsKx4ZzYEppLd6leNcG2mqeSz53OiATIgHQv2ieY2Br +NU0LbbqhPcCT4H8js1WtciVORvnSFu+wZMEBnunKoGqYDs/YYPIvSbjkQuE4NRb0yG5P94FW6Lqj +viOvrv1vA+ACOzB2+httQc8Bsem4yWb02ybzOqR08kkkW8mw0FfB+j564ZfJ +-----END CERTIFICATE----- + +SwissSign Silver CA - G2 +======================== +-----BEGIN CERTIFICATE----- +MIIFvTCCA6WgAwIBAgIITxvUL1S7L0swDQYJKoZIhvcNAQEFBQAwRzELMAkGA1UEBhMCQ0gxFTAT +BgNVBAoTDFN3aXNzU2lnbiBBRzEhMB8GA1UEAxMYU3dpc3NTaWduIFNpbHZlciBDQSAtIEcyMB4X +DTA2MTAyNTA4MzI0NloXDTM2MTAyNTA4MzI0NlowRzELMAkGA1UEBhMCQ0gxFTATBgNVBAoTDFN3 +aXNzU2lnbiBBRzEhMB8GA1UEAxMYU3dpc3NTaWduIFNpbHZlciBDQSAtIEcyMIICIjANBgkqhkiG +9w0BAQEFAAOCAg8AMIICCgKCAgEAxPGHf9N4Mfc4yfjDmUO8x/e8N+dOcbpLj6VzHVxumK4DV644 +N0MvFz0fyM5oEMF4rhkDKxD6LHmD9ui5aLlV8gREpzn5/ASLHvGiTSf5YXu6t+WiE7brYT7QbNHm ++/pe7R20nqA1W6GSy/BJkv6FCgU+5tkL4k+73JU3/JHpMjUi0R86TieFnbAVlDLaYQ1HTWBCrpJH +6INaUFjpiou5XaHc3ZlKHzZnu0jkg7Y360g6rw9njxcH6ATK72oxh9TAtvmUcXtnZLi2kUpCe2Uu +MGoM9ZDulebyzYLs2aFK7PayS+VFheZteJMELpyCbTapxDFkH4aDCyr0NQp4yVXPQbBH6TCfmb5h +qAaEuSh6XzjZG6k4sIN/c8HDO0gqgg8hm7jMqDXDhBuDsz6+pJVpATqJAHgE2cn0mRmrVn5bi4Y5 +FZGkECwJMoBgs5PAKrYYC51+jUnyEEp/+dVGLxmSo5mnJqy7jDzmDrxHB9xzUfFwZC8I+bRHHTBs +ROopN4WSaGa8gzj+ezku01DwH/teYLappvonQfGbGHLy9YR0SslnxFSuSGTfjNFusB3hB48IHpmc +celM2KX3RxIfdNFRnobzwqIjQAtz20um53MGjMGg6cFZrEb65i/4z3GcRm25xBWNOHkDRUjvxF3X +CO6HOSKGsg0PWEP3calILv3q1h8CAwEAAaOBrDCBqTAOBgNVHQ8BAf8EBAMCAQYwDwYDVR0TAQH/ +BAUwAwEB/zAdBgNVHQ4EFgQUF6DNweRBtjpbO8tFnb0cwpj6hlgwHwYDVR0jBBgwFoAUF6DNweRB +tjpbO8tFnb0cwpj6hlgwRgYDVR0gBD8wPTA7BglghXQBWQEDAQEwLjAsBggrBgEFBQcCARYgaHR0 +cDovL3JlcG9zaXRvcnkuc3dpc3NzaWduLmNvbS8wDQYJKoZIhvcNAQEFBQADggIBAHPGgeAn0i0P +4JUw4ppBf1AsX19iYamGamkYDHRJ1l2E6kFSGG9YrVBWIGrGvShpWJHckRE1qTodvBqlYJ7YH39F +kWnZfrt4csEGDyrOj4VwYaygzQu4OSlWhDJOhrs9xCrZ1x9y7v5RoSJBsXECYxqCsGKrXlcSH9/L +3XWgwF15kIwb4FDm3jH+mHtwX6WQ2K34ArZv02DdQEsixT2tOnqfGhpHkXkzuoLcMmkDlm4fS/Bx +/uNncqCxv1yL5PqZIseEuRuNI5c/7SXgz2W79WEE790eslpBIlqhn10s6FvJbakMDHiqYMZWjwFa +DGi8aRl5xB9+lwW/xekkUV7U1UtT7dkjWjYDZaPBA61BMPNGG4WQr2W11bHkFlt4dR2Xem1ZqSqP +e97Dh4kQmUlzeMg9vVE1dCrV8X5pGyq7O70luJpaPXJhkGaH7gzWTdQRdAtq/gsD/KNVV4n+Ssuu +WxcFyPKNIzFTONItaj+CuY0IavdeQXRuwxF+B6wpYJE/OMpXEA29MC/HpeZBoNquBYeaoKRlbEwJ +DIm6uNO5wJOKMPqN5ZprFQFOZ6raYlY+hAhm0sQ2fac+EPyI4NSA5QC9qvNOBqN6avlicuMJT+ub +DgEj8Z+7fNzcbBGXJbLytGMU0gYqZ4yD9c7qB9iaah7s5Aq7KkzrCWA5zspi2C5u +-----END CERTIFICATE----- + +GeoTrust Primary Certification Authority +======================================== +-----BEGIN CERTIFICATE----- +MIIDfDCCAmSgAwIBAgIQGKy1av1pthU6Y2yv2vrEoTANBgkqhkiG9w0BAQUFADBYMQswCQYDVQQG +EwJVUzEWMBQGA1UEChMNR2VvVHJ1c3QgSW5jLjExMC8GA1UEAxMoR2VvVHJ1c3QgUHJpbWFyeSBD +ZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAeFw0wNjExMjcwMDAwMDBaFw0zNjA3MTYyMzU5NTlaMFgx +CzAJBgNVBAYTAlVTMRYwFAYDVQQKEw1HZW9UcnVzdCBJbmMuMTEwLwYDVQQDEyhHZW9UcnVzdCBQ +cmltYXJ5IENlcnRpZmljYXRpb24gQXV0aG9yaXR5MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIB +CgKCAQEAvrgVe//UfH1nrYNke8hCUy3f9oQIIGHWAVlqnEQRr+92/ZV+zmEwu3qDXwK9AWbK7hWN +b6EwnL2hhZ6UOvNWiAAxz9juapYC2e0DjPt1befquFUWBRaa9OBesYjAZIVcFU2Ix7e64HXprQU9 +nceJSOC7KMgD4TCTZF5SwFlwIjVXiIrxlQqD17wxcwE07e9GceBrAqg1cmuXm2bgyxx5X9gaBGge +RwLmnWDiNpcB3841kt++Z8dtd1k7j53WkBWUvEI0EME5+bEnPn7WinXFsq+W06Lem+SYvn3h6YGt +tm/81w7a4DSwDRp35+MImO9Y+pyEtzavwt+s0vQQBnBxNQIDAQABo0IwQDAPBgNVHRMBAf8EBTAD +AQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQULNVQQZcVi/CPNmFbSvtr2ZnJM5IwDQYJKoZI +hvcNAQEFBQADggEBAFpwfyzdtzRP9YZRqSa+S7iq8XEN3GHHoOo0Hnp3DwQ16CePbJC/kRYkRj5K +Ts4rFtULUh38H2eiAkUxT87z+gOneZ1TatnaYzr4gNfTmeGl4b7UVXGYNTq+k+qurUKykG/g/CFN +NWMziUnWm07Kx+dOCQD32sfvmWKZd7aVIl6KoKv0uHiYyjgZmclynnjNS6yvGaBzEi38wkG6gZHa +Floxt/m0cYASSJlyc1pZU8FjUjPtp8nSOQJw+uCxQmYpqptR7TBUIhRf2asdweSU8Pj1K/fqynhG +1riR/aYNKxoUAT6A8EKglQdebc3MS6RFjasS6LPeWuWgfOgPIh1a6Vk= +-----END CERTIFICATE----- + +thawte Primary Root CA +====================== +-----BEGIN CERTIFICATE----- +MIIEIDCCAwigAwIBAgIQNE7VVyDV7exJ9C/ON9srbTANBgkqhkiG9w0BAQUFADCBqTELMAkGA1UE +BhMCVVMxFTATBgNVBAoTDHRoYXd0ZSwgSW5jLjEoMCYGA1UECxMfQ2VydGlmaWNhdGlvbiBTZXJ2 +aWNlcyBEaXZpc2lvbjE4MDYGA1UECxMvKGMpIDIwMDYgdGhhd3RlLCBJbmMuIC0gRm9yIGF1dGhv +cml6ZWQgdXNlIG9ubHkxHzAdBgNVBAMTFnRoYXd0ZSBQcmltYXJ5IFJvb3QgQ0EwHhcNMDYxMTE3 +MDAwMDAwWhcNMzYwNzE2MjM1OTU5WjCBqTELMAkGA1UEBhMCVVMxFTATBgNVBAoTDHRoYXd0ZSwg +SW5jLjEoMCYGA1UECxMfQ2VydGlmaWNhdGlvbiBTZXJ2aWNlcyBEaXZpc2lvbjE4MDYGA1UECxMv +KGMpIDIwMDYgdGhhd3RlLCBJbmMuIC0gRm9yIGF1dGhvcml6ZWQgdXNlIG9ubHkxHzAdBgNVBAMT +FnRoYXd0ZSBQcmltYXJ5IFJvb3QgQ0EwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCs +oPD7gFnUnMekz52hWXMJEEUMDSxuaPFsW0hoSVk3/AszGcJ3f8wQLZU0HObrTQmnHNK4yZc2AreJ +1CRfBsDMRJSUjQJib+ta3RGNKJpchJAQeg29dGYvajig4tVUROsdB58Hum/u6f1OCyn1PoSgAfGc +q/gcfomk6KHYcWUNo1F77rzSImANuVud37r8UVsLr5iy6S7pBOhih94ryNdOwUxkHt3Ph1i6Sk/K +aAcdHJ1KxtUvkcx8cXIcxcBn6zL9yZJclNqFwJu/U30rCfSMnZEfl2pSy94JNqR32HuHUETVPm4p +afs5SSYeCaWAe0At6+gnhcn+Yf1+5nyXHdWdAgMBAAGjQjBAMA8GA1UdEwEB/wQFMAMBAf8wDgYD +VR0PAQH/BAQDAgEGMB0GA1UdDgQWBBR7W0XPr87Lev0xkhpqtvNG61dIUDANBgkqhkiG9w0BAQUF +AAOCAQEAeRHAS7ORtvzw6WfUDW5FvlXok9LOAz/t2iWwHVfLHjp2oEzsUHboZHIMpKnxuIvW1oeE +uzLlQRHAd9mzYJ3rG9XRbkREqaYB7FViHXe4XI5ISXycO1cRrK1zN44veFyQaEfZYGDm/Ac9IiAX +xPcW6cTYcvnIc3zfFi8VqT79aie2oetaupgf1eNNZAqdE8hhuvU5HIe6uL17In/2/qxAeeWsEG89 +jxt5dovEN7MhGITlNgDrYyCZuen+MwS7QcjBAvlEYyCegc5C09Y/LHbTY5xZ3Y+m4Q6gLkH3LpVH +z7z9M/P2C2F+fpErgUfCJzDupxBdN49cOSvkBPB7jVaMaA== +-----END CERTIFICATE----- + +VeriSign Class 3 Public Primary Certification Authority - G5 +============================================================ +-----BEGIN CERTIFICATE----- +MIIE0zCCA7ugAwIBAgIQGNrRniZ96LtKIVjNzGs7SjANBgkqhkiG9w0BAQUFADCByjELMAkGA1UE +BhMCVVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMR8wHQYDVQQLExZWZXJpU2lnbiBUcnVzdCBO +ZXR3b3JrMTowOAYDVQQLEzEoYykgMjAwNiBWZXJpU2lnbiwgSW5jLiAtIEZvciBhdXRob3JpemVk +IHVzZSBvbmx5MUUwQwYDVQQDEzxWZXJpU2lnbiBDbGFzcyAzIFB1YmxpYyBQcmltYXJ5IENlcnRp +ZmljYXRpb24gQXV0aG9yaXR5IC0gRzUwHhcNMDYxMTA4MDAwMDAwWhcNMzYwNzE2MjM1OTU5WjCB +yjELMAkGA1UEBhMCVVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMR8wHQYDVQQLExZWZXJpU2ln +biBUcnVzdCBOZXR3b3JrMTowOAYDVQQLEzEoYykgMjAwNiBWZXJpU2lnbiwgSW5jLiAtIEZvciBh +dXRob3JpemVkIHVzZSBvbmx5MUUwQwYDVQQDEzxWZXJpU2lnbiBDbGFzcyAzIFB1YmxpYyBQcmlt +YXJ5IENlcnRpZmljYXRpb24gQXV0aG9yaXR5IC0gRzUwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAw +ggEKAoIBAQCvJAgIKXo1nmAMqudLO07cfLw8RRy7K+D+KQL5VwijZIUVJ/XxrcgxiV0i6CqqpkKz +j/i5Vbext0uz/o9+B1fs70PbZmIVYc9gDaTY3vjgw2IIPVQT60nKWVSFJuUrjxuf6/WhkcIzSdhD +Y2pSS9KP6HBRTdGJaXvHcPaz3BJ023tdS1bTlr8Vd6Gw9KIl8q8ckmcY5fQGBO+QueQA5N06tRn/ +Arr0PO7gi+s3i+z016zy9vA9r911kTMZHRxAy3QkGSGT2RT+rCpSx4/VBEnkjWNHiDxpg8v+R70r +fk/Fla4OndTRQ8Bnc+MUCH7lP59zuDMKz10/NIeWiu5T6CUVAgMBAAGjgbIwga8wDwYDVR0TAQH/ +BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwbQYIKwYBBQUHAQwEYTBfoV2gWzBZMFcwVRYJaW1hZ2Uv +Z2lmMCEwHzAHBgUrDgMCGgQUj+XTGoasjY5rw8+AatRIGCx7GS4wJRYjaHR0cDovL2xvZ28udmVy +aXNpZ24uY29tL3ZzbG9nby5naWYwHQYDVR0OBBYEFH/TZafC3ey78DAJ80M5+gKvMzEzMA0GCSqG +SIb3DQEBBQUAA4IBAQCTJEowX2LP2BqYLz3q3JktvXf2pXkiOOzEp6B4Eq1iDkVwZMXnl2YtmAl+ +X6/WzChl8gGqCBpH3vn5fJJaCGkgDdk+bW48DW7Y5gaRQBi5+MHt39tBquCWIMnNZBU4gcmU7qKE +KQsTb47bDN0lAtukixlE0kF6BWlKWE9gyn6CagsCqiUXObXbf+eEZSqVir2G3l6BFoMtEMze/aiC +Km0oHw0LxOXnGiYZ4fQRbxC1lfznQgUy286dUV4otp6F01vvpX1FQHKOtw5rDgb7MzVIcbidJ4vE +ZV8NhnacRHr2lVz2XTIIM6RUthg/aFzyQkqFOFSDX9HoLPKsEdao7WNq +-----END CERTIFICATE----- + +SecureTrust CA +============== +-----BEGIN CERTIFICATE----- +MIIDuDCCAqCgAwIBAgIQDPCOXAgWpa1Cf/DrJxhZ0DANBgkqhkiG9w0BAQUFADBIMQswCQYDVQQG +EwJVUzEgMB4GA1UEChMXU2VjdXJlVHJ1c3QgQ29ycG9yYXRpb24xFzAVBgNVBAMTDlNlY3VyZVRy +dXN0IENBMB4XDTA2MTEwNzE5MzExOFoXDTI5MTIzMTE5NDA1NVowSDELMAkGA1UEBhMCVVMxIDAe +BgNVBAoTF1NlY3VyZVRydXN0IENvcnBvcmF0aW9uMRcwFQYDVQQDEw5TZWN1cmVUcnVzdCBDQTCC +ASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAKukgeWVzfX2FI7CT8rU4niVWJxB4Q2ZQCQX +OZEzZum+4YOvYlyJ0fwkW2Gz4BERQRwdbvC4u/jep4G6pkjGnx29vo6pQT64lO0pGtSO0gMdA+9t +DWccV9cGrcrI9f4Or2YlSASWC12juhbDCE/RRvgUXPLIXgGZbf2IzIaowW8xQmxSPmjL8xk037uH +GFaAJsTQ3MBv396gwpEWoGQRS0S8Hvbn+mPeZqx2pHGj7DaUaHp3pLHnDi+BeuK1cobvomuL8A/b +01k/unK8RCSc43Oz969XL0Imnal0ugBS8kvNU3xHCzaFDmapCJcWNFfBZveA4+1wVMeT4C4oFVmH +ursCAwEAAaOBnTCBmjATBgkrBgEEAYI3FAIEBh4EAEMAQTALBgNVHQ8EBAMCAYYwDwYDVR0TAQH/ +BAUwAwEB/zAdBgNVHQ4EFgQUQjK2FvoE/f5dS3rD/fdMQB1aQ68wNAYDVR0fBC0wKzApoCegJYYj +aHR0cDovL2NybC5zZWN1cmV0cnVzdC5jb20vU1RDQS5jcmwwEAYJKwYBBAGCNxUBBAMCAQAwDQYJ +KoZIhvcNAQEFBQADggEBADDtT0rhWDpSclu1pqNlGKa7UTt36Z3q059c4EVlew3KW+JwULKUBRSu +SceNQQcSc5R+DCMh/bwQf2AQWnL1mA6s7Ll/3XpvXdMc9P+IBWlCqQVxyLesJugutIxq/3HcuLHf +mbx8IVQr5Fiiu1cprp6poxkmD5kuCLDv/WnPmRoJjeOnnyvJNjR7JLN4TJUXpAYmHrZkUjZfYGfZ +nMUFdAvnZyPSCPyI6a6Lf+Ew9Dd+/cYy2i2eRDAwbO4H3tI0/NL/QPZL9GZGBlSm8jIKYyYwa5vR +3ItHuuG51WLQoqD0ZwV4KWMabwTW+MZMo5qxN7SN5ShLHZ4swrhovO0C7jE= +-----END CERTIFICATE----- + +Secure Global CA +================ +-----BEGIN CERTIFICATE----- +MIIDvDCCAqSgAwIBAgIQB1YipOjUiolN9BPI8PjqpTANBgkqhkiG9w0BAQUFADBKMQswCQYDVQQG +EwJVUzEgMB4GA1UEChMXU2VjdXJlVHJ1c3QgQ29ycG9yYXRpb24xGTAXBgNVBAMTEFNlY3VyZSBH +bG9iYWwgQ0EwHhcNMDYxMTA3MTk0MjI4WhcNMjkxMjMxMTk1MjA2WjBKMQswCQYDVQQGEwJVUzEg +MB4GA1UEChMXU2VjdXJlVHJ1c3QgQ29ycG9yYXRpb24xGTAXBgNVBAMTEFNlY3VyZSBHbG9iYWwg +Q0EwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCvNS7YrGxVaQZx5RNoJLNP2MwhR/jx +YDiJiQPpvepeRlMJ3Fz1Wuj3RSoC6zFh1ykzTM7HfAo3fg+6MpjhHZevj8fcyTiW89sa/FHtaMbQ +bqR8JNGuQsiWUGMu4P51/pinX0kuleM5M2SOHqRfkNJnPLLZ/kG5VacJjnIFHovdRIWCQtBJwB1g +8NEXLJXr9qXBkqPFwqcIYA1gBBCWeZ4WNOaptvolRTnIHmX5k/Wq8VLcmZg9pYYaDDUz+kulBAYV +HDGA76oYa8J719rO+TMg1fW9ajMtgQT7sFzUnKPiXB3jqUJ1XnvUd+85VLrJChgbEplJL4hL/VBi +0XPnj3pDAgMBAAGjgZ0wgZowEwYJKwYBBAGCNxQCBAYeBABDAEEwCwYDVR0PBAQDAgGGMA8GA1Ud +EwEB/wQFMAMBAf8wHQYDVR0OBBYEFK9EBMJBfkiD2045AuzshHrmzsmkMDQGA1UdHwQtMCswKaAn +oCWGI2h0dHA6Ly9jcmwuc2VjdXJldHJ1c3QuY29tL1NHQ0EuY3JsMBAGCSsGAQQBgjcVAQQDAgEA +MA0GCSqGSIb3DQEBBQUAA4IBAQBjGghAfaReUw132HquHw0LURYD7xh8yOOvaliTFGCRsoTciE6+ +OYo68+aCiV0BN7OrJKQVDpI1WkpEXk5X+nXOH0jOZvQ8QCaSmGwb7iRGDBezUqXbpZGRzzfTb+cn +CDpOGR86p1hcF895P4vkp9MmI50mD1hp/Ed+stCNi5O/KU9DaXR2Z0vPB4zmAve14bRDtUstFJ/5 +3CYNv6ZHdAbYiNE6KTCEztI5gGIbqMdXSbxqVVFnFUq+NQfk1XWYN3kwFNspnWzFacxHVaIw98xc +f8LDmBxrThaA63p4ZUWiABqvDA1VZDRIuJK58bRQKfJPIx/abKwfROHdI3hRW8cW +-----END CERTIFICATE----- + +COMODO Certification Authority +============================== +-----BEGIN CERTIFICATE----- +MIIEHTCCAwWgAwIBAgIQToEtioJl4AsC7j41AkblPTANBgkqhkiG9w0BAQUFADCBgTELMAkGA1UE +BhMCR0IxGzAZBgNVBAgTEkdyZWF0ZXIgTWFuY2hlc3RlcjEQMA4GA1UEBxMHU2FsZm9yZDEaMBgG +A1UEChMRQ09NT0RPIENBIExpbWl0ZWQxJzAlBgNVBAMTHkNPTU9ETyBDZXJ0aWZpY2F0aW9uIEF1 +dGhvcml0eTAeFw0wNjEyMDEwMDAwMDBaFw0yOTEyMzEyMzU5NTlaMIGBMQswCQYDVQQGEwJHQjEb +MBkGA1UECBMSR3JlYXRlciBNYW5jaGVzdGVyMRAwDgYDVQQHEwdTYWxmb3JkMRowGAYDVQQKExFD +T01PRE8gQ0EgTGltaXRlZDEnMCUGA1UEAxMeQ09NT0RPIENlcnRpZmljYXRpb24gQXV0aG9yaXR5 +MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA0ECLi3LjkRv3UcEbVASY06m/weaKXTuH ++7uIzg3jLz8GlvCiKVCZrts7oVewdFFxze1CkU1B/qnI2GqGd0S7WWaXUF601CxwRM/aN5VCaTww +xHGzUvAhTaHYujl8HJ6jJJ3ygxaYqhZ8Q5sVW7euNJH+1GImGEaaP+vB+fGQV+useg2L23IwambV +4EajcNxo2f8ESIl33rXp+2dtQem8Ob0y2WIC8bGoPW43nOIv4tOiJovGuFVDiOEjPqXSJDlqR6sA +1KGzqSX+DT+nHbrTUcELpNqsOO9VUCQFZUaTNE8tja3G1CEZ0o7KBWFxB3NH5YoZEr0ETc5OnKVI +rLsm9wIDAQABo4GOMIGLMB0GA1UdDgQWBBQLWOWLxkwVN6RAqTCpIb5HNlpW/zAOBgNVHQ8BAf8E +BAMCAQYwDwYDVR0TAQH/BAUwAwEB/zBJBgNVHR8EQjBAMD6gPKA6hjhodHRwOi8vY3JsLmNvbW9k +b2NhLmNvbS9DT01PRE9DZXJ0aWZpY2F0aW9uQXV0aG9yaXR5LmNybDANBgkqhkiG9w0BAQUFAAOC +AQEAPpiem/Yb6dc5t3iuHXIYSdOH5EOC6z/JqvWote9VfCFSZfnVDeFs9D6Mk3ORLgLETgdxb8CP +OGEIqB6BCsAvIC9Bi5HcSEW88cbeunZrM8gALTFGTO3nnc+IlP8zwFboJIYmuNg4ON8qa90SzMc/ +RxdMosIGlgnW2/4/PEZB31jiVg88O8EckzXZOFKs7sjsLjBOlDW0JB9LeGna8gI4zJVSk/BwJVmc +IGfE7vmLV2H0knZ9P4SNVbfo5azV8fUZVqZa+5Acr5Pr5RzUZ5ddBA6+C4OmF4O5MBKgxTMVBbkN ++8cFduPYSo38NBejxiEovjBFMR7HeL5YYTisO+IBZQ== +-----END CERTIFICATE----- + +Network Solutions Certificate Authority +======================================= +-----BEGIN CERTIFICATE----- +MIID5jCCAs6gAwIBAgIQV8szb8JcFuZHFhfjkDFo4DANBgkqhkiG9w0BAQUFADBiMQswCQYDVQQG +EwJVUzEhMB8GA1UEChMYTmV0d29yayBTb2x1dGlvbnMgTC5MLkMuMTAwLgYDVQQDEydOZXR3b3Jr +IFNvbHV0aW9ucyBDZXJ0aWZpY2F0ZSBBdXRob3JpdHkwHhcNMDYxMjAxMDAwMDAwWhcNMjkxMjMx +MjM1OTU5WjBiMQswCQYDVQQGEwJVUzEhMB8GA1UEChMYTmV0d29yayBTb2x1dGlvbnMgTC5MLkMu +MTAwLgYDVQQDEydOZXR3b3JrIFNvbHV0aW9ucyBDZXJ0aWZpY2F0ZSBBdXRob3JpdHkwggEiMA0G +CSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDkvH6SMG3G2I4rC7xGzuAnlt7e+foS0zwzc7MEL7xx +jOWftiJgPl9dzgn/ggwbmlFQGiaJ3dVhXRncEg8tCqJDXRfQNJIg6nPPOCwGJgl6cvf6UDL4wpPT +aaIjzkGxzOTVHzbRijr4jGPiFFlp7Q3Tf2vouAPlT2rlmGNpSAW+Lv8ztumXWWn4Zxmuk2GWRBXT +crA/vGp97Eh/jcOrqnErU2lBUzS1sLnFBgrEsEX1QV1uiUV7PTsmjHTC5dLRfbIR1PtYMiKagMnc +/Qzpf14Dl847ABSHJ3A4qY5usyd2mFHgBeMhqxrVhSI8KbWaFsWAqPS7azCPL0YCorEMIuDTAgMB +AAGjgZcwgZQwHQYDVR0OBBYEFCEwyfsA106Y2oeqKtCnLrFAMadMMA4GA1UdDwEB/wQEAwIBBjAP +BgNVHRMBAf8EBTADAQH/MFIGA1UdHwRLMEkwR6BFoEOGQWh0dHA6Ly9jcmwubmV0c29sc3NsLmNv +bS9OZXR3b3JrU29sdXRpb25zQ2VydGlmaWNhdGVBdXRob3JpdHkuY3JsMA0GCSqGSIb3DQEBBQUA +A4IBAQC7rkvnt1frf6ott3NHhWrB5KUd5Oc86fRZZXe1eltajSU24HqXLjjAV2CDmAaDn7l2em5Q +4LqILPxFzBiwmZVRDuwduIj/h1AcgsLj4DKAv6ALR8jDMe+ZZzKATxcheQxpXN5eNK4CtSbqUN9/ +GGUsyfJj4akH/nxxH2szJGoeBfcFaMBqEssuXmHLrijTfsK0ZpEmXzwuJF/LWA/rKOyvEZbz3Htv +wKeI8lN3s2Berq4o2jUsbzRF0ybh3uxbTydrFny9RAQYgrOJeRcQcT16ohZO9QHNpGxlaKFJdlxD +ydi8NmdspZS11My5vWo1ViHe2MPr+8ukYEywVaCge1ey +-----END CERTIFICATE----- + +COMODO ECC Certification Authority +================================== +-----BEGIN CERTIFICATE----- +MIICiTCCAg+gAwIBAgIQH0evqmIAcFBUTAGem2OZKjAKBggqhkjOPQQDAzCBhTELMAkGA1UEBhMC +R0IxGzAZBgNVBAgTEkdyZWF0ZXIgTWFuY2hlc3RlcjEQMA4GA1UEBxMHU2FsZm9yZDEaMBgGA1UE +ChMRQ09NT0RPIENBIExpbWl0ZWQxKzApBgNVBAMTIkNPTU9ETyBFQ0MgQ2VydGlmaWNhdGlvbiBB +dXRob3JpdHkwHhcNMDgwMzA2MDAwMDAwWhcNMzgwMTE4MjM1OTU5WjCBhTELMAkGA1UEBhMCR0Ix +GzAZBgNVBAgTEkdyZWF0ZXIgTWFuY2hlc3RlcjEQMA4GA1UEBxMHU2FsZm9yZDEaMBgGA1UEChMR +Q09NT0RPIENBIExpbWl0ZWQxKzApBgNVBAMTIkNPTU9ETyBFQ0MgQ2VydGlmaWNhdGlvbiBBdXRo +b3JpdHkwdjAQBgcqhkjOPQIBBgUrgQQAIgNiAAQDR3svdcmCFYX7deSRFtSrYpn1PlILBs5BAH+X +4QokPB0BBO490o0JlwzgdeT6+3eKKvUDYEs2ixYjFq0JcfRK9ChQtP6IHG4/bC8vCVlbpVsLM5ni +wz2J+Wos77LTBumjQjBAMB0GA1UdDgQWBBR1cacZSBm8nZ3qQUfflMRId5nTeTAOBgNVHQ8BAf8E +BAMCAQYwDwYDVR0TAQH/BAUwAwEB/zAKBggqhkjOPQQDAwNoADBlAjEA7wNbeqy3eApyt4jf/7VG +FAkK+qDmfQjGGoe9GKhzvSbKYAydzpmfz1wPMOG+FDHqAjAU9JM8SaczepBGR7NjfRObTrdvGDeA +U/7dIOA1mjbRxwG55tzd8/8dLDoWV9mSOdY= +-----END CERTIFICATE----- + +Security Communication EV RootCA1 +================================= +-----BEGIN CERTIFICATE----- +MIIDfTCCAmWgAwIBAgIBADANBgkqhkiG9w0BAQUFADBgMQswCQYDVQQGEwJKUDElMCMGA1UEChMc +U0VDT00gVHJ1c3QgU3lzdGVtcyBDTy4sTFRELjEqMCgGA1UECxMhU2VjdXJpdHkgQ29tbXVuaWNh +dGlvbiBFViBSb290Q0ExMB4XDTA3MDYwNjAyMTIzMloXDTM3MDYwNjAyMTIzMlowYDELMAkGA1UE +BhMCSlAxJTAjBgNVBAoTHFNFQ09NIFRydXN0IFN5c3RlbXMgQ08uLExURC4xKjAoBgNVBAsTIVNl +Y3VyaXR5IENvbW11bmljYXRpb24gRVYgUm9vdENBMTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCC +AQoCggEBALx/7FebJOD+nLpCeamIivqA4PUHKUPqjgo0No0c+qe1OXj/l3X3L+SqawSERMqm4miO +/VVQYg+kcQ7OBzgtQoVQrTyWb4vVog7P3kmJPdZkLjjlHmy1V4qe70gOzXppFodEtZDkBp2uoQSX +WHnvIEqCa4wiv+wfD+mEce3xDuS4GBPMVjZd0ZoeUWs5bmB2iDQL87PRsJ3KYeJkHcFGB7hj3R4z +ZbOOCVVSPbW9/wfrrWFVGCypaZhKqkDFMxRldAD5kd6vA0jFQFTcD4SQaCDFkpbcLuUCRarAX1T4 +bepJz11sS6/vmsJWXMY1VkJqMF/Cq/biPT+zyRGPMUzXn0kCAwEAAaNCMEAwHQYDVR0OBBYEFDVK +9U2vP9eCOKyrcWUXdYydVZPmMA4GA1UdDwEB/wQEAwIBBjAPBgNVHRMBAf8EBTADAQH/MA0GCSqG +SIb3DQEBBQUAA4IBAQCoh+ns+EBnXcPBZsdAS5f8hxOQWsTvoMpfi7ent/HWtWS3irO4G8za+6xm +iEHO6Pzk2x6Ipu0nUBsCMCRGef4Eh3CXQHPRwMFXGZpppSeZq51ihPZRwSzJIxXYKLerJRO1RuGG +Av8mjMSIkh1W/hln8lXkgKNrnKt34VFxDSDbEJrbvXZ5B3eZKK2aXtqxT0QsNY6llsf9g/BYxnnW +mHyojf6GPgcWkuF75x3sM3Z+Qi5KhfmRiWiEA4Glm5q+4zfFVKtWOxgtQaQM+ELbmaDgcm+7XeEW +T1MKZPlO9L9OVL14bIjqv5wTJMJwaaJ/D8g8rQjJsJhAoyrniIPtd490 +-----END CERTIFICATE----- + +OISTE WISeKey Global Root GA CA +=============================== +-----BEGIN CERTIFICATE----- +MIID8TCCAtmgAwIBAgIQQT1yx/RrH4FDffHSKFTfmjANBgkqhkiG9w0BAQUFADCBijELMAkGA1UE +BhMCQ0gxEDAOBgNVBAoTB1dJU2VLZXkxGzAZBgNVBAsTEkNvcHlyaWdodCAoYykgMjAwNTEiMCAG +A1UECxMZT0lTVEUgRm91bmRhdGlvbiBFbmRvcnNlZDEoMCYGA1UEAxMfT0lTVEUgV0lTZUtleSBH +bG9iYWwgUm9vdCBHQSBDQTAeFw0wNTEyMTExNjAzNDRaFw0zNzEyMTExNjA5NTFaMIGKMQswCQYD +VQQGEwJDSDEQMA4GA1UEChMHV0lTZUtleTEbMBkGA1UECxMSQ29weXJpZ2h0IChjKSAyMDA1MSIw +IAYDVQQLExlPSVNURSBGb3VuZGF0aW9uIEVuZG9yc2VkMSgwJgYDVQQDEx9PSVNURSBXSVNlS2V5 +IEdsb2JhbCBSb290IEdBIENBMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAy0+zAJs9 +Nt350UlqaxBJH+zYK7LG+DKBKUOVTJoZIyEVRd7jyBxRVVuuk+g3/ytr6dTqvirdqFEr12bDYVxg +Asj1znJ7O7jyTmUIms2kahnBAbtzptf2w93NvKSLtZlhuAGio9RN1AU9ka34tAhxZK9w8RxrfvbD +d50kc3vkDIzh2TbhmYsFmQvtRTEJysIA2/dyoJaqlYfQjse2YXMNdmaM3Bu0Y6Kff5MTMPGhJ9vZ +/yxViJGg4E8HsChWjBgbl0SOid3gF27nKu+POQoxhILYQBRJLnpB5Kf+42TMwVlxSywhp1t94B3R +LoGbw9ho972WG6xwsRYUC9tguSYBBQIDAQABo1EwTzALBgNVHQ8EBAMCAYYwDwYDVR0TAQH/BAUw +AwEB/zAdBgNVHQ4EFgQUswN+rja8sHnR3JQmthG+IbJphpQwEAYJKwYBBAGCNxUBBAMCAQAwDQYJ +KoZIhvcNAQEFBQADggEBAEuh/wuHbrP5wUOxSPMowB0uyQlB+pQAHKSkq0lPjz0e701vvbyk9vIm +MMkQyh2I+3QZH4VFvbBsUfk2ftv1TDI6QU9bR8/oCy22xBmddMVHxjtqD6wU2zz0c5ypBd8A3HR4 ++vg1YFkCExh8vPtNsCBtQ7tgMHpnM1zFmdH4LTlSc/uMqpclXHLZCB6rTjzjgTGfA6b7wP4piFXa +hNVQA7bihKOmNqoROgHhGEvWRGizPflTdISzRpFGlgC3gCy24eMQ4tui5yiPAZZiFj4A4xylNoEY +okxSdsARo27mHbrjWr42U8U+dY+GaSlYU7Wcu2+fXMUY7N0v4ZjJ/L7fCg0= +-----END CERTIFICATE----- + +Certigna +======== +-----BEGIN CERTIFICATE----- +MIIDqDCCApCgAwIBAgIJAP7c4wEPyUj/MA0GCSqGSIb3DQEBBQUAMDQxCzAJBgNVBAYTAkZSMRIw +EAYDVQQKDAlEaGlteW90aXMxETAPBgNVBAMMCENlcnRpZ25hMB4XDTA3MDYyOTE1MTMwNVoXDTI3 +MDYyOTE1MTMwNVowNDELMAkGA1UEBhMCRlIxEjAQBgNVBAoMCURoaW15b3RpczERMA8GA1UEAwwI +Q2VydGlnbmEwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDIaPHJ1tazNHUmgh7stL7q +XOEm7RFHYeGifBZ4QCHkYJ5ayGPhxLGWkv8YbWkj4Sti993iNi+RB7lIzw7sebYs5zRLcAglozyH +GxnygQcPOJAZ0xH+hrTy0V4eHpbNgGzOOzGTtvKg0KmVEn2lmsxryIRWijOp5yIVUxbwzBfsV1/p +ogqYCd7jX5xv3EjjhQsVWqa6n6xI4wmy9/Qy3l40vhx4XUJbzg4ij02Q130yGLMLLGq/jj8UEYkg +DncUtT2UCIf3JR7VsmAA7G8qKCVuKj4YYxclPz5EIBb2JsglrgVKtOdjLPOMFlN+XPsRGgjBRmKf +Irjxwo1p3Po6WAbfAgMBAAGjgbwwgbkwDwYDVR0TAQH/BAUwAwEB/zAdBgNVHQ4EFgQUGu3+QTmQ +tCRZvgHyUtVF9lo53BEwZAYDVR0jBF0wW4AUGu3+QTmQtCRZvgHyUtVF9lo53BGhOKQ2MDQxCzAJ +BgNVBAYTAkZSMRIwEAYDVQQKDAlEaGlteW90aXMxETAPBgNVBAMMCENlcnRpZ25hggkA/tzjAQ/J +SP8wDgYDVR0PAQH/BAQDAgEGMBEGCWCGSAGG+EIBAQQEAwIABzANBgkqhkiG9w0BAQUFAAOCAQEA +hQMeknH2Qq/ho2Ge6/PAD/Kl1NqV5ta+aDY9fm4fTIrv0Q8hbV6lUmPOEvjvKtpv6zf+EwLHyzs+ +ImvaYS5/1HI93TDhHkxAGYwP15zRgzB7mFncfca5DClMoTOi62c6ZYTTluLtdkVwj7Ur3vkj1klu +PBS1xp81HlDQwY9qcEQCYsuuHWhBp6pX6FOqB9IG9tUUBguRA3UsbHK1YZWaDYu5Def131TN3ubY +1gkIl2PlwS6wt0QmwCbAr1UwnjvVNioZBPRcHv/PLLf/0P2HQBHVESO7SMAhqaQoLf0V+LBOK/Qw +WyH8EZE0vkHve52Xdf+XlcCWWC/qu0bXu+TZLg== +-----END CERTIFICATE----- + +Deutsche Telekom Root CA 2 +========================== +-----BEGIN CERTIFICATE----- +MIIDnzCCAoegAwIBAgIBJjANBgkqhkiG9w0BAQUFADBxMQswCQYDVQQGEwJERTEcMBoGA1UEChMT +RGV1dHNjaGUgVGVsZWtvbSBBRzEfMB0GA1UECxMWVC1UZWxlU2VjIFRydXN0IENlbnRlcjEjMCEG +A1UEAxMaRGV1dHNjaGUgVGVsZWtvbSBSb290IENBIDIwHhcNOTkwNzA5MTIxMTAwWhcNMTkwNzA5 +MjM1OTAwWjBxMQswCQYDVQQGEwJERTEcMBoGA1UEChMTRGV1dHNjaGUgVGVsZWtvbSBBRzEfMB0G +A1UECxMWVC1UZWxlU2VjIFRydXN0IENlbnRlcjEjMCEGA1UEAxMaRGV1dHNjaGUgVGVsZWtvbSBS +b290IENBIDIwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCrC6M14IspFLEUha88EOQ5 +bzVdSq7d6mGNlUn0b2SjGmBmpKlAIoTZ1KXleJMOaAGtuU1cOs7TuKhCQN/Po7qCWWqSG6wcmtoI +KyUn+WkjR/Hg6yx6m/UTAtB+NHzCnjwAWav12gz1MjwrrFDa1sPeg5TKqAyZMg4ISFZbavva4VhY +AUlfckE8FQYBjl2tqriTtM2e66foai1SNNs671x1Udrb8zH57nGYMsRUFUQM+ZtV7a3fGAigo4aK +Se5TBY8ZTNXeWHmb0mocQqvF1afPaA+W5OFhmHZhyJF81j4A4pFQh+GdCuatl9Idxjp9y7zaAzTV +jlsB9WoHtxa2bkp/AgMBAAGjQjBAMB0GA1UdDgQWBBQxw3kbuvVT1xfgiXotF2wKsyudMzAPBgNV +HRMECDAGAQH/AgEFMA4GA1UdDwEB/wQEAwIBBjANBgkqhkiG9w0BAQUFAAOCAQEAlGRZrTlk5ynr +E/5aw4sTV8gEJPB0d8Bg42f76Ymmg7+Wgnxu1MM9756AbrsptJh6sTtU6zkXR34ajgv8HzFZMQSy +zhfzLMdiNlXiItiJVbSYSKpk+tYcNthEeFpaIzpXl/V6ME+un2pMSyuOoAPjPuCp1NJ70rOo4nI8 +rZ7/gFnkm0W09juwzTkZmDLl6iFhkOQxIY40sfcvNUqFENrnijchvllj4PKFiDFT1FQUhXB59C4G +dyd1Lx+4ivn+xbrYNuSD7Odlt79jWvNGr4GUN9RBjNYj1h7P9WgbRGOiWrqnNVmh5XAFmw4jV5mU +Cm26OWMohpLzGITY+9HPBVZkVw== +-----END CERTIFICATE----- + +Cybertrust Global Root +====================== +-----BEGIN CERTIFICATE----- +MIIDoTCCAomgAwIBAgILBAAAAAABD4WqLUgwDQYJKoZIhvcNAQEFBQAwOzEYMBYGA1UEChMPQ3li +ZXJ0cnVzdCwgSW5jMR8wHQYDVQQDExZDeWJlcnRydXN0IEdsb2JhbCBSb290MB4XDTA2MTIxNTA4 +MDAwMFoXDTIxMTIxNTA4MDAwMFowOzEYMBYGA1UEChMPQ3liZXJ0cnVzdCwgSW5jMR8wHQYDVQQD +ExZDeWJlcnRydXN0IEdsb2JhbCBSb290MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA ++Mi8vRRQZhP/8NN57CPytxrHjoXxEnOmGaoQ25yiZXRadz5RfVb23CO21O1fWLE3TdVJDm71aofW +0ozSJ8bi/zafmGWgE07GKmSb1ZASzxQG9Dvj1Ci+6A74q05IlG2OlTEQXO2iLb3VOm2yHLtgwEZL +AfVJrn5GitB0jaEMAs7u/OePuGtm839EAL9mJRQr3RAwHQeWP032a7iPt3sMpTjr3kfb1V05/Iin +89cqdPHoWqI7n1C6poxFNcJQZZXcY4Lv3b93TZxiyWNzFtApD0mpSPCzqrdsxacwOUBdrsTiXSZT +8M4cIwhhqJQZugRiQOwfOHB3EgZxpzAYXSUnpQIDAQABo4GlMIGiMA4GA1UdDwEB/wQEAwIBBjAP +BgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBS2CHsNesysIEyGVjJez6tuhS1wVzA/BgNVHR8EODA2 +MDSgMqAwhi5odHRwOi8vd3d3Mi5wdWJsaWMtdHJ1c3QuY29tL2NybC9jdC9jdHJvb3QuY3JsMB8G +A1UdIwQYMBaAFLYIew16zKwgTIZWMl7Pq26FLXBXMA0GCSqGSIb3DQEBBQUAA4IBAQBW7wojoFRO +lZfJ+InaRcHUowAl9B8Tq7ejhVhpwjCt2BWKLePJzYFa+HMjWqd8BfP9IjsO0QbE2zZMcwSO5bAi +5MXzLqXZI+O4Tkogp24CJJ8iYGd7ix1yCcUxXOl5n4BHPa2hCwcUPUf/A2kaDAtE52Mlp3+yybh2 +hO0j9n0Hq0V+09+zv+mKts2oomcrUtW3ZfA5TGOgkXmTUg9U3YO7n9GPp1Nzw8v/MOx8BLjYRB+T +X3EJIrduPuocA06dGiBh+4E37F78CkWr1+cXVdCg6mCbpvbjjFspwgZgFJ0tl0ypkxWdYcQBX0jW +WL1WMRJOEcgh4LMRkWXbtKaIOM5V +-----END CERTIFICATE----- + +ePKI Root Certification Authority +================================= +-----BEGIN CERTIFICATE----- +MIIFsDCCA5igAwIBAgIQFci9ZUdcr7iXAF7kBtK8nTANBgkqhkiG9w0BAQUFADBeMQswCQYDVQQG +EwJUVzEjMCEGA1UECgwaQ2h1bmdod2EgVGVsZWNvbSBDby4sIEx0ZC4xKjAoBgNVBAsMIWVQS0kg +Um9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAeFw0wNDEyMjAwMjMxMjdaFw0zNDEyMjAwMjMx +MjdaMF4xCzAJBgNVBAYTAlRXMSMwIQYDVQQKDBpDaHVuZ2h3YSBUZWxlY29tIENvLiwgTHRkLjEq +MCgGA1UECwwhZVBLSSBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5MIICIjANBgkqhkiG9w0B +AQEFAAOCAg8AMIICCgKCAgEA4SUP7o3biDN1Z82tH306Tm2d0y8U82N0ywEhajfqhFAHSyZbCUNs +IZ5qyNUD9WBpj8zwIuQf5/dqIjG3LBXy4P4AakP/h2XGtRrBp0xtInAhijHyl3SJCRImHJ7K2RKi +lTza6We/CKBk49ZCt0Xvl/T29de1ShUCWH2YWEtgvM3XDZoTM1PRYfl61dd4s5oz9wCGzh1NlDiv +qOx4UXCKXBCDUSH3ET00hl7lSM2XgYI1TBnsZfZrxQWh7kcT1rMhJ5QQCtkkO7q+RBNGMD+XPNjX +12ruOzjjK9SXDrkb5wdJfzcq+Xd4z1TtW0ado4AOkUPB1ltfFLqfpo0kR0BZv3I4sjZsN/+Z0V0O +WQqraffAsgRFelQArr5T9rXn4fg8ozHSqf4hUmTFpmfwdQcGlBSBVcYn5AGPF8Fqcde+S/uUWH1+ +ETOxQvdibBjWzwloPn9s9h6PYq2lY9sJpx8iQkEeb5mKPtf5P0B6ebClAZLSnT0IFaUQAS2zMnao +lQ2zepr7BxB4EW/hj8e6DyUadCrlHJhBmd8hh+iVBmoKs2pHdmX2Os+PYhcZewoozRrSgx4hxyy/ +vv9haLdnG7t4TY3OZ+XkwY63I2binZB1NJipNiuKmpS5nezMirH4JYlcWrYvjB9teSSnUmjDhDXi +Zo1jDiVN1Rmy5nk3pyKdVDECAwEAAaNqMGgwHQYDVR0OBBYEFB4M97Zn8uGSJglFwFU5Lnc/Qkqi +MAwGA1UdEwQFMAMBAf8wOQYEZyoHAAQxMC8wLQIBADAJBgUrDgMCGgUAMAcGBWcqAwAABBRFsMLH +ClZ87lt4DJX5GFPBphzYEDANBgkqhkiG9w0BAQUFAAOCAgEACbODU1kBPpVJufGBuvl2ICO1J2B0 +1GqZNF5sAFPZn/KmsSQHRGoqxqWOeBLoR9lYGxMqXnmbnwoqZ6YlPwZpVnPDimZI+ymBV3QGypzq +KOg4ZyYr8dW1P2WT+DZdjo2NQCCHGervJ8A9tDkPJXtoUHRVnAxZfVo9QZQlUgjgRywVMRnVvwdV +xrsStZf0X4OFunHB2WyBEXYKCrC/gpf36j36+uwtqSiUO1bd0lEursC9CBWMd1I0ltabrNMdjmEP +NXubrjlpC2JgQCA2j6/7Nu4tCEoduL+bXPjqpRugc6bY+G7gMwRfaKonh+3ZwZCc7b3jajWvY9+r +GNm65ulK6lCKD2GTHuItGeIwlDWSXQ62B68ZgI9HkFFLLk3dheLSClIKF5r8GrBQAuUBo2M3IUxE +xJtRmREOc5wGj1QupyheRDmHVi03vYVElOEMSyycw5KFNGHLD7ibSkNS/jQ6fbjpKdx2qcgw+BRx +gMYeNkh0IkFch4LoGHGLQYlE535YW6i4jRPpp2zDR+2zGp1iro2C6pSe3VkQw63d4k3jMdXH7Ojy +sP6SHhYKGvzZ8/gntsm+HbRsZJB/9OTEW9c3rkIO3aQab3yIVMUWbuF6aC74Or8NpDyJO3inTmOD +BCEIZ43ygknQW/2xzQ+DhNQ+IIX3Sj0rnP0qCglN6oH4EZw= +-----END CERTIFICATE----- + +certSIGN ROOT CA +================ +-----BEGIN CERTIFICATE----- +MIIDODCCAiCgAwIBAgIGIAYFFnACMA0GCSqGSIb3DQEBBQUAMDsxCzAJBgNVBAYTAlJPMREwDwYD +VQQKEwhjZXJ0U0lHTjEZMBcGA1UECxMQY2VydFNJR04gUk9PVCBDQTAeFw0wNjA3MDQxNzIwMDRa +Fw0zMTA3MDQxNzIwMDRaMDsxCzAJBgNVBAYTAlJPMREwDwYDVQQKEwhjZXJ0U0lHTjEZMBcGA1UE +CxMQY2VydFNJR04gUk9PVCBDQTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBALczuX7I +JUqOtdu0KBuqV5Do0SLTZLrTk+jUrIZhQGpgV2hUhE28alQCBf/fm5oqrl0Hj0rDKH/v+yv6efHH +rfAQUySQi2bJqIirr1qjAOm+ukbuW3N7LBeCgV5iLKECZbO9xSsAfsT8AzNXDe3i+s5dRdY4zTW2 +ssHQnIFKquSyAVwdj1+ZxLGt24gh65AIgoDzMKND5pCCrlUoSe1b16kQOA7+j0xbm0bqQfWwCHTD +0IgztnzXdN/chNFDDnU5oSVAKOp4yw4sLjmdjItuFhwvJoIQ4uNllAoEwF73XVv4EOLQunpL+943 +AAAaWyjj0pxzPjKHmKHJUS/X3qwzs08CAwEAAaNCMEAwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8B +Af8EBAMCAcYwHQYDVR0OBBYEFOCMm9slSbPxfIbWskKHC9BroNnkMA0GCSqGSIb3DQEBBQUAA4IB +AQA+0hyJLjX8+HXd5n9liPRyTMks1zJO890ZeUe9jjtbkw9QSSQTaxQGcu8J06Gh40CEyecYMnQ8 +SG4Pn0vU9x7Tk4ZkVJdjclDVVc/6IJMCopvDI5NOFlV2oHB5bc0hH88vLbwZ44gx+FkagQnIl6Z0 +x2DEW8xXjrJ1/RsCCdtZb3KTafcxQdaIOL+Hsr0Wefmq5L6IJd1hJyMctTEHBDa0GpC9oHRxUIlt +vBTjD4au8as+x6AJzKNI0eDbZOeStc+vckNwi/nDhDwTqn6Sm1dTk/pwwpEOMfmbZ13pljheX7Nz +TogVZ96edhBiIL5VaZVDADlN9u6wWk5JRFRYX0KD +-----END CERTIFICATE----- + +GeoTrust Primary Certification Authority - G3 +============================================= +-----BEGIN CERTIFICATE----- +MIID/jCCAuagAwIBAgIQFaxulBmyeUtB9iepwxgPHzANBgkqhkiG9w0BAQsFADCBmDELMAkGA1UE +BhMCVVMxFjAUBgNVBAoTDUdlb1RydXN0IEluYy4xOTA3BgNVBAsTMChjKSAyMDA4IEdlb1RydXN0 +IEluYy4gLSBGb3IgYXV0aG9yaXplZCB1c2Ugb25seTE2MDQGA1UEAxMtR2VvVHJ1c3QgUHJpbWFy +eSBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eSAtIEczMB4XDTA4MDQwMjAwMDAwMFoXDTM3MTIwMTIz +NTk1OVowgZgxCzAJBgNVBAYTAlVTMRYwFAYDVQQKEw1HZW9UcnVzdCBJbmMuMTkwNwYDVQQLEzAo +YykgMjAwOCBHZW9UcnVzdCBJbmMuIC0gRm9yIGF1dGhvcml6ZWQgdXNlIG9ubHkxNjA0BgNVBAMT +LUdlb1RydXN0IFByaW1hcnkgQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkgLSBHMzCCASIwDQYJKoZI +hvcNAQEBBQADggEPADCCAQoCggEBANziXmJYHTNXOTIz+uvLh4yn1ErdBojqZI4xmKU4kB6Yzy5j +K/BGvESyiaHAKAxJcCGVn2TAppMSAmUmhsalifD614SgcK9PGpc/BkTVyetyEH3kMSj7HGHmKAdE +c5IiaacDiGydY8hS2pgn5whMcD60yRLBxWeDXTPzAxHsatBT4tG6NmCUgLthY2xbF37fQJQeqw3C +IShwiP/WJmxsYAQlTlV+fe+/lEjetx3dcI0FX4ilm/LC7urRQEFtYjgdVgbFA0dRIBn8exALDmKu +dlW/X3e+PkkBUz2YJQN2JFodtNuJ6nnltrM7P7pMKEF/BqxqjsHQ9gUdfeZChuOl1UcCAwEAAaNC +MEAwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0OBBYEFMR5yo6hTgMdHNxr +2zFblD4/MH8tMA0GCSqGSIb3DQEBCwUAA4IBAQAtxRPPVoB7eni9n64smefv2t+UXglpp+duaIy9 +cr5HqQ6XErhK8WTTOd8lNNTBzU6B8A8ExCSzNJbGpqow32hhc9f5joWJ7w5elShKKiePEI4ufIbE +Ap7aDHdlDkQNkv39sxY2+hENHYwOB4lqKVb3cvTdFZx3NWZXqxNT2I7BQMXXExZacse3aQHEerGD +AWh9jUGhlBjBJVz88P6DAod8DQ3PLghcSkANPuyBYeYk28rgDi0Hsj5W3I31QYUHSJsMC8tJP33s +t/3LjWeJGqvtux6jAAgIFyqCXDFdRootD4abdNlF+9RAsXqqaC2Gspki4cErx5z481+oghLrGREt +-----END CERTIFICATE----- + +thawte Primary Root CA - G2 +=========================== +-----BEGIN CERTIFICATE----- +MIICiDCCAg2gAwIBAgIQNfwmXNmET8k9Jj1Xm67XVjAKBggqhkjOPQQDAzCBhDELMAkGA1UEBhMC +VVMxFTATBgNVBAoTDHRoYXd0ZSwgSW5jLjE4MDYGA1UECxMvKGMpIDIwMDcgdGhhd3RlLCBJbmMu +IC0gRm9yIGF1dGhvcml6ZWQgdXNlIG9ubHkxJDAiBgNVBAMTG3RoYXd0ZSBQcmltYXJ5IFJvb3Qg +Q0EgLSBHMjAeFw0wNzExMDUwMDAwMDBaFw0zODAxMTgyMzU5NTlaMIGEMQswCQYDVQQGEwJVUzEV +MBMGA1UEChMMdGhhd3RlLCBJbmMuMTgwNgYDVQQLEy8oYykgMjAwNyB0aGF3dGUsIEluYy4gLSBG +b3IgYXV0aG9yaXplZCB1c2Ugb25seTEkMCIGA1UEAxMbdGhhd3RlIFByaW1hcnkgUm9vdCBDQSAt +IEcyMHYwEAYHKoZIzj0CAQYFK4EEACIDYgAEotWcgnuVnfFSeIf+iha/BebfowJPDQfGAFG6DAJS +LSKkQjnE/o/qycG+1E3/n3qe4rF8mq2nhglzh9HnmuN6papu+7qzcMBniKI11KOasf2twu8x+qi5 +8/sIxpHR+ymVo0IwQDAPBgNVHRMBAf8EBTADAQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQU +mtgAMADna3+FGO6Lts6KDPgR4bswCgYIKoZIzj0EAwMDaQAwZgIxAN344FdHW6fmCsO99YCKlzUN +G4k8VIZ3KMqh9HneteY4sPBlcIx/AlTCv//YoT7ZzwIxAMSNlPzcU9LcnXgWHxUzI1NS41oxXZ3K +rr0TKUQNJ1uo52icEvdYPy5yAlejj6EULg== +-----END CERTIFICATE----- + +thawte Primary Root CA - G3 +=========================== +-----BEGIN CERTIFICATE----- +MIIEKjCCAxKgAwIBAgIQYAGXt0an6rS0mtZLL/eQ+zANBgkqhkiG9w0BAQsFADCBrjELMAkGA1UE +BhMCVVMxFTATBgNVBAoTDHRoYXd0ZSwgSW5jLjEoMCYGA1UECxMfQ2VydGlmaWNhdGlvbiBTZXJ2 +aWNlcyBEaXZpc2lvbjE4MDYGA1UECxMvKGMpIDIwMDggdGhhd3RlLCBJbmMuIC0gRm9yIGF1dGhv +cml6ZWQgdXNlIG9ubHkxJDAiBgNVBAMTG3RoYXd0ZSBQcmltYXJ5IFJvb3QgQ0EgLSBHMzAeFw0w +ODA0MDIwMDAwMDBaFw0zNzEyMDEyMzU5NTlaMIGuMQswCQYDVQQGEwJVUzEVMBMGA1UEChMMdGhh +d3RlLCBJbmMuMSgwJgYDVQQLEx9DZXJ0aWZpY2F0aW9uIFNlcnZpY2VzIERpdmlzaW9uMTgwNgYD +VQQLEy8oYykgMjAwOCB0aGF3dGUsIEluYy4gLSBGb3IgYXV0aG9yaXplZCB1c2Ugb25seTEkMCIG +A1UEAxMbdGhhd3RlIFByaW1hcnkgUm9vdCBDQSAtIEczMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8A +MIIBCgKCAQEAsr8nLPvb2FvdeHsbnndmgcs+vHyu86YnmjSjaDFxODNi5PNxZnmxqWWjpYvVj2At +P0LMqmsywCPLLEHd5N/8YZzic7IilRFDGF/Eth9XbAoFWCLINkw6fKXRz4aviKdEAhN0cXMKQlkC ++BsUa0Lfb1+6a4KinVvnSr0eAXLbS3ToO39/fR8EtCab4LRarEc9VbjXsCZSKAExQGbY2SS99irY +7CFJXJv2eul/VTV+lmuNk5Mny5K76qxAwJ/C+IDPXfRa3M50hqY+bAtTyr2SzhkGcuYMXDhpxwTW +vGzOW/b3aJzcJRVIiKHpqfiYnODz1TEoYRFsZ5aNOZnLwkUkOQIDAQABo0IwQDAPBgNVHRMBAf8E +BTADAQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQUrWyqlGCc7eT/+j4KdCtjA/e2Wb8wDQYJ +KoZIhvcNAQELBQADggEBABpA2JVlrAmSicY59BDlqQ5mU1143vokkbvnRFHfxhY0Cu9qRFHqKweK +A3rD6z8KLFIWoCtDuSWQP3CpMyVtRRooOyfPqsMpQhvfO0zAMzRbQYi/aytlryjvsvXDqmbOe1bu +t8jLZ8HJnBoYuMTDSQPxYA5QzUbF83d597YV4Djbxy8ooAw/dyZ02SUS2jHaGh7cKUGRIjxpp7sC +8rZcJwOJ9Abqm+RyguOhCcHpABnTPtRwa7pxpqpYrvS76Wy274fMm7v/OeZWYdMKp8RcTGB7BXcm +er/YB1IsYvdwY9k5vG8cwnncdimvzsUsZAReiDZuMdRAGmI0Nj81Aa6sY6A= +-----END CERTIFICATE----- + +GeoTrust Primary Certification Authority - G2 +============================================= +-----BEGIN CERTIFICATE----- +MIICrjCCAjWgAwIBAgIQPLL0SAoA4v7rJDteYD7DazAKBggqhkjOPQQDAzCBmDELMAkGA1UEBhMC +VVMxFjAUBgNVBAoTDUdlb1RydXN0IEluYy4xOTA3BgNVBAsTMChjKSAyMDA3IEdlb1RydXN0IElu +Yy4gLSBGb3IgYXV0aG9yaXplZCB1c2Ugb25seTE2MDQGA1UEAxMtR2VvVHJ1c3QgUHJpbWFyeSBD +ZXJ0aWZpY2F0aW9uIEF1dGhvcml0eSAtIEcyMB4XDTA3MTEwNTAwMDAwMFoXDTM4MDExODIzNTk1 +OVowgZgxCzAJBgNVBAYTAlVTMRYwFAYDVQQKEw1HZW9UcnVzdCBJbmMuMTkwNwYDVQQLEzAoYykg +MjAwNyBHZW9UcnVzdCBJbmMuIC0gRm9yIGF1dGhvcml6ZWQgdXNlIG9ubHkxNjA0BgNVBAMTLUdl +b1RydXN0IFByaW1hcnkgQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkgLSBHMjB2MBAGByqGSM49AgEG +BSuBBAAiA2IABBWx6P0DFUPlrOuHNxFi79KDNlJ9RVcLSo17VDs6bl8VAsBQps8lL33KSLjHUGMc +KiEIfJo22Av+0SbFWDEwKCXzXV2juLaltJLtbCyf691DiaI8S0iRHVDsJt/WYC69IaNCMEAwDwYD +VR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0OBBYEFBVfNVdRVfslsq0DafwBo/q+ +EVXVMAoGCCqGSM49BAMDA2cAMGQCMGSWWaboCd6LuvpaiIjwH5HTRqjySkwCY/tsXzjbLkGTqQ7m +ndwxHLKgpxgceeHHNgIwOlavmnRs9vuD4DPTCF+hnMJbn0bWtsuRBmOiBuczrD6ogRLQy7rQkgu2 +npaqBA+K +-----END CERTIFICATE----- + +VeriSign Universal Root Certification Authority +=============================================== +-----BEGIN CERTIFICATE----- +MIIEuTCCA6GgAwIBAgIQQBrEZCGzEyEDDrvkEhrFHTANBgkqhkiG9w0BAQsFADCBvTELMAkGA1UE +BhMCVVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMR8wHQYDVQQLExZWZXJpU2lnbiBUcnVzdCBO +ZXR3b3JrMTowOAYDVQQLEzEoYykgMjAwOCBWZXJpU2lnbiwgSW5jLiAtIEZvciBhdXRob3JpemVk +IHVzZSBvbmx5MTgwNgYDVQQDEy9WZXJpU2lnbiBVbml2ZXJzYWwgUm9vdCBDZXJ0aWZpY2F0aW9u +IEF1dGhvcml0eTAeFw0wODA0MDIwMDAwMDBaFw0zNzEyMDEyMzU5NTlaMIG9MQswCQYDVQQGEwJV +UzEXMBUGA1UEChMOVmVyaVNpZ24sIEluYy4xHzAdBgNVBAsTFlZlcmlTaWduIFRydXN0IE5ldHdv +cmsxOjA4BgNVBAsTMShjKSAyMDA4IFZlcmlTaWduLCBJbmMuIC0gRm9yIGF1dGhvcml6ZWQgdXNl +IG9ubHkxODA2BgNVBAMTL1ZlcmlTaWduIFVuaXZlcnNhbCBSb290IENlcnRpZmljYXRpb24gQXV0 +aG9yaXR5MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAx2E3XrEBNNti1xWb/1hajCMj +1mCOkdeQmIN65lgZOIzF9uVkhbSicfvtvbnazU0AtMgtc6XHaXGVHzk8skQHnOgO+k1KxCHfKWGP +MiJhgsWHH26MfF8WIFFE0XBPV+rjHOPMee5Y2A7Cs0WTwCznmhcrewA3ekEzeOEz4vMQGn+HLL72 +9fdC4uW/h2KJXwBL38Xd5HVEMkE6HnFuacsLdUYI0crSK5XQz/u5QGtkjFdN/BMReYTtXlT2NJ8I +AfMQJQYXStrxHXpma5hgZqTZ79IugvHw7wnqRMkVauIDbjPTrJ9VAMf2CGqUuV/c4DPxhGD5WycR +tPwW8rtWaoAljQIDAQABo4GyMIGvMA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMG0G +CCsGAQUFBwEMBGEwX6FdoFswWTBXMFUWCWltYWdlL2dpZjAhMB8wBwYFKw4DAhoEFI/l0xqGrI2O +a8PPgGrUSBgsexkuMCUWI2h0dHA6Ly9sb2dvLnZlcmlzaWduLmNvbS92c2xvZ28uZ2lmMB0GA1Ud +DgQWBBS2d/ppSEefUxLVwuoHMnYH0ZcHGTANBgkqhkiG9w0BAQsFAAOCAQEASvj4sAPmLGd75JR3 +Y8xuTPl9Dg3cyLk1uXBPY/ok+myDjEedO2Pzmvl2MpWRsXe8rJq+seQxIcaBlVZaDrHC1LGmWazx +Y8u4TB1ZkErvkBYoH1quEPuBUDgMbMzxPcP1Y+Oz4yHJJDnp/RVmRvQbEdBNc6N9Rvk97ahfYtTx +P/jgdFcrGJ2BtMQo2pSXpXDrrB2+BxHw1dvd5Yzw1TKwg+ZX4o+/vqGqvz0dtdQ46tewXDpPaj+P +wGZsY6rp2aQW9IHRlRQOfc2VNNnSj3BzgXucfr2YYdhFh5iQxeuGMMY1v/D/w1WIg0vvBZIGcfK4 +mJO37M2CYfE45k+XmCpajQ== +-----END CERTIFICATE----- + +VeriSign Class 3 Public Primary Certification Authority - G4 +============================================================ +-----BEGIN CERTIFICATE----- +MIIDhDCCAwqgAwIBAgIQL4D+I4wOIg9IZxIokYesszAKBggqhkjOPQQDAzCByjELMAkGA1UEBhMC +VVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMR8wHQYDVQQLExZWZXJpU2lnbiBUcnVzdCBOZXR3 +b3JrMTowOAYDVQQLEzEoYykgMjAwNyBWZXJpU2lnbiwgSW5jLiAtIEZvciBhdXRob3JpemVkIHVz +ZSBvbmx5MUUwQwYDVQQDEzxWZXJpU2lnbiBDbGFzcyAzIFB1YmxpYyBQcmltYXJ5IENlcnRpZmlj +YXRpb24gQXV0aG9yaXR5IC0gRzQwHhcNMDcxMTA1MDAwMDAwWhcNMzgwMTE4MjM1OTU5WjCByjEL +MAkGA1UEBhMCVVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMR8wHQYDVQQLExZWZXJpU2lnbiBU +cnVzdCBOZXR3b3JrMTowOAYDVQQLEzEoYykgMjAwNyBWZXJpU2lnbiwgSW5jLiAtIEZvciBhdXRo +b3JpemVkIHVzZSBvbmx5MUUwQwYDVQQDEzxWZXJpU2lnbiBDbGFzcyAzIFB1YmxpYyBQcmltYXJ5 +IENlcnRpZmljYXRpb24gQXV0aG9yaXR5IC0gRzQwdjAQBgcqhkjOPQIBBgUrgQQAIgNiAASnVnp8 +Utpkmw4tXNherJI9/gHmGUo9FANL+mAnINmDiWn6VMaaGF5VKmTeBvaNSjutEDxlPZCIBIngMGGz +rl0Bp3vefLK+ymVhAIau2o970ImtTR1ZmkGxvEeA3J5iw/mjgbIwga8wDwYDVR0TAQH/BAUwAwEB +/zAOBgNVHQ8BAf8EBAMCAQYwbQYIKwYBBQUHAQwEYTBfoV2gWzBZMFcwVRYJaW1hZ2UvZ2lmMCEw +HzAHBgUrDgMCGgQUj+XTGoasjY5rw8+AatRIGCx7GS4wJRYjaHR0cDovL2xvZ28udmVyaXNpZ24u +Y29tL3ZzbG9nby5naWYwHQYDVR0OBBYEFLMWkf3upm7ktS5Jj4d4gYDs5bG1MAoGCCqGSM49BAMD +A2gAMGUCMGYhDBgmYFo4e1ZC4Kf8NoRRkSAsdk1DPcQdhCPQrNZ8NQbOzWm9kA3bbEhCHQ6qQgIx +AJw9SDkjOVgaFRJZap7v1VmyHVIsmXHNxynfGyphe3HR3vPA5Q06Sqotp9iGKt0uEA== +-----END CERTIFICATE----- + +NetLock Arany (Class Gold) FÅ‘tanúsÃtvány +======================================== +-----BEGIN CERTIFICATE----- +MIIEFTCCAv2gAwIBAgIGSUEs5AAQMA0GCSqGSIb3DQEBCwUAMIGnMQswCQYDVQQGEwJIVTERMA8G +A1UEBwwIQnVkYXBlc3QxFTATBgNVBAoMDE5ldExvY2sgS2Z0LjE3MDUGA1UECwwuVGFuw7pzw610 +dsOhbnlraWFkw7NrIChDZXJ0aWZpY2F0aW9uIFNlcnZpY2VzKTE1MDMGA1UEAwwsTmV0TG9jayBB +cmFueSAoQ2xhc3MgR29sZCkgRsWRdGFuw7pzw610dsOhbnkwHhcNMDgxMjExMTUwODIxWhcNMjgx +MjA2MTUwODIxWjCBpzELMAkGA1UEBhMCSFUxETAPBgNVBAcMCEJ1ZGFwZXN0MRUwEwYDVQQKDAxO +ZXRMb2NrIEtmdC4xNzA1BgNVBAsMLlRhbsO6c8OtdHbDoW55a2lhZMOzayAoQ2VydGlmaWNhdGlv +biBTZXJ2aWNlcykxNTAzBgNVBAMMLE5ldExvY2sgQXJhbnkgKENsYXNzIEdvbGQpIEbFkXRhbsO6 +c8OtdHbDoW55MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAxCRec75LbRTDofTjl5Bu +0jBFHjzuZ9lk4BqKf8owyoPjIMHj9DrTlF8afFttvzBPhCf2nx9JvMaZCpDyD/V/Q4Q3Y1GLeqVw +/HpYzY6b7cNGbIRwXdrzAZAj/E4wqX7hJ2Pn7WQ8oLjJM2P+FpD/sLj916jAwJRDC7bVWaaeVtAk +H3B5r9s5VA1lddkVQZQBr17s9o3x/61k/iCa11zr/qYfCGSji3ZVrR47KGAuhyXoqq8fxmRGILdw +fzzeSNuWU7c5d+Qa4scWhHaXWy+7GRWF+GmF9ZmnqfI0p6m2pgP8b4Y9VHx2BJtr+UBdADTHLpl1 +neWIA6pN+APSQnbAGwIDAKiLo0UwQzASBgNVHRMBAf8ECDAGAQH/AgEEMA4GA1UdDwEB/wQEAwIB +BjAdBgNVHQ4EFgQUzPpnk/C2uNClwB7zU/2MU9+D15YwDQYJKoZIhvcNAQELBQADggEBAKt/7hwW +qZw8UQCgwBEIBaeZ5m8BiFRhbvG5GK1Krf6BQCOUL/t1fC8oS2IkgYIL9WHxHG64YTjrgfpioTta +YtOUZcTh5m2C+C8lcLIhJsFyUR+MLMOEkMNaj7rP9KdlpeuY0fsFskZ1FSNqb4VjMIDw1Z4fKRzC +bLBQWV2QWzuoDTDPv31/zvGdg73JRm4gpvlhUbohL3u+pRVjodSVh/GeufOJ8z2FuLjbvrW5Kfna +NwUASZQDhETnv0Mxz3WLJdH0pmT1kvarBes96aULNmLazAZfNou2XjG4Kvte9nHfRCaexOYNkbQu +dZWAUWpLMKawYqGT8ZvYzsRjdT9ZR7E= +-----END CERTIFICATE----- + +Staat der Nederlanden Root CA - G2 +================================== +-----BEGIN CERTIFICATE----- +MIIFyjCCA7KgAwIBAgIEAJiWjDANBgkqhkiG9w0BAQsFADBaMQswCQYDVQQGEwJOTDEeMBwGA1UE +CgwVU3RhYXQgZGVyIE5lZGVybGFuZGVuMSswKQYDVQQDDCJTdGFhdCBkZXIgTmVkZXJsYW5kZW4g +Um9vdCBDQSAtIEcyMB4XDTA4MDMyNjExMTgxN1oXDTIwMDMyNTExMDMxMFowWjELMAkGA1UEBhMC +TkwxHjAcBgNVBAoMFVN0YWF0IGRlciBOZWRlcmxhbmRlbjErMCkGA1UEAwwiU3RhYXQgZGVyIE5l +ZGVybGFuZGVuIFJvb3QgQ0EgLSBHMjCCAiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBAMVZ +5291qj5LnLW4rJ4L5PnZyqtdj7U5EILXr1HgO+EASGrP2uEGQxGZqhQlEq0i6ABtQ8SpuOUfiUtn +vWFI7/3S4GCI5bkYYCjDdyutsDeqN95kWSpGV+RLufg3fNU254DBtvPUZ5uW6M7XxgpT0GtJlvOj +CwV3SPcl5XCsMBQgJeN/dVrlSPhOewMHBPqCYYdu8DvEpMfQ9XQ+pV0aCPKbJdL2rAQmPlU6Yiil +e7Iwr/g3wtG61jj99O9JMDeZJiFIhQGp5Rbn3JBV3w/oOM2ZNyFPXfUib2rFEhZgF1XyZWampzCR +OME4HYYEhLoaJXhena/MUGDWE4dS7WMfbWV9whUYdMrhfmQpjHLYFhN9C0lK8SgbIHRrxT3dsKpI +CT0ugpTNGmXZK4iambwYfp/ufWZ8Pr2UuIHOzZgweMFvZ9C+X+Bo7d7iscksWXiSqt8rYGPy5V65 +48r6f1CGPqI0GAwJaCgRHOThuVw+R7oyPxjMW4T182t0xHJ04eOLoEq9jWYv6q012iDTiIJh8BIi +trzQ1aTsr1SIJSQ8p22xcik/Plemf1WvbibG/ufMQFxRRIEKeN5KzlW/HdXZt1bv8Hb/C3m1r737 +qWmRRpdogBQ2HbN/uymYNqUg+oJgYjOk7Na6B6duxc8UpufWkjTYgfX8HV2qXB72o007uPc5AgMB +AAGjgZcwgZQwDwYDVR0TAQH/BAUwAwEB/zBSBgNVHSAESzBJMEcGBFUdIAAwPzA9BggrBgEFBQcC +ARYxaHR0cDovL3d3dy5wa2lvdmVyaGVpZC5ubC9wb2xpY2llcy9yb290LXBvbGljeS1HMjAOBgNV +HQ8BAf8EBAMCAQYwHQYDVR0OBBYEFJFoMocVHYnitfGsNig0jQt8YojrMA0GCSqGSIb3DQEBCwUA +A4ICAQCoQUpnKpKBglBu4dfYszk78wIVCVBR7y29JHuIhjv5tLySCZa59sCrI2AGeYwRTlHSeYAz ++51IvuxBQ4EffkdAHOV6CMqqi3WtFMTC6GY8ggen5ieCWxjmD27ZUD6KQhgpxrRW/FYQoAUXvQwj +f/ST7ZwaUb7dRUG/kSS0H4zpX897IZmflZ85OkYcbPnNe5yQzSipx6lVu6xiNGI1E0sUOlWDuYaN +kqbG9AclVMwWVxJKgnjIFNkXgiYtXSAfea7+1HAWFpWD2DU5/1JddRwWxRNVz0fMdWVSSt7wsKfk +CpYL+63C4iWEst3kvX5ZbJvw8NjnyvLplzh+ib7M+zkXYT9y2zqR2GUBGR2tUKRXCnxLvJxxcypF +URmFzI79R6d0lR2o0a9OF7FpJsKqeFdbxU2n5Z4FF5TKsl+gSRiNNOkmbEgeqmiSBeGCc1qb3Adb +CG19ndeNIdn8FCCqwkXfP+cAslHkwvgFuXkajDTznlvkN1trSt8sV4pAWja63XVECDdCcAz+3F4h +oKOKwJCcaNpQ5kUQR3i2TtJlycM33+FCY7BXN0Ute4qcvwXqZVUz9zkQxSgqIXobisQk+T8VyJoV +IPVVYpbtbZNQvOSqeK3Zywplh6ZmwcSBo3c6WB4L7oOLnR7SUqTMHW+wmG2UMbX4cQrcufx9MmDm +66+KAQ== +-----END CERTIFICATE----- + +Hongkong Post Root CA 1 +======================= +-----BEGIN CERTIFICATE----- +MIIDMDCCAhigAwIBAgICA+gwDQYJKoZIhvcNAQEFBQAwRzELMAkGA1UEBhMCSEsxFjAUBgNVBAoT +DUhvbmdrb25nIFBvc3QxIDAeBgNVBAMTF0hvbmdrb25nIFBvc3QgUm9vdCBDQSAxMB4XDTAzMDUx +NTA1MTMxNFoXDTIzMDUxNTA0NTIyOVowRzELMAkGA1UEBhMCSEsxFjAUBgNVBAoTDUhvbmdrb25n +IFBvc3QxIDAeBgNVBAMTF0hvbmdrb25nIFBvc3QgUm9vdCBDQSAxMIIBIjANBgkqhkiG9w0BAQEF +AAOCAQ8AMIIBCgKCAQEArP84tulmAknjorThkPlAj3n54r15/gK97iSSHSL22oVyaf7XPwnU3ZG1 +ApzQjVrhVcNQhrkpJsLj2aDxaQMoIIBFIi1WpztUlVYiWR8o3x8gPW2iNr4joLFutbEnPzlTCeqr +auh0ssJlXI6/fMN4hM2eFvz1Lk8gKgifd/PFHsSaUmYeSF7jEAaPIpjhZY4bXSNmO7ilMlHIhqqh +qZ5/dpTCpmy3QfDVyAY45tQM4vM7TG1QjMSDJ8EThFk9nnV0ttgCXjqQesBCNnLsak3c78QA3xMY +V18meMjWCnl3v/evt3a5pQuEF10Q6m/hq5URX208o1xNg1vysxmKgIsLhwIDAQABoyYwJDASBgNV +HRMBAf8ECDAGAQH/AgEDMA4GA1UdDwEB/wQEAwIBxjANBgkqhkiG9w0BAQUFAAOCAQEADkbVPK7i +h9legYsCmEEIjEy82tvuJxuC52pF7BaLT4Wg87JwvVqWuspube5Gi27nKi6Wsxkz67SfqLI37pio +l7Yutmcn1KZJ/RyTZXaeQi/cImyaT/JaFTmxcdcrUehtHJjA2Sr0oYJ71clBoiMBdDhViw+5Lmei +IAQ32pwL0xch4I+XeTRvhEgCIDMb5jREn5Fw9IBehEPCKdJsEhTkYY2sEJCehFC78JZvRZ+K88ps +T/oROhUVRsPNH4NbLUES7VBnQRM9IauUiqpOfMGx+6fWtScvl6tu4B3i0RwsH0Ti/L6RoZz71ilT +c4afU9hDDl3WY4JxHYB0yvbiAmvZWg== +-----END CERTIFICATE----- + +SecureSign RootCA11 +=================== +-----BEGIN CERTIFICATE----- +MIIDbTCCAlWgAwIBAgIBATANBgkqhkiG9w0BAQUFADBYMQswCQYDVQQGEwJKUDErMCkGA1UEChMi +SmFwYW4gQ2VydGlmaWNhdGlvbiBTZXJ2aWNlcywgSW5jLjEcMBoGA1UEAxMTU2VjdXJlU2lnbiBS +b290Q0ExMTAeFw0wOTA0MDgwNDU2NDdaFw0yOTA0MDgwNDU2NDdaMFgxCzAJBgNVBAYTAkpQMSsw +KQYDVQQKEyJKYXBhbiBDZXJ0aWZpY2F0aW9uIFNlcnZpY2VzLCBJbmMuMRwwGgYDVQQDExNTZWN1 +cmVTaWduIFJvb3RDQTExMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA/XeqpRyQBTvL +TJszi1oURaTnkBbR31fSIRCkF/3frNYfp+TbfPfs37gD2pRY/V1yfIw/XwFndBWW4wI8h9uuywGO +wvNmxoVF9ALGOrVisq/6nL+k5tSAMJjzDbaTj6nU2DbysPyKyiyhFTOVMdrAG/LuYpmGYz+/3ZMq +g6h2uRMft85OQoWPIucuGvKVCbIFtUROd6EgvanyTgp9UK31BQ1FT0Zx/Sg+U/sE2C3XZR1KG/rP +O7AxmjVuyIsG0wCR8pQIZUyxNAYAeoni8McDWc/V1uinMrPmmECGxc0nEovMe863ETxiYAcjPitA +bpSACW22s293bzUIUPsCh8U+iQIDAQABo0IwQDAdBgNVHQ4EFgQUW/hNT7KlhtQ60vFjmqC+CfZX +t94wDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZIhvcNAQEFBQADggEBAKCh +OBZmLqdWHyGcBvod7bkixTgm2E5P7KN/ed5GIaGHd48HCJqypMWvDzKYC3xmKbabfSVSSUOrTC4r +bnpwrxYO4wJs+0LmGJ1F2FXI6Dvd5+H0LgscNFxsWEr7jIhQX5Ucv+2rIrVls4W6ng+4reV6G4pQ +Oh29Dbx7VFALuUKvVaAYga1lme++5Jy/xIWrQbJUb9wlze144o4MjQlJ3WN7WmmWAiGovVJZ6X01 +y8hSyn+B/tlr0/cR7SXf+Of5pPpyl4RTDaXQMhhRdlkUbA/r7F+AjHVDg8OFmP9Mni0N5HeDk061 +lgeLKBObjBmNQSdJQO7e5iNEOdyhIta6A/I= +-----END CERTIFICATE----- + +Microsec e-Szigno Root CA 2009 +============================== +-----BEGIN CERTIFICATE----- +MIIECjCCAvKgAwIBAgIJAMJ+QwRORz8ZMA0GCSqGSIb3DQEBCwUAMIGCMQswCQYDVQQGEwJIVTER +MA8GA1UEBwwIQnVkYXBlc3QxFjAUBgNVBAoMDU1pY3Jvc2VjIEx0ZC4xJzAlBgNVBAMMHk1pY3Jv +c2VjIGUtU3ppZ25vIFJvb3QgQ0EgMjAwOTEfMB0GCSqGSIb3DQEJARYQaW5mb0BlLXN6aWduby5o +dTAeFw0wOTA2MTYxMTMwMThaFw0yOTEyMzAxMTMwMThaMIGCMQswCQYDVQQGEwJIVTERMA8GA1UE +BwwIQnVkYXBlc3QxFjAUBgNVBAoMDU1pY3Jvc2VjIEx0ZC4xJzAlBgNVBAMMHk1pY3Jvc2VjIGUt +U3ppZ25vIFJvb3QgQ0EgMjAwOTEfMB0GCSqGSIb3DQEJARYQaW5mb0BlLXN6aWduby5odTCCASIw +DQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAOn4j/NjrdqG2KfgQvvPkd6mJviZpWNwrZuuyjNA +fW2WbqEORO7hE52UQlKavXWFdCyoDh2Tthi3jCyoz/tccbna7P7ofo/kLx2yqHWH2Leh5TvPmUpG +0IMZfcChEhyVbUr02MelTTMuhTlAdX4UfIASmFDHQWe4oIBhVKZsTh/gnQ4H6cm6M+f+wFUoLAKA +pxn1ntxVUwOXewdI/5n7N4okxFnMUBBjjqqpGrCEGob5X7uxUG6k0QrM1XF+H6cbfPVTbiJfyyvm +1HxdrtbCxkzlBQHZ7Vf8wSN5/PrIJIOV87VqUQHQd9bpEqH5GoP7ghu5sJf0dgYzQ0mg/wu1+rUC +AwEAAaOBgDB+MA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMB0GA1UdDgQWBBTLD8bf +QkPMPcu1SCOhGnqmKrs0aDAfBgNVHSMEGDAWgBTLD8bfQkPMPcu1SCOhGnqmKrs0aDAbBgNVHREE +FDASgRBpbmZvQGUtc3ppZ25vLmh1MA0GCSqGSIb3DQEBCwUAA4IBAQDJ0Q5eLtXMs3w+y/w9/w0o +lZMEyL/azXm4Q5DwpL7v8u8hmLzU1F0G9u5C7DBsoKqpyvGvivo/C3NqPuouQH4frlRheesuCDfX +I/OMn74dseGkddug4lQUsbocKaQY9hK6ohQU4zE1yED/t+AFdlfBHFny+L/k7SViXITwfn4fs775 +tyERzAMBVnCnEJIeGzSBHq2cGsMEPO0CYdYeBvNfOofyK/FFh+U9rNHHV4S9a67c2Pm2G2JwCz02 +yULyMtd6YebS2z3PyKnJm9zbWETXbzivf3jTo60adbocwTZ8jx5tHMN1Rq41Bab2XD0h7lbwyYIi +LXpUq3DDfSJlgnCW +-----END CERTIFICATE----- + +GlobalSign Root CA - R3 +======================= +-----BEGIN CERTIFICATE----- +MIIDXzCCAkegAwIBAgILBAAAAAABIVhTCKIwDQYJKoZIhvcNAQELBQAwTDEgMB4GA1UECxMXR2xv +YmFsU2lnbiBSb290IENBIC0gUjMxEzARBgNVBAoTCkdsb2JhbFNpZ24xEzARBgNVBAMTCkdsb2Jh +bFNpZ24wHhcNMDkwMzE4MTAwMDAwWhcNMjkwMzE4MTAwMDAwWjBMMSAwHgYDVQQLExdHbG9iYWxT +aWduIFJvb3QgQ0EgLSBSMzETMBEGA1UEChMKR2xvYmFsU2lnbjETMBEGA1UEAxMKR2xvYmFsU2ln +bjCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAMwldpB5BngiFvXAg7aEyiie/QV2EcWt +iHL8RgJDx7KKnQRfJMsuS+FggkbhUqsMgUdwbN1k0ev1LKMPgj0MK66X17YUhhB5uzsTgHeMCOFJ +0mpiLx9e+pZo34knlTifBtc+ycsmWQ1z3rDI6SYOgxXG71uL0gRgykmmKPZpO/bLyCiR5Z2KYVc3 +rHQU3HTgOu5yLy6c+9C7v/U9AOEGM+iCK65TpjoWc4zdQQ4gOsC0p6Hpsk+QLjJg6VfLuQSSaGjl +OCZgdbKfd/+RFO+uIEn8rUAVSNECMWEZXriX7613t2Saer9fwRPvm2L7DWzgVGkWqQPabumDk3F2 +xmmFghcCAwEAAaNCMEAwDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYE +FI/wS3+oLkUkrk1Q+mOai97i3Ru8MA0GCSqGSIb3DQEBCwUAA4IBAQBLQNvAUKr+yAzv95ZURUm7 +lgAJQayzE4aGKAczymvmdLm6AC2upArT9fHxD4q/c2dKg8dEe3jgr25sbwMpjjM5RcOO5LlXbKr8 +EpbsU8Yt5CRsuZRj+9xTaGdWPoO4zzUhw8lo/s7awlOqzJCK6fBdRoyV3XpYKBovHd7NADdBj+1E +bddTKJd+82cEHhXXipa0095MJ6RMG3NzdvQXmcIfeg7jLQitChws/zyrVQ4PkX4268NXSb7hLi18 +YIvDQVETI53O9zJrlAGomecsMx86OyXShkDOOyyGeMlhLxS67ttVb9+E7gUJTb0o2HLO02JQZR7r +kpeDMdmztcpHWD9f +-----END CERTIFICATE----- + +Autoridad de Certificacion Firmaprofesional CIF A62634068 +========================================================= +-----BEGIN CERTIFICATE----- +MIIGFDCCA/ygAwIBAgIIU+w77vuySF8wDQYJKoZIhvcNAQEFBQAwUTELMAkGA1UEBhMCRVMxQjBA +BgNVBAMMOUF1dG9yaWRhZCBkZSBDZXJ0aWZpY2FjaW9uIEZpcm1hcHJvZmVzaW9uYWwgQ0lGIEE2 +MjYzNDA2ODAeFw0wOTA1MjAwODM4MTVaFw0zMDEyMzEwODM4MTVaMFExCzAJBgNVBAYTAkVTMUIw +QAYDVQQDDDlBdXRvcmlkYWQgZGUgQ2VydGlmaWNhY2lvbiBGaXJtYXByb2Zlc2lvbmFsIENJRiBB +NjI2MzQwNjgwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQDKlmuO6vj78aI14H9M2uDD +Utd9thDIAl6zQyrET2qyyhxdKJp4ERppWVevtSBC5IsP5t9bpgOSL/UR5GLXMnE42QQMcas9UX4P +B99jBVzpv5RvwSmCwLTaUbDBPLutN0pcyvFLNg4kq7/DhHf9qFD0sefGL9ItWY16Ck6WaVICqjaY +7Pz6FIMMNx/Jkjd/14Et5cS54D40/mf0PmbR0/RAz15iNA9wBj4gGFrO93IbJWyTdBSTo3OxDqqH +ECNZXyAFGUftaI6SEspd/NYrspI8IM/hX68gvqB2f3bl7BqGYTM+53u0P6APjqK5am+5hyZvQWyI +plD9amML9ZMWGxmPsu2bm8mQ9QEM3xk9Dz44I8kvjwzRAv4bVdZO0I08r0+k8/6vKtMFnXkIoctX +MbScyJCyZ/QYFpM6/EfY0XiWMR+6KwxfXZmtY4laJCB22N/9q06mIqqdXuYnin1oKaPnirjaEbsX +LZmdEyRG98Xi2J+Of8ePdG1asuhy9azuJBCtLxTa/y2aRnFHvkLfuwHb9H/TKI8xWVvTyQKmtFLK +bpf7Q8UIJm+K9Lv9nyiqDdVF8xM6HdjAeI9BZzwelGSuewvF6NkBiDkal4ZkQdU7hwxu+g/GvUgU +vzlN1J5Bto+WHWOWk9mVBngxaJ43BjuAiUVhOSPHG0SjFeUc+JIwuwIDAQABo4HvMIHsMBIGA1Ud +EwEB/wQIMAYBAf8CAQEwDgYDVR0PAQH/BAQDAgEGMB0GA1UdDgQWBBRlzeurNR4APn7VdMActHNH +DhpkLzCBpgYDVR0gBIGeMIGbMIGYBgRVHSAAMIGPMC8GCCsGAQUFBwIBFiNodHRwOi8vd3d3LmZp +cm1hcHJvZmVzaW9uYWwuY29tL2NwczBcBggrBgEFBQcCAjBQHk4AUABhAHMAZQBvACAAZABlACAA +bABhACAAQgBvAG4AYQBuAG8AdgBhACAANAA3ACAAQgBhAHIAYwBlAGwAbwBuAGEAIAAwADgAMAAx +ADcwDQYJKoZIhvcNAQEFBQADggIBABd9oPm03cXF661LJLWhAqvdpYhKsg9VSytXjDvlMd3+xDLx +51tkljYyGOylMnfX40S2wBEqgLk9am58m9Ot/MPWo+ZkKXzR4Tgegiv/J2Wv+xYVxC5xhOW1//qk +R71kMrv2JYSiJ0L1ILDCExARzRAVukKQKtJE4ZYm6zFIEv0q2skGz3QeqUvVhyj5eTSSPi5E6PaP +T481PyWzOdxjKpBrIF/EUhJOlywqrJ2X3kjyo2bbwtKDlaZmp54lD+kLM5FlClrD2VQS3a/DTg4f +Jl4N3LON7NWBcN7STyQF82xO9UxJZo3R/9ILJUFI/lGExkKvgATP0H5kSeTy36LssUzAKh3ntLFl +osS88Zj0qnAHY7S42jtM+kAiMFsRpvAFDsYCA0irhpuF3dvd6qJ2gHN99ZwExEWN57kci57q13XR +crHedUTnQn3iV2t93Jm8PYMo6oCTjcVMZcFwgbg4/EMxsvYDNEeyrPsiBsse3RdHHF9mudMaotoR +saS8I8nkvof/uZS2+F0gStRf571oe2XyFR7SOqkt6dhrJKyXWERHrVkY8SFlcN7ONGCoQPHzPKTD +KCOM/iczQ0CgFzzr6juwcqajuUpLXhZI9LK8yIySxZ2frHI2vDSANGupi5LAuBft7HZT9SQBjLMi +6Et8Vcad+qMUu2WFbm5PEn4KPJ2V +-----END CERTIFICATE----- + +Izenpe.com +========== +-----BEGIN CERTIFICATE----- +MIIF8TCCA9mgAwIBAgIQALC3WhZIX7/hy/WL1xnmfTANBgkqhkiG9w0BAQsFADA4MQswCQYDVQQG +EwJFUzEUMBIGA1UECgwLSVpFTlBFIFMuQS4xEzARBgNVBAMMCkl6ZW5wZS5jb20wHhcNMDcxMjEz +MTMwODI4WhcNMzcxMjEzMDgyNzI1WjA4MQswCQYDVQQGEwJFUzEUMBIGA1UECgwLSVpFTlBFIFMu +QS4xEzARBgNVBAMMCkl6ZW5wZS5jb20wggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQDJ +03rKDx6sp4boFmVqscIbRTJxldn+EFvMr+eleQGPicPK8lVx93e+d5TzcqQsRNiekpsUOqHnJJAK +ClaOxdgmlOHZSOEtPtoKct2jmRXagaKH9HtuJneJWK3W6wyyQXpzbm3benhB6QiIEn6HLmYRY2xU ++zydcsC8Lv/Ct90NduM61/e0aL6i9eOBbsFGb12N4E3GVFWJGjMxCrFXuaOKmMPsOzTFlUFpfnXC +PCDFYbpRR6AgkJOhkEvzTnyFRVSa0QUmQbC1TR0zvsQDyCV8wXDbO/QJLVQnSKwv4cSsPsjLkkxT +OTcj7NMB+eAJRE1NZMDhDVqHIrytG6P+JrUV86f8hBnp7KGItERphIPzidF0BqnMC9bC3ieFUCbK +F7jJeodWLBoBHmy+E60QrLUk9TiRodZL2vG70t5HtfG8gfZZa88ZU+mNFctKy6lvROUbQc/hhqfK +0GqfvEyNBjNaooXlkDWgYlwWTvDjovoDGrQscbNYLN57C9saD+veIR8GdwYDsMnvmfzAuU8Lhij+ +0rnq49qlw0dpEuDb8PYZi+17cNcC1u2HGCgsBCRMd+RIihrGO5rUD8r6ddIBQFqNeb+Lz0vPqhbB +leStTIo+F5HUsWLlguWABKQDfo2/2n+iD5dPDNMN+9fR5XJ+HMh3/1uaD7euBUbl8agW7EekFwID +AQABo4H2MIHzMIGwBgNVHREEgagwgaWBD2luZm9AaXplbnBlLmNvbaSBkTCBjjFHMEUGA1UECgw+ +SVpFTlBFIFMuQS4gLSBDSUYgQTAxMzM3MjYwLVJNZXJjLlZpdG9yaWEtR2FzdGVpeiBUMTA1NSBG +NjIgUzgxQzBBBgNVBAkMOkF2ZGEgZGVsIE1lZGl0ZXJyYW5lbyBFdG9yYmlkZWEgMTQgLSAwMTAx +MCBWaXRvcmlhLUdhc3RlaXowDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0O +BBYEFB0cZQ6o8iV7tJHP5LGx5r1VdGwFMA0GCSqGSIb3DQEBCwUAA4ICAQB4pgwWSp9MiDrAyw6l +Fn2fuUhfGI8NYjb2zRlrrKvV9pF9rnHzP7MOeIWblaQnIUdCSnxIOvVFfLMMjlF4rJUT3sb9fbga +kEyrkgPH7UIBzg/YsfqikuFgba56awmqxinuaElnMIAkejEWOVt+8Rwu3WwJrfIxwYJOubv5vr8q +hT/AQKM6WfxZSzwoJNu0FXWuDYi6LnPAvViH5ULy617uHjAimcs30cQhbIHsvm0m5hzkQiCeR7Cs +g1lwLDXWrzY0tM07+DKo7+N4ifuNRSzanLh+QBxh5z6ikixL8s36mLYp//Pye6kfLqCTVyvehQP5 +aTfLnnhqBbTFMXiJ7HqnheG5ezzevh55hM6fcA5ZwjUukCox2eRFekGkLhObNA5me0mrZJfQRsN5 +nXJQY6aYWwa9SG3YOYNw6DXwBdGqvOPbyALqfP2C2sJbUjWumDqtujWTI6cfSN01RpiyEGjkpTHC +ClguGYEQyVB1/OpaFs4R1+7vUIgtYf8/QnMFlEPVjjxOAToZpR9GTnfQXeWBIiGH/pR9hNiTrdZo +Q0iy2+tzJOeRf1SktoA+naM8THLCV8Sg1Mw4J87VBp6iSNnpn86CcDaTmjvfliHjWbcM2pE38P1Z +WrOZyGlsQyYBNWNgVYkDOnXYukrZVP/u3oDYLdE41V4tC5h9Pmzb/CaIxw== +-----END CERTIFICATE----- + +Chambers of Commerce Root - 2008 +================================ +-----BEGIN CERTIFICATE----- +MIIHTzCCBTegAwIBAgIJAKPaQn6ksa7aMA0GCSqGSIb3DQEBBQUAMIGuMQswCQYDVQQGEwJFVTFD +MEEGA1UEBxM6TWFkcmlkIChzZWUgY3VycmVudCBhZGRyZXNzIGF0IHd3dy5jYW1lcmZpcm1hLmNv +bS9hZGRyZXNzKTESMBAGA1UEBRMJQTgyNzQzMjg3MRswGQYDVQQKExJBQyBDYW1lcmZpcm1hIFMu +QS4xKTAnBgNVBAMTIENoYW1iZXJzIG9mIENvbW1lcmNlIFJvb3QgLSAyMDA4MB4XDTA4MDgwMTEy +Mjk1MFoXDTM4MDczMTEyMjk1MFowga4xCzAJBgNVBAYTAkVVMUMwQQYDVQQHEzpNYWRyaWQgKHNl +ZSBjdXJyZW50IGFkZHJlc3MgYXQgd3d3LmNhbWVyZmlybWEuY29tL2FkZHJlc3MpMRIwEAYDVQQF +EwlBODI3NDMyODcxGzAZBgNVBAoTEkFDIENhbWVyZmlybWEgUy5BLjEpMCcGA1UEAxMgQ2hhbWJl +cnMgb2YgQ29tbWVyY2UgUm9vdCAtIDIwMDgwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoIC +AQCvAMtwNyuAWko6bHiUfaN/Gh/2NdW928sNRHI+JrKQUrpjOyhYb6WzbZSm891kDFX29ufyIiKA +XuFixrYp4YFs8r/lfTJqVKAyGVn+H4vXPWCGhSRv4xGzdz4gljUha7MI2XAuZPeEklPWDrCQiorj +h40G072QDuKZoRuGDtqaCrsLYVAGUvGef3bsyw/QHg3PmTA9HMRFEFis1tPo1+XqxQEHd9ZR5gN/ +ikilTWh1uem8nk4ZcfUyS5xtYBkL+8ydddy/Js2Pk3g5eXNeJQ7KXOt3EgfLZEFHcpOrUMPrCXZk +NNI5t3YRCQ12RcSprj1qr7V9ZS+UWBDsXHyvfuK2GNnQm05aSd+pZgvMPMZ4fKecHePOjlO+Bd5g +D2vlGts/4+EhySnB8esHnFIbAURRPHsl18TlUlRdJQfKFiC4reRB7noI/plvg6aRArBsNlVq5331 +lubKgdaX8ZSD6e2wsWsSaR6s+12pxZjptFtYer49okQ6Y1nUCyXeG0+95QGezdIp1Z8XGQpvvwyQ +0wlf2eOKNcx5Wk0ZN5K3xMGtr/R5JJqyAQuxr1yW84Ay+1w9mPGgP0revq+ULtlVmhduYJ1jbLhj +ya6BXBg14JC7vjxPNyK5fuvPnnchpj04gftI2jE9K+OJ9dC1vX7gUMQSibMjmhAxhduub+84Mxh2 +EQIDAQABo4IBbDCCAWgwEgYDVR0TAQH/BAgwBgEB/wIBDDAdBgNVHQ4EFgQU+SSsD7K1+HnA+mCI +G8TZTQKeFxkwgeMGA1UdIwSB2zCB2IAU+SSsD7K1+HnA+mCIG8TZTQKeFxmhgbSkgbEwga4xCzAJ +BgNVBAYTAkVVMUMwQQYDVQQHEzpNYWRyaWQgKHNlZSBjdXJyZW50IGFkZHJlc3MgYXQgd3d3LmNh +bWVyZmlybWEuY29tL2FkZHJlc3MpMRIwEAYDVQQFEwlBODI3NDMyODcxGzAZBgNVBAoTEkFDIENh +bWVyZmlybWEgUy5BLjEpMCcGA1UEAxMgQ2hhbWJlcnMgb2YgQ29tbWVyY2UgUm9vdCAtIDIwMDiC +CQCj2kJ+pLGu2jAOBgNVHQ8BAf8EBAMCAQYwPQYDVR0gBDYwNDAyBgRVHSAAMCowKAYIKwYBBQUH +AgEWHGh0dHA6Ly9wb2xpY3kuY2FtZXJmaXJtYS5jb20wDQYJKoZIhvcNAQEFBQADggIBAJASryI1 +wqM58C7e6bXpeHxIvj99RZJe6dqxGfwWPJ+0W2aeaufDuV2I6A+tzyMP3iU6XsxPpcG1Lawk0lgH +3qLPaYRgM+gQDROpI9CF5Y57pp49chNyM/WqfcZjHwj0/gF/JM8rLFQJ3uIrbZLGOU8W6jx+ekbU +RWpGqOt1glanq6B8aBMz9p0w8G8nOSQjKpD9kCk18pPfNKXG9/jvjA9iSnyu0/VU+I22mlaHFoI6 +M6taIgj3grrqLuBHmrS1RaMFO9ncLkVAO+rcf+g769HsJtg1pDDFOqxXnrN2pSB7+R5KBWIBpih1 +YJeSDW4+TTdDDZIVnBgizVGZoCkaPF+KMjNbMMeJL0eYD6MDxvbxrN8y8NmBGuScvfaAFPDRLLmF +9dijscilIeUcE5fuDr3fKanvNFNb0+RqE4QGtjICxFKuItLcsiFCGtpA8CnJ7AoMXOLQusxI0zcK +zBIKinmwPQN/aUv0NCB9szTqjktk9T79syNnFQ0EuPAtwQlRPLJsFfClI9eDdOTlLsn+mCdCxqvG +nrDQWzilm1DefhiYtUU79nm06PcaewaD+9CL2rvHvRirCG88gGtAPxkZumWK5r7VXNM21+9AUiRg +OGcEMeyP84LG3rlV8zsxkVrctQgVrXYlCg17LofiDKYGvCYQbTed7N14jHyAxfDZd0jQ +-----END CERTIFICATE----- + +Global Chambersign Root - 2008 +============================== +-----BEGIN CERTIFICATE----- +MIIHSTCCBTGgAwIBAgIJAMnN0+nVfSPOMA0GCSqGSIb3DQEBBQUAMIGsMQswCQYDVQQGEwJFVTFD +MEEGA1UEBxM6TWFkcmlkIChzZWUgY3VycmVudCBhZGRyZXNzIGF0IHd3dy5jYW1lcmZpcm1hLmNv +bS9hZGRyZXNzKTESMBAGA1UEBRMJQTgyNzQzMjg3MRswGQYDVQQKExJBQyBDYW1lcmZpcm1hIFMu +QS4xJzAlBgNVBAMTHkdsb2JhbCBDaGFtYmVyc2lnbiBSb290IC0gMjAwODAeFw0wODA4MDExMjMx +NDBaFw0zODA3MzExMjMxNDBaMIGsMQswCQYDVQQGEwJFVTFDMEEGA1UEBxM6TWFkcmlkIChzZWUg +Y3VycmVudCBhZGRyZXNzIGF0IHd3dy5jYW1lcmZpcm1hLmNvbS9hZGRyZXNzKTESMBAGA1UEBRMJ +QTgyNzQzMjg3MRswGQYDVQQKExJBQyBDYW1lcmZpcm1hIFMuQS4xJzAlBgNVBAMTHkdsb2JhbCBD +aGFtYmVyc2lnbiBSb290IC0gMjAwODCCAiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBAMDf +VtPkOpt2RbQT2//BthmLN0EYlVJH6xedKYiONWwGMi5HYvNJBL99RDaxccy9Wglz1dmFRP+RVyXf +XjaOcNFccUMd2drvXNL7G706tcuto8xEpw2uIRU/uXpbknXYpBI4iRmKt4DS4jJvVpyR1ogQC7N0 +ZJJ0YPP2zxhPYLIj0Mc7zmFLmY/CDNBAspjcDahOo7kKrmCgrUVSY7pmvWjg+b4aqIG7HkF4ddPB +/gBVsIdU6CeQNR1MM62X/JcumIS/LMmjv9GYERTtY/jKmIhYF5ntRQOXfjyGHoiMvvKRhI9lNNgA +TH23MRdaKXoKGCQwoze1eqkBfSbW+Q6OWfH9GzO1KTsXO0G2Id3UwD2ln58fQ1DJu7xsepeY7s2M +H/ucUa6LcL0nn3HAa6x9kGbo1106DbDVwo3VyJ2dwW3Q0L9R5OP4wzg2rtandeavhENdk5IMagfe +Ox2YItaswTXbo6Al/3K1dh3ebeksZixShNBFks4c5eUzHdwHU1SjqoI7mjcv3N2gZOnm3b2u/GSF +HTynyQbehP9r6GsaPMWis0L7iwk+XwhSx2LE1AVxv8Rk5Pihg+g+EpuoHtQ2TS9x9o0o9oOpE9Jh +wZG7SMA0j0GMS0zbaRL/UJScIINZc+18ofLx/d33SdNDWKBWY8o9PeU1VlnpDsogzCtLkykPAgMB +AAGjggFqMIIBZjASBgNVHRMBAf8ECDAGAQH/AgEMMB0GA1UdDgQWBBS5CcqcHtvTbDprru1U8VuT +BjUuXjCB4QYDVR0jBIHZMIHWgBS5CcqcHtvTbDprru1U8VuTBjUuXqGBsqSBrzCBrDELMAkGA1UE +BhMCRVUxQzBBBgNVBAcTOk1hZHJpZCAoc2VlIGN1cnJlbnQgYWRkcmVzcyBhdCB3d3cuY2FtZXJm +aXJtYS5jb20vYWRkcmVzcykxEjAQBgNVBAUTCUE4Mjc0MzI4NzEbMBkGA1UEChMSQUMgQ2FtZXJm +aXJtYSBTLkEuMScwJQYDVQQDEx5HbG9iYWwgQ2hhbWJlcnNpZ24gUm9vdCAtIDIwMDiCCQDJzdPp +1X0jzjAOBgNVHQ8BAf8EBAMCAQYwPQYDVR0gBDYwNDAyBgRVHSAAMCowKAYIKwYBBQUHAgEWHGh0 +dHA6Ly9wb2xpY3kuY2FtZXJmaXJtYS5jb20wDQYJKoZIhvcNAQEFBQADggIBAICIf3DekijZBZRG +/5BXqfEv3xoNa/p8DhxJJHkn2EaqbylZUohwEurdPfWbU1Rv4WCiqAm57OtZfMY18dwY6fFn5a+6 +ReAJ3spED8IXDneRRXozX1+WLGiLwUePmJs9wOzL9dWCkoQ10b42OFZyMVtHLaoXpGNR6woBrX/s +dZ7LoR/xfxKxueRkf2fWIyr0uDldmOghp+G9PUIadJpwr2hsUF1Jz//7Dl3mLEfXgTpZALVza2Mg +9jFFCDkO9HB+QHBaP9BrQql0PSgvAm11cpUJjUhjxsYjV5KTXjXBjfkK9yydYhz2rXzdpjEetrHH +foUm+qRqtdpjMNHvkzeyZi99Bffnt0uYlDXA2TopwZ2yUDMdSqlapskD7+3056huirRXhOukP9Du +qqqHW2Pok+JrqNS4cnhrG+055F3Lm6qH1U9OAP7Zap88MQ8oAgF9mOinsKJknnn4SPIVqczmyETr +P3iZ8ntxPjzxmKfFGBI/5rsoM0LpRQp8bfKGeS/Fghl9CYl8slR2iK7ewfPM4W7bMdaTrpmg7yVq +c5iJWzouE4gev8CSlDQb4ye3ix5vQv/n6TebUB0tovkC7stYWDpxvGjjqsGvHCgfotwjZT+B6q6Z +09gwzxMNTxXJhLynSC34MCN32EZLeW32jO06f2ARePTpm67VVMB0gNELQp/B +-----END CERTIFICATE----- + +Go Daddy Root Certificate Authority - G2 +======================================== +-----BEGIN CERTIFICATE----- +MIIDxTCCAq2gAwIBAgIBADANBgkqhkiG9w0BAQsFADCBgzELMAkGA1UEBhMCVVMxEDAOBgNVBAgT +B0FyaXpvbmExEzARBgNVBAcTClNjb3R0c2RhbGUxGjAYBgNVBAoTEUdvRGFkZHkuY29tLCBJbmMu +MTEwLwYDVQQDEyhHbyBEYWRkeSBSb290IENlcnRpZmljYXRlIEF1dGhvcml0eSAtIEcyMB4XDTA5 +MDkwMTAwMDAwMFoXDTM3MTIzMTIzNTk1OVowgYMxCzAJBgNVBAYTAlVTMRAwDgYDVQQIEwdBcml6 +b25hMRMwEQYDVQQHEwpTY290dHNkYWxlMRowGAYDVQQKExFHb0RhZGR5LmNvbSwgSW5jLjExMC8G +A1UEAxMoR28gRGFkZHkgUm9vdCBDZXJ0aWZpY2F0ZSBBdXRob3JpdHkgLSBHMjCCASIwDQYJKoZI +hvcNAQEBBQADggEPADCCAQoCggEBAL9xYgjx+lk09xvJGKP3gElY6SKDE6bFIEMBO4Tx5oVJnyfq +9oQbTqC023CYxzIBsQU+B07u9PpPL1kwIuerGVZr4oAH/PMWdYA5UXvl+TW2dE6pjYIT5LY/qQOD ++qK+ihVqf94Lw7YZFAXK6sOoBJQ7RnwyDfMAZiLIjWltNowRGLfTshxgtDj6AozO091GB94KPutd +fMh8+7ArU6SSYmlRJQVhGkSBjCypQ5Yj36w6gZoOKcUcqeldHraenjAKOc7xiID7S13MMuyFYkMl +NAJWJwGRtDtwKj9useiciAF9n9T521NtYJ2/LOdYq7hfRvzOxBsDPAnrSTFcaUaz4EcCAwEAAaNC +MEAwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0OBBYEFDqahQcQZyi27/a9 +BUFuIMGU2g/eMA0GCSqGSIb3DQEBCwUAA4IBAQCZ21151fmXWWcDYfF+OwYxdS2hII5PZYe096ac +vNjpL9DbWu7PdIxztDhC2gV7+AJ1uP2lsdeu9tfeE8tTEH6KRtGX+rcuKxGrkLAngPnon1rpN5+r +5N9ss4UXnT3ZJE95kTXWXwTrgIOrmgIttRD02JDHBHNA7XIloKmf7J6raBKZV8aPEjoJpL1E/QYV +N8Gb5DKj7Tjo2GTzLH4U/ALqn83/B2gX2yKQOC16jdFU8WnjXzPKej17CuPKf1855eJ1usV2GDPO +LPAvTK33sefOT6jEm0pUBsV/fdUID+Ic/n4XuKxe9tQWskMJDE32p2u0mYRlynqI4uJEvlz36hz1 +-----END CERTIFICATE----- + +Starfield Root Certificate Authority - G2 +========================================= +-----BEGIN CERTIFICATE----- +MIID3TCCAsWgAwIBAgIBADANBgkqhkiG9w0BAQsFADCBjzELMAkGA1UEBhMCVVMxEDAOBgNVBAgT +B0FyaXpvbmExEzARBgNVBAcTClNjb3R0c2RhbGUxJTAjBgNVBAoTHFN0YXJmaWVsZCBUZWNobm9s +b2dpZXMsIEluYy4xMjAwBgNVBAMTKVN0YXJmaWVsZCBSb290IENlcnRpZmljYXRlIEF1dGhvcml0 +eSAtIEcyMB4XDTA5MDkwMTAwMDAwMFoXDTM3MTIzMTIzNTk1OVowgY8xCzAJBgNVBAYTAlVTMRAw +DgYDVQQIEwdBcml6b25hMRMwEQYDVQQHEwpTY290dHNkYWxlMSUwIwYDVQQKExxTdGFyZmllbGQg +VGVjaG5vbG9naWVzLCBJbmMuMTIwMAYDVQQDEylTdGFyZmllbGQgUm9vdCBDZXJ0aWZpY2F0ZSBB +dXRob3JpdHkgLSBHMjCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAL3twQP89o/8ArFv +W59I2Z154qK3A2FWGMNHttfKPTUuiUP3oWmb3ooa/RMgnLRJdzIpVv257IzdIvpy3Cdhl+72WoTs +bhm5iSzchFvVdPtrX8WJpRBSiUZV9Lh1HOZ/5FSuS/hVclcCGfgXcVnrHigHdMWdSL5stPSksPNk +N3mSwOxGXn/hbVNMYq/NHwtjuzqd+/x5AJhhdM8mgkBj87JyahkNmcrUDnXMN/uLicFZ8WJ/X7Nf +ZTD4p7dNdloedl40wOiWVpmKs/B/pM293DIxfJHP4F8R+GuqSVzRmZTRouNjWwl2tVZi4Ut0HZbU +JtQIBFnQmA4O5t78w+wfkPECAwEAAaNCMEAwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMC +AQYwHQYDVR0OBBYEFHwMMh+n2TB/xH1oo2Kooc6rB1snMA0GCSqGSIb3DQEBCwUAA4IBAQARWfol +TwNvlJk7mh+ChTnUdgWUXuEok21iXQnCoKjUsHU48TRqneSfioYmUeYs0cYtbpUgSpIB7LiKZ3sx +4mcujJUDJi5DnUox9g61DLu34jd/IroAow57UvtruzvE03lRTs2Q9GcHGcg8RnoNAX3FWOdt5oUw +F5okxBDgBPfg8n/Uqgr/Qh037ZTlZFkSIHc40zI+OIF1lnP6aI+xy84fxez6nH7PfrHxBy22/L/K +pL/QlwVKvOoYKAKQvVR4CSFx09F9HdkWsKlhPdAKACL8x3vLCWRFCztAgfd9fDL1mMpYjn0q7pBZ +c2T5NnReJaH1ZgUufzkVqSr7UIuOhWn0 +-----END CERTIFICATE----- + +Starfield Services Root Certificate Authority - G2 +================================================== +-----BEGIN CERTIFICATE----- +MIID7zCCAtegAwIBAgIBADANBgkqhkiG9w0BAQsFADCBmDELMAkGA1UEBhMCVVMxEDAOBgNVBAgT +B0FyaXpvbmExEzARBgNVBAcTClNjb3R0c2RhbGUxJTAjBgNVBAoTHFN0YXJmaWVsZCBUZWNobm9s +b2dpZXMsIEluYy4xOzA5BgNVBAMTMlN0YXJmaWVsZCBTZXJ2aWNlcyBSb290IENlcnRpZmljYXRl +IEF1dGhvcml0eSAtIEcyMB4XDTA5MDkwMTAwMDAwMFoXDTM3MTIzMTIzNTk1OVowgZgxCzAJBgNV +BAYTAlVTMRAwDgYDVQQIEwdBcml6b25hMRMwEQYDVQQHEwpTY290dHNkYWxlMSUwIwYDVQQKExxT +dGFyZmllbGQgVGVjaG5vbG9naWVzLCBJbmMuMTswOQYDVQQDEzJTdGFyZmllbGQgU2VydmljZXMg +Um9vdCBDZXJ0aWZpY2F0ZSBBdXRob3JpdHkgLSBHMjCCASIwDQYJKoZIhvcNAQEBBQADggEPADCC +AQoCggEBANUMOsQq+U7i9b4Zl1+OiFOxHz/Lz58gE20pOsgPfTz3a3Y4Y9k2YKibXlwAgLIvWX/2 +h/klQ4bnaRtSmpDhcePYLQ1Ob/bISdm28xpWriu2dBTrz/sm4xq6HZYuajtYlIlHVv8loJNwU4Pa +hHQUw2eeBGg6345AWh1KTs9DkTvnVtYAcMtS7nt9rjrnvDH5RfbCYM8TWQIrgMw0R9+53pBlbQLP +LJGmpufehRhJfGZOozptqbXuNC66DQO4M99H67FrjSXZm86B0UVGMpZwh94CDklDhbZsc7tk6mFB +rMnUVN+HL8cisibMn1lUaJ/8viovxFUcdUBgF4UCVTmLfwUCAwEAAaNCMEAwDwYDVR0TAQH/BAUw +AwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0OBBYEFJxfAN+qAdcwKziIorhtSpzyEZGDMA0GCSqG +SIb3DQEBCwUAA4IBAQBLNqaEd2ndOxmfZyMIbw5hyf2E3F/YNoHN2BtBLZ9g3ccaaNnRbobhiCPP +E95Dz+I0swSdHynVv/heyNXBve6SbzJ08pGCL72CQnqtKrcgfU28elUSwhXqvfdqlS5sdJ/PHLTy +xQGjhdByPq1zqwubdQxtRbeOlKyWN7Wg0I8VRw7j6IPdj/3vQQF3zCepYoUz8jcI73HPdwbeyBkd +iEDPfUYd/x7H4c7/I9vG+o1VTqkC50cRRj70/b17KSa7qWFiNyi2LSr2EIZkyXCn0q23KXB56jza +YyWf/Wi3MOxw+3WKt21gZ7IeyLnp2KhvAotnDU0mV3HaIPzBSlCNsSi6 +-----END CERTIFICATE----- + +AffirmTrust Commercial +====================== +-----BEGIN CERTIFICATE----- +MIIDTDCCAjSgAwIBAgIId3cGJyapsXwwDQYJKoZIhvcNAQELBQAwRDELMAkGA1UEBhMCVVMxFDAS +BgNVBAoMC0FmZmlybVRydXN0MR8wHQYDVQQDDBZBZmZpcm1UcnVzdCBDb21tZXJjaWFsMB4XDTEw +MDEyOTE0MDYwNloXDTMwMTIzMTE0MDYwNlowRDELMAkGA1UEBhMCVVMxFDASBgNVBAoMC0FmZmly +bVRydXN0MR8wHQYDVQQDDBZBZmZpcm1UcnVzdCBDb21tZXJjaWFsMIIBIjANBgkqhkiG9w0BAQEF +AAOCAQ8AMIIBCgKCAQEA9htPZwcroRX1BiLLHwGy43NFBkRJLLtJJRTWzsO3qyxPxkEylFf6Eqdb +DuKPHx6GGaeqtS25Xw2Kwq+FNXkyLbscYjfysVtKPcrNcV/pQr6U6Mje+SJIZMblq8Yrba0F8PrV +C8+a5fBQpIs7R6UjW3p6+DM/uO+Zl+MgwdYoic+U+7lF7eNAFxHUdPALMeIrJmqbTFeurCA+ukV6 +BfO9m2kVrn1OIGPENXY6BwLJN/3HR+7o8XYdcxXyl6S1yHp52UKqK39c/s4mT6NmgTWvRLpUHhww +MmWd5jyTXlBOeuM61G7MGvv50jeuJCqrVwMiKA1JdX+3KNp1v47j3A55MQIDAQABo0IwQDAdBgNV +HQ4EFgQUnZPGU4teyq8/nx4P5ZmVvCT2lI8wDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMC +AQYwDQYJKoZIhvcNAQELBQADggEBAFis9AQOzcAN/wr91LoWXym9e2iZWEnStB03TX8nfUYGXUPG +hi4+c7ImfU+TqbbEKpqrIZcUsd6M06uJFdhrJNTxFq7YpFzUf1GO7RgBsZNjvbz4YYCanrHOQnDi +qX0GJX0nof5v7LMeJNrjS1UaADs1tDvZ110w/YETifLCBivtZ8SOyUOyXGsViQK8YvxO8rUzqrJv +0wqiUOP2O+guRMLbZjipM1ZI8W0bM40NjD9gN53Tym1+NH4Nn3J2ixufcv1SNUFFApYvHLKac0kh +sUlHRUe072o0EclNmsxZt9YCnlpOZbWUrhvfKbAW8b8Angc6F2S1BLUjIZkKlTuXfO8= +-----END CERTIFICATE----- + +AffirmTrust Networking +====================== +-----BEGIN CERTIFICATE----- +MIIDTDCCAjSgAwIBAgIIfE8EORzUmS0wDQYJKoZIhvcNAQEFBQAwRDELMAkGA1UEBhMCVVMxFDAS +BgNVBAoMC0FmZmlybVRydXN0MR8wHQYDVQQDDBZBZmZpcm1UcnVzdCBOZXR3b3JraW5nMB4XDTEw +MDEyOTE0MDgyNFoXDTMwMTIzMTE0MDgyNFowRDELMAkGA1UEBhMCVVMxFDASBgNVBAoMC0FmZmly +bVRydXN0MR8wHQYDVQQDDBZBZmZpcm1UcnVzdCBOZXR3b3JraW5nMIIBIjANBgkqhkiG9w0BAQEF +AAOCAQ8AMIIBCgKCAQEAtITMMxcua5Rsa2FSoOujz3mUTOWUgJnLVWREZY9nZOIG41w3SfYvm4SE +Hi3yYJ0wTsyEheIszx6e/jarM3c1RNg1lho9Nuh6DtjVR6FqaYvZ/Ls6rnla1fTWcbuakCNrmreI +dIcMHl+5ni36q1Mr3Lt2PpNMCAiMHqIjHNRqrSK6mQEubWXLviRmVSRLQESxG9fhwoXA3hA/Pe24 +/PHxI1Pcv2WXb9n5QHGNfb2V1M6+oF4nI979ptAmDgAp6zxG8D1gvz9Q0twmQVGeFDdCBKNwV6gb +h+0t+nvujArjqWaJGctB+d1ENmHP4ndGyH329JKBNv3bNPFyfvMMFr20FQIDAQABo0IwQDAdBgNV +HQ4EFgQUBx/S55zawm6iQLSwelAQUHTEyL0wDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMC +AQYwDQYJKoZIhvcNAQEFBQADggEBAIlXshZ6qML91tmbmzTCnLQyFE2npN/svqe++EPbkTfOtDIu +UFUaNU52Q3Eg75N3ThVwLofDwR1t3Mu1J9QsVtFSUzpE0nPIxBsFZVpikpzuQY0x2+c06lkh1QF6 +12S4ZDnNye2v7UsDSKegmQGA3GWjNq5lWUhPgkvIZfFXHeVZLgo/bNjR9eUJtGxUAArgFU2HdW23 +WJZa3W3SAKD0m0i+wzekujbgfIeFlxoVot4uolu9rxj5kFDNcFn4J2dHy8egBzp90SxdbBk6ZrV9 +/ZFvgrG+CJPbFEfxojfHRZ48x3evZKiT3/Zpg4Jg8klCNO1aAFSFHBY2kgxc+qatv9s= +-----END CERTIFICATE----- + +AffirmTrust Premium +=================== +-----BEGIN CERTIFICATE----- +MIIFRjCCAy6gAwIBAgIIbYwURrGmCu4wDQYJKoZIhvcNAQEMBQAwQTELMAkGA1UEBhMCVVMxFDAS +BgNVBAoMC0FmZmlybVRydXN0MRwwGgYDVQQDDBNBZmZpcm1UcnVzdCBQcmVtaXVtMB4XDTEwMDEy +OTE0MTAzNloXDTQwMTIzMTE0MTAzNlowQTELMAkGA1UEBhMCVVMxFDASBgNVBAoMC0FmZmlybVRy +dXN0MRwwGgYDVQQDDBNBZmZpcm1UcnVzdCBQcmVtaXVtMIICIjANBgkqhkiG9w0BAQEFAAOCAg8A +MIICCgKCAgEAxBLfqV/+Qd3d9Z+K4/as4Tx4mrzY8H96oDMq3I0gW64tb+eT2TZwamjPjlGjhVtn +BKAQJG9dKILBl1fYSCkTtuG+kU3fhQxTGJoeJKJPj/CihQvL9Cl/0qRY7iZNyaqoe5rZ+jjeRFcV +5fiMyNlI4g0WJx0eyIOFJbe6qlVBzAMiSy2RjYvmia9mx+n/K+k8rNrSs8PhaJyJ+HoAVt70VZVs ++7pk3WKL3wt3MutizCaam7uqYoNMtAZ6MMgpv+0GTZe5HMQxK9VfvFMSF5yZVylmd2EhMQcuJUmd +GPLu8ytxjLW6OQdJd/zvLpKQBY0tL3d770O/Nbua2Plzpyzy0FfuKE4mX4+QaAkvuPjcBukumj5R +p9EixAqnOEhss/n/fauGV+O61oV4d7pD6kh/9ti+I20ev9E2bFhc8e6kGVQa9QPSdubhjL08s9NI +S+LI+H+SqHZGnEJlPqQewQcDWkYtuJfzt9WyVSHvutxMAJf7FJUnM7/oQ0dG0giZFmA7mn7S5u04 +6uwBHjxIVkkJx0w3AJ6IDsBz4W9m6XJHMD4Q5QsDyZpCAGzFlH5hxIrff4IaC1nEWTJ3s7xgaVY5 +/bQGeyzWZDbZvUjthB9+pSKPKrhC9IK31FOQeE4tGv2Bb0TXOwF0lkLgAOIua+rF7nKsu7/+6qqo ++Nz2snmKtmcCAwEAAaNCMEAwHQYDVR0OBBYEFJ3AZ6YMItkm9UWrpmVSESfYRaxjMA8GA1UdEwEB +/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMA0GCSqGSIb3DQEBDAUAA4ICAQCzV00QYk465KzquByv +MiPIs0laUZx2KI15qldGF9X1Uva3ROgIRL8YhNILgM3FEv0AVQVhh0HctSSePMTYyPtwni94loMg +Nt58D2kTiKV1NpgIpsbfrM7jWNa3Pt668+s0QNiigfV4Py/VpfzZotReBA4Xrf5B8OWycvpEgjNC +6C1Y91aMYj+6QrCcDFx+LmUmXFNPALJ4fqENmS2NuB2OosSw/WDQMKSOyARiqcTtNd56l+0OOF6S +L5Nwpamcb6d9Ex1+xghIsV5n61EIJenmJWtSKZGc0jlzCFfemQa0W50QBuHCAKi4HEoCChTQwUHK ++4w1IX2COPKpVJEZNZOUbWo6xbLQu4mGk+ibyQ86p3q4ofB4Rvr8Ny/lioTz3/4E2aFooC8k4gmV +BtWVyuEklut89pMFu+1z6S3RdTnX5yTb2E5fQ4+e0BQ5v1VwSJlXMbSc7kqYA5YwH2AG7hsj/oFg +IxpHYoWlzBk0gG+zrBrjn/B7SK3VAdlntqlyk+otZrWyuOQ9PLLvTIzq6we/qzWaVYa8GKa1qF60 +g2xraUDTn9zxw2lrueFtCfTxqlB2Cnp9ehehVZZCmTEJ3WARjQUwfuaORtGdFNrHF+QFlozEJLUb +zxQHskD4o55BhrwE0GuWyCqANP2/7waj3VjFhT0+j/6eKeC2uAloGRwYQw== +-----END CERTIFICATE----- + +AffirmTrust Premium ECC +======================= +-----BEGIN CERTIFICATE----- +MIIB/jCCAYWgAwIBAgIIdJclisc/elQwCgYIKoZIzj0EAwMwRTELMAkGA1UEBhMCVVMxFDASBgNV +BAoMC0FmZmlybVRydXN0MSAwHgYDVQQDDBdBZmZpcm1UcnVzdCBQcmVtaXVtIEVDQzAeFw0xMDAx +MjkxNDIwMjRaFw00MDEyMzExNDIwMjRaMEUxCzAJBgNVBAYTAlVTMRQwEgYDVQQKDAtBZmZpcm1U +cnVzdDEgMB4GA1UEAwwXQWZmaXJtVHJ1c3QgUHJlbWl1bSBFQ0MwdjAQBgcqhkjOPQIBBgUrgQQA +IgNiAAQNMF4bFZ0D0KF5Nbc6PJJ6yhUczWLznCZcBz3lVPqj1swS6vQUX+iOGasvLkjmrBhDeKzQ +N8O9ss0s5kfiGuZjuD0uL3jET9v0D6RoTFVya5UdThhClXjMNzyR4ptlKymjQjBAMB0GA1UdDgQW +BBSaryl6wBE1NSZRMADDav5A1a7WPDAPBgNVHRMBAf8EBTADAQH/MA4GA1UdDwEB/wQEAwIBBjAK +BggqhkjOPQQDAwNnADBkAjAXCfOHiFBar8jAQr9HX/VsaobgxCd05DhT1wV/GzTjxi+zygk8N53X +57hG8f2h4nECMEJZh0PUUd+60wkyWs6Iflc9nF9Ca/UHLbXwgpP5WW+uZPpY5Yse42O+tYHNbwKM +eQ== +-----END CERTIFICATE----- + +Certum Trusted Network CA +========================= +-----BEGIN CERTIFICATE----- +MIIDuzCCAqOgAwIBAgIDBETAMA0GCSqGSIb3DQEBBQUAMH4xCzAJBgNVBAYTAlBMMSIwIAYDVQQK +ExlVbml6ZXRvIFRlY2hub2xvZ2llcyBTLkEuMScwJQYDVQQLEx5DZXJ0dW0gQ2VydGlmaWNhdGlv +biBBdXRob3JpdHkxIjAgBgNVBAMTGUNlcnR1bSBUcnVzdGVkIE5ldHdvcmsgQ0EwHhcNMDgxMDIy +MTIwNzM3WhcNMjkxMjMxMTIwNzM3WjB+MQswCQYDVQQGEwJQTDEiMCAGA1UEChMZVW5pemV0byBU +ZWNobm9sb2dpZXMgUy5BLjEnMCUGA1UECxMeQ2VydHVtIENlcnRpZmljYXRpb24gQXV0aG9yaXR5 +MSIwIAYDVQQDExlDZXJ0dW0gVHJ1c3RlZCBOZXR3b3JrIENBMIIBIjANBgkqhkiG9w0BAQEFAAOC +AQ8AMIIBCgKCAQEA4/t9o3K6wvDJFIf1awFO4W5AB7ptJ11/91sts1rHUV+rpDKmYYe2bg+G0jAC +l/jXaVehGDldamR5xgFZrDwxSjh80gTSSyjoIF87B6LMTXPb865Px1bVWqeWifrzq2jUI4ZZJ88J +J7ysbnKDHDBy3+Ci6dLhdHUZvSqeexVUBBvXQzmtVSjF4hq79MDkrjhJM8x2hZ85RdKknvISjFH4 +fOQtf/WsX+sWn7Et0brMkUJ3TCXJkDhv2/DM+44el1k+1WBO5gUo7Ul5E0u6SNsv+XLTOcr+H9g0 +cvW0QM8xAcPs3hEtF10fuFDRXhmnad4HMyjKUJX5p1TLVIZQRan5SQIDAQABo0IwQDAPBgNVHRMB +Af8EBTADAQH/MB0GA1UdDgQWBBQIds3LB/8k9sXN7buQvOKEN0Z19zAOBgNVHQ8BAf8EBAMCAQYw +DQYJKoZIhvcNAQEFBQADggEBAKaorSLOAT2mo/9i0Eidi15ysHhE49wcrwn9I0j6vSrEuVUEtRCj +jSfeC4Jj0O7eDDd5QVsisrCaQVymcODU0HfLI9MA4GxWL+FpDQ3Zqr8hgVDZBqWo/5U30Kr+4rP1 +mS1FhIrlQgnXdAIv94nYmem8J9RHjboNRhx3zxSkHLmkMcScKHQDNP8zGSal6Q10tz6XxnboJ5aj +Zt3hrvJBW8qYVoNzcOSGGtIxQbovvi0TWnZvTuhOgQ4/WwMioBK+ZlgRSssDxLQqKi2WF+A5VLxI +03YnnZotBqbJ7DnSq9ufmgsnAjUpsUCV5/nonFWIGUbWtzT1fs45mtk48VH3Tyw= +-----END CERTIFICATE----- + +TWCA Root Certification Authority +================================= +-----BEGIN CERTIFICATE----- +MIIDezCCAmOgAwIBAgIBATANBgkqhkiG9w0BAQUFADBfMQswCQYDVQQGEwJUVzESMBAGA1UECgwJ +VEFJV0FOLUNBMRAwDgYDVQQLDAdSb290IENBMSowKAYDVQQDDCFUV0NBIFJvb3QgQ2VydGlmaWNh +dGlvbiBBdXRob3JpdHkwHhcNMDgwODI4MDcyNDMzWhcNMzAxMjMxMTU1OTU5WjBfMQswCQYDVQQG +EwJUVzESMBAGA1UECgwJVEFJV0FOLUNBMRAwDgYDVQQLDAdSb290IENBMSowKAYDVQQDDCFUV0NB +IFJvb3QgQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEK +AoIBAQCwfnK4pAOU5qfeCTiRShFAh6d8WWQUe7UREN3+v9XAu1bihSX0NXIP+FPQQeFEAcK0HMMx +QhZHhTMidrIKbw/lJVBPhYa+v5guEGcevhEFhgWQxFnQfHgQsIBct+HHK3XLfJ+utdGdIzdjp9xC +oi2SBBtQwXu4PhvJVgSLL1KbralW6cH/ralYhzC2gfeXRfwZVzsrb+RH9JlF/h3x+JejiB03HFyP +4HYlmlD4oFT/RJB2I9IyxsOrBr/8+7/zrX2SYgJbKdM1o5OaQ2RgXbL6Mv87BK9NQGr5x+PvI/1r +y+UPizgN7gr8/g+YnzAx3WxSZfmLgb4i4RxYA7qRG4kHAgMBAAGjQjBAMA4GA1UdDwEB/wQEAwIB +BjAPBgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBRqOFsmjd6LWvJPelSDGRjjCDWmujANBgkqhkiG +9w0BAQUFAAOCAQEAPNV3PdrfibqHDAhUaiBQkr6wQT25JmSDCi/oQMCXKCeCMErJk/9q56YAf4lC +mtYR5VPOL8zy2gXE/uJQxDqGfczafhAJO5I1KlOy/usrBdlsXebQ79NqZp4VKIV66IIArB6nCWlW +QtNoURi+VJq/REG6Sb4gumlc7rh3zc5sH62Dlhh9DrUUOYTxKOkto557HnpyWoOzeW/vtPzQCqVY +T0bf+215WfKEIlKuD8z7fDvnaspHYcN6+NOSBB+4IIThNlQWx0DeO4pz3N/GCUzf7Nr/1FNCocny +Yh0igzyXxfkZYiesZSLX0zzG5Y6yU8xJzrww/nsOM5D77dIUkR8Hrw== +-----END CERTIFICATE----- + +Security Communication RootCA2 +============================== +-----BEGIN CERTIFICATE----- +MIIDdzCCAl+gAwIBAgIBADANBgkqhkiG9w0BAQsFADBdMQswCQYDVQQGEwJKUDElMCMGA1UEChMc +U0VDT00gVHJ1c3QgU3lzdGVtcyBDTy4sTFRELjEnMCUGA1UECxMeU2VjdXJpdHkgQ29tbXVuaWNh +dGlvbiBSb290Q0EyMB4XDTA5MDUyOTA1MDAzOVoXDTI5MDUyOTA1MDAzOVowXTELMAkGA1UEBhMC +SlAxJTAjBgNVBAoTHFNFQ09NIFRydXN0IFN5c3RlbXMgQ08uLExURC4xJzAlBgNVBAsTHlNlY3Vy +aXR5IENvbW11bmljYXRpb24gUm9vdENBMjCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEB +ANAVOVKxUrO6xVmCxF1SrjpDZYBLx/KWvNs2l9amZIyoXvDjChz335c9S672XewhtUGrzbl+dp++ ++T42NKA7wfYxEUV0kz1XgMX5iZnK5atq1LXaQZAQwdbWQonCv/Q4EpVMVAX3NuRFg3sUZdbcDE3R +3n4MqzvEFb46VqZab3ZpUql6ucjrappdUtAtCms1FgkQhNBqyjoGADdH5H5XTz+L62e4iKrFvlNV +spHEfbmwhRkGeC7bYRr6hfVKkaHnFtWOojnflLhwHyg/i/xAXmODPIMqGplrz95Zajv8bxbXH/1K +EOtOghY6rCcMU/Gt1SSwawNQwS08Ft1ENCcadfsCAwEAAaNCMEAwHQYDVR0OBBYEFAqFqXdlBZh8 +QIH4D5csOPEK7DzPMA4GA1UdDwEB/wQEAwIBBjAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEB +CwUAA4IBAQBMOqNErLlFsceTfsgLCkLfZOoc7llsCLqJX2rKSpWeeo8HxdpFcoJxDjrSzG+ntKEj +u/Ykn8sX/oymzsLS28yN/HH8AynBbF0zX2S2ZTuJbxh2ePXcokgfGT+Ok+vx+hfuzU7jBBJV1uXk +3fs+BXziHV7Gp7yXT2g69ekuCkO2r1dcYmh8t/2jioSgrGK+KwmHNPBqAbubKVY8/gA3zyNs8U6q +tnRGEmyR7jTV7JqR50S+kDFy1UkC9gLl9B/rfNmWVan/7Ir5mUf/NVoCqgTLiluHcSmRvaS0eg29 +mvVXIwAHIRc/SjnRBUkLp7Y3gaVdjKozXoEofKd9J+sAro03 +-----END CERTIFICATE----- + +EC-ACC +====== +-----BEGIN CERTIFICATE----- +MIIFVjCCBD6gAwIBAgIQ7is969Qh3hSoYqwE893EATANBgkqhkiG9w0BAQUFADCB8zELMAkGA1UE +BhMCRVMxOzA5BgNVBAoTMkFnZW5jaWEgQ2F0YWxhbmEgZGUgQ2VydGlmaWNhY2lvIChOSUYgUS0w +ODAxMTc2LUkpMSgwJgYDVQQLEx9TZXJ2ZWlzIFB1YmxpY3MgZGUgQ2VydGlmaWNhY2lvMTUwMwYD +VQQLEyxWZWdldSBodHRwczovL3d3dy5jYXRjZXJ0Lm5ldC92ZXJhcnJlbCAoYykwMzE1MDMGA1UE +CxMsSmVyYXJxdWlhIEVudGl0YXRzIGRlIENlcnRpZmljYWNpbyBDYXRhbGFuZXMxDzANBgNVBAMT +BkVDLUFDQzAeFw0wMzAxMDcyMzAwMDBaFw0zMTAxMDcyMjU5NTlaMIHzMQswCQYDVQQGEwJFUzE7 +MDkGA1UEChMyQWdlbmNpYSBDYXRhbGFuYSBkZSBDZXJ0aWZpY2FjaW8gKE5JRiBRLTA4MDExNzYt +SSkxKDAmBgNVBAsTH1NlcnZlaXMgUHVibGljcyBkZSBDZXJ0aWZpY2FjaW8xNTAzBgNVBAsTLFZl +Z2V1IGh0dHBzOi8vd3d3LmNhdGNlcnQubmV0L3ZlcmFycmVsIChjKTAzMTUwMwYDVQQLEyxKZXJh +cnF1aWEgRW50aXRhdHMgZGUgQ2VydGlmaWNhY2lvIENhdGFsYW5lczEPMA0GA1UEAxMGRUMtQUND +MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAsyLHT+KXQpWIR4NA9h0X84NzJB5R85iK +w5K4/0CQBXCHYMkAqbWUZRkiFRfCQ2xmRJoNBD45b6VLeqpjt4pEndljkYRm4CgPukLjbo73FCeT +ae6RDqNfDrHrZqJyTxIThmV6PttPB/SnCWDaOkKZx7J/sxaVHMf5NLWUhdWZXqBIoH7nF2W4onW4 +HvPlQn2v7fOKSGRdghST2MDk/7NQcvJ29rNdQlB50JQ+awwAvthrDk4q7D7SzIKiGGUzE3eeml0a +E9jD2z3Il3rucO2n5nzbcc8tlGLfbdb1OL4/pYUKGbio2Al1QnDE6u/LDsg0qBIimAy4E5S2S+zw +0JDnJwIDAQABo4HjMIHgMB0GA1UdEQQWMBSBEmVjX2FjY0BjYXRjZXJ0Lm5ldDAPBgNVHRMBAf8E +BTADAQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQUoMOLRKo3pUW/l4Ba0fF4opvpXY0wfwYD +VR0gBHgwdjB0BgsrBgEEAfV4AQMBCjBlMCwGCCsGAQUFBwIBFiBodHRwczovL3d3dy5jYXRjZXJ0 +Lm5ldC92ZXJhcnJlbDA1BggrBgEFBQcCAjApGidWZWdldSBodHRwczovL3d3dy5jYXRjZXJ0Lm5l +dC92ZXJhcnJlbCAwDQYJKoZIhvcNAQEFBQADggEBAKBIW4IB9k1IuDlVNZyAelOZ1Vr/sXE7zDkJ +lF7W2u++AVtd0x7Y/X1PzaBB4DSTv8vihpw3kpBWHNzrKQXlxJ7HNd+KDM3FIUPpqojlNcAZQmNa +Al6kSBg6hW/cnbw/nZzBh7h6YQjpdwt/cKt63dmXLGQehb+8dJahw3oS7AwaboMMPOhyRp/7SNVe +l+axofjk70YllJyJ22k4vuxcDlbHZVHlUIiIv0LVKz3l+bqeLrPK9HOSAgu+TGbrIP65y7WZf+a2 +E/rKS03Z7lNGBjvGTq2TWoF+bCpLagVFjPIhpDGQh2xlnJ2lYJU6Un/10asIbvPuW/mIPX64b24D +5EI= +-----END CERTIFICATE----- + +Hellenic Academic and Research Institutions RootCA 2011 +======================================================= +-----BEGIN CERTIFICATE----- +MIIEMTCCAxmgAwIBAgIBADANBgkqhkiG9w0BAQUFADCBlTELMAkGA1UEBhMCR1IxRDBCBgNVBAoT +O0hlbGxlbmljIEFjYWRlbWljIGFuZCBSZXNlYXJjaCBJbnN0aXR1dGlvbnMgQ2VydC4gQXV0aG9y +aXR5MUAwPgYDVQQDEzdIZWxsZW5pYyBBY2FkZW1pYyBhbmQgUmVzZWFyY2ggSW5zdGl0dXRpb25z +IFJvb3RDQSAyMDExMB4XDTExMTIwNjEzNDk1MloXDTMxMTIwMTEzNDk1MlowgZUxCzAJBgNVBAYT +AkdSMUQwQgYDVQQKEztIZWxsZW5pYyBBY2FkZW1pYyBhbmQgUmVzZWFyY2ggSW5zdGl0dXRpb25z +IENlcnQuIEF1dGhvcml0eTFAMD4GA1UEAxM3SGVsbGVuaWMgQWNhZGVtaWMgYW5kIFJlc2VhcmNo +IEluc3RpdHV0aW9ucyBSb290Q0EgMjAxMTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEB +AKlTAOMupvaO+mDYLZU++CwqVE7NuYRhlFhPjz2L5EPzdYmNUeTDN9KKiE15HrcS3UN4SoqS5tdI +1Q+kOilENbgH9mgdVc04UfCMJDGFr4PJfel3r+0ae50X+bOdOFAPplp5kYCvN66m0zH7tSYJnTxa +71HFK9+WXesyHgLacEnsbgzImjeN9/E2YEsmLIKe0HjzDQ9jpFEw4fkrJxIH2Oq9GGKYsFk3fb7u +8yBRQlqD75O6aRXxYp2fmTmCobd0LovUxQt7L/DICto9eQqakxylKHJzkUOap9FNhYS5qXSPFEDH +3N6sQWRstBmbAmNtJGSPRLIl6s5ddAxjMlyNh+UCAwEAAaOBiTCBhjAPBgNVHRMBAf8EBTADAQH/ +MAsGA1UdDwQEAwIBBjAdBgNVHQ4EFgQUppFC/RNhSiOeCKQp5dgTBCPuQSUwRwYDVR0eBEAwPqA8 +MAWCAy5ncjAFggMuZXUwBoIELmVkdTAGggQub3JnMAWBAy5ncjAFgQMuZXUwBoEELmVkdTAGgQQu +b3JnMA0GCSqGSIb3DQEBBQUAA4IBAQAf73lB4XtuP7KMhjdCSk4cNx6NZrokgclPEg8hwAOXhiVt +XdMiKahsog2p6z0GW5k6x8zDmjR/qw7IThzh+uTczQ2+vyT+bOdrwg3IBp5OjWEopmr95fZi6hg8 +TqBTnbI6nOulnJEWtk2C4AwFSKls9cz4y51JtPACpf1wA+2KIaWuE4ZJwzNzvoc7dIsXRSZMFpGD +/md9zU1jZ/rzAxKWeAaNsWftjj++n08C9bMJL/NMh98qy5V8AcysNnq/onN694/BtZqhFLKPM58N +7yLcZnuEvUUXBj08yrl3NI/K6s8/MT7jiOOASSXIl7WdmplNsDz4SgCbZN2fOUvRJ9e4 +-----END CERTIFICATE----- + +Actalis Authentication Root CA +============================== +-----BEGIN CERTIFICATE----- +MIIFuzCCA6OgAwIBAgIIVwoRl0LE48wwDQYJKoZIhvcNAQELBQAwazELMAkGA1UEBhMCSVQxDjAM +BgNVBAcMBU1pbGFuMSMwIQYDVQQKDBpBY3RhbGlzIFMucC5BLi8wMzM1ODUyMDk2NzEnMCUGA1UE +AwweQWN0YWxpcyBBdXRoZW50aWNhdGlvbiBSb290IENBMB4XDTExMDkyMjExMjIwMloXDTMwMDky +MjExMjIwMlowazELMAkGA1UEBhMCSVQxDjAMBgNVBAcMBU1pbGFuMSMwIQYDVQQKDBpBY3RhbGlz +IFMucC5BLi8wMzM1ODUyMDk2NzEnMCUGA1UEAwweQWN0YWxpcyBBdXRoZW50aWNhdGlvbiBSb290 +IENBMIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEAp8bEpSmkLO/lGMWwUKNvUTufClrJ +wkg4CsIcoBh/kbWHuUA/3R1oHwiD1S0eiKD4j1aPbZkCkpAW1V8IbInX4ay8IMKx4INRimlNAJZa +by/ARH6jDuSRzVju3PvHHkVH3Se5CAGfpiEd9UEtL0z9KK3giq0itFZljoZUj5NDKd45RnijMCO6 +zfB9E1fAXdKDa0hMxKufgFpbOr3JpyI/gCczWw63igxdBzcIy2zSekciRDXFzMwujt0q7bd9Zg1f +YVEiVRvjRuPjPdA1YprbrxTIW6HMiRvhMCb8oJsfgadHHwTrozmSBp+Z07/T6k9QnBn+locePGX2 +oxgkg4YQ51Q+qDp2JE+BIcXjDwL4k5RHILv+1A7TaLndxHqEguNTVHnd25zS8gebLra8Pu2Fbe8l +EfKXGkJh90qX6IuxEAf6ZYGyojnP9zz/GPvG8VqLWeICrHuS0E4UT1lF9gxeKF+w6D9Fz8+vm2/7 +hNN3WpVvrJSEnu68wEqPSpP4RCHiMUVhUE4Q2OM1fEwZtN4Fv6MGn8i1zeQf1xcGDXqVdFUNaBr8 +EBtiZJ1t4JWgw5QHVw0U5r0F+7if5t+L4sbnfpb2U8WANFAoWPASUHEXMLrmeGO89LKtmyuy/uE5 +jF66CyCU3nuDuP/jVo23Eek7jPKxwV2dpAtMK9myGPW1n0sCAwEAAaNjMGEwHQYDVR0OBBYEFFLY +iDrIn3hm7YnzezhwlMkCAjbQMA8GA1UdEwEB/wQFMAMBAf8wHwYDVR0jBBgwFoAUUtiIOsifeGbt +ifN7OHCUyQICNtAwDgYDVR0PAQH/BAQDAgEGMA0GCSqGSIb3DQEBCwUAA4ICAQALe3KHwGCmSUyI +WOYdiPcUZEim2FgKDk8TNd81HdTtBjHIgT5q1d07GjLukD0R0i70jsNjLiNmsGe+b7bAEzlgqqI0 +JZN1Ut6nna0Oh4lScWoWPBkdg/iaKWW+9D+a2fDzWochcYBNy+A4mz+7+uAwTc+G02UQGRjRlwKx +K3JCaKygvU5a2hi/a5iB0P2avl4VSM0RFbnAKVy06Ij3Pjaut2L9HmLecHgQHEhb2rykOLpn7VU+ +Xlff1ANATIGk0k9jpwlCCRT8AKnCgHNPLsBA2RF7SOp6AsDT6ygBJlh0wcBzIm2Tlf05fbsq4/aC +4yyXX04fkZT6/iyj2HYauE2yOE+b+h1IYHkm4vP9qdCa6HCPSXrW5b0KDtst842/6+OkfcvHlXHo +2qN8xcL4dJIEG4aspCJTQLas/kx2z/uUMsA1n3Y/buWQbqCmJqK4LL7RK4X9p2jIugErsWx0Hbhz +lefut8cl8ABMALJ+tguLHPPAUJ4lueAI3jZm/zel0btUZCzJJ7VLkn5l/9Mt4blOvH+kQSGQQXem +OR/qnuOf0GZvBeyqdn6/axag67XH/JJULysRJyU3eExRarDzzFhdFPFqSBX/wge2sY0PjlxQRrM9 +vwGYT7JZVEc+NHt4bVaTLnPqZih4zR0Uv6CPLy64Lo7yFIrM6bV8+2ydDKXhlg== +-----END CERTIFICATE----- + +Trustis FPS Root CA +=================== +-----BEGIN CERTIFICATE----- +MIIDZzCCAk+gAwIBAgIQGx+ttiD5JNM2a/fH8YygWTANBgkqhkiG9w0BAQUFADBFMQswCQYDVQQG +EwJHQjEYMBYGA1UEChMPVHJ1c3RpcyBMaW1pdGVkMRwwGgYDVQQLExNUcnVzdGlzIEZQUyBSb290 +IENBMB4XDTAzMTIyMzEyMTQwNloXDTI0MDEyMTExMzY1NFowRTELMAkGA1UEBhMCR0IxGDAWBgNV +BAoTD1RydXN0aXMgTGltaXRlZDEcMBoGA1UECxMTVHJ1c3RpcyBGUFMgUm9vdCBDQTCCASIwDQYJ +KoZIhvcNAQEBBQADggEPADCCAQoCggEBAMVQe547NdDfxIzNjpvto8A2mfRC6qc+gIMPpqdZh8mQ +RUN+AOqGeSoDvT03mYlmt+WKVoaTnGhLaASMk5MCPjDSNzoiYYkchU59j9WvezX2fihHiTHcDnlk +H5nSW7r+f2C/revnPDgpai/lkQtV/+xvWNUtyd5MZnGPDNcE2gfmHhjjvSkCqPoc4Vu5g6hBSLwa +cY3nYuUtsuvffM/bq1rKMfFMIvMFE/eC+XN5DL7XSxzA0RU8k0Fk0ea+IxciAIleH2ulrG6nS4zt +o3Lmr2NNL4XSFDWaLk6M6jKYKIahkQlBOrTh4/L68MkKokHdqeMDx4gVOxzUGpTXn2RZEm0CAwEA +AaNTMFEwDwYDVR0TAQH/BAUwAwEB/zAfBgNVHSMEGDAWgBS6+nEleYtXQSUhhgtx67JkDoshZzAd +BgNVHQ4EFgQUuvpxJXmLV0ElIYYLceuyZA6LIWcwDQYJKoZIhvcNAQEFBQADggEBAH5Y//01GX2c +GE+esCu8jowU/yyg2kdbw++BLa8F6nRIW/M+TgfHbcWzk88iNVy2P3UnXwmWzaD+vkAMXBJV+JOC +yinpXj9WV4s4NvdFGkwozZ5BuO1WTISkQMi4sKUraXAEasP41BIy+Q7DsdwyhEQsb8tGD+pmQQ9P +8Vilpg0ND2HepZ5dfWWhPBfnqFVO76DH7cZEf1T1o+CP8HxVIo8ptoGj4W1OLBuAZ+ytIJ8MYmHV +l/9D7S3B2l0pKoU/rGXuhg8FjZBf3+6f9L/uHfuY5H+QK4R4EA5sSVPvFVtlRkpdr7r7OnIdzfYl +iB6XzCGcKQENZetX2fNXlrtIzYE= +-----END CERTIFICATE----- + +Buypass Class 2 Root CA +======================= +-----BEGIN CERTIFICATE----- +MIIFWTCCA0GgAwIBAgIBAjANBgkqhkiG9w0BAQsFADBOMQswCQYDVQQGEwJOTzEdMBsGA1UECgwU +QnV5cGFzcyBBUy05ODMxNjMzMjcxIDAeBgNVBAMMF0J1eXBhc3MgQ2xhc3MgMiBSb290IENBMB4X +DTEwMTAyNjA4MzgwM1oXDTQwMTAyNjA4MzgwM1owTjELMAkGA1UEBhMCTk8xHTAbBgNVBAoMFEJ1 +eXBhc3MgQVMtOTgzMTYzMzI3MSAwHgYDVQQDDBdCdXlwYXNzIENsYXNzIDIgUm9vdCBDQTCCAiIw +DQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBANfHXvfBB9R3+0Mh9PT1aeTuMgHbo4Yf5FkNuud1 +g1Lr6hxhFUi7HQfKjK6w3Jad6sNgkoaCKHOcVgb/S2TwDCo3SbXlzwx87vFKu3MwZfPVL4O2fuPn +9Z6rYPnT8Z2SdIrkHJasW4DptfQxh6NR/Md+oW+OU3fUl8FVM5I+GC911K2GScuVr1QGbNgGE41b +/+EmGVnAJLqBcXmQRFBoJJRfuLMR8SlBYaNByyM21cHxMlAQTn/0hpPshNOOvEu/XAFOBz3cFIqU +CqTqc/sLUegTBxj6DvEr0VQVfTzh97QZQmdiXnfgolXsttlpF9U6r0TtSsWe5HonfOV116rLJeff +awrbD02TTqigzXsu8lkBarcNuAeBfos4GzjmCleZPe4h6KP1DBbdi+w0jpwqHAAVF41og9JwnxgI +zRFo1clrUs3ERo/ctfPYV3Me6ZQ5BL/T3jjetFPsaRyifsSP5BtwrfKi+fv3FmRmaZ9JUaLiFRhn +Bkp/1Wy1TbMz4GHrXb7pmA8y1x1LPC5aAVKRCfLf6o3YBkBjqhHk/sM3nhRSP/TizPJhk9H9Z2vX +Uq6/aKtAQ6BXNVN48FP4YUIHZMbXb5tMOA1jrGKvNouicwoN9SG9dKpN6nIDSdvHXx1iY8f93ZHs +M+71bbRuMGjeyNYmsHVee7QHIJihdjK4TWxPAgMBAAGjQjBAMA8GA1UdEwEB/wQFMAMBAf8wHQYD +VR0OBBYEFMmAd+BikoL1RpzzuvdMw964o605MA4GA1UdDwEB/wQEAwIBBjANBgkqhkiG9w0BAQsF +AAOCAgEAU18h9bqwOlI5LJKwbADJ784g7wbylp7ppHR/ehb8t/W2+xUbP6umwHJdELFx7rxP462s +A20ucS6vxOOto70MEae0/0qyexAQH6dXQbLArvQsWdZHEIjzIVEpMMpghq9Gqx3tOluwlN5E40EI +osHsHdb9T7bWR9AUC8rmyrV7d35BH16Dx7aMOZawP5aBQW9gkOLo+fsicdl9sz1Gv7SEr5AcD48S +aq/v7h56rgJKihcrdv6sVIkkLE8/trKnToyokZf7KcZ7XC25y2a2t6hbElGFtQl+Ynhw/qlqYLYd +DnkM/crqJIByw5c/8nerQyIKx+u2DISCLIBrQYoIwOula9+ZEsuK1V6ADJHgJgg2SMX6OBE1/yWD +LfJ6v9r9jv6ly0UsH8SIU653DtmadsWOLB2jutXsMq7Aqqz30XpN69QH4kj3Io6wpJ9qzo6ysmD0 +oyLQI+uUWnpp3Q+/QFesa1lQ2aOZ4W7+jQF5JyMV3pKdewlNWudLSDBaGOYKbeaP4NK75t98biGC +wWg5TbSYWGZizEqQXsP6JwSxeRV0mcy+rSDeJmAc61ZRpqPq5KM/p/9h3PFaTWwyI0PurKju7koS +CTxdccK+efrCh2gdC/1cacwG0Jp9VJkqyTkaGa9LKkPzY11aWOIv4x3kqdbQCtCev9eBCfHJxyYN +rJgWVqA= +-----END CERTIFICATE----- + +Buypass Class 3 Root CA +======================= +-----BEGIN CERTIFICATE----- +MIIFWTCCA0GgAwIBAgIBAjANBgkqhkiG9w0BAQsFADBOMQswCQYDVQQGEwJOTzEdMBsGA1UECgwU +QnV5cGFzcyBBUy05ODMxNjMzMjcxIDAeBgNVBAMMF0J1eXBhc3MgQ2xhc3MgMyBSb290IENBMB4X +DTEwMTAyNjA4Mjg1OFoXDTQwMTAyNjA4Mjg1OFowTjELMAkGA1UEBhMCTk8xHTAbBgNVBAoMFEJ1 +eXBhc3MgQVMtOTgzMTYzMzI3MSAwHgYDVQQDDBdCdXlwYXNzIENsYXNzIDMgUm9vdCBDQTCCAiIw +DQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBAKXaCpUWUOOV8l6ddjEGMnqb8RB2uACatVI2zSRH +sJ8YZLya9vrVediQYkwiL944PdbgqOkcLNt4EemOaFEVcsfzM4fkoF0LXOBXByow9c3EN3coTRiR +5r/VUv1xLXA+58bEiuPwKAv0dpihi4dVsjoT/Lc+JzeOIuOoTyrvYLs9tznDDgFHmV0ST9tD+leh +7fmdvhFHJlsTmKtdFoqwNxxXnUX/iJY2v7vKB3tvh2PX0DJq1l1sDPGzbjniazEuOQAnFN44wOwZ +ZoYS6J1yFhNkUsepNxz9gjDthBgd9K5c/3ATAOux9TN6S9ZV+AWNS2mw9bMoNlwUxFFzTWsL8TQH +2xc519woe2v1n/MuwU8XKhDzzMro6/1rqy6any2CbgTUUgGTLT2G/H783+9CHaZr77kgxve9oKeV +/afmiSTYzIw0bOIjL9kSGiG5VZFvC5F5GQytQIgLcOJ60g7YaEi7ghM5EFjp2CoHxhLbWNvSO1UQ +RwUVZ2J+GGOmRj8JDlQyXr8NYnon74Do29lLBlo3WiXQCBJ31G8JUJc9yB3D34xFMFbG02SrZvPA +Xpacw8Tvw3xrizp5f7NJzz3iiZ+gMEuFuZyUJHmPfWupRWgPK9Dx2hzLabjKSWJtyNBjYt1gD1iq +j6G8BaVmos8bdrKEZLFMOVLAMLrwjEsCsLa3AgMBAAGjQjBAMA8GA1UdEwEB/wQFMAMBAf8wHQYD +VR0OBBYEFEe4zf/lb+74suwvTg75JbCOPGvDMA4GA1UdDwEB/wQEAwIBBjANBgkqhkiG9w0BAQsF +AAOCAgEAACAjQTUEkMJAYmDv4jVM1z+s4jSQuKFvdvoWFqRINyzpkMLyPPgKn9iB5btb2iUspKdV +cSQy9sgL8rxq+JOssgfCX5/bzMiKqr5qb+FJEMwx14C7u8jYog5kV+qi9cKpMRXSIGrs/CIBKM+G +uIAeqcwRpTzyFrNHnfzSgCHEy9BHcEGhyoMZCCxt8l13nIoUE9Q2HJLw5QY33KbmkJs4j1xrG0aG +Q0JfPgEHU1RdZX33inOhmlRaHylDFCfChQ+1iHsaO5S3HWCntZznKWlXWpuTekMwGwPXYshApqr8 +ZORK15FTAaggiG6cX0S5y2CBNOxv033aSF/rtJC8LakcC6wc1aJoIIAE1vyxjy+7SjENSoYc6+I2 +KSb12tjE8nVhz36udmNKekBlk4f4HoCMhuWG1o8O/FMsYOgWYRqiPkN7zTlgVGr18okmAWiDSKIz +6MkEkbIRNBE+6tBDGR8Dk5AM/1E9V/RBbuHLoL7ryWPNbczk+DaqaJ3tvV2XcEQNtg413OEMXbug +UZTLfhbrES+jkkXITHHZvMmZUldGL1DPvTVp9D0VzgalLA8+9oG6lLvDu79leNKGef9JOxqDDPDe +eOzI8k1MGt6CKfjBWtrt7uYnXuhF0J0cUahoq0Tj0Itq4/g7u9xN12TyUb7mqqta6THuBrxzvxNi +Cp/HuZc= +-----END CERTIFICATE----- + +T-TeleSec GlobalRoot Class 3 +============================ +-----BEGIN CERTIFICATE----- +MIIDwzCCAqugAwIBAgIBATANBgkqhkiG9w0BAQsFADCBgjELMAkGA1UEBhMCREUxKzApBgNVBAoM +IlQtU3lzdGVtcyBFbnRlcnByaXNlIFNlcnZpY2VzIEdtYkgxHzAdBgNVBAsMFlQtU3lzdGVtcyBU +cnVzdCBDZW50ZXIxJTAjBgNVBAMMHFQtVGVsZVNlYyBHbG9iYWxSb290IENsYXNzIDMwHhcNMDgx +MDAxMTAyOTU2WhcNMzMxMDAxMjM1OTU5WjCBgjELMAkGA1UEBhMCREUxKzApBgNVBAoMIlQtU3lz +dGVtcyBFbnRlcnByaXNlIFNlcnZpY2VzIEdtYkgxHzAdBgNVBAsMFlQtU3lzdGVtcyBUcnVzdCBD +ZW50ZXIxJTAjBgNVBAMMHFQtVGVsZVNlYyBHbG9iYWxSb290IENsYXNzIDMwggEiMA0GCSqGSIb3 +DQEBAQUAA4IBDwAwggEKAoIBAQC9dZPwYiJvJK7genasfb3ZJNW4t/zN8ELg63iIVl6bmlQdTQyK +9tPPcPRStdiTBONGhnFBSivwKixVA9ZIw+A5OO3yXDw/RLyTPWGrTs0NvvAgJ1gORH8EGoel15YU +NpDQSXuhdfsaa3Ox+M6pCSzyU9XDFES4hqX2iys52qMzVNn6chr3IhUciJFrf2blw2qAsCTz34ZF +iP0Zf3WHHx+xGwpzJFu5ZeAsVMhg02YXP+HMVDNzkQI6pn97djmiH5a2OK61yJN0HZ65tOVgnS9W +0eDrXltMEnAMbEQgqxHY9Bn20pxSN+f6tsIxO0rUFJmtxxr1XV/6B7h8DR/Wgx6zAgMBAAGjQjBA +MA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMB0GA1UdDgQWBBS1A/d2O2GCahKqGFPr +AyGUv/7OyjANBgkqhkiG9w0BAQsFAAOCAQEAVj3vlNW92nOyWL6ukK2YJ5f+AbGwUgC4TeQbIXQb +fsDuXmkqJa9c1h3a0nnJ85cp4IaH3gRZD/FZ1GSFS5mvJQQeyUapl96Cshtwn5z2r3Ex3XsFpSzT +ucpH9sry9uetuUg/vBa3wW306gmv7PO15wWeph6KU1HWk4HMdJP2udqmJQV0eVp+QD6CSyYRMG7h +P0HHRwA11fXT91Q+gT3aSWqas+8QPebrb9HIIkfLzM8BMZLZGOMivgkeGj5asuRrDFR6fUNOuIml +e9eiPZaGzPImNC1qkp2aGtAw4l1OBLBfiyB+d8E9lYLRRpo7PHi4b6HQDWSieB4pTpPDpFQUWw== +-----END CERTIFICATE----- + +EE Certification Centre Root CA +=============================== +-----BEGIN CERTIFICATE----- +MIIEAzCCAuugAwIBAgIQVID5oHPtPwBMyonY43HmSjANBgkqhkiG9w0BAQUFADB1MQswCQYDVQQG +EwJFRTEiMCAGA1UECgwZQVMgU2VydGlmaXRzZWVyaW1pc2tlc2t1czEoMCYGA1UEAwwfRUUgQ2Vy +dGlmaWNhdGlvbiBDZW50cmUgUm9vdCBDQTEYMBYGCSqGSIb3DQEJARYJcGtpQHNrLmVlMCIYDzIw +MTAxMDMwMTAxMDMwWhgPMjAzMDEyMTcyMzU5NTlaMHUxCzAJBgNVBAYTAkVFMSIwIAYDVQQKDBlB +UyBTZXJ0aWZpdHNlZXJpbWlza2Vza3VzMSgwJgYDVQQDDB9FRSBDZXJ0aWZpY2F0aW9uIENlbnRy +ZSBSb290IENBMRgwFgYJKoZIhvcNAQkBFglwa2lAc2suZWUwggEiMA0GCSqGSIb3DQEBAQUAA4IB +DwAwggEKAoIBAQDIIMDs4MVLqwd4lfNE7vsLDP90jmG7sWLqI9iroWUyeuuOF0+W2Ap7kaJjbMeM +TC55v6kF/GlclY1i+blw7cNRfdCT5mzrMEvhvH2/UpvObntl8jixwKIy72KyaOBhU8E2lf/slLo2 +rpwcpzIP5Xy0xm90/XsY6KxX7QYgSzIwWFv9zajmofxwvI6Sc9uXp3whrj3B9UiHbCe9nyV0gVWw +93X2PaRka9ZP585ArQ/dMtO8ihJTmMmJ+xAdTX7Nfh9WDSFwhfYggx/2uh8Ej+p3iDXE/+pOoYtN +P2MbRMNE1CV2yreN1x5KZmTNXMWcg+HCCIia7E6j8T4cLNlsHaFLAgMBAAGjgYowgYcwDwYDVR0T +AQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0OBBYEFBLyWj7qVhy/zQas8fElyalL1BSZ +MEUGA1UdJQQ+MDwGCCsGAQUFBwMCBggrBgEFBQcDAQYIKwYBBQUHAwMGCCsGAQUFBwMEBggrBgEF +BQcDCAYIKwYBBQUHAwkwDQYJKoZIhvcNAQEFBQADggEBAHv25MANqhlHt01Xo/6tu7Fq1Q+e2+Rj +xY6hUFaTlrg4wCQiZrxTFGGVv9DHKpY5P30osxBAIWrEr7BSdxjhlthWXePdNl4dp1BUoMUq5KqM +lIpPnTX/dqQGE5Gion0ARD9V04I8GtVbvFZMIi5GQ4okQC3zErg7cBqklrkar4dBGmoYDQZPxz5u +uSlNDUmJEYcyW+ZLBMjkXOZ0c5RdFpgTlf7727FE5TpwrDdr5rMzcijJs1eg9gIWiAYLtqZLICjU +3j2LrTcFU3T+bsy8QxdxXvnFzBqpYe73dgzzcvRyrc9yAjYHR8/vGVCJYMzpJJUPwssd8m92kMfM +dcGWxZ0= +-----END CERTIFICATE----- + +D-TRUST Root Class 3 CA 2 2009 +============================== +-----BEGIN CERTIFICATE----- +MIIEMzCCAxugAwIBAgIDCYPzMA0GCSqGSIb3DQEBCwUAME0xCzAJBgNVBAYTAkRFMRUwEwYDVQQK +DAxELVRydXN0IEdtYkgxJzAlBgNVBAMMHkQtVFJVU1QgUm9vdCBDbGFzcyAzIENBIDIgMjAwOTAe +Fw0wOTExMDUwODM1NThaFw0yOTExMDUwODM1NThaME0xCzAJBgNVBAYTAkRFMRUwEwYDVQQKDAxE +LVRydXN0IEdtYkgxJzAlBgNVBAMMHkQtVFJVU1QgUm9vdCBDbGFzcyAzIENBIDIgMjAwOTCCASIw +DQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBANOySs96R+91myP6Oi/WUEWJNTrGa9v+2wBoqOAD +ER03UAifTUpolDWzU9GUY6cgVq/eUXjsKj3zSEhQPgrfRlWLJ23DEE0NkVJD2IfgXU42tSHKXzlA +BF9bfsyjxiupQB7ZNoTWSPOSHjRGICTBpFGOShrvUD9pXRl/RcPHAY9RySPocq60vFYJfxLLHLGv +KZAKyVXMD9O0Gu1HNVpK7ZxzBCHQqr0ME7UAyiZsxGsMlFqVlNpQmvH/pStmMaTJOKDfHR+4CS7z +p+hnUquVH+BGPtikw8paxTGA6Eian5Rp/hnd2HN8gcqW3o7tszIFZYQ05ub9VxC1X3a/L7AQDcUC +AwEAAaOCARowggEWMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYEFP3aFMSfMN4hvR5COfyrYyNJ +4PGEMA4GA1UdDwEB/wQEAwIBBjCB0wYDVR0fBIHLMIHIMIGAoH6gfIZ6bGRhcDovL2RpcmVjdG9y +eS5kLXRydXN0Lm5ldC9DTj1ELVRSVVNUJTIwUm9vdCUyMENsYXNzJTIwMyUyMENBJTIwMiUyMDIw +MDksTz1ELVRydXN0JTIwR21iSCxDPURFP2NlcnRpZmljYXRlcmV2b2NhdGlvbmxpc3QwQ6BBoD+G +PWh0dHA6Ly93d3cuZC10cnVzdC5uZXQvY3JsL2QtdHJ1c3Rfcm9vdF9jbGFzc18zX2NhXzJfMjAw +OS5jcmwwDQYJKoZIhvcNAQELBQADggEBAH+X2zDI36ScfSF6gHDOFBJpiBSVYEQBrLLpME+bUMJm +2H6NMLVwMeniacfzcNsgFYbQDfC+rAF1hM5+n02/t2A7nPPKHeJeaNijnZflQGDSNiH+0LS4F9p0 +o3/U37CYAqxva2ssJSRyoWXuJVrl5jLn8t+rSfrzkGkj2wTZ51xY/GXUl77M/C4KzCUqNQT4YJEV +dT1B/yMfGchs64JTBKbkTCJNjYy6zltz7GRUUG3RnFX7acM2w4y8PIWmawomDeCTmGCufsYkl4ph +X5GOZpIJhzbNi5stPvZR1FDUWSi9g/LMKHtThm3YJohw1+qRzT65ysCQblrGXnRl11z+o+I= +-----END CERTIFICATE----- + +D-TRUST Root Class 3 CA 2 EV 2009 +================================= +-----BEGIN CERTIFICATE----- +MIIEQzCCAyugAwIBAgIDCYP0MA0GCSqGSIb3DQEBCwUAMFAxCzAJBgNVBAYTAkRFMRUwEwYDVQQK +DAxELVRydXN0IEdtYkgxKjAoBgNVBAMMIUQtVFJVU1QgUm9vdCBDbGFzcyAzIENBIDIgRVYgMjAw +OTAeFw0wOTExMDUwODUwNDZaFw0yOTExMDUwODUwNDZaMFAxCzAJBgNVBAYTAkRFMRUwEwYDVQQK +DAxELVRydXN0IEdtYkgxKjAoBgNVBAMMIUQtVFJVU1QgUm9vdCBDbGFzcyAzIENBIDIgRVYgMjAw +OTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAJnxhDRwui+3MKCOvXwEz75ivJn9gpfS +egpnljgJ9hBOlSJzmY3aFS3nBfwZcyK3jpgAvDw9rKFs+9Z5JUut8Mxk2og+KbgPCdM03TP1YtHh +zRnp7hhPTFiu4h7WDFsVWtg6uMQYZB7jM7K1iXdODL/ZlGsTl28So/6ZqQTMFexgaDbtCHu39b+T +7WYxg4zGcTSHThfqr4uRjRxWQa4iN1438h3Z0S0NL2lRp75mpoo6Kr3HGrHhFPC+Oh25z1uxav60 +sUYgovseO3Dvk5h9jHOW8sXvhXCtKSb8HgQ+HKDYD8tSg2J87otTlZCpV6LqYQXY+U3EJ/pure35 +11H3a6UCAwEAAaOCASQwggEgMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYEFNOUikxiEyoZLsyv +cop9NteaHNxnMA4GA1UdDwEB/wQEAwIBBjCB3QYDVR0fBIHVMIHSMIGHoIGEoIGBhn9sZGFwOi8v +ZGlyZWN0b3J5LmQtdHJ1c3QubmV0L0NOPUQtVFJVU1QlMjBSb290JTIwQ2xhc3MlMjAzJTIwQ0El +MjAyJTIwRVYlMjAyMDA5LE89RC1UcnVzdCUyMEdtYkgsQz1ERT9jZXJ0aWZpY2F0ZXJldm9jYXRp +b25saXN0MEagRKBChkBodHRwOi8vd3d3LmQtdHJ1c3QubmV0L2NybC9kLXRydXN0X3Jvb3RfY2xh +c3NfM19jYV8yX2V2XzIwMDkuY3JsMA0GCSqGSIb3DQEBCwUAA4IBAQA07XtaPKSUiO8aEXUHL7P+ +PPoeUSbrh/Yp3uDx1MYkCenBz1UbtDDZzhr+BlGmFaQt77JLvyAoJUnRpjZ3NOhk31KxEcdzes05 +nsKtjHEh8lprr988TlWvsoRlFIm5d8sqMb7Po23Pb0iUMkZv53GMoKaEGTcH8gNFCSuGdXzfX2lX +ANtu2KZyIktQ1HWYVt+3GP9DQ1CuekR78HlR10M9p9OB0/DJT7naxpeG0ILD5EJt/rDiZE4OJudA +NCa1CInXCGNjOCd1HjPqbqjdn5lPdE2BiYBL3ZqXKVwvvoFBuYz/6n1gBp7N1z3TLqMVvKjmJuVv +w9y4AyHqnxbxLFS1 +-----END CERTIFICATE----- + +CA Disig Root R1 +================ +-----BEGIN CERTIFICATE----- +MIIFaTCCA1GgAwIBAgIJAMMDmu5QkG4oMA0GCSqGSIb3DQEBBQUAMFIxCzAJBgNVBAYTAlNLMRMw +EQYDVQQHEwpCcmF0aXNsYXZhMRMwEQYDVQQKEwpEaXNpZyBhLnMuMRkwFwYDVQQDExBDQSBEaXNp +ZyBSb290IFIxMB4XDTEyMDcxOTA5MDY1NloXDTQyMDcxOTA5MDY1NlowUjELMAkGA1UEBhMCU0sx +EzARBgNVBAcTCkJyYXRpc2xhdmExEzARBgNVBAoTCkRpc2lnIGEucy4xGTAXBgNVBAMTEENBIERp +c2lnIFJvb3QgUjEwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCqw3j33Jijp1pedxiy +3QRkD2P9m5YJgNXoqqXinCaUOuiZc4yd39ffg/N4T0Dhf9Kn0uXKE5Pn7cZ3Xza1lK/oOI7bm+V8 +u8yN63Vz4STN5qctGS7Y1oprFOsIYgrY3LMATcMjfF9DCCMyEtztDK3AfQ+lekLZWnDZv6fXARz2 +m6uOt0qGeKAeVjGu74IKgEH3G8muqzIm1Cxr7X1r5OJeIgpFy4QxTaz+29FHuvlglzmxZcfe+5nk +CiKxLU3lSCZpq+Kq8/v8kiky6bM+TR8noc2OuRf7JT7JbvN32g0S9l3HuzYQ1VTW8+DiR0jm3hTa +YVKvJrT1cU/J19IG32PK/yHoWQbgCNWEFVP3Q+V8xaCJmGtzxmjOZd69fwX3se72V6FglcXM6pM6 +vpmumwKjrckWtc7dXpl4fho5frLABaTAgqWjR56M6ly2vGfb5ipN0gTco65F97yLnByn1tUD3AjL +LhbKXEAz6GfDLuemROoRRRw1ZS0eRWEkG4IupZ0zXWX4Qfkuy5Q/H6MMMSRE7cderVC6xkGbrPAX +ZcD4XW9boAo0PO7X6oifmPmvTiT6l7Jkdtqr9O3jw2Dv1fkCyC2fg69naQanMVXVz0tv/wQFx1is +XxYb5dKj6zHbHzMVTdDypVP1y+E9Tmgt2BLdqvLmTZtJ5cUoobqwWsagtQIDAQABo0IwQDAPBgNV +HRMBAf8EBTADAQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQUiQq0OJMa5qvum5EY+fU8PjXQ +04IwDQYJKoZIhvcNAQEFBQADggIBADKL9p1Kyb4U5YysOMo6CdQbzoaz3evUuii+Eq5FLAR0rBNR +xVgYZk2C2tXck8An4b58n1KeElb21Zyp9HWc+jcSjxyT7Ff+Bw+r1RL3D65hXlaASfX8MPWbTx9B +LxyE04nH4toCdu0Jz2zBuByDHBb6lM19oMgY0sidbvW9adRtPTXoHqJPYNcHKfyyo6SdbhWSVhlM +CrDpfNIZTUJG7L399ldb3Zh+pE3McgODWF3vkzpBemOqfDqo9ayk0d2iLbYq/J8BjuIQscTK5Gfb +VSUZP/3oNn6z4eGBrxEWi1CXYBmCAMBrTXO40RMHPuq2MU/wQppt4hF05ZSsjYSVPCGvxdpHyN85 +YmLLW1AL14FABZyb7bq2ix4Eb5YgOe2kfSnbSM6C3NQCjR0EMVrHS/BsYVLXtFHCgWzN4funodKS +ds+xDzdYpPJScWc/DIh4gInByLUfkmO+p3qKViwaqKactV2zY9ATIKHrkWzQjX2v3wvkF7mGnjix +lAxYjOBVqjtjbZqJYLhkKpLGN/R+Q0O3c+gB53+XD9fyexn9GtePyfqFa3qdnom2piiZk4hA9z7N +UaPK6u95RyG1/jLix8NRb76AdPCkwzryT+lf3xkK8jsTQ6wxpLPn6/wY1gGp8yqPNg7rtLG8t0zJ +a7+h89n07eLw4+1knj0vllJPgFOL +-----END CERTIFICATE----- + +CA Disig Root R2 +================ +-----BEGIN CERTIFICATE----- +MIIFaTCCA1GgAwIBAgIJAJK4iNuwisFjMA0GCSqGSIb3DQEBCwUAMFIxCzAJBgNVBAYTAlNLMRMw +EQYDVQQHEwpCcmF0aXNsYXZhMRMwEQYDVQQKEwpEaXNpZyBhLnMuMRkwFwYDVQQDExBDQSBEaXNp +ZyBSb290IFIyMB4XDTEyMDcxOTA5MTUzMFoXDTQyMDcxOTA5MTUzMFowUjELMAkGA1UEBhMCU0sx +EzARBgNVBAcTCkJyYXRpc2xhdmExEzARBgNVBAoTCkRpc2lnIGEucy4xGTAXBgNVBAMTEENBIERp +c2lnIFJvb3QgUjIwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCio8QACdaFXS1tFPbC +w3OeNcJxVX6B+6tGUODBfEl45qt5WDza/3wcn9iXAng+a0EE6UG9vgMsRfYvZNSrXaNHPWSb6Wia +xswbP7q+sos0Ai6YVRn8jG+qX9pMzk0DIaPY0jSTVpbLTAwAFjxfGs3Ix2ymrdMxp7zo5eFm1tL7 +A7RBZckQrg4FY8aAamkw/dLukO8NJ9+flXP04SXabBbeQTg06ov80egEFGEtQX6sx3dOy1FU+16S +GBsEWmjGycT6txOgmLcRK7fWV8x8nhfRyyX+hk4kLlYMeE2eARKmK6cBZW58Yh2EhN/qwGu1pSqV +g8NTEQxzHQuyRpDRQjrOQG6Vrf/GlK1ul4SOfW+eioANSW1z4nuSHsPzwfPrLgVv2RvPN3YEyLRa +5Beny912H9AZdugsBbPWnDTYltxhh5EF5EQIM8HauQhl1K6yNg3ruji6DOWbnuuNZt2Zz9aJQfYE +koopKW1rOhzndX0CcQ7zwOe9yxndnWCywmZgtrEE7snmhrmaZkCo5xHtgUUDi/ZnWejBBhG93c+A +Ak9lQHhcR1DIm+YfgXvkRKhbhZri3lrVx/k6RGZL5DJUfORsnLMOPReisjQS1n6yqEm70XooQL6i +Fh/f5DcfEXP7kAplQ6INfPgGAVUzfbANuPT1rqVCV3w2EYx7XsQDnYx5nQIDAQABo0IwQDAPBgNV +HRMBAf8EBTADAQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQUtZn4r7CU9eMg1gqtzk5WpC5u +Qu0wDQYJKoZIhvcNAQELBQADggIBACYGXnDnZTPIgm7ZnBc6G3pmsgH2eDtpXi/q/075KMOYKmFM +tCQSin1tERT3nLXK5ryeJ45MGcipvXrA1zYObYVybqjGom32+nNjf7xueQgcnYqfGopTpti72TVV +sRHFqQOzVju5hJMiXn7B9hJSi+osZ7z+Nkz1uM/Rs0mSO9MpDpkblvdhuDvEK7Z4bLQjb/D907Je +dR+Zlais9trhxTF7+9FGs9K8Z7RiVLoJ92Owk6Ka+elSLotgEqv89WBW7xBci8QaQtyDW2QOy7W8 +1k/BfDxujRNt+3vrMNDcTa/F1balTFtxyegxvug4BkihGuLq0t4SOVga/4AOgnXmt8kHbA7v/zjx +mHHEt38OFdAlab0inSvtBfZGR6ztwPDUO+Ls7pZbkBNOHlY667DvlruWIxG68kOGdGSVyCh13x01 +utI3gzhTODY7z2zp+WsO0PsE6E9312UBeIYMej4hYvF/Y3EMyZ9E26gnonW+boE+18DrG5gPcFw0 +sorMwIUY6256s/daoQe/qUKS82Ail+QUoQebTnbAjn39pCXHR+3/H3OszMOl6W8KjptlwlCFtaOg +UxLMVYdh84GuEEZhvUQhuMI9dM9+JDX6HAcOmz0iyu8xL4ysEr3vQCj8KWefshNPZiTEUxnpHikV +7+ZtsH8tZ/3zbBt1RqPlShfppNcL +-----END CERTIFICATE----- + +ACCVRAIZ1 +========= +-----BEGIN CERTIFICATE----- +MIIH0zCCBbugAwIBAgIIXsO3pkN/pOAwDQYJKoZIhvcNAQEFBQAwQjESMBAGA1UEAwwJQUNDVlJB +SVoxMRAwDgYDVQQLDAdQS0lBQ0NWMQ0wCwYDVQQKDARBQ0NWMQswCQYDVQQGEwJFUzAeFw0xMTA1 +MDUwOTM3MzdaFw0zMDEyMzEwOTM3MzdaMEIxEjAQBgNVBAMMCUFDQ1ZSQUlaMTEQMA4GA1UECwwH +UEtJQUNDVjENMAsGA1UECgwEQUNDVjELMAkGA1UEBhMCRVMwggIiMA0GCSqGSIb3DQEBAQUAA4IC +DwAwggIKAoICAQCbqau/YUqXry+XZpp0X9DZlv3P4uRm7x8fRzPCRKPfmt4ftVTdFXxpNRFvu8gM +jmoYHtiP2Ra8EEg2XPBjs5BaXCQ316PWywlxufEBcoSwfdtNgM3802/J+Nq2DoLSRYWoG2ioPej0 +RGy9ocLLA76MPhMAhN9KSMDjIgro6TenGEyxCQ0jVn8ETdkXhBilyNpAlHPrzg5XPAOBOp0KoVdD +aaxXbXmQeOW1tDvYvEyNKKGno6e6Ak4l0Squ7a4DIrhrIA8wKFSVf+DuzgpmndFALW4ir50awQUZ +0m/A8p/4e7MCQvtQqR0tkw8jq8bBD5L/0KIV9VMJcRz/RROE5iZe+OCIHAr8Fraocwa48GOEAqDG +WuzndN9wrqODJerWx5eHk6fGioozl2A3ED6XPm4pFdahD9GILBKfb6qkxkLrQaLjlUPTAYVtjrs7 +8yM2x/474KElB0iryYl0/wiPgL/AlmXz7uxLaL2diMMxs0Dx6M/2OLuc5NF/1OVYm3z61PMOm3WR +5LpSLhl+0fXNWhn8ugb2+1KoS5kE3fj5tItQo05iifCHJPqDQsGH+tUtKSpacXpkatcnYGMN285J +9Y0fkIkyF/hzQ7jSWpOGYdbhdQrqeWZ2iE9x6wQl1gpaepPluUsXQA+xtrn13k/c4LOsOxFwYIRK +Q26ZIMApcQrAZQIDAQABo4ICyzCCAscwfQYIKwYBBQUHAQEEcTBvMEwGCCsGAQUFBzAChkBodHRw +Oi8vd3d3LmFjY3YuZXMvZmlsZWFkbWluL0FyY2hpdm9zL2NlcnRpZmljYWRvcy9yYWl6YWNjdjEu +Y3J0MB8GCCsGAQUFBzABhhNodHRwOi8vb2NzcC5hY2N2LmVzMB0GA1UdDgQWBBTSh7Tj3zcnk1X2 +VuqB5TbMjB4/vTAPBgNVHRMBAf8EBTADAQH/MB8GA1UdIwQYMBaAFNKHtOPfNyeTVfZW6oHlNsyM +Hj+9MIIBcwYDVR0gBIIBajCCAWYwggFiBgRVHSAAMIIBWDCCASIGCCsGAQUFBwICMIIBFB6CARAA +QQB1AHQAbwByAGkAZABhAGQAIABkAGUAIABDAGUAcgB0AGkAZgBpAGMAYQBjAGkA8wBuACAAUgBh +AO0AegAgAGQAZQAgAGwAYQAgAEEAQwBDAFYAIAAoAEEAZwBlAG4AYwBpAGEAIABkAGUAIABUAGUA +YwBuAG8AbABvAGcA7QBhACAAeQAgAEMAZQByAHQAaQBmAGkAYwBhAGMAaQDzAG4AIABFAGwAZQBj +AHQAcgDzAG4AaQBjAGEALAAgAEMASQBGACAAUQA0ADYAMAAxADEANQA2AEUAKQAuACAAQwBQAFMA +IABlAG4AIABoAHQAdABwADoALwAvAHcAdwB3AC4AYQBjAGMAdgAuAGUAczAwBggrBgEFBQcCARYk +aHR0cDovL3d3dy5hY2N2LmVzL2xlZ2lzbGFjaW9uX2MuaHRtMFUGA1UdHwROMEwwSqBIoEaGRGh0 +dHA6Ly93d3cuYWNjdi5lcy9maWxlYWRtaW4vQXJjaGl2b3MvY2VydGlmaWNhZG9zL3JhaXphY2N2 +MV9kZXIuY3JsMA4GA1UdDwEB/wQEAwIBBjAXBgNVHREEEDAOgQxhY2N2QGFjY3YuZXMwDQYJKoZI +hvcNAQEFBQADggIBAJcxAp/n/UNnSEQU5CmH7UwoZtCPNdpNYbdKl02125DgBS4OxnnQ8pdpD70E +R9m+27Up2pvZrqmZ1dM8MJP1jaGo/AaNRPTKFpV8M9xii6g3+CfYCS0b78gUJyCpZET/LtZ1qmxN +YEAZSUNUY9rizLpm5U9EelvZaoErQNV/+QEnWCzI7UiRfD+mAM/EKXMRNt6GGT6d7hmKG9Ww7Y49 +nCrADdg9ZuM8Db3VlFzi4qc1GwQA9j9ajepDvV+JHanBsMyZ4k0ACtrJJ1vnE5Bc5PUzolVt3OAJ +TS+xJlsndQAJxGJ3KQhfnlmstn6tn1QwIgPBHnFk/vk4CpYY3QIUrCPLBhwepH2NDd4nQeit2hW3 +sCPdK6jT2iWH7ehVRE2I9DZ+hJp4rPcOVkkO1jMl1oRQQmwgEh0q1b688nCBpHBgvgW1m54ERL5h +I6zppSSMEYCUWqKiuUnSwdzRp+0xESyeGabu4VXhwOrPDYTkF7eifKXeVSUG7szAh1xA2syVP1Xg +Nce4hL60Xc16gwFy7ofmXx2utYXGJt/mwZrpHgJHnyqobalbz+xFd3+YJ5oyXSrjhO7FmGYvliAd +3djDJ9ew+f7Zfc3Qn48LFFhRny+Lwzgt3uiP1o2HpPVWQxaZLPSkVrQ0uGE3ycJYgBugl6H8WY3p +EfbRD0tVNEYqi4Y7 +-----END CERTIFICATE----- + +TWCA Global Root CA +=================== +-----BEGIN CERTIFICATE----- +MIIFQTCCAymgAwIBAgICDL4wDQYJKoZIhvcNAQELBQAwUTELMAkGA1UEBhMCVFcxEjAQBgNVBAoT +CVRBSVdBTi1DQTEQMA4GA1UECxMHUm9vdCBDQTEcMBoGA1UEAxMTVFdDQSBHbG9iYWwgUm9vdCBD +QTAeFw0xMjA2MjcwNjI4MzNaFw0zMDEyMzExNTU5NTlaMFExCzAJBgNVBAYTAlRXMRIwEAYDVQQK +EwlUQUlXQU4tQ0ExEDAOBgNVBAsTB1Jvb3QgQ0ExHDAaBgNVBAMTE1RXQ0EgR2xvYmFsIFJvb3Qg +Q0EwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCwBdvI64zEbooh745NnHEKH1Jw7W2C +nJfF10xORUnLQEK1EjRsGcJ0pDFfhQKX7EMzClPSnIyOt7h52yvVavKOZsTuKwEHktSz0ALfUPZV +r2YOy+BHYC8rMjk1Ujoog/h7FsYYuGLWRyWRzvAZEk2tY/XTP3VfKfChMBwqoJimFb3u/Rk28OKR +Q4/6ytYQJ0lM793B8YVwm8rqqFpD/G2Gb3PpN0Wp8DbHzIh1HrtsBv+baz4X7GGqcXzGHaL3SekV +tTzWoWH1EfcFbx39Eb7QMAfCKbAJTibc46KokWofwpFFiFzlmLhxpRUZyXx1EcxwdE8tmx2RRP1W +KKD+u4ZqyPpcC1jcxkt2yKsi2XMPpfRaAok/T54igu6idFMqPVMnaR1sjjIsZAAmY2E2TqNGtz99 +sy2sbZCilaLOz9qC5wc0GZbpuCGqKX6mOL6OKUohZnkfs8O1CWfe1tQHRvMq2uYiN2DLgbYPoA/p +yJV/v1WRBXrPPRXAb94JlAGD1zQbzECl8LibZ9WYkTunhHiVJqRaCPgrdLQABDzfuBSO6N+pjWxn +kjMdwLfS7JLIvgm/LCkFbwJrnu+8vyq8W8BQj0FwcYeyTbcEqYSjMq+u7msXi7Kx/mzhkIyIqJdI +zshNy/MGz19qCkKxHh53L46g5pIOBvwFItIm4TFRfTLcDwIDAQABoyMwITAOBgNVHQ8BAf8EBAMC +AQYwDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAgEAXzSBdu+WHdXltdkCY4QWwa6g +cFGn90xHNcgL1yg9iXHZqjNB6hQbbCEAwGxCGX6faVsgQt+i0trEfJdLjbDorMjupWkEmQqSpqsn +LhpNgb+E1HAerUf+/UqdM+DyucRFCCEK2mlpc3INvjT+lIutwx4116KD7+U4x6WFH6vPNOw/KP4M +8VeGTslV9xzU2KV9Bnpv1d8Q34FOIWWxtuEXeZVFBs5fzNxGiWNoRI2T9GRwoD2dKAXDOXC4Ynsg +/eTb6QihuJ49CcdP+yz4k3ZB3lLg4VfSnQO8d57+nile98FRYB/e2guyLXW3Q0iT5/Z5xoRdgFlg +lPx4mI88k1HtQJAH32RjJMtOcQWh15QaiDLxInQirqWm2BJpTGCjAu4r7NRjkgtevi92a6O2JryP +A9gK8kxkRr05YuWW6zRjESjMlfGt7+/cgFhI6Uu46mWs6fyAtbXIRfmswZ/ZuepiiI7E8UuDEq3m +i4TWnsLrgxifarsbJGAzcMzs9zLzXNl5fe+epP7JI8Mk7hWSsT2RTyaGvWZzJBPqpK5jwa19hAM8 +EHiGG3njxPPyBJUgriOCxLM6AGK/5jYk4Ve6xx6QddVfP5VhK8E7zeWzaGHQRiapIVJpLesux+t3 +zqY6tQMzT3bR51xUAV3LePTJDL/PEo4XLSNolOer/qmyKwbQBM0= +-----END CERTIFICATE----- + +TeliaSonera Root CA v1 +====================== +-----BEGIN CERTIFICATE----- +MIIFODCCAyCgAwIBAgIRAJW+FqD3LkbxezmCcvqLzZYwDQYJKoZIhvcNAQEFBQAwNzEUMBIGA1UE +CgwLVGVsaWFTb25lcmExHzAdBgNVBAMMFlRlbGlhU29uZXJhIFJvb3QgQ0EgdjEwHhcNMDcxMDE4 +MTIwMDUwWhcNMzIxMDE4MTIwMDUwWjA3MRQwEgYDVQQKDAtUZWxpYVNvbmVyYTEfMB0GA1UEAwwW +VGVsaWFTb25lcmEgUm9vdCBDQSB2MTCCAiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBAMK+ +6yfwIaPzaSZVfp3FVRaRXP3vIb9TgHot0pGMYzHw7CTww6XScnwQbfQ3t+XmfHnqjLWCi65ItqwA +3GV17CpNX8GH9SBlK4GoRz6JI5UwFpB/6FcHSOcZrr9FZ7E3GwYq/t75rH2D+1665I+XZ75Ljo1k +B1c4VWk0Nj0TSO9P4tNmHqTPGrdeNjPUtAa9GAH9d4RQAEX1jF3oI7x+/jXh7VB7qTCNGdMJjmhn +Xb88lxhTuylixcpecsHHltTbLaC0H2kD7OriUPEMPPCs81Mt8Bz17Ww5OXOAFshSsCPN4D7c3TxH +oLs1iuKYaIu+5b9y7tL6pe0S7fyYGKkmdtwoSxAgHNN/Fnct7W+A90m7UwW7XWjH1Mh1Fj+JWov3 +F0fUTPHSiXk+TT2YqGHeOh7S+F4D4MHJHIzTjU3TlTazN19jY5szFPAtJmtTfImMMsJu7D0hADnJ +oWjiUIMusDor8zagrC/kb2HCUQk5PotTubtn2txTuXZZNp1D5SDgPTJghSJRt8czu90VL6R4pgd7 +gUY2BIbdeTXHlSw7sKMXNeVzH7RcWe/a6hBle3rQf5+ztCo3O3CLm1u5K7fsslESl1MpWtTwEhDc +TwK7EpIvYtQ/aUN8Ddb8WHUBiJ1YFkveupD/RwGJBmr2X7KQarMCpgKIv7NHfirZ1fpoeDVNAgMB +AAGjPzA9MA8GA1UdEwEB/wQFMAMBAf8wCwYDVR0PBAQDAgEGMB0GA1UdDgQWBBTwj1k4ALP1j5qW +DNXr+nuqF+gTEjANBgkqhkiG9w0BAQUFAAOCAgEAvuRcYk4k9AwI//DTDGjkk0kiP0Qnb7tt3oNm +zqjMDfz1mgbldxSR651Be5kqhOX//CHBXfDkH1e3damhXwIm/9fH907eT/j3HEbAek9ALCI18Bmx +0GtnLLCo4MBANzX2hFxc469CeP6nyQ1Q6g2EdvZR74NTxnr/DlZJLo961gzmJ1TjTQpgcmLNkQfW +pb/ImWvtxBnmq0wROMVvMeJuScg/doAmAyYp4Db29iBT4xdwNBedY2gea+zDTYa4EzAvXUYNR0PV +G6pZDrlcjQZIrXSHX8f8MVRBE+LHIQ6e4B4N4cB7Q4WQxYpYxmUKeFfyxiMPAdkgS94P+5KFdSpc +c41teyWRyu5FrgZLAMzTsVlQ2jqIOylDRl6XK1TOU2+NSueW+r9xDkKLfP0ooNBIytrEgUy7onOT +JsjrDNYmiLbAJM+7vVvrdX3pCI6GMyx5dwlppYn8s3CQh3aP0yK7Qs69cwsgJirQmz1wHiRszYd2 +qReWt88NkvuOGKmYSdGe/mBEciG5Ge3C9THxOUiIkCR1VBatzvT4aRRkOfujuLpwQMcnHL/EVlP6 +Y2XQ8xwOFvVrhlhNGNTkDY6lnVuR3HYkUD/GKvvZt5y11ubQ2egZixVxSK236thZiNSQvxaz2ems +WWFUyBy6ysHK4bkgTI86k4mloMy/0/Z1pHWWbVY= +-----END CERTIFICATE----- + +E-Tugra Certification Authority +=============================== +-----BEGIN CERTIFICATE----- +MIIGSzCCBDOgAwIBAgIIamg+nFGby1MwDQYJKoZIhvcNAQELBQAwgbIxCzAJBgNVBAYTAlRSMQ8w +DQYDVQQHDAZBbmthcmExQDA+BgNVBAoMN0UtVHXEn3JhIEVCRyBCaWxpxZ9pbSBUZWtub2xvamls +ZXJpIHZlIEhpem1ldGxlcmkgQS7Fni4xJjAkBgNVBAsMHUUtVHVncmEgU2VydGlmaWthc3lvbiBN +ZXJrZXppMSgwJgYDVQQDDB9FLVR1Z3JhIENlcnRpZmljYXRpb24gQXV0aG9yaXR5MB4XDTEzMDMw +NTEyMDk0OFoXDTIzMDMwMzEyMDk0OFowgbIxCzAJBgNVBAYTAlRSMQ8wDQYDVQQHDAZBbmthcmEx +QDA+BgNVBAoMN0UtVHXEn3JhIEVCRyBCaWxpxZ9pbSBUZWtub2xvamlsZXJpIHZlIEhpem1ldGxl +cmkgQS7Fni4xJjAkBgNVBAsMHUUtVHVncmEgU2VydGlmaWthc3lvbiBNZXJrZXppMSgwJgYDVQQD +DB9FLVR1Z3JhIENlcnRpZmljYXRpb24gQXV0aG9yaXR5MIICIjANBgkqhkiG9w0BAQEFAAOCAg8A +MIICCgKCAgEA4vU/kwVRHoViVF56C/UYB4Oufq9899SKa6VjQzm5S/fDxmSJPZQuVIBSOTkHS0vd +hQd2h8y/L5VMzH2nPbxHD5hw+IyFHnSOkm0bQNGZDbt1bsipa5rAhDGvykPL6ys06I+XawGb1Q5K +CKpbknSFQ9OArqGIW66z6l7LFpp3RMih9lRozt6Plyu6W0ACDGQXwLWTzeHxE2bODHnv0ZEoq1+g +ElIwcxmOj+GMB6LDu0rw6h8VqO4lzKRG+Bsi77MOQ7osJLjFLFzUHPhdZL3Dk14opz8n8Y4e0ypQ +BaNV2cvnOVPAmJ6MVGKLJrD3fY185MaeZkJVgkfnsliNZvcHfC425lAcP9tDJMW/hkd5s3kc91r0 +E+xs+D/iWR+V7kI+ua2oMoVJl0b+SzGPWsutdEcf6ZG33ygEIqDUD13ieU/qbIWGvaimzuT6w+Gz +rt48Ue7LE3wBf4QOXVGUnhMMti6lTPk5cDZvlsouDERVxcr6XQKj39ZkjFqzAQqptQpHF//vkUAq +jqFGOjGY5RH8zLtJVor8udBhmm9lbObDyz51Sf6Pp+KJxWfXnUYTTjF2OySznhFlhqt/7x3U+Lzn +rFpct1pHXFXOVbQicVtbC/DP3KBhZOqp12gKY6fgDT+gr9Oq0n7vUaDmUStVkhUXU8u3Zg5mTPj5 +dUyQ5xJwx0UCAwEAAaNjMGEwHQYDVR0OBBYEFC7j27JJ0JxUeVz6Jyr+zE7S6E5UMA8GA1UdEwEB +/wQFMAMBAf8wHwYDVR0jBBgwFoAULuPbsknQnFR5XPonKv7MTtLoTlQwDgYDVR0PAQH/BAQDAgEG +MA0GCSqGSIb3DQEBCwUAA4ICAQAFNzr0TbdF4kV1JI+2d1LoHNgQk2Xz8lkGpD4eKexd0dCrfOAK +kEh47U6YA5n+KGCRHTAduGN8qOY1tfrTYXbm1gdLymmasoR6d5NFFxWfJNCYExL/u6Au/U5Mh/jO +XKqYGwXgAEZKgoClM4so3O0409/lPun++1ndYYRP0lSWE2ETPo+Aab6TR7U1Q9Jauz1c77NCR807 +VRMGsAnb/WP2OogKmW9+4c4bU2pEZiNRCHu8W1Ki/QY3OEBhj0qWuJA3+GbHeJAAFS6LrVE1Uweo +a2iu+U48BybNCAVwzDk/dr2l02cmAYamU9JgO3xDf1WKvJUawSg5TB9D0pH0clmKuVb8P7Sd2nCc +dlqMQ1DujjByTd//SffGqWfZbawCEeI6FiWnWAjLb1NBnEg4R2gz0dfHj9R0IdTDBZB6/86WiLEV +KV0jq9BgoRJP3vQXzTLlyb/IQ639Lo7xr+L0mPoSHyDYwKcMhcWQ9DstliaxLL5Mq+ux0orJ23gT +Dx4JnW2PAJ8C2sH6H3p6CcRK5ogql5+Ji/03X186zjhZhkuvcQu02PJwT58yE+Owp1fl2tpDy4Q0 +8ijE6m30Ku/Ba3ba+367hTzSU8JNvnHhRdH9I2cNE3X7z2VnIp2usAnRCf8dNL/+I5c30jn6PQ0G +C7TbO6Orb1wdtn7os4I07QZcJA== +-----END CERTIFICATE----- + +T-TeleSec GlobalRoot Class 2 +============================ +-----BEGIN CERTIFICATE----- +MIIDwzCCAqugAwIBAgIBATANBgkqhkiG9w0BAQsFADCBgjELMAkGA1UEBhMCREUxKzApBgNVBAoM +IlQtU3lzdGVtcyBFbnRlcnByaXNlIFNlcnZpY2VzIEdtYkgxHzAdBgNVBAsMFlQtU3lzdGVtcyBU +cnVzdCBDZW50ZXIxJTAjBgNVBAMMHFQtVGVsZVNlYyBHbG9iYWxSb290IENsYXNzIDIwHhcNMDgx +MDAxMTA0MDE0WhcNMzMxMDAxMjM1OTU5WjCBgjELMAkGA1UEBhMCREUxKzApBgNVBAoMIlQtU3lz +dGVtcyBFbnRlcnByaXNlIFNlcnZpY2VzIEdtYkgxHzAdBgNVBAsMFlQtU3lzdGVtcyBUcnVzdCBD +ZW50ZXIxJTAjBgNVBAMMHFQtVGVsZVNlYyBHbG9iYWxSb290IENsYXNzIDIwggEiMA0GCSqGSIb3 +DQEBAQUAA4IBDwAwggEKAoIBAQCqX9obX+hzkeXaXPSi5kfl82hVYAUdAqSzm1nzHoqvNK38DcLZ +SBnuaY/JIPwhqgcZ7bBcrGXHX+0CfHt8LRvWurmAwhiCFoT6ZrAIxlQjgeTNuUk/9k9uN0goOA/F +vudocP05l03Sx5iRUKrERLMjfTlH6VJi1hKTXrcxlkIF+3anHqP1wvzpesVsqXFP6st4vGCvx970 +2cu+fjOlbpSD8DT6IavqjnKgP6TeMFvvhk1qlVtDRKgQFRzlAVfFmPHmBiiRqiDFt1MmUUOyCxGV +WOHAD3bZwI18gfNycJ5v/hqO2V81xrJvNHy+SE/iWjnX2J14np+GPgNeGYtEotXHAgMBAAGjQjBA +MA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMB0GA1UdDgQWBBS/WSA2AHmgoCJrjNXy +YdK4LMuCSjANBgkqhkiG9w0BAQsFAAOCAQEAMQOiYQsfdOhyNsZt+U2e+iKo4YFWz827n+qrkRk4 +r6p8FU3ztqONpfSO9kSpp+ghla0+AGIWiPACuvxhI+YzmzB6azZie60EI4RYZeLbK4rnJVM3YlNf +vNoBYimipidx5joifsFvHZVwIEoHNN/q/xWA5brXethbdXwFeilHfkCoMRN3zUA7tFFHei4R40cR +3p1m0IvVVGb6g1XqfMIpiRvpb7PO4gWEyS8+eIVibslfwXhjdFjASBgMmTnrpMwatXlajRWc2BQN +9noHV8cigwUtPJslJj0Ys6lDfMjIq2SPDqO/nBudMNva0Bkuqjzx+zOAduTNrRlPBSeOE6Fuwg== +-----END CERTIFICATE----- + +Atos TrustedRoot 2011 +===================== +-----BEGIN CERTIFICATE----- +MIIDdzCCAl+gAwIBAgIIXDPLYixfszIwDQYJKoZIhvcNAQELBQAwPDEeMBwGA1UEAwwVQXRvcyBU +cnVzdGVkUm9vdCAyMDExMQ0wCwYDVQQKDARBdG9zMQswCQYDVQQGEwJERTAeFw0xMTA3MDcxNDU4 +MzBaFw0zMDEyMzEyMzU5NTlaMDwxHjAcBgNVBAMMFUF0b3MgVHJ1c3RlZFJvb3QgMjAxMTENMAsG +A1UECgwEQXRvczELMAkGA1UEBhMCREUwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCV +hTuXbyo7LjvPpvMpNb7PGKw+qtn4TaA+Gke5vJrf8v7MPkfoepbCJI419KkM/IL9bcFyYie96mvr +54rMVD6QUM+A1JX76LWC1BTFtqlVJVfbsVD2sGBkWXppzwO3bw2+yj5vdHLqqjAqc2K+SZFhyBH+ +DgMq92og3AIVDV4VavzjgsG1xZ1kCWyjWZgHJ8cblithdHFsQ/H3NYkQ4J7sVaE3IqKHBAUsR320 +HLliKWYoyrfhk/WklAOZuXCFteZI6o1Q/NnezG8HDt0Lcp2AMBYHlT8oDv3FdU9T1nSatCQujgKR +z3bFmx5VdJx4IbHwLfELn8LVlhgf8FQieowHAgMBAAGjfTB7MB0GA1UdDgQWBBSnpQaxLKYJYO7R +l+lwrrw7GWzbITAPBgNVHRMBAf8EBTADAQH/MB8GA1UdIwQYMBaAFKelBrEspglg7tGX6XCuvDsZ +bNshMBgGA1UdIAQRMA8wDQYLKwYBBAGwLQMEAQEwDgYDVR0PAQH/BAQDAgGGMA0GCSqGSIb3DQEB +CwUAA4IBAQAmdzTblEiGKkGdLD4GkGDEjKwLVLgfuXvTBznk+j57sj1O7Z8jvZfza1zv7v1Apt+h +k6EKhqzvINB5Ab149xnYJDE0BAGmuhWawyfc2E8PzBhj/5kPDpFrdRbhIfzYJsdHt6bPWHJxfrrh +TZVHO8mvbaG0weyJ9rQPOLXiZNwlz6bb65pcmaHFCN795trV1lpFDMS3wrUU77QR/w4VtfX128a9 +61qn8FYiqTxlVMYVqL2Gns2Dlmh6cYGJ4Qvh6hEbaAjMaZ7snkGeRDImeuKHCnE96+RapNLbxc3G +3mB/ufNPRJLvKrcYPqcZ2Qt9sTdBQrC6YB3y/gkRsPCHe6ed +-----END CERTIFICATE----- + +QuoVadis Root CA 1 G3 +===================== +-----BEGIN CERTIFICATE----- +MIIFYDCCA0igAwIBAgIUeFhfLq0sGUvjNwc1NBMotZbUZZMwDQYJKoZIhvcNAQELBQAwSDELMAkG +A1UEBhMCQk0xGTAXBgNVBAoTEFF1b1ZhZGlzIExpbWl0ZWQxHjAcBgNVBAMTFVF1b1ZhZGlzIFJv +b3QgQ0EgMSBHMzAeFw0xMjAxMTIxNzI3NDRaFw00MjAxMTIxNzI3NDRaMEgxCzAJBgNVBAYTAkJN +MRkwFwYDVQQKExBRdW9WYWRpcyBMaW1pdGVkMR4wHAYDVQQDExVRdW9WYWRpcyBSb290IENBIDEg +RzMwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCgvlAQjunybEC0BJyFuTHK3C3kEakE +PBtVwedYMB0ktMPvhd6MLOHBPd+C5k+tR4ds7FtJwUrVu4/sh6x/gpqG7D0DmVIB0jWerNrwU8lm +PNSsAgHaJNM7qAJGr6Qc4/hzWHa39g6QDbXwz8z6+cZM5cOGMAqNF34168Xfuw6cwI2H44g4hWf6 +Pser4BOcBRiYz5P1sZK0/CPTz9XEJ0ngnjybCKOLXSoh4Pw5qlPafX7PGglTvF0FBM+hSo+LdoIN +ofjSxxR3W5A2B4GbPgb6Ul5jxaYA/qXpUhtStZI5cgMJYr2wYBZupt0lwgNm3fME0UDiTouG9G/l +g6AnhF4EwfWQvTA9xO+oabw4m6SkltFi2mnAAZauy8RRNOoMqv8hjlmPSlzkYZqn0ukqeI1RPToV +7qJZjqlc3sX5kCLliEVx3ZGZbHqfPT2YfF72vhZooF6uCyP8Wg+qInYtyaEQHeTTRCOQiJ/GKubX +9ZqzWB4vMIkIG1SitZgj7Ah3HJVdYdHLiZxfokqRmu8hqkkWCKi9YSgxyXSthfbZxbGL0eUQMk1f +iyA6PEkfM4VZDdvLCXVDaXP7a3F98N/ETH3Goy7IlXnLc6KOTk0k+17kBL5yG6YnLUlamXrXXAkg +t3+UuU/xDRxeiEIbEbfnkduebPRq34wGmAOtzCjvpUfzUwIDAQABo0IwQDAPBgNVHRMBAf8EBTAD +AQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQUo5fW816iEOGrRZ88F2Q87gFwnMwwDQYJKoZI +hvcNAQELBQADggIBABj6W3X8PnrHX3fHyt/PX8MSxEBd1DKquGrX1RUVRpgjpeaQWxiZTOOtQqOC +MTaIzen7xASWSIsBx40Bz1szBpZGZnQdT+3Btrm0DWHMY37XLneMlhwqI2hrhVd2cDMT/uFPpiN3 +GPoajOi9ZcnPP/TJF9zrx7zABC4tRi9pZsMbj/7sPtPKlL92CiUNqXsCHKnQO18LwIE6PWThv6ct +Tr1NxNgpxiIY0MWscgKCP6o6ojoilzHdCGPDdRS5YCgtW2jgFqlmgiNR9etT2DGbe+m3nUvriBbP ++V04ikkwj+3x6xn0dxoxGE1nVGwvb2X52z3sIexe9PSLymBlVNFxZPT5pqOBMzYzcfCkeF9OrYMh +3jRJjehZrJ3ydlo28hP0r+AJx2EqbPfgna67hkooby7utHnNkDPDs3b69fBsnQGQ+p6Q9pxyz0fa +wx/kNSBT8lTR32GDpgLiJTjehTItXnOQUl1CxM49S+H5GYQd1aJQzEH7QRTDvdbJWqNjZgKAvQU6 +O0ec7AAmTPWIUb+oI38YB7AL7YsmoWTTYUrrXJ/es69nA7Mf3W1daWhpq1467HxpvMc7hU6eFbm0 +FU/DlXpY18ls6Wy58yljXrQs8C097Vpl4KlbQMJImYFtnh8GKjwStIsPm6Ik8KaN1nrgS7ZklmOV +hMJKzRwuJIczYOXD +-----END CERTIFICATE----- + +QuoVadis Root CA 2 G3 +===================== +-----BEGIN CERTIFICATE----- +MIIFYDCCA0igAwIBAgIURFc0JFuBiZs18s64KztbpybwdSgwDQYJKoZIhvcNAQELBQAwSDELMAkG +A1UEBhMCQk0xGTAXBgNVBAoTEFF1b1ZhZGlzIExpbWl0ZWQxHjAcBgNVBAMTFVF1b1ZhZGlzIFJv +b3QgQ0EgMiBHMzAeFw0xMjAxMTIxODU5MzJaFw00MjAxMTIxODU5MzJaMEgxCzAJBgNVBAYTAkJN +MRkwFwYDVQQKExBRdW9WYWRpcyBMaW1pdGVkMR4wHAYDVQQDExVRdW9WYWRpcyBSb290IENBIDIg +RzMwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQChriWyARjcV4g/Ruv5r+LrI3HimtFh +ZiFfqq8nUeVuGxbULX1QsFN3vXg6YOJkApt8hpvWGo6t/x8Vf9WVHhLL5hSEBMHfNrMWn4rjyduY +NM7YMxcoRvynyfDStNVNCXJJ+fKH46nafaF9a7I6JaltUkSs+L5u+9ymc5GQYaYDFCDy54ejiK2t +oIz/pgslUiXnFgHVy7g1gQyjO/Dh4fxaXc6AcW34Sas+O7q414AB+6XrW7PFXmAqMaCvN+ggOp+o +MiwMzAkd056OXbxMmO7FGmh77FOm6RQ1o9/NgJ8MSPsc9PG/Srj61YxxSscfrf5BmrODXfKEVu+l +V0POKa2Mq1W/xPtbAd0jIaFYAI7D0GoT7RPjEiuA3GfmlbLNHiJuKvhB1PLKFAeNilUSxmn1uIZo +L1NesNKqIcGY5jDjZ1XHm26sGahVpkUG0CM62+tlXSoREfA7T8pt9DTEceT/AFr2XK4jYIVz8eQQ +sSWu1ZK7E8EM4DnatDlXtas1qnIhO4M15zHfeiFuuDIIfR0ykRVKYnLP43ehvNURG3YBZwjgQQvD +6xVu+KQZ2aKrr+InUlYrAoosFCT5v0ICvybIxo/gbjh9Uy3l7ZizlWNof/k19N+IxWA1ksB8aRxh +lRbQ694Lrz4EEEVlWFA4r0jyWbYW8jwNkALGcC4BrTwV1wIDAQABo0IwQDAPBgNVHRMBAf8EBTAD +AQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQU7edvdlq/YOxJW8ald7tyFnGbxD0wDQYJKoZI +hvcNAQELBQADggIBAJHfgD9DCX5xwvfrs4iP4VGyvD11+ShdyLyZm3tdquXK4Qr36LLTn91nMX66 +AarHakE7kNQIXLJgapDwyM4DYvmL7ftuKtwGTTwpD4kWilhMSA/ohGHqPHKmd+RCroijQ1h5fq7K +pVMNqT1wvSAZYaRsOPxDMuHBR//47PERIjKWnML2W2mWeyAMQ0GaW/ZZGYjeVYg3UQt4XAoeo0L9 +x52ID8DyeAIkVJOviYeIyUqAHerQbj5hLja7NQ4nlv1mNDthcnPxFlxHBlRJAHpYErAK74X9sbgz +dWqTHBLmYF5vHX/JHyPLhGGfHoJE+V+tYlUkmlKY7VHnoX6XOuYvHxHaU4AshZ6rNRDbIl9qxV6X +U/IyAgkwo1jwDQHVcsaxfGl7w/U2Rcxhbl5MlMVerugOXou/983g7aEOGzPuVBj+D77vfoRrQ+Nw +mNtddbINWQeFFSM51vHfqSYP1kjHs6Yi9TM3WpVHn3u6GBVv/9YUZINJ0gpnIdsPNWNgKCLjsZWD +zYWm3S8P52dSbrsvhXz1SnPnxT7AvSESBT/8twNJAlvIJebiVDj1eYeMHVOyToV7BjjHLPj4sHKN +JeV3UvQDHEimUF+IIDBu8oJDqz2XhOdT+yHBTw8imoa4WSr2Rz0ZiC3oheGe7IUIarFsNMkd7Egr +O3jtZsSOeWmD3n+M +-----END CERTIFICATE----- + +QuoVadis Root CA 3 G3 +===================== +-----BEGIN CERTIFICATE----- +MIIFYDCCA0igAwIBAgIULvWbAiin23r/1aOp7r0DoM8Sah0wDQYJKoZIhvcNAQELBQAwSDELMAkG +A1UEBhMCQk0xGTAXBgNVBAoTEFF1b1ZhZGlzIExpbWl0ZWQxHjAcBgNVBAMTFVF1b1ZhZGlzIFJv +b3QgQ0EgMyBHMzAeFw0xMjAxMTIyMDI2MzJaFw00MjAxMTIyMDI2MzJaMEgxCzAJBgNVBAYTAkJN +MRkwFwYDVQQKExBRdW9WYWRpcyBMaW1pdGVkMR4wHAYDVQQDExVRdW9WYWRpcyBSb290IENBIDMg +RzMwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCzyw4QZ47qFJenMioKVjZ/aEzHs286 +IxSR/xl/pcqs7rN2nXrpixurazHb+gtTTK/FpRp5PIpM/6zfJd5O2YIyC0TeytuMrKNuFoM7pmRL +Mon7FhY4futD4tN0SsJiCnMK3UmzV9KwCoWdcTzeo8vAMvMBOSBDGzXRU7Ox7sWTaYI+FrUoRqHe +6okJ7UO4BUaKhvVZR74bbwEhELn9qdIoyhA5CcoTNs+cra1AdHkrAj80//ogaX3T7mH1urPnMNA3 +I4ZyYUUpSFlob3emLoG+B01vr87ERRORFHAGjx+f+IdpsQ7vw4kZ6+ocYfx6bIrc1gMLnia6Et3U +VDmrJqMz6nWB2i3ND0/kA9HvFZcba5DFApCTZgIhsUfei5pKgLlVj7WiL8DWM2fafsSntARE60f7 +5li59wzweyuxwHApw0BiLTtIadwjPEjrewl5qW3aqDCYz4ByA4imW0aucnl8CAMhZa634RylsSqi +Md5mBPfAdOhx3v89WcyWJhKLhZVXGqtrdQtEPREoPHtht+KPZ0/l7DxMYIBpVzgeAVuNVejH38DM +dyM0SXV89pgR6y3e7UEuFAUCf+D+IOs15xGsIs5XPd7JMG0QA4XN8f+MFrXBsj6IbGB/kE+V9/Yt +rQE5BwT6dYB9v0lQ7e/JxHwc64B+27bQ3RP+ydOc17KXqQIDAQABo0IwQDAPBgNVHRMBAf8EBTAD +AQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQUxhfQvKjqAkPyGwaZXSuQILnXnOQwDQYJKoZI +hvcNAQELBQADggIBADRh2Va1EodVTd2jNTFGu6QHcrxfYWLopfsLN7E8trP6KZ1/AvWkyaiTt3px +KGmPc+FSkNrVvjrlt3ZqVoAh313m6Tqe5T72omnHKgqwGEfcIHB9UqM+WXzBusnIFUBhynLWcKzS +t/Ac5IYp8M7vaGPQtSCKFWGafoaYtMnCdvvMujAWzKNhxnQT5WvvoxXqA/4Ti2Tk08HS6IT7SdEQ +TXlm66r99I0xHnAUrdzeZxNMgRVhvLfZkXdxGYFgu/BYpbWcC/ePIlUnwEsBbTuZDdQdm2NnL9Du +DcpmvJRPpq3t/O5jrFc/ZSXPsoaP0Aj/uHYUbt7lJ+yreLVTubY/6CD50qi+YUbKh4yE8/nxoGib +Ih6BJpsQBJFxwAYf3KDTuVan45gtf4Od34wrnDKOMpTwATwiKp9Dwi7DmDkHOHv8XgBCH/MyJnmD +hPbl8MFREsALHgQjDFSlTC9JxUrRtm5gDWv8a4uFJGS3iQ6rJUdbPM9+Sb3H6QrG2vd+DhcI00iX +0HGS8A85PjRqHH3Y8iKuu2n0M7SmSFXRDw4m6Oy2Cy2nhTXN/VnIn9HNPlopNLk9hM6xZdRZkZFW +dSHBd575euFgndOtBBj0fOtek49TSiIp+EgrPk2GrFt/ywaZWWDYWGWVjUTR939+J399roD1B0y2 +PpxxVJkES/1Y+Zj0 +-----END CERTIFICATE----- + +DigiCert Assured ID Root G2 +=========================== +-----BEGIN CERTIFICATE----- +MIIDljCCAn6gAwIBAgIQC5McOtY5Z+pnI7/Dr5r0SzANBgkqhkiG9w0BAQsFADBlMQswCQYDVQQG +EwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3d3cuZGlnaWNlcnQuY29tMSQw +IgYDVQQDExtEaWdpQ2VydCBBc3N1cmVkIElEIFJvb3QgRzIwHhcNMTMwODAxMTIwMDAwWhcNMzgw +MTE1MTIwMDAwWjBlMQswCQYDVQQGEwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQL +ExB3d3cuZGlnaWNlcnQuY29tMSQwIgYDVQQDExtEaWdpQ2VydCBBc3N1cmVkIElEIFJvb3QgRzIw +ggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDZ5ygvUj82ckmIkzTz+GoeMVSAn61UQbVH +35ao1K+ALbkKz3X9iaV9JPrjIgwrvJUXCzO/GU1BBpAAvQxNEP4HteccbiJVMWWXvdMX0h5i89vq +bFCMP4QMls+3ywPgym2hFEwbid3tALBSfK+RbLE4E9HpEgjAALAcKxHad3A2m67OeYfcgnDmCXRw +VWmvo2ifv922ebPynXApVfSr/5Vh88lAbx3RvpO704gqu52/clpWcTs/1PPRCv4o76Pu2ZmvA9OP +YLfykqGxvYmJHzDNw6YuYjOuFgJ3RFrngQo8p0Quebg/BLxcoIfhG69Rjs3sLPr4/m3wOnyqi+Rn +lTGNAgMBAAGjQjBAMA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgGGMB0GA1UdDgQWBBTO +w0q5mVXyuNtgv6l+vVa1lzan1jANBgkqhkiG9w0BAQsFAAOCAQEAyqVVjOPIQW5pJ6d1Ee88hjZv +0p3GeDgdaZaikmkuOGybfQTUiaWxMTeKySHMq2zNixya1r9I0jJmwYrA8y8678Dj1JGG0VDjA9tz +d29KOVPt3ibHtX2vK0LRdWLjSisCx1BL4GnilmwORGYQRI+tBev4eaymG+g3NJ1TyWGqolKvSnAW +hsI6yLETcDbYz+70CjTVW0z9B5yiutkBclzzTcHdDrEcDcRjvq30FPuJ7KJBDkzMyFdA0G4Dqs0M +jomZmWzwPDCvON9vvKO+KSAnq3T/EyJ43pdSVR6DtVQgA+6uwE9W3jfMw3+qBCe703e4YtsXfJwo +IhNzbM8m9Yop5w== +-----END CERTIFICATE----- + +DigiCert Assured ID Root G3 +=========================== +-----BEGIN CERTIFICATE----- +MIICRjCCAc2gAwIBAgIQC6Fa+h3foLVJRK/NJKBs7DAKBggqhkjOPQQDAzBlMQswCQYDVQQGEwJV +UzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3d3cuZGlnaWNlcnQuY29tMSQwIgYD +VQQDExtEaWdpQ2VydCBBc3N1cmVkIElEIFJvb3QgRzMwHhcNMTMwODAxMTIwMDAwWhcNMzgwMTE1 +MTIwMDAwWjBlMQswCQYDVQQGEwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3 +d3cuZGlnaWNlcnQuY29tMSQwIgYDVQQDExtEaWdpQ2VydCBBc3N1cmVkIElEIFJvb3QgRzMwdjAQ +BgcqhkjOPQIBBgUrgQQAIgNiAAQZ57ysRGXtzbg/WPuNsVepRC0FFfLvC/8QdJ+1YlJfZn4f5dwb +RXkLzMZTCp2NXQLZqVneAlr2lSoOjThKiknGvMYDOAdfVdp+CW7if17QRSAPWXYQ1qAk8C3eNvJs +KTmjQjBAMA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgGGMB0GA1UdDgQWBBTL0L2p4ZgF +UaFNN6KDec6NHSrkhDAKBggqhkjOPQQDAwNnADBkAjAlpIFFAmsSS3V0T8gj43DydXLefInwz5Fy +YZ5eEJJZVrmDxxDnOOlYJjZ91eQ0hjkCMHw2U/Aw5WJjOpnitqM7mzT6HtoQknFekROn3aRukswy +1vUhZscv6pZjamVFkpUBtA== +-----END CERTIFICATE----- + +DigiCert Global Root G2 +======================= +-----BEGIN CERTIFICATE----- +MIIDjjCCAnagAwIBAgIQAzrx5qcRqaC7KGSxHQn65TANBgkqhkiG9w0BAQsFADBhMQswCQYDVQQG +EwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3d3cuZGlnaWNlcnQuY29tMSAw +HgYDVQQDExdEaWdpQ2VydCBHbG9iYWwgUm9vdCBHMjAeFw0xMzA4MDExMjAwMDBaFw0zODAxMTUx +MjAwMDBaMGExCzAJBgNVBAYTAlVTMRUwEwYDVQQKEwxEaWdpQ2VydCBJbmMxGTAXBgNVBAsTEHd3 +dy5kaWdpY2VydC5jb20xIDAeBgNVBAMTF0RpZ2lDZXJ0IEdsb2JhbCBSb290IEcyMIIBIjANBgkq +hkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAuzfNNNx7a8myaJCtSnX/RrohCgiN9RlUyfuI2/Ou8jqJ +kTx65qsGGmvPrC3oXgkkRLpimn7Wo6h+4FR1IAWsULecYxpsMNzaHxmx1x7e/dfgy5SDN67sH0NO +3Xss0r0upS/kqbitOtSZpLYl6ZtrAGCSYP9PIUkY92eQq2EGnI/yuum06ZIya7XzV+hdG82MHauV +BJVJ8zUtluNJbd134/tJS7SsVQepj5WztCO7TG1F8PapspUwtP1MVYwnSlcUfIKdzXOS0xZKBgyM +UNGPHgm+F6HmIcr9g+UQvIOlCsRnKPZzFBQ9RnbDhxSJITRNrw9FDKZJobq7nMWxM4MphQIDAQAB +o0IwQDAPBgNVHRMBAf8EBTADAQH/MA4GA1UdDwEB/wQEAwIBhjAdBgNVHQ4EFgQUTiJUIBiV5uNu +5g/6+rkS7QYXjzkwDQYJKoZIhvcNAQELBQADggEBAGBnKJRvDkhj6zHd6mcY1Yl9PMWLSn/pvtsr +F9+wX3N3KjITOYFnQoQj8kVnNeyIv/iPsGEMNKSuIEyExtv4NeF22d+mQrvHRAiGfzZ0JFrabA0U +WTW98kndth/Jsw1HKj2ZL7tcu7XUIOGZX1NGFdtom/DzMNU+MeKNhJ7jitralj41E6Vf8PlwUHBH +QRFXGU7Aj64GxJUTFy8bJZ918rGOmaFvE7FBcf6IKshPECBV1/MUReXgRPTqh5Uykw7+U0b6LJ3/ +iyK5S9kJRaTepLiaWN0bfVKfjllDiIGknibVb63dDcY3fe0Dkhvld1927jyNxF1WW6LZZm6zNTfl +MrY= +-----END CERTIFICATE----- + +DigiCert Global Root G3 +======================= +-----BEGIN CERTIFICATE----- +MIICPzCCAcWgAwIBAgIQBVVWvPJepDU1w6QP1atFcjAKBggqhkjOPQQDAzBhMQswCQYDVQQGEwJV +UzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3d3cuZGlnaWNlcnQuY29tMSAwHgYD +VQQDExdEaWdpQ2VydCBHbG9iYWwgUm9vdCBHMzAeFw0xMzA4MDExMjAwMDBaFw0zODAxMTUxMjAw +MDBaMGExCzAJBgNVBAYTAlVTMRUwEwYDVQQKEwxEaWdpQ2VydCBJbmMxGTAXBgNVBAsTEHd3dy5k +aWdpY2VydC5jb20xIDAeBgNVBAMTF0RpZ2lDZXJ0IEdsb2JhbCBSb290IEczMHYwEAYHKoZIzj0C +AQYFK4EEACIDYgAE3afZu4q4C/sLfyHS8L6+c/MzXRq8NOrexpu80JX28MzQC7phW1FGfp4tn+6O +YwwX7Adw9c+ELkCDnOg/QW07rdOkFFk2eJ0DQ+4QE2xy3q6Ip6FrtUPOZ9wj/wMco+I+o0IwQDAP +BgNVHRMBAf8EBTADAQH/MA4GA1UdDwEB/wQEAwIBhjAdBgNVHQ4EFgQUs9tIpPmhxdiuNkHMEWNp +Yim8S8YwCgYIKoZIzj0EAwMDaAAwZQIxAK288mw/EkrRLTnDCgmXc/SINoyIJ7vmiI1Qhadj+Z4y +3maTD/HMsQmP3Wyr+mt/oAIwOWZbwmSNuJ5Q3KjVSaLtx9zRSX8XAbjIho9OjIgrqJqpisXRAL34 +VOKa5Vt8sycX +-----END CERTIFICATE----- + +DigiCert Trusted Root G4 +======================== +-----BEGIN CERTIFICATE----- +MIIFkDCCA3igAwIBAgIQBZsbV56OITLiOQe9p3d1XDANBgkqhkiG9w0BAQwFADBiMQswCQYDVQQG +EwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3d3cuZGlnaWNlcnQuY29tMSEw +HwYDVQQDExhEaWdpQ2VydCBUcnVzdGVkIFJvb3QgRzQwHhcNMTMwODAxMTIwMDAwWhcNMzgwMTE1 +MTIwMDAwWjBiMQswCQYDVQQGEwJVUzEVMBMGA1UEChMMRGlnaUNlcnQgSW5jMRkwFwYDVQQLExB3 +d3cuZGlnaWNlcnQuY29tMSEwHwYDVQQDExhEaWdpQ2VydCBUcnVzdGVkIFJvb3QgRzQwggIiMA0G +CSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQC/5pBzaN675F1KPDAiMGkz7MKnJS7JIT3yithZwuEp +pz1Yq3aaza57G4QNxDAf8xukOBbrVsaXbR2rsnnyyhHS5F/WBTxSD1Ifxp4VpX6+n6lXFllVcq9o +k3DCsrp1mWpzMpTREEQQLt+C8weE5nQ7bXHiLQwb7iDVySAdYyktzuxeTsiT+CFhmzTrBcZe7Fsa +vOvJz82sNEBfsXpm7nfISKhmV1efVFiODCu3T6cw2Vbuyntd463JT17lNecxy9qTXtyOj4DatpGY +QJB5w3jHtrHEtWoYOAMQjdjUN6QuBX2I9YI+EJFwq1WCQTLX2wRzKm6RAXwhTNS8rhsDdV14Ztk6 +MUSaM0C/CNdaSaTC5qmgZ92kJ7yhTzm1EVgX9yRcRo9k98FpiHaYdj1ZXUJ2h4mXaXpI8OCiEhtm +mnTK3kse5w5jrubU75KSOp493ADkRSWJtppEGSt+wJS00mFt6zPZxd9LBADMfRyVw4/3IbKyEbe7 +f/LVjHAsQWCqsWMYRJUadmJ+9oCw++hkpjPRiQfhvbfmQ6QYuKZ3AeEPlAwhHbJUKSWJbOUOUlFH +dL4mrLZBdd56rF+NP8m800ERElvlEFDrMcXKchYiCd98THU/Y+whX8QgUWtvsauGi0/C1kVfnSD8 +oR7FwI+isX4KJpn15GkvmB0t9dmpsh3lGwIDAQABo0IwQDAPBgNVHRMBAf8EBTADAQH/MA4GA1Ud +DwEB/wQEAwIBhjAdBgNVHQ4EFgQU7NfjgtJxXWRM3y5nP+e6mK4cD08wDQYJKoZIhvcNAQEMBQAD +ggIBALth2X2pbL4XxJEbw6GiAI3jZGgPVs93rnD5/ZpKmbnJeFwMDF/k5hQpVgs2SV1EY+CtnJYY +ZhsjDT156W1r1lT40jzBQ0CuHVD1UvyQO7uYmWlrx8GnqGikJ9yd+SeuMIW59mdNOj6PWTkiU0Tr +yF0Dyu1Qen1iIQqAyHNm0aAFYF/opbSnr6j3bTWcfFqK1qI4mfN4i/RN0iAL3gTujJtHgXINwBQy +7zBZLq7gcfJW5GqXb5JQbZaNaHqasjYUegbyJLkJEVDXCLG4iXqEI2FCKeWjzaIgQdfRnGTZ6iah +ixTXTBmyUEFxPT9NcCOGDErcgdLMMpSEDQgJlxxPwO5rIHQw0uA5NBCFIRUBCOhVMt5xSdkoF1BN +5r5N0XWs0Mr7QbhDparTwwVETyw2m+L64kW4I1NsBm9nVX9GtUw/bihaeSbSpKhil9Ie4u1Ki7wb +/UdKDd9nZn6yW0HQO+T0O/QEY+nvwlQAUaCKKsnOeMzV6ocEGLPOr0mIr/OSmbaz5mEP0oUA51Aa +5BuVnRmhuZyxm7EAHu/QD09CbMkKvO5D+jpxpchNJqU1/YldvIViHTLSoCtU7ZpXwdv6EM8Zt4tK +G48BtieVU+i2iW1bvGjUI+iLUaJW+fCmgKDWHrO8Dw9TdSmq6hN35N6MgSGtBxBHEa2HPQfRdbzP +82Z+ +-----END CERTIFICATE----- + +COMODO RSA Certification Authority +================================== +-----BEGIN CERTIFICATE----- +MIIF2DCCA8CgAwIBAgIQTKr5yttjb+Af907YWwOGnTANBgkqhkiG9w0BAQwFADCBhTELMAkGA1UE +BhMCR0IxGzAZBgNVBAgTEkdyZWF0ZXIgTWFuY2hlc3RlcjEQMA4GA1UEBxMHU2FsZm9yZDEaMBgG +A1UEChMRQ09NT0RPIENBIExpbWl0ZWQxKzApBgNVBAMTIkNPTU9ETyBSU0EgQ2VydGlmaWNhdGlv +biBBdXRob3JpdHkwHhcNMTAwMTE5MDAwMDAwWhcNMzgwMTE4MjM1OTU5WjCBhTELMAkGA1UEBhMC +R0IxGzAZBgNVBAgTEkdyZWF0ZXIgTWFuY2hlc3RlcjEQMA4GA1UEBxMHU2FsZm9yZDEaMBgGA1UE +ChMRQ09NT0RPIENBIExpbWl0ZWQxKzApBgNVBAMTIkNPTU9ETyBSU0EgQ2VydGlmaWNhdGlvbiBB +dXRob3JpdHkwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCR6FSS0gpWsawNJN3Fz0Rn +dJkrN6N9I3AAcbxT38T6KhKPS38QVr2fcHK3YX/JSw8Xpz3jsARh7v8Rl8f0hj4K+j5c+ZPmNHrZ +FGvnnLOFoIJ6dq9xkNfs/Q36nGz637CC9BR++b7Epi9Pf5l/tfxnQ3K9DADWietrLNPtj5gcFKt+ +5eNu/Nio5JIk2kNrYrhV/erBvGy2i/MOjZrkm2xpmfh4SDBF1a3hDTxFYPwyllEnvGfDyi62a+pG +x8cgoLEfZd5ICLqkTqnyg0Y3hOvozIFIQ2dOciqbXL1MGyiKXCJ7tKuY2e7gUYPDCUZObT6Z+pUX +2nwzV0E8jVHtC7ZcryxjGt9XyD+86V3Em69FmeKjWiS0uqlWPc9vqv9JWL7wqP/0uK3pN/u6uPQL +OvnoQ0IeidiEyxPx2bvhiWC4jChWrBQdnArncevPDt09qZahSL0896+1DSJMwBGB7FY79tOi4lu3 +sgQiUpWAk2nojkxl8ZEDLXB0AuqLZxUpaVICu9ffUGpVRr+goyhhf3DQw6KqLCGqR84onAZFdr+C +GCe01a60y1Dma/RMhnEw6abfFobg2P9A3fvQQoh/ozM6LlweQRGBY84YcWsr7KaKtzFcOmpH4MN5 +WdYgGq/yapiqcrxXStJLnbsQ/LBMQeXtHT1eKJ2czL+zUdqnR+WEUwIDAQABo0IwQDAdBgNVHQ4E +FgQUu69+Aj36pvE8hI6t7jiY7NkyMtQwDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8w +DQYJKoZIhvcNAQEMBQADggIBAArx1UaEt65Ru2yyTUEUAJNMnMvlwFTPoCWOAvn9sKIN9SCYPBMt +rFaisNZ+EZLpLrqeLppysb0ZRGxhNaKatBYSaVqM4dc+pBroLwP0rmEdEBsqpIt6xf4FpuHA1sj+ +nq6PK7o9mfjYcwlYRm6mnPTXJ9OV2jeDchzTc+CiR5kDOF3VSXkAKRzH7JsgHAckaVd4sjn8OoSg +tZx8jb8uk2IntznaFxiuvTwJaP+EmzzV1gsD41eeFPfR60/IvYcjt7ZJQ3mFXLrrkguhxuhoqEwW +sRqZCuhTLJK7oQkYdQxlqHvLI7cawiiFwxv/0Cti76R7CZGYZ4wUAc1oBmpjIXUDgIiKboHGhfKp +pC3n9KUkEEeDys30jXlYsQab5xoq2Z0B15R97QNKyvDb6KkBPvVWmckejkk9u+UJueBPSZI9FoJA +zMxZxuY67RIuaTxslbH9qh17f4a+Hg4yRvv7E491f0yLS0Zj/gA0QHDBw7mh3aZw4gSzQbzpgJHq +ZJx64SIDqZxubw5lT2yHh17zbqD5daWbQOhTsiedSrnAdyGN/4fy3ryM7xfft0kL0fJuMAsaDk52 +7RH89elWsn2/x20Kk4yl0MC2Hb46TpSi125sC8KKfPog88Tk5c0NqMuRkrF8hey1FGlmDoLnzc7I +LaZRfyHBNVOFBkpdn627G190 +-----END CERTIFICATE----- + +USERTrust RSA Certification Authority +===================================== +-----BEGIN CERTIFICATE----- +MIIF3jCCA8agAwIBAgIQAf1tMPyjylGoG7xkDjUDLTANBgkqhkiG9w0BAQwFADCBiDELMAkGA1UE +BhMCVVMxEzARBgNVBAgTCk5ldyBKZXJzZXkxFDASBgNVBAcTC0plcnNleSBDaXR5MR4wHAYDVQQK +ExVUaGUgVVNFUlRSVVNUIE5ldHdvcmsxLjAsBgNVBAMTJVVTRVJUcnVzdCBSU0EgQ2VydGlmaWNh +dGlvbiBBdXRob3JpdHkwHhcNMTAwMjAxMDAwMDAwWhcNMzgwMTE4MjM1OTU5WjCBiDELMAkGA1UE +BhMCVVMxEzARBgNVBAgTCk5ldyBKZXJzZXkxFDASBgNVBAcTC0plcnNleSBDaXR5MR4wHAYDVQQK +ExVUaGUgVVNFUlRSVVNUIE5ldHdvcmsxLjAsBgNVBAMTJVVTRVJUcnVzdCBSU0EgQ2VydGlmaWNh +dGlvbiBBdXRob3JpdHkwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCAEmUXNg7D2wiz +0KxXDXbtzSfTTK1Qg2HiqiBNCS1kCdzOiZ/MPans9s/B3PHTsdZ7NygRK0faOca8Ohm0X6a9fZ2j +Y0K2dvKpOyuR+OJv0OwWIJAJPuLodMkYtJHUYmTbf6MG8YgYapAiPLz+E/CHFHv25B+O1ORRxhFn +RghRy4YUVD+8M/5+bJz/Fp0YvVGONaanZshyZ9shZrHUm3gDwFA66Mzw3LyeTP6vBZY1H1dat//O ++T23LLb2VN3I5xI6Ta5MirdcmrS3ID3KfyI0rn47aGYBROcBTkZTmzNg95S+UzeQc0PzMsNT79uq +/nROacdrjGCT3sTHDN/hMq7MkztReJVni+49Vv4M0GkPGw/zJSZrM233bkf6c0Plfg6lZrEpfDKE +Y1WJxA3Bk1QwGROs0303p+tdOmw1XNtB1xLaqUkL39iAigmTYo61Zs8liM2EuLE/pDkP2QKe6xJM +lXzzawWpXhaDzLhn4ugTncxbgtNMs+1b/97lc6wjOy0AvzVVdAlJ2ElYGn+SNuZRkg7zJn0cTRe8 +yexDJtC/QV9AqURE9JnnV4eeUB9XVKg+/XRjL7FQZQnmWEIuQxpMtPAlR1n6BB6T1CZGSlCBst6+ +eLf8ZxXhyVeEHg9j1uliutZfVS7qXMYoCAQlObgOK6nyTJccBz8NUvXt7y+CDwIDAQABo0IwQDAd +BgNVHQ4EFgQUU3m/WqorSs9UgOHYm8Cd8rIDZsswDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQF +MAMBAf8wDQYJKoZIhvcNAQEMBQADggIBAFzUfA3P9wF9QZllDHPFUp/L+M+ZBn8b2kMVn54CVVeW +FPFSPCeHlCjtHzoBN6J2/FNQwISbxmtOuowhT6KOVWKR82kV2LyI48SqC/3vqOlLVSoGIG1VeCkZ +7l8wXEskEVX/JJpuXior7gtNn3/3ATiUFJVDBwn7YKnuHKsSjKCaXqeYalltiz8I+8jRRa8YFWSQ +Eg9zKC7F4iRO/Fjs8PRF/iKz6y+O0tlFYQXBl2+odnKPi4w2r78NBc5xjeambx9spnFixdjQg3IM +8WcRiQycE0xyNN+81XHfqnHd4blsjDwSXWXavVcStkNr/+XeTWYRUc+ZruwXtuhxkYzeSf7dNXGi +FSeUHM9h4ya7b6NnJSFd5t0dCy5oGzuCr+yDZ4XUmFF0sbmZgIn/f3gZXHlKYC6SQK5MNyosycdi +yA5d9zZbyuAlJQG03RoHnHcAP9Dc1ew91Pq7P8yF1m9/qS3fuQL39ZeatTXaw2ewh0qpKJ4jjv9c +J2vhsE/zB+4ALtRZh8tSQZXq9EfX7mRBVXyNWQKV3WKdwrnuWih0hKWbt5DHDAff9Yk2dDLWKMGw +sAvgnEzDHNb842m1R0aBL6KCq9NjRHDEjf8tM7qtj3u1cIiuPhnPQCjY/MiQu12ZIvVS5ljFH4gx +Q+6IHdfGjjxDah2nGN59PRbxYvnKkKj9 +-----END CERTIFICATE----- + +USERTrust ECC Certification Authority +===================================== +-----BEGIN CERTIFICATE----- +MIICjzCCAhWgAwIBAgIQXIuZxVqUxdJxVt7NiYDMJjAKBggqhkjOPQQDAzCBiDELMAkGA1UEBhMC +VVMxEzARBgNVBAgTCk5ldyBKZXJzZXkxFDASBgNVBAcTC0plcnNleSBDaXR5MR4wHAYDVQQKExVU +aGUgVVNFUlRSVVNUIE5ldHdvcmsxLjAsBgNVBAMTJVVTRVJUcnVzdCBFQ0MgQ2VydGlmaWNhdGlv +biBBdXRob3JpdHkwHhcNMTAwMjAxMDAwMDAwWhcNMzgwMTE4MjM1OTU5WjCBiDELMAkGA1UEBhMC +VVMxEzARBgNVBAgTCk5ldyBKZXJzZXkxFDASBgNVBAcTC0plcnNleSBDaXR5MR4wHAYDVQQKExVU +aGUgVVNFUlRSVVNUIE5ldHdvcmsxLjAsBgNVBAMTJVVTRVJUcnVzdCBFQ0MgQ2VydGlmaWNhdGlv +biBBdXRob3JpdHkwdjAQBgcqhkjOPQIBBgUrgQQAIgNiAAQarFRaqfloI+d61SRvU8Za2EurxtW2 +0eZzca7dnNYMYf3boIkDuAUU7FfO7l0/4iGzzvfUinngo4N+LZfQYcTxmdwlkWOrfzCjtHDix6Ez +nPO/LlxTsV+zfTJ/ijTjeXmjQjBAMB0GA1UdDgQWBBQ64QmG1M8ZwpZ2dEl23OA1xmNjmjAOBgNV +HQ8BAf8EBAMCAQYwDwYDVR0TAQH/BAUwAwEB/zAKBggqhkjOPQQDAwNoADBlAjA2Z6EWCNzklwBB +HU6+4WMBzzuqQhFkoJ2UOQIReVx7Hfpkue4WQrO/isIJxOzksU0CMQDpKmFHjFJKS04YcPbWRNZu +9YO6bVi9JNlWSOrvxKJGgYhqOkbRqZtNyWHa0V1Xahg= +-----END CERTIFICATE----- + +GlobalSign ECC Root CA - R4 +=========================== +-----BEGIN CERTIFICATE----- +MIIB4TCCAYegAwIBAgIRKjikHJYKBN5CsiilC+g0mAIwCgYIKoZIzj0EAwIwUDEkMCIGA1UECxMb +R2xvYmFsU2lnbiBFQ0MgUm9vdCBDQSAtIFI0MRMwEQYDVQQKEwpHbG9iYWxTaWduMRMwEQYDVQQD +EwpHbG9iYWxTaWduMB4XDTEyMTExMzAwMDAwMFoXDTM4MDExOTAzMTQwN1owUDEkMCIGA1UECxMb +R2xvYmFsU2lnbiBFQ0MgUm9vdCBDQSAtIFI0MRMwEQYDVQQKEwpHbG9iYWxTaWduMRMwEQYDVQQD +EwpHbG9iYWxTaWduMFkwEwYHKoZIzj0CAQYIKoZIzj0DAQcDQgAEuMZ5049sJQ6fLjkZHAOkrprl +OQcJFspjsbmG+IpXwVfOQvpzofdlQv8ewQCybnMO/8ch5RikqtlxP6jUuc6MHaNCMEAwDgYDVR0P +AQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYEFFSwe61FuOJAf/sKbvu+M8k8o4TV +MAoGCCqGSM49BAMCA0gAMEUCIQDckqGgE6bPA7DmxCGXkPoUVy0D7O48027KqGx2vKLeuwIgJ6iF +JzWbVsaj8kfSt24bAgAXqmemFZHe+pTsewv4n4Q= +-----END CERTIFICATE----- + +GlobalSign ECC Root CA - R5 +=========================== +-----BEGIN CERTIFICATE----- +MIICHjCCAaSgAwIBAgIRYFlJ4CYuu1X5CneKcflK2GwwCgYIKoZIzj0EAwMwUDEkMCIGA1UECxMb +R2xvYmFsU2lnbiBFQ0MgUm9vdCBDQSAtIFI1MRMwEQYDVQQKEwpHbG9iYWxTaWduMRMwEQYDVQQD +EwpHbG9iYWxTaWduMB4XDTEyMTExMzAwMDAwMFoXDTM4MDExOTAzMTQwN1owUDEkMCIGA1UECxMb +R2xvYmFsU2lnbiBFQ0MgUm9vdCBDQSAtIFI1MRMwEQYDVQQKEwpHbG9iYWxTaWduMRMwEQYDVQQD +EwpHbG9iYWxTaWduMHYwEAYHKoZIzj0CAQYFK4EEACIDYgAER0UOlvt9Xb/pOdEh+J8LttV7HpI6 +SFkc8GIxLcB6KP4ap1yztsyX50XUWPrRd21DosCHZTQKH3rd6zwzocWdTaRvQZU4f8kehOvRnkmS +h5SHDDqFSmafnVmTTZdhBoZKo0IwQDAOBgNVHQ8BAf8EBAMCAQYwDwYDVR0TAQH/BAUwAwEB/zAd +BgNVHQ4EFgQUPeYpSJvqB8ohREom3m7e0oPQn1kwCgYIKoZIzj0EAwMDaAAwZQIxAOVpEslu28Yx +uglB4Zf4+/2a4n0Sye18ZNPLBSWLVtmg515dTguDnFt2KaAJJiFqYgIwcdK1j1zqO+F4CYWodZI7 +yFz9SO8NdCKoCOJuxUnOxwy8p2Fp8fc74SrL+SvzZpA3 +-----END CERTIFICATE----- + +Staat der Nederlanden Root CA - G3 +================================== +-----BEGIN CERTIFICATE----- +MIIFdDCCA1ygAwIBAgIEAJiiOTANBgkqhkiG9w0BAQsFADBaMQswCQYDVQQGEwJOTDEeMBwGA1UE +CgwVU3RhYXQgZGVyIE5lZGVybGFuZGVuMSswKQYDVQQDDCJTdGFhdCBkZXIgTmVkZXJsYW5kZW4g +Um9vdCBDQSAtIEczMB4XDTEzMTExNDExMjg0MloXDTI4MTExMzIzMDAwMFowWjELMAkGA1UEBhMC +TkwxHjAcBgNVBAoMFVN0YWF0IGRlciBOZWRlcmxhbmRlbjErMCkGA1UEAwwiU3RhYXQgZGVyIE5l +ZGVybGFuZGVuIFJvb3QgQ0EgLSBHMzCCAiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBAL4y +olQPcPssXFnrbMSkUeiFKrPMSjTysF/zDsccPVMeiAho2G89rcKezIJnByeHaHE6n3WWIkYFsO2t +x1ueKt6c/DrGlaf1F2cY5y9JCAxcz+bMNO14+1Cx3Gsy8KL+tjzk7FqXxz8ecAgwoNzFs21v0IJy +EavSgWhZghe3eJJg+szeP4TrjTgzkApyI/o1zCZxMdFyKJLZWyNtZrVtB0LrpjPOktvA9mxjeM3K +Tj215VKb8b475lRgsGYeCasH/lSJEULR9yS6YHgamPfJEf0WwTUaVHXvQ9Plrk7O53vDxk5hUUur +mkVLoR9BvUhTFXFkC4az5S6+zqQbwSmEorXLCCN2QyIkHxcE1G6cxvx/K2Ya7Irl1s9N9WMJtxU5 +1nus6+N86U78dULI7ViVDAZCopz35HCz33JvWjdAidiFpNfxC95DGdRKWCyMijmev4SH8RY7Ngzp +07TKbBlBUgmhHbBqv4LvcFEhMtwFdozL92TkA1CvjJFnq8Xy7ljY3r735zHPbMk7ccHViLVlvMDo +FxcHErVc0qsgk7TmgoNwNsXNo42ti+yjwUOH5kPiNL6VizXtBznaqB16nzaeErAMZRKQFWDZJkBE +41ZgpRDUajz9QdwOWke275dhdU/Z/seyHdTtXUmzqWrLZoQT1Vyg3N9udwbRcXXIV2+vD3dbAgMB +AAGjQjBAMA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMB0GA1UdDgQWBBRUrfrHkleu +yjWcLhL75LpdINyUVzANBgkqhkiG9w0BAQsFAAOCAgEAMJmdBTLIXg47mAE6iqTnB/d6+Oea31BD +U5cqPco8R5gu4RV78ZLzYdqQJRZlwJ9UXQ4DO1t3ApyEtg2YXzTdO2PCwyiBwpwpLiniyMMB8jPq +KqrMCQj3ZWfGzd/TtiunvczRDnBfuCPRy5FOCvTIeuXZYzbB1N/8Ipf3YF3qKS9Ysr1YvY2WTxB1 +v0h7PVGHoTx0IsL8B3+A3MSs/mrBcDCw6Y5p4ixpgZQJut3+TcCDjJRYwEYgr5wfAvg1VUkvRtTA +8KCWAg8zxXHzniN9lLf9OtMJgwYh/WA9rjLA0u6NpvDntIJ8CsxwyXmA+P5M9zWEGYox+wrZ13+b +8KKaa8MFSu1BYBQw0aoRQm7TIwIEC8Zl3d1Sd9qBa7Ko+gE4uZbqKmxnl4mUnrzhVNXkanjvSr0r +mj1AfsbAddJu+2gw7OyLnflJNZoaLNmzlTnVHpL3prllL+U9bTpITAjc5CgSKL59NVzq4BZ+Extq +1z7XnvwtdbLBFNUjA9tbbws+eC8N3jONFrdI54OagQ97wUNNVQQXOEpR1VmiiXTTn74eS9fGbbeI +JG9gkaSChVtWQbzQRKtqE77RLFi3EjNYsjdj3BP1lB0/QFH1T/U67cjF68IeHRaVesd+QnGTbksV +tzDfqu1XhUisHWrdOWnk4Xl4vs4Fv6EM94B7IWcnMFk= +-----END CERTIFICATE----- + +Staat der Nederlanden EV Root CA +================================ +-----BEGIN CERTIFICATE----- +MIIFcDCCA1igAwIBAgIEAJiWjTANBgkqhkiG9w0BAQsFADBYMQswCQYDVQQGEwJOTDEeMBwGA1UE +CgwVU3RhYXQgZGVyIE5lZGVybGFuZGVuMSkwJwYDVQQDDCBTdGFhdCBkZXIgTmVkZXJsYW5kZW4g +RVYgUm9vdCBDQTAeFw0xMDEyMDgxMTE5MjlaFw0yMjEyMDgxMTEwMjhaMFgxCzAJBgNVBAYTAk5M +MR4wHAYDVQQKDBVTdGFhdCBkZXIgTmVkZXJsYW5kZW4xKTAnBgNVBAMMIFN0YWF0IGRlciBOZWRl +cmxhbmRlbiBFViBSb290IENBMIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEA48d+ifkk +SzrSM4M1LGns3Amk41GoJSt5uAg94JG6hIXGhaTK5skuU6TJJB79VWZxXSzFYGgEt9nCUiY4iKTW +O0Cmws0/zZiTs1QUWJZV1VD+hq2kY39ch/aO5ieSZxeSAgMs3NZmdO3dZ//BYY1jTw+bbRcwJu+r +0h8QoPnFfxZpgQNH7R5ojXKhTbImxrpsX23Wr9GxE46prfNeaXUmGD5BKyF/7otdBwadQ8QpCiv8 +Kj6GyzyDOvnJDdrFmeK8eEEzduG/L13lpJhQDBXd4Pqcfzho0LKmeqfRMb1+ilgnQ7O6M5HTp5gV +XJrm0w912fxBmJc+qiXbj5IusHsMX/FjqTf5m3VpTCgmJdrV8hJwRVXj33NeN/UhbJCONVrJ0yPr +08C+eKxCKFhmpUZtcALXEPlLVPxdhkqHz3/KRawRWrUgUY0viEeXOcDPusBCAUCZSCELa6fS/ZbV +0b5GnUngC6agIk440ME8MLxwjyx1zNDFjFE7PZQIZCZhfbnDZY8UnCHQqv0XcgOPvZuM5l5Tnrmd +74K74bzickFbIZTTRTeU0d8JOV3nI6qaHcptqAqGhYqCvkIH1vI4gnPah1vlPNOePqc7nvQDs/nx +fRN0Av+7oeX6AHkcpmZBiFxgV6YuCcS6/ZrPpx9Aw7vMWgpVSzs4dlG4Y4uElBbmVvMCAwEAAaNC +MEAwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0OBBYEFP6rAJCYniT8qcwa +ivsnuL8wbqg7MA0GCSqGSIb3DQEBCwUAA4ICAQDPdyxuVr5Os7aEAJSrR8kN0nbHhp8dB9O2tLsI +eK9p0gtJ3jPFrK3CiAJ9Brc1AsFgyb/E6JTe1NOpEyVa/m6irn0F3H3zbPB+po3u2dfOWBfoqSmu +c0iH55vKbimhZF8ZE/euBhD/UcabTVUlT5OZEAFTdfETzsemQUHSv4ilf0X8rLiltTMMgsT7B/Zq +5SWEXwbKwYY5EdtYzXc7LMJMD16a4/CrPmEbUCTCwPTxGfARKbalGAKb12NMcIxHowNDXLldRqAN +b/9Zjr7dn3LDWyvfjFvO5QxGbJKyCqNMVEIYFRIYvdr8unRu/8G2oGTYqV9Vrp9canaW2HNnh/tN +f1zuacpzEPuKqf2evTY4SUmH9A4U8OmHuD+nT3pajnnUk+S7aFKErGzp85hwVXIy+TSrK0m1zSBi +5Dp6Z2Orltxtrpfs/J92VoguZs9btsmksNcFuuEnL5O7Jiqik7Ab846+HUCjuTaPPoIaGl6I6lD4 +WeKDRikL40Rc4ZW2aZCaFG+XroHPaO+Zmr615+F/+PoTRxZMzG0IQOeLeG9QgkRQP2YGiqtDhFZK +DyAthg710tvSeopLzaXoTvFeJiUBWSOgftL2fiFX1ye8FVdMpEbB4IMeDExNH08GGeL5qPQ6gqGy +eUN51q1veieQA6TqJIc/2b3Z6fJfUEkc7uzXLg== +-----END CERTIFICATE----- + +IdenTrust Commercial Root CA 1 +============================== +-----BEGIN CERTIFICATE----- +MIIFYDCCA0igAwIBAgIQCgFCgAAAAUUjyES1AAAAAjANBgkqhkiG9w0BAQsFADBKMQswCQYDVQQG +EwJVUzESMBAGA1UEChMJSWRlblRydXN0MScwJQYDVQQDEx5JZGVuVHJ1c3QgQ29tbWVyY2lhbCBS +b290IENBIDEwHhcNMTQwMTE2MTgxMjIzWhcNMzQwMTE2MTgxMjIzWjBKMQswCQYDVQQGEwJVUzES +MBAGA1UEChMJSWRlblRydXN0MScwJQYDVQQDEx5JZGVuVHJ1c3QgQ29tbWVyY2lhbCBSb290IENB +IDEwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCnUBneP5k91DNG8W9RYYKyqU+PZ4ld +hNlT3Qwo2dfw/66VQ3KZ+bVdfIrBQuExUHTRgQ18zZshq0PirK1ehm7zCYofWjK9ouuU+ehcCuz/ +mNKvcbO0U59Oh++SvL3sTzIwiEsXXlfEU8L2ApeN2WIrvyQfYo3fw7gpS0l4PJNgiCL8mdo2yMKi +1CxUAGc1bnO/AljwpN3lsKImesrgNqUZFvX9t++uP0D1bVoE/c40yiTcdCMbXTMTEl3EASX2MN0C +XZ/g1Ue9tOsbobtJSdifWwLziuQkkORiT0/Br4sOdBeo0XKIanoBScy0RnnGF7HamB4HWfp1IYVl +3ZBWzvurpWCdxJ35UrCLvYf5jysjCiN2O/cz4ckA82n5S6LgTrx+kzmEB/dEcH7+B1rlsazRGMzy +NeVJSQjKVsk9+w8YfYs7wRPCTY/JTw436R+hDmrfYi7LNQZReSzIJTj0+kuniVyc0uMNOYZKdHzV +WYfCP04MXFL0PfdSgvHqo6z9STQaKPNBiDoT7uje/5kdX7rL6B7yuVBgwDHTc+XvvqDtMwt0viAg +xGds8AgDelWAf0ZOlqf0Hj7h9tgJ4TNkK2PXMl6f+cB7D3hvl7yTmvmcEpB4eoCHFddydJxVdHix +uuFucAS6T6C6aMN7/zHwcz09lCqxC0EOoP5NiGVreTO01wIDAQABo0IwQDAOBgNVHQ8BAf8EBAMC +AQYwDwYDVR0TAQH/BAUwAwEB/zAdBgNVHQ4EFgQU7UQZwNPwBovupHu+QucmVMiONnYwDQYJKoZI +hvcNAQELBQADggIBAA2ukDL2pkt8RHYZYR4nKM1eVO8lvOMIkPkp165oCOGUAFjvLi5+U1KMtlwH +6oi6mYtQlNeCgN9hCQCTrQ0U5s7B8jeUeLBfnLOic7iPBZM4zY0+sLj7wM+x8uwtLRvM7Kqas6pg +ghstO8OEPVeKlh6cdbjTMM1gCIOQ045U8U1mwF10A0Cj7oV+wh93nAbowacYXVKV7cndJZ5t+qnt +ozo00Fl72u1Q8zW/7esUTTHHYPTa8Yec4kjixsU3+wYQ+nVZZjFHKdp2mhzpgq7vmrlR94gjmmmV +YjzlVYA211QC//G5Xc7UI2/YRYRKW2XviQzdFKcgyxilJbQN+QHwotL0AMh0jqEqSI5l2xPE4iUX +feu+h1sXIFRRk0pTAwvsXcoz7WL9RccvW9xYoIA55vrX/hMUpu09lEpCdNTDd1lzzY9GvlU47/ro +kTLql1gEIt44w8y8bckzOmoKaT+gyOpyj4xjhiO9bTyWnpXgSUyqorkqG5w2gXjtw+hG4iZZRHUe +2XWJUc0QhJ1hYMtd+ZciTY6Y5uN/9lu7rs3KSoFrXgvzUeF0K+l+J6fZmUlO+KWA2yUPHGNiiskz +Z2s8EIPGrd6ozRaOjfAHN3Gf8qv8QfXBi+wAN10J5U6A7/qxXDgGpRtK4dw4LTzcqx+QGtVKnO7R +cGzM7vRX+Bi6hG6H +-----END CERTIFICATE----- + +IdenTrust Public Sector Root CA 1 +================================= +-----BEGIN CERTIFICATE----- +MIIFZjCCA06gAwIBAgIQCgFCgAAAAUUjz0Z8AAAAAjANBgkqhkiG9w0BAQsFADBNMQswCQYDVQQG +EwJVUzESMBAGA1UEChMJSWRlblRydXN0MSowKAYDVQQDEyFJZGVuVHJ1c3QgUHVibGljIFNlY3Rv +ciBSb290IENBIDEwHhcNMTQwMTE2MTc1MzMyWhcNMzQwMTE2MTc1MzMyWjBNMQswCQYDVQQGEwJV +UzESMBAGA1UEChMJSWRlblRydXN0MSowKAYDVQQDEyFJZGVuVHJ1c3QgUHVibGljIFNlY3RvciBS +b290IENBIDEwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQC2IpT8pEiv6EdrCvsnduTy +P4o7ekosMSqMjbCpwzFrqHd2hCa2rIFCDQjrVVi7evi8ZX3yoG2LqEfpYnYeEe4IFNGyRBb06tD6 +Hi9e28tzQa68ALBKK0CyrOE7S8ItneShm+waOh7wCLPQ5CQ1B5+ctMlSbdsHyo+1W/CD80/HLaXI +rcuVIKQxKFdYWuSNG5qrng0M8gozOSI5Cpcu81N3uURF/YTLNiCBWS2ab21ISGHKTN9T0a9SvESf +qy9rg3LvdYDaBjMbXcjaY8ZNzaxmMc3R3j6HEDbhuaR672BQssvKplbgN6+rNBM5Jeg5ZuSYeqoS +mJxZZoY+rfGwyj4GD3vwEUs3oERte8uojHH01bWRNszwFcYr3lEXsZdMUD2xlVl8BX0tIdUAvwFn +ol57plzy9yLxkA2T26pEUWbMfXYD62qoKjgZl3YNa4ph+bz27nb9cCvdKTz4Ch5bQhyLVi9VGxyh +LrXHFub4qjySjmm2AcG1hp2JDws4lFTo6tyePSW8Uybt1as5qsVATFSrsrTZ2fjXctscvG29ZV/v +iDUqZi/u9rNl8DONfJhBaUYPQxxp+pu10GFqzcpL2UyQRqsVWaFHVCkugyhfHMKiq3IXAAaOReyL +4jM9f9oZRORicsPfIsbyVtTdX5Vy7W1f90gDW/3FKqD2cyOEEBsB5wIDAQABo0IwQDAOBgNVHQ8B +Af8EBAMCAQYwDwYDVR0TAQH/BAUwAwEB/zAdBgNVHQ4EFgQU43HgntinQtnbcZFrlJPrw6PRFKMw +DQYJKoZIhvcNAQELBQADggIBAEf63QqwEZE4rU1d9+UOl1QZgkiHVIyqZJnYWv6IAcVYpZmxI1Qj +t2odIFflAWJBF9MJ23XLblSQdf4an4EKwt3X9wnQW3IV5B4Jaj0z8yGa5hV+rVHVDRDtfULAj+7A +mgjVQdZcDiFpboBhDhXAuM/FSRJSzL46zNQuOAXeNf0fb7iAaJg9TaDKQGXSc3z1i9kKlT/YPyNt +GtEqJBnZhbMX73huqVjRI9PHE+1yJX9dsXNw0H8GlwmEKYBhHfpe/3OsoOOJuBxxFcbeMX8S3OFt +m6/n6J91eEyrRjuazr8FGF1NFTwWmhlQBJqymm9li1JfPFgEKCXAZmExfrngdbkaqIHWchezxQMx +NRF4eKLg6TCMf4DfWN88uieW4oA0beOY02QnrEh+KHdcxiVhJfiFDGX6xDIvpZgF5PgLZxYWxoK4 +Mhn5+bl53B/N66+rDt0b20XkeucC4pVd/GnwU2lhlXV5C15V5jgclKlZM57IcXR5f1GJtshquDDI +ajjDbp7hNxbqBWJMWxJH7ae0s1hWx0nzfxJoCTFx8G34Tkf71oXuxVhAGaQdp/lLQzfcaFpPz+vC +ZHTetBXZ9FRUGi8c15dxVJCO2SCdUyt/q4/i6jC8UDfv8Ue1fXwsBOxonbRJRBD0ckscZOf85muQ +3Wl9af0AVqW3rLatt8o+Ae+c +-----END CERTIFICATE----- + +Entrust Root Certification Authority - G2 +========================================= +-----BEGIN CERTIFICATE----- +MIIEPjCCAyagAwIBAgIESlOMKDANBgkqhkiG9w0BAQsFADCBvjELMAkGA1UEBhMCVVMxFjAUBgNV +BAoTDUVudHJ1c3QsIEluYy4xKDAmBgNVBAsTH1NlZSB3d3cuZW50cnVzdC5uZXQvbGVnYWwtdGVy +bXMxOTA3BgNVBAsTMChjKSAyMDA5IEVudHJ1c3QsIEluYy4gLSBmb3IgYXV0aG9yaXplZCB1c2Ug +b25seTEyMDAGA1UEAxMpRW50cnVzdCBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5IC0gRzIw +HhcNMDkwNzA3MTcyNTU0WhcNMzAxMjA3MTc1NTU0WjCBvjELMAkGA1UEBhMCVVMxFjAUBgNVBAoT +DUVudHJ1c3QsIEluYy4xKDAmBgNVBAsTH1NlZSB3d3cuZW50cnVzdC5uZXQvbGVnYWwtdGVybXMx +OTA3BgNVBAsTMChjKSAyMDA5IEVudHJ1c3QsIEluYy4gLSBmb3IgYXV0aG9yaXplZCB1c2Ugb25s +eTEyMDAGA1UEAxMpRW50cnVzdCBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5IC0gRzIwggEi +MA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQC6hLZy254Ma+KZ6TABp3bqMriVQRrJ2mFOWHLP +/vaCeb9zYQYKpSfYs1/TRU4cctZOMvJyig/3gxnQaoCAAEUesMfnmr8SVycco2gvCoe9amsOXmXz +HHfV1IWNcCG0szLni6LVhjkCsbjSR87kyUnEO6fe+1R9V77w6G7CebI6C1XiUJgWMhNcL3hWwcKU +s/Ja5CeanyTXxuzQmyWC48zCxEXFjJd6BmsqEZ+pCm5IO2/b1BEZQvePB7/1U1+cPvQXLOZprE4y +TGJ36rfo5bs0vBmLrpxR57d+tVOxMyLlbc9wPBr64ptntoP0jaWvYkxN4FisZDQSA/i2jZRjJKRx +AgMBAAGjQjBAMA4GA1UdDwEB/wQEAwIBBjAPBgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBRqciZ6 +0B7vfec7aVHUbI2fkBJmqzANBgkqhkiG9w0BAQsFAAOCAQEAeZ8dlsa2eT8ijYfThwMEYGprmi5Z +iXMRrEPR9RP/jTkrwPK9T3CMqS/qF8QLVJ7UG5aYMzyorWKiAHarWWluBh1+xLlEjZivEtRh2woZ +Rkfz6/djwUAFQKXSt/S1mja/qYh2iARVBCuch38aNzx+LaUa2NSJXsq9rD1s2G2v1fN2D807iDgi +nWyTmsQ9v4IbZT+mD12q/OWyFcq1rca8PdCE6OoGcrBNOTJ4vz4RnAuknZoh8/CbCzB428Hch0P+ +vGOaysXCHMnHjf87ElgI5rY97HosTvuDls4MPGmHVHOkc8KT/1EQrBVUAdj8BbGJoX90g5pJ19xO +e4pIb4tF9g== +-----END CERTIFICATE----- + +Entrust Root Certification Authority - EC1 +========================================== +-----BEGIN CERTIFICATE----- +MIIC+TCCAoCgAwIBAgINAKaLeSkAAAAAUNCR+TAKBggqhkjOPQQDAzCBvzELMAkGA1UEBhMCVVMx +FjAUBgNVBAoTDUVudHJ1c3QsIEluYy4xKDAmBgNVBAsTH1NlZSB3d3cuZW50cnVzdC5uZXQvbGVn +YWwtdGVybXMxOTA3BgNVBAsTMChjKSAyMDEyIEVudHJ1c3QsIEluYy4gLSBmb3IgYXV0aG9yaXpl +ZCB1c2Ugb25seTEzMDEGA1UEAxMqRW50cnVzdCBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5 +IC0gRUMxMB4XDTEyMTIxODE1MjUzNloXDTM3MTIxODE1NTUzNlowgb8xCzAJBgNVBAYTAlVTMRYw +FAYDVQQKEw1FbnRydXN0LCBJbmMuMSgwJgYDVQQLEx9TZWUgd3d3LmVudHJ1c3QubmV0L2xlZ2Fs +LXRlcm1zMTkwNwYDVQQLEzAoYykgMjAxMiBFbnRydXN0LCBJbmMuIC0gZm9yIGF1dGhvcml6ZWQg +dXNlIG9ubHkxMzAxBgNVBAMTKkVudHJ1c3QgUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eSAt +IEVDMTB2MBAGByqGSM49AgEGBSuBBAAiA2IABIQTydC6bUF74mzQ61VfZgIaJPRbiWlH47jCffHy +AsWfoPZb1YsGGYZPUxBtByQnoaD41UcZYUx9ypMn6nQM72+WCf5j7HBdNq1nd67JnXxVRDqiY1Ef +9eNi1KlHBz7MIKNCMEAwDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYE +FLdj5xrdjekIplWDpOBqUEFlEUJJMAoGCCqGSM49BAMDA2cAMGQCMGF52OVCR98crlOZF7ZvHH3h +vxGU0QOIdeSNiaSKd0bebWHvAvX7td/M/k7//qnmpwIwW5nXhTcGtXsI/esni0qU+eH6p44mCOh8 +kmhtc9hvJqwhAriZtyZBWyVgrtBIGu4G +-----END CERTIFICATE----- + +CFCA EV ROOT +============ +-----BEGIN CERTIFICATE----- +MIIFjTCCA3WgAwIBAgIEGErM1jANBgkqhkiG9w0BAQsFADBWMQswCQYDVQQGEwJDTjEwMC4GA1UE +CgwnQ2hpbmEgRmluYW5jaWFsIENlcnRpZmljYXRpb24gQXV0aG9yaXR5MRUwEwYDVQQDDAxDRkNB +IEVWIFJPT1QwHhcNMTIwODA4MDMwNzAxWhcNMjkxMjMxMDMwNzAxWjBWMQswCQYDVQQGEwJDTjEw +MC4GA1UECgwnQ2hpbmEgRmluYW5jaWFsIENlcnRpZmljYXRpb24gQXV0aG9yaXR5MRUwEwYDVQQD +DAxDRkNBIEVWIFJPT1QwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQDXXWvNED8fBVnV +BU03sQ7smCuOFR36k0sXgiFxEFLXUWRwFsJVaU2OFW2fvwwbwuCjZ9YMrM8irq93VCpLTIpTUnrD +7i7es3ElweldPe6hL6P3KjzJIx1qqx2hp/Hz7KDVRM8Vz3IvHWOX6Jn5/ZOkVIBMUtRSqy5J35DN +uF++P96hyk0g1CXohClTt7GIH//62pCfCqktQT+x8Rgp7hZZLDRJGqgG16iI0gNyejLi6mhNbiyW +ZXvKWfry4t3uMCz7zEasxGPrb382KzRzEpR/38wmnvFyXVBlWY9ps4deMm/DGIq1lY+wejfeWkU7 +xzbh72fROdOXW3NiGUgthxwG+3SYIElz8AXSG7Ggo7cbcNOIabla1jj0Ytwli3i/+Oh+uFzJlU9f +py25IGvPa931DfSCt/SyZi4QKPaXWnuWFo8BGS1sbn85WAZkgwGDg8NNkt0yxoekN+kWzqotaK8K +gWU6cMGbrU1tVMoqLUuFG7OA5nBFDWteNfB/O7ic5ARwiRIlk9oKmSJgamNgTnYGmE69g60dWIol +hdLHZR4tjsbftsbhf4oEIRUpdPA+nJCdDC7xij5aqgwJHsfVPKPtl8MeNPo4+QgO48BdK4PRVmrJ +tqhUUy54Mmc9gn900PvhtgVguXDbjgv5E1hvcWAQUhC5wUEJ73IfZzF4/5YFjQIDAQABo2MwYTAf +BgNVHSMEGDAWgBTj/i39KNALtbq2osS/BqoFjJP7LzAPBgNVHRMBAf8EBTADAQH/MA4GA1UdDwEB +/wQEAwIBBjAdBgNVHQ4EFgQU4/4t/SjQC7W6tqLEvwaqBYyT+y8wDQYJKoZIhvcNAQELBQADggIB +ACXGumvrh8vegjmWPfBEp2uEcwPenStPuiB/vHiyz5ewG5zz13ku9Ui20vsXiObTej/tUxPQ4i9q +ecsAIyjmHjdXNYmEwnZPNDatZ8POQQaIxffu2Bq41gt/UP+TqhdLjOztUmCypAbqTuv0axn96/Ua +4CUqmtzHQTb3yHQFhDmVOdYLO6Qn+gjYXB74BGBSESgoA//vU2YApUo0FmZ8/Qmkrp5nGm9BC2sG +E5uPhnEFtC+NiWYzKXZUmhH4J/qyP5Hgzg0b8zAarb8iXRvTvyUFTeGSGn+ZnzxEk8rUQElsgIfX +BDrDMlI1Dlb4pd19xIsNER9Tyx6yF7Zod1rg1MvIB671Oi6ON7fQAUtDKXeMOZePglr4UeWJoBjn +aH9dCi77o0cOPaYjesYBx4/IXr9tgFa+iiS6M+qf4TIRnvHST4D2G0CvOJ4RUHlzEhLN5mydLIhy +PDCBBpEi6lmt2hkuIsKNuYyH4Ga8cyNfIWRjgEj1oDwYPZTISEEdQLpe/v5WOaHIz16eGWRGENoX +kbcFgKyLmZJ956LYBws2J+dIeWCKw9cTXPhyQN9Ky8+ZAAoACxGV2lZFA4gKn2fQ1XmxqI1AbQ3C +ekD6819kR5LLU7m7Wc5P/dAVUwHY3+vZ5nbv0CO7O6l5s9UCKc2Jo5YPSjXnTkLAdc0Hz+Ys63su +-----END CERTIFICATE----- + +TÃœRKTRUST Elektronik Sertifika Hizmet SaÄŸlayıcısı H5 +==================================================== +-----BEGIN CERTIFICATE----- +MIIEJzCCAw+gAwIBAgIHAI4X/iQggTANBgkqhkiG9w0BAQsFADCBsTELMAkGA1UEBhMCVFIxDzAN +BgNVBAcMBkFua2FyYTFNMEsGA1UECgxEVMOcUktUUlVTVCBCaWxnaSDEsGxldGnFn2ltIHZlIEJp +bGnFn2ltIEfDvHZlbmxpxJ9pIEhpem1ldGxlcmkgQS7Fni4xQjBABgNVBAMMOVTDnFJLVFJVU1Qg +RWxla3Ryb25payBTZXJ0aWZpa2EgSGl6bWV0IFNhxJ9sYXnEsWPEsXPEsSBINTAeFw0xMzA0MzAw +ODA3MDFaFw0yMzA0MjgwODA3MDFaMIGxMQswCQYDVQQGEwJUUjEPMA0GA1UEBwwGQW5rYXJhMU0w +SwYDVQQKDERUw5xSS1RSVVNUIEJpbGdpIMSwbGV0acWfaW0gdmUgQmlsacWfaW0gR8O8dmVubGnE +n2kgSGl6bWV0bGVyaSBBLsWeLjFCMEAGA1UEAww5VMOcUktUUlVTVCBFbGVrdHJvbmlrIFNlcnRp +ZmlrYSBIaXptZXQgU2HEn2xhecSxY8Sxc8SxIEg1MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIB +CgKCAQEApCUZ4WWe60ghUEoI5RHwWrom/4NZzkQqL/7hzmAD/I0Dpe3/a6i6zDQGn1k19uwsu537 +jVJp45wnEFPzpALFp/kRGml1bsMdi9GYjZOHp3GXDSHHmflS0yxjXVW86B8BSLlg/kJK9siArs1m +ep5Fimh34khon6La8eHBEJ/rPCmBp+EyCNSgBbGM+42WAA4+Jd9ThiI7/PS98wl+d+yG6w8z5UNP +9FR1bSmZLmZaQ9/LXMrI5Tjxfjs1nQ/0xVqhzPMggCTTV+wVunUlm+hkS7M0hO8EuPbJbKoCPrZV +4jI3X/xml1/N1p7HIL9Nxqw/dV8c7TKcfGkAaZHjIxhT6QIDAQABo0IwQDAdBgNVHQ4EFgQUVpkH +HtOsDGlktAxQR95DLL4gwPswDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZI +hvcNAQELBQADggEBAJ5FdnsXSDLyOIspve6WSk6BGLFRRyDN0GSxDsnZAdkJzsiZ3GglE9Rc8qPo +BP5yCccLqh0lVX6Wmle3usURehnmp349hQ71+S4pL+f5bFgWV1Al9j4uPqrtd3GqqpmWRgqujuwq +URawXs3qZwQcWDD1YIq9pr1N5Za0/EKJAWv2cMhQOQwt1WbZyNKzMrcbGW3LM/nfpeYVhDfwwvJl +lpKQd/Ct9JDpEXjXk4nAPQu6KfTomZ1yju2dL+6SfaHx/126M2CFYv4HAqGEVka+lgqaE9chTLd8 +B59OTj+RdPsnnRHM3eaxynFNExc5JsUpISuTKWqW+qtB4Uu2NQvAmxU= +-----END CERTIFICATE----- + +Certinomis - Root CA +==================== +-----BEGIN CERTIFICATE----- +MIIFkjCCA3qgAwIBAgIBATANBgkqhkiG9w0BAQsFADBaMQswCQYDVQQGEwJGUjETMBEGA1UEChMK +Q2VydGlub21pczEXMBUGA1UECxMOMDAwMiA0MzM5OTg5MDMxHTAbBgNVBAMTFENlcnRpbm9taXMg +LSBSb290IENBMB4XDTEzMTAyMTA5MTcxOFoXDTMzMTAyMTA5MTcxOFowWjELMAkGA1UEBhMCRlIx +EzARBgNVBAoTCkNlcnRpbm9taXMxFzAVBgNVBAsTDjAwMDIgNDMzOTk4OTAzMR0wGwYDVQQDExRD +ZXJ0aW5vbWlzIC0gUm9vdCBDQTCCAiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBANTMCQos +P5L2fxSeC5yaah1AMGT9qt8OHgZbn1CF6s2Nq0Nn3rD6foCWnoR4kkjW4znuzuRZWJflLieY6pOo +d5tK8O90gC3rMB+12ceAnGInkYjwSond3IjmFPnVAy//ldu9n+ws+hQVWZUKxkd8aRi5pwP5ynap +z8dvtF4F/u7BUrJ1Mofs7SlmO/NKFoL21prbcpjp3vDFTKWrteoB4owuZH9kb/2jJZOLyKIOSY00 +8B/sWEUuNKqEUL3nskoTuLAPrjhdsKkb5nPJWqHZZkCqqU2mNAKthH6yI8H7KsZn9DS2sJVqM09x +RLWtwHkziOC/7aOgFLScCbAK42C++PhmiM1b8XcF4LVzbsF9Ri6OSyemzTUK/eVNfaoqoynHWmgE +6OXWk6RiwsXm9E/G+Z8ajYJJGYrKWUM66A0ywfRMEwNvbqY/kXPLynNvEiCL7sCCeN5LLsJJwx3t +FvYk9CcbXFcx3FXuqB5vbKziRcxXV4p1VxngtViZSTYxPDMBbRZKzbgqg4SGm/lg0h9tkQPTYKbV +PZrdd5A9NaSfD171UkRpucC63M9933zZxKyGIjK8e2uR73r4F2iw4lNVYC2vPsKD2NkJK/DAZNuH +i5HMkesE/Xa0lZrmFAYb1TQdvtj/dBxThZngWVJKYe2InmtJiUZ+IFrZ50rlau7SZRFDAgMBAAGj +YzBhMA4GA1UdDwEB/wQEAwIBBjAPBgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBTvkUz1pcMw6C8I +6tNxIqSSaHh02TAfBgNVHSMEGDAWgBTvkUz1pcMw6C8I6tNxIqSSaHh02TANBgkqhkiG9w0BAQsF +AAOCAgEAfj1U2iJdGlg+O1QnurrMyOMaauo++RLrVl89UM7g6kgmJs95Vn6RHJk/0KGRHCwPT5iV +WVO90CLYiF2cN/z7ZMF4jIuaYAnq1fohX9B0ZedQxb8uuQsLrbWwF6YSjNRieOpWauwK0kDDPAUw +Pk2Ut59KA9N9J0u2/kTO+hkzGm2kQtHdzMjI1xZSg081lLMSVX3l4kLr5JyTCcBMWwerx20RoFAX +lCOotQqSD7J6wWAsOMwaplv/8gzjqh8c3LigkyfeY+N/IZ865Z764BNqdeuWXGKRlI5nU7aJ+BIJ +y29SWwNyhlCVCNSNh4YVH5Uk2KRvms6knZtt0rJ2BobGVgjF6wnaNsIbW0G+YSrjcOa4pvi2WsS9 +Iff/ql+hbHY5ZtbqTFXhADObE5hjyW/QASAJN1LnDE8+zbz1X5YnpyACleAu6AdBBR8Vbtaw5Bng +DwKTACdyxYvRVB9dSsNAl35VpnzBMwQUAR1JIGkLGZOdblgi90AMRgwjY/M50n92Uaf0yKHxDHYi +I0ZSKS3io0EHVmmY0gUJvGnHWmHNj4FgFU2A3ZDifcRQ8ow7bkrHxuaAKzyBvBGAFhAn1/DNP3nM +cyrDflOR1m749fPH0FFNjkulW+YZFzvWgQncItzujrnEj1PhZ7szuIgVRs/taTX/dQ1G885x4cVr +hkIGuUE= +-----END CERTIFICATE----- + +OISTE WISeKey Global Root GB CA +=============================== +-----BEGIN CERTIFICATE----- +MIIDtTCCAp2gAwIBAgIQdrEgUnTwhYdGs/gjGvbCwDANBgkqhkiG9w0BAQsFADBtMQswCQYDVQQG +EwJDSDEQMA4GA1UEChMHV0lTZUtleTEiMCAGA1UECxMZT0lTVEUgRm91bmRhdGlvbiBFbmRvcnNl +ZDEoMCYGA1UEAxMfT0lTVEUgV0lTZUtleSBHbG9iYWwgUm9vdCBHQiBDQTAeFw0xNDEyMDExNTAw +MzJaFw0zOTEyMDExNTEwMzFaMG0xCzAJBgNVBAYTAkNIMRAwDgYDVQQKEwdXSVNlS2V5MSIwIAYD +VQQLExlPSVNURSBGb3VuZGF0aW9uIEVuZG9yc2VkMSgwJgYDVQQDEx9PSVNURSBXSVNlS2V5IEds +b2JhbCBSb290IEdCIENBMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA2Be3HEokKtaX +scriHvt9OO+Y9bI5mE4nuBFde9IllIiCFSZqGzG7qFshISvYD06fWvGxWuR51jIjK+FTzJlFXHtP +rby/h0oLS5daqPZI7H17Dc0hBt+eFf1Biki3IPShehtX1F1Q/7pn2COZH8g/497/b1t3sWtuuMlk +9+HKQUYOKXHQuSP8yYFfTvdv37+ErXNku7dCjmn21HYdfp2nuFeKUWdy19SouJVUQHMD9ur06/4o +Qnc/nSMbsrY9gBQHTC5P99UKFg29ZkM3fiNDecNAhvVMKdqOmq0NpQSHiB6F4+lT1ZvIiwNjeOvg +GUpuuy9rM2RYk61pv48b74JIxwIDAQABo1EwTzALBgNVHQ8EBAMCAYYwDwYDVR0TAQH/BAUwAwEB +/zAdBgNVHQ4EFgQUNQ/INmNe4qPs+TtmFc5RUuORmj0wEAYJKwYBBAGCNxUBBAMCAQAwDQYJKoZI +hvcNAQELBQADggEBAEBM+4eymYGQfp3FsLAmzYh7KzKNbrghcViXfa43FK8+5/ea4n32cZiZBKpD +dHij40lhPnOMTZTg+XHEthYOU3gf1qKHLwI5gSk8rxWYITD+KJAAjNHhy/peyP34EEY7onhCkRd0 +VQreUGdNZtGn//3ZwLWoo4rOZvUPQ82nK1d7Y0Zqqi5S2PTt4W2tKZB4SLrhI6qjiey1q5bAtEui +HZeeevJuQHHfaPFlTc58Bd9TZaml8LGXBHAVRgOY1NK/VLSgWH1Sb9pWJmLU2NuJMW8c8CLC02Ic +Nc1MaRVUGpCY3useX8p3x8uOPUNpnJpY0CQ73xtAln41rYHHTnG6iBM= +-----END CERTIFICATE----- + +SZAFIR ROOT CA2 +=============== +-----BEGIN CERTIFICATE----- +MIIDcjCCAlqgAwIBAgIUPopdB+xV0jLVt+O2XwHrLdzk1uQwDQYJKoZIhvcNAQELBQAwUTELMAkG +A1UEBhMCUEwxKDAmBgNVBAoMH0tyYWpvd2EgSXpiYSBSb3psaWN6ZW5pb3dhIFMuQS4xGDAWBgNV +BAMMD1NaQUZJUiBST09UIENBMjAeFw0xNTEwMTkwNzQzMzBaFw0zNTEwMTkwNzQzMzBaMFExCzAJ +BgNVBAYTAlBMMSgwJgYDVQQKDB9LcmFqb3dhIEl6YmEgUm96bGljemVuaW93YSBTLkEuMRgwFgYD +VQQDDA9TWkFGSVIgUk9PVCBDQTIwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQC3vD5Q +qEvNQLXOYeeWyrSh2gwisPq1e3YAd4wLz32ohswmUeQgPYUM1ljj5/QqGJ3a0a4m7utT3PSQ1hNK +DJA8w/Ta0o4NkjrcsbH/ON7Dui1fgLkCvUqdGw+0w8LBZwPd3BucPbOw3gAeqDRHu5rr/gsUvTaE +2g0gv/pby6kWIK05YO4vdbbnl5z5Pv1+TW9NL++IDWr63fE9biCloBK0TXC5ztdyO4mTp4CEHCdJ +ckm1/zuVnsHMyAHs6A6KCpbns6aH5db5BSsNl0BwPLqsdVqc1U2dAgrSS5tmS0YHF2Wtn2yIANwi +ieDhZNRnvDF5YTy7ykHNXGoAyDw4jlivAgMBAAGjQjBAMA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0P +AQH/BAQDAgEGMB0GA1UdDgQWBBQuFqlKGLXLzPVvUPMjX/hd56zwyDANBgkqhkiG9w0BAQsFAAOC +AQEAtXP4A9xZWx126aMqe5Aosk3AM0+qmrHUuOQn/6mWmc5G4G18TKI4pAZw8PRBEew/R40/cof5 +O/2kbytTAOD/OblqBw7rHRz2onKQy4I9EYKL0rufKq8h5mOGnXkZ7/e7DDWQw4rtTw/1zBLZpD67 +oPwglV9PJi8RI4NOdQcPv5vRtB3pEAT+ymCPoky4rc/hkA/NrgrHXXu3UNLUYfrVFdvXn4dRVOul +4+vJhaAlIDf7js4MNIThPIGyd05DpYhfhmehPea0XGG2Ptv+tyjFogeutcrKjSoS75ftwjCkySp6 ++/NNIxuZMzSgLvWpCz/UXeHPhJ/iGcJfitYgHuNztw== +-----END CERTIFICATE----- + +Certum Trusted Network CA 2 +=========================== +-----BEGIN CERTIFICATE----- +MIIF0jCCA7qgAwIBAgIQIdbQSk8lD8kyN/yqXhKN6TANBgkqhkiG9w0BAQ0FADCBgDELMAkGA1UE +BhMCUEwxIjAgBgNVBAoTGVVuaXpldG8gVGVjaG5vbG9naWVzIFMuQS4xJzAlBgNVBAsTHkNlcnR1 +bSBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTEkMCIGA1UEAxMbQ2VydHVtIFRydXN0ZWQgTmV0d29y +ayBDQSAyMCIYDzIwMTExMDA2MDgzOTU2WhgPMjA0NjEwMDYwODM5NTZaMIGAMQswCQYDVQQGEwJQ +TDEiMCAGA1UEChMZVW5pemV0byBUZWNobm9sb2dpZXMgUy5BLjEnMCUGA1UECxMeQ2VydHVtIENl +cnRpZmljYXRpb24gQXV0aG9yaXR5MSQwIgYDVQQDExtDZXJ0dW0gVHJ1c3RlZCBOZXR3b3JrIENB +IDIwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQC9+Xj45tWADGSdhhuWZGc/IjoedQF9 +7/tcZ4zJzFxrqZHmuULlIEub2pt7uZld2ZuAS9eEQCsn0+i6MLs+CRqnSZXvK0AkwpfHp+6bJe+o +CgCXhVqqndwpyeI1B+twTUrWwbNWuKFBOJvR+zF/j+Bf4bE/D44WSWDXBo0Y+aomEKsq09DRZ40b +Rr5HMNUuctHFY9rnY3lEfktjJImGLjQ/KUxSiyqnwOKRKIm5wFv5HdnnJ63/mgKXwcZQkpsCLL2p +uTRZCr+ESv/f/rOf69me4Jgj7KZrdxYq28ytOxykh9xGc14ZYmhFV+SQgkK7QtbwYeDBoz1mo130 +GO6IyY0XRSmZMnUCMe4pJshrAua1YkV/NxVaI2iJ1D7eTiew8EAMvE0Xy02isx7QBlrd9pPPV3WZ +9fqGGmd4s7+W/jTcvedSVuWz5XV710GRBdxdaeOVDUO5/IOWOZV7bIBaTxNyxtd9KXpEulKkKtVB +Rgkg/iKgtlswjbyJDNXXcPiHUv3a76xRLgezTv7QCdpw75j6VuZt27VXS9zlLCUVyJ4ueE742pye +hizKV/Ma5ciSixqClnrDvFASadgOWkaLOusm+iPJtrCBvkIApPjW/jAux9JG9uWOdf3yzLnQh1vM +BhBgu4M1t15n3kfsmUjxpKEV/q2MYo45VU85FrmxY53/twIDAQABo0IwQDAPBgNVHRMBAf8EBTAD +AQH/MB0GA1UdDgQWBBS2oVQ5AsOgP46KvPrU+Bym0ToO/TAOBgNVHQ8BAf8EBAMCAQYwDQYJKoZI +hvcNAQENBQADggIBAHGlDs7k6b8/ONWJWsQCYftMxRQXLYtPU2sQF/xlhMcQSZDe28cmk4gmb3DW +Al45oPePq5a1pRNcgRRtDoGCERuKTsZPpd1iHkTfCVn0W3cLN+mLIMb4Ck4uWBzrM9DPhmDJ2vuA +L55MYIR4PSFk1vtBHxgP58l1cb29XN40hz5BsA72udY/CROWFC/emh1auVbONTqwX3BNXuMp8SMo +clm2q8KMZiYcdywmdjWLKKdpoPk79SPdhRB0yZADVpHnr7pH1BKXESLjokmUbOe3lEu6LaTaM4tM +pkT/WjzGHWTYtTHkpjx6qFcL2+1hGsvxznN3Y6SHb0xRONbkX8eftoEq5IVIeVheO/jbAoJnwTnb +w3RLPTYe+SmTiGhbqEQZIfCn6IENLOiTNrQ3ssqwGyZ6miUfmpqAnksqP/ujmv5zMnHCnsZy4Ypo +J/HkD7TETKVhk/iXEAcqMCWpuchxuO9ozC1+9eB+D4Kob7a6bINDd82Kkhehnlt4Fj1F4jNy3eFm +ypnTycUm/Q1oBEauttmbjL4ZvrHG8hnjXALKLNhvSgfZyTXaQHXyxKcZb55CEJh15pWLYLztxRLX +is7VmFxWlgPF7ncGNf/P5O4/E2Hu29othfDNrp2yGAlFw5Khchf8R7agCyzxxN5DaAhqXzvwdmP7 +zAYspsbiDrW5viSP +-----END CERTIFICATE----- + +Hellenic Academic and Research Institutions RootCA 2015 +======================================================= +-----BEGIN CERTIFICATE----- +MIIGCzCCA/OgAwIBAgIBADANBgkqhkiG9w0BAQsFADCBpjELMAkGA1UEBhMCR1IxDzANBgNVBAcT +BkF0aGVuczFEMEIGA1UEChM7SGVsbGVuaWMgQWNhZGVtaWMgYW5kIFJlc2VhcmNoIEluc3RpdHV0 +aW9ucyBDZXJ0LiBBdXRob3JpdHkxQDA+BgNVBAMTN0hlbGxlbmljIEFjYWRlbWljIGFuZCBSZXNl +YXJjaCBJbnN0aXR1dGlvbnMgUm9vdENBIDIwMTUwHhcNMTUwNzA3MTAxMTIxWhcNNDAwNjMwMTAx +MTIxWjCBpjELMAkGA1UEBhMCR1IxDzANBgNVBAcTBkF0aGVuczFEMEIGA1UEChM7SGVsbGVuaWMg +QWNhZGVtaWMgYW5kIFJlc2VhcmNoIEluc3RpdHV0aW9ucyBDZXJ0LiBBdXRob3JpdHkxQDA+BgNV +BAMTN0hlbGxlbmljIEFjYWRlbWljIGFuZCBSZXNlYXJjaCBJbnN0aXR1dGlvbnMgUm9vdENBIDIw +MTUwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQDC+Kk/G4n8PDwEXT2QNrCROnk8Zlrv +bTkBSRq0t89/TSNTt5AA4xMqKKYx8ZEA4yjsriFBzh/a/X0SWwGDD7mwX5nh8hKDgE0GPt+sr+eh +iGsxr/CL0BgzuNtFajT0AoAkKAoCFZVedioNmToUW/bLy1O8E00BiDeUJRtCvCLYjqOWXjrZMts+ +6PAQZe104S+nfK8nNLspfZu2zwnI5dMK/IhlZXQK3HMcXM1AsRzUtoSMTFDPaI6oWa7CJ06CojXd +FPQf/7J31Ycvqm59JCfnxssm5uX+Zwdj2EUN3TpZZTlYepKZcj2chF6IIbjV9Cz82XBST3i4vTwr +i5WY9bPRaM8gFH5MXF/ni+X1NYEZN9cRCLdmvtNKzoNXADrDgfgXy5I2XdGj2HUb4Ysn6npIQf1F +GQatJ5lOwXBH3bWfgVMS5bGMSF0xQxfjjMZ6Y5ZLKTBOhE5iGV48zpeQpX8B653g+IuJ3SWYPZK2 +fu/Z8VFRfS0myGlZYeCsargqNhEEelC9MoS+L9xy1dcdFkfkR2YgP/SWxa+OAXqlD3pk9Q0Yh9mu +iNX6hME6wGkoLfINaFGq46V3xqSQDqE3izEjR8EJCOtu93ib14L8hCCZSRm2Ekax+0VVFqmjZayc +Bw/qa9wfLgZy7IaIEuQt218FL+TwA9MmM+eAws1CoRc0CwIDAQABo0IwQDAPBgNVHRMBAf8EBTAD +AQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQUcRVnyMjJvXVdctA4GGqd83EkVAswDQYJKoZI +hvcNAQELBQADggIBAHW7bVRLqhBYRjTyYtcWNl0IXtVsyIe9tC5G8jH4fOpCtZMWVdyhDBKg2mF+ +D1hYc2Ryx+hFjtyp8iY/xnmMsVMIM4GwVhO+5lFc2JsKT0ucVlMC6U/2DWDqTUJV6HwbISHTGzrM +d/K4kPFox/la/vot9L/J9UUbzjgQKjeKeaO04wlshYaT/4mWJ3iBj2fjRnRUjtkNaeJK9E10A/+y +d+2VZ5fkscWrv2oj6NSU4kQoYsRL4vDY4ilrGnB+JGGTe08DMiUNRSQrlrRGar9KC/eaj8GsGsVn +82800vpzY4zvFrCopEYq+OsS7HK07/grfoxSwIuEVPkvPuNVqNxmsdnhX9izjFk0WaSrT2y7Hxjb +davYy5LNlDhhDgcGH0tGEPEVvo2FXDtKK4F5D7Rpn0lQl033DlZdwJVqwjbDG2jJ9SrcR5q+ss7F +Jej6A7na+RZukYT1HCjI/CbM1xyQVqdfbzoEvM14iQuODy+jqk+iGxI9FghAD/FGTNeqewjBCvVt +J94Cj8rDtSvK6evIIVM4pcw72Hc3MKJP2W/R8kCtQXoXxdZKNYm3QdV8hn9VTYNKpXMgwDqvkPGa +JI7ZjnHKe7iG2rKPmT4dEw0SEe7Uq/DpFXYC5ODfqiAeW2GFZECpkJcNrVPSWh2HagCXZWK0vm9q +p/UsQu0yrbYhnr68 +-----END CERTIFICATE----- + +Hellenic Academic and Research Institutions ECC RootCA 2015 +=========================================================== +-----BEGIN CERTIFICATE----- +MIICwzCCAkqgAwIBAgIBADAKBggqhkjOPQQDAjCBqjELMAkGA1UEBhMCR1IxDzANBgNVBAcTBkF0 +aGVuczFEMEIGA1UEChM7SGVsbGVuaWMgQWNhZGVtaWMgYW5kIFJlc2VhcmNoIEluc3RpdHV0aW9u +cyBDZXJ0LiBBdXRob3JpdHkxRDBCBgNVBAMTO0hlbGxlbmljIEFjYWRlbWljIGFuZCBSZXNlYXJj +aCBJbnN0aXR1dGlvbnMgRUNDIFJvb3RDQSAyMDE1MB4XDTE1MDcwNzEwMzcxMloXDTQwMDYzMDEw +MzcxMlowgaoxCzAJBgNVBAYTAkdSMQ8wDQYDVQQHEwZBdGhlbnMxRDBCBgNVBAoTO0hlbGxlbmlj +IEFjYWRlbWljIGFuZCBSZXNlYXJjaCBJbnN0aXR1dGlvbnMgQ2VydC4gQXV0aG9yaXR5MUQwQgYD +VQQDEztIZWxsZW5pYyBBY2FkZW1pYyBhbmQgUmVzZWFyY2ggSW5zdGl0dXRpb25zIEVDQyBSb290 +Q0EgMjAxNTB2MBAGByqGSM49AgEGBSuBBAAiA2IABJKgQehLgoRc4vgxEZmGZE4JJS+dQS8KrjVP +dJWyUWRrjWvmP3CV8AVER6ZyOFB2lQJajq4onvktTpnvLEhvTCUp6NFxW98dwXU3tNf6e3pCnGoK +Vlp8aQuqgAkkbH7BRqNCMEAwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0O +BBYEFLQiC4KZJAEOnLvkDv2/+5cgk5kqMAoGCCqGSM49BAMCA2cAMGQCMGfOFmI4oqxiRaeplSTA +GiecMjvAwNW6qef4BENThe5SId6d9SWDPp5YSy/XZxMOIQIwBeF1Ad5o7SofTUwJCA3sS61kFyjn +dc5FZXIhF8siQQ6ME5g4mlRtm8rifOoCWCKR +-----END CERTIFICATE----- + +Certplus Root CA G1 +=================== +-----BEGIN CERTIFICATE----- +MIIFazCCA1OgAwIBAgISESBVg+QtPlRWhS2DN7cs3EYRMA0GCSqGSIb3DQEBDQUAMD4xCzAJBgNV +BAYTAkZSMREwDwYDVQQKDAhDZXJ0cGx1czEcMBoGA1UEAwwTQ2VydHBsdXMgUm9vdCBDQSBHMTAe +Fw0xNDA1MjYwMDAwMDBaFw0zODAxMTUwMDAwMDBaMD4xCzAJBgNVBAYTAkZSMREwDwYDVQQKDAhD +ZXJ0cGx1czEcMBoGA1UEAwwTQ2VydHBsdXMgUm9vdCBDQSBHMTCCAiIwDQYJKoZIhvcNAQEBBQAD +ggIPADCCAgoCggIBANpQh7bauKk+nWT6VjOaVj0W5QOVsjQcmm1iBdTYj+eJZJ+622SLZOZ5KmHN +r49aiZFluVj8tANfkT8tEBXgfs+8/H9DZ6itXjYj2JizTfNDnjl8KvzsiNWI7nC9hRYt6kuJPKNx +Qv4c/dMcLRC4hlTqQ7jbxofaqK6AJc96Jh2qkbBIb6613p7Y1/oA/caP0FG7Yn2ksYyy/yARujVj +BYZHYEMzkPZHogNPlk2dT8Hq6pyi/jQu3rfKG3akt62f6ajUeD94/vI4CTYd0hYCyOwqaK/1jpTv +LRN6HkJKHRUxrgwEV/xhc/MxVoYxgKDEEW4wduOU8F8ExKyHcomYxZ3MVwia9Az8fXoFOvpHgDm2 +z4QTd28n6v+WZxcIbekN1iNQMLAVdBM+5S//Ds3EC0pd8NgAM0lm66EYfFkuPSi5YXHLtaW6uOrc +4nBvCGrch2c0798wct3zyT8j/zXhviEpIDCB5BmlIOklynMxdCm+4kLV87ImZsdo/Rmz5yCTmehd +4F6H50boJZwKKSTUzViGUkAksnsPmBIgJPaQbEfIDbsYIC7Z/fyL8inqh3SV4EJQeIQEQWGw9CEj +jy3LKCHyamz0GqbFFLQ3ZU+V/YDI+HLlJWvEYLF7bY5KinPOWftwenMGE9nTdDckQQoRb5fc5+R+ +ob0V8rqHDz1oihYHAgMBAAGjYzBhMA4GA1UdDwEB/wQEAwIBBjAPBgNVHRMBAf8EBTADAQH/MB0G +A1UdDgQWBBSowcCbkahDFXxdBie0KlHYlwuBsTAfBgNVHSMEGDAWgBSowcCbkahDFXxdBie0KlHY +lwuBsTANBgkqhkiG9w0BAQ0FAAOCAgEAnFZvAX7RvUz1isbwJh/k4DgYzDLDKTudQSk0YcbX8ACh +66Ryj5QXvBMsdbRX7gp8CXrc1cqh0DQT+Hern+X+2B50ioUHj3/MeXrKls3N/U/7/SMNkPX0XtPG +YX2eEeAC7gkE2Qfdpoq3DIMku4NQkv5gdRE+2J2winq14J2by5BSS7CTKtQ+FjPlnsZlFT5kOwQ/ +2wyPX1wdaR+v8+khjPPvl/aatxm2hHSco1S1cE5j2FddUyGbQJJD+tZ3VTNPZNX70Cxqjm0lpu+F +6ALEUz65noe8zDUa3qHpimOHZR4RKttjd5cUvpoUmRGywO6wT/gUITJDT5+rosuoD6o7BlXGEilX +CNQ314cnrUlZp5GrRHpejXDbl85IULFzk/bwg2D5zfHhMf1bfHEhYxQUqq/F3pN+aLHsIqKqkHWe +tUNy6mSjhEv9DKgma3GX7lZjZuhCVPnHHd/Qj1vfyDBviP4NxDMcU6ij/UgQ8uQKTuEVV/xuZDDC +VRHc6qnNSlSsKWNEz0pAoNZoWRsz+e86i9sgktxChL8Bq4fA1SCC28a5g4VCXA9DO2pJNdWY9BW/ ++mGBDAkgGNLQFwzLSABQ6XaCjGTXOqAHVcweMcDvOrRl++O/QmueD6i9a5jc2NvLi6Td11n0bt3+ +qsOR0C5CB8AMTVPNJLFMWx5R9N/pkvo= +-----END CERTIFICATE----- + +Certplus Root CA G2 +=================== +-----BEGIN CERTIFICATE----- +MIICHDCCAaKgAwIBAgISESDZkc6uo+jF5//pAq/Pc7xVMAoGCCqGSM49BAMDMD4xCzAJBgNVBAYT +AkZSMREwDwYDVQQKDAhDZXJ0cGx1czEcMBoGA1UEAwwTQ2VydHBsdXMgUm9vdCBDQSBHMjAeFw0x +NDA1MjYwMDAwMDBaFw0zODAxMTUwMDAwMDBaMD4xCzAJBgNVBAYTAkZSMREwDwYDVQQKDAhDZXJ0 +cGx1czEcMBoGA1UEAwwTQ2VydHBsdXMgUm9vdCBDQSBHMjB2MBAGByqGSM49AgEGBSuBBAAiA2IA +BM0PW1aC3/BFGtat93nwHcmsltaeTpwftEIRyoa/bfuFo8XlGVzX7qY/aWfYeOKmycTbLXku54uN +Am8xIk0G42ByRZ0OQneezs/lf4WbGOT8zC5y0xaTTsqZY1yhBSpsBqNjMGEwDgYDVR0PAQH/BAQD +AgEGMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYEFNqDYwJ5jtpMxjwjFNiPwyCrKGBZMB8GA1Ud +IwQYMBaAFNqDYwJ5jtpMxjwjFNiPwyCrKGBZMAoGCCqGSM49BAMDA2gAMGUCMHD+sAvZ94OX7PNV +HdTcswYO/jOYnYs5kGuUIe22113WTNchp+e/IQ8rzfcq3IUHnQIxAIYUFuXcsGXCwI4Un78kFmjl +vPl5adytRSv3tjFzzAalU5ORGpOucGpnutee5WEaXw== +-----END CERTIFICATE----- + +OpenTrust Root CA G1 +==================== +-----BEGIN CERTIFICATE----- +MIIFbzCCA1egAwIBAgISESCzkFU5fX82bWTCp59rY45nMA0GCSqGSIb3DQEBCwUAMEAxCzAJBgNV +BAYTAkZSMRIwEAYDVQQKDAlPcGVuVHJ1c3QxHTAbBgNVBAMMFE9wZW5UcnVzdCBSb290IENBIEcx +MB4XDTE0MDUyNjA4NDU1MFoXDTM4MDExNTAwMDAwMFowQDELMAkGA1UEBhMCRlIxEjAQBgNVBAoM +CU9wZW5UcnVzdDEdMBsGA1UEAwwUT3BlblRydXN0IFJvb3QgQ0EgRzEwggIiMA0GCSqGSIb3DQEB +AQUAA4ICDwAwggIKAoICAQD4eUbalsUwXopxAy1wpLuwxQjczeY1wICkES3d5oeuXT2R0odsN7fa +Yp6bwiTXj/HbpqbfRm9RpnHLPhsxZ2L3EVs0J9V5ToybWL0iEA1cJwzdMOWo010hOHQX/uMftk87 +ay3bfWAfjH1MBcLrARYVmBSO0ZB3Ij/swjm4eTrwSSTilZHcYTSSjFR077F9jAHiOH3BX2pfJLKO +YheteSCtqx234LSWSE9mQxAGFiQD4eCcjsZGT44ameGPuY4zbGneWK2gDqdkVBFpRGZPTBKnjix9 +xNRbxQA0MMHZmf4yzgeEtE7NCv82TWLxp2NX5Ntqp66/K7nJ5rInieV+mhxNaMbBGN4zK1FGSxyO +9z0M+Yo0FMT7MzUj8czxKselu7Cizv5Ta01BG2Yospb6p64KTrk5M0ScdMGTHPjgniQlQ/GbI4Kq +3ywgsNw2TgOzfALU5nsaqocTvz6hdLubDuHAk5/XpGbKuxs74zD0M1mKB3IDVedzagMxbm+WG+Oi +n6+Sx+31QrclTDsTBM8clq8cIqPQqwWyTBIjUtz9GVsnnB47ev1CI9sjgBPwvFEVVJSmdz7QdFG9 +URQIOTfLHzSpMJ1ShC5VkLG631UAC9hWLbFJSXKAqWLXwPYYEQRVzXR7z2FwefR7LFxckvzluFqr +TJOVoSfupb7PcSNCupt2LQIDAQABo2MwYTAOBgNVHQ8BAf8EBAMCAQYwDwYDVR0TAQH/BAUwAwEB +/zAdBgNVHQ4EFgQUl0YhVyE12jZVx/PxN3DlCPaTKbYwHwYDVR0jBBgwFoAUl0YhVyE12jZVx/Px +N3DlCPaTKbYwDQYJKoZIhvcNAQELBQADggIBAB3dAmB84DWn5ph76kTOZ0BP8pNuZtQ5iSas000E +PLuHIT839HEl2ku6q5aCgZG27dmxpGWX4m9kWaSW7mDKHyP7Rbr/jyTwyqkxf3kfgLMtMrpkZ2Cv +uVnN35pJ06iCsfmYlIrM4LvgBBuZYLFGZdwIorJGnkSI6pN+VxbSFXJfLkur1J1juONI5f6ELlgK +n0Md/rcYkoZDSw6cMoYsYPXpSOqV7XAp8dUv/TW0V8/bhUiZucJvbI/NeJWsZCj9VrDDb8O+WVLh +X4SPgPL0DTatdrOjteFkdjpY3H1PXlZs5VVZV6Xf8YpmMIzUUmI4d7S+KNfKNsSbBfD4Fdvb8e80 +nR14SohWZ25g/4/Ii+GOvUKpMwpZQhISKvqxnUOOBZuZ2mKtVzazHbYNeS2WuOvyDEsMpZTGMKcm +GS3tTAZQMPH9WD25SxdfGbRqhFS0OE85og2WaMMolP3tLR9Ka0OWLpABEPs4poEL0L9109S5zvE/ +bw4cHjdx5RiHdRk/ULlepEU0rbDK5uUTdg8xFKmOLZTW1YVNcxVPS/KyPu1svf0OnWZzsD2097+o +4BGkxK51CUpjAEggpsadCwmKtODmzj7HPiY46SvepghJAwSQiumPv+i2tCqjI40cHLI5kqiPAlxA +OXXUc0ECd97N4EOH1uS6SsNsEn/+KuYj1oxx +-----END CERTIFICATE----- + +OpenTrust Root CA G2 +==================== +-----BEGIN CERTIFICATE----- +MIIFbzCCA1egAwIBAgISESChaRu/vbm9UpaPI+hIvyYRMA0GCSqGSIb3DQEBDQUAMEAxCzAJBgNV +BAYTAkZSMRIwEAYDVQQKDAlPcGVuVHJ1c3QxHTAbBgNVBAMMFE9wZW5UcnVzdCBSb290IENBIEcy +MB4XDTE0MDUyNjAwMDAwMFoXDTM4MDExNTAwMDAwMFowQDELMAkGA1UEBhMCRlIxEjAQBgNVBAoM +CU9wZW5UcnVzdDEdMBsGA1UEAwwUT3BlblRydXN0IFJvb3QgQ0EgRzIwggIiMA0GCSqGSIb3DQEB +AQUAA4ICDwAwggIKAoICAQDMtlelM5QQgTJT32F+D3Y5z1zCU3UdSXqWON2ic2rxb95eolq5cSG+ +Ntmh/LzubKh8NBpxGuga2F8ORAbtp+Dz0mEL4DKiltE48MLaARf85KxP6O6JHnSrT78eCbY2albz +4e6WiWYkBuTNQjpK3eCasMSCRbP+yatcfD7J6xcvDH1urqWPyKwlCm/61UWY0jUJ9gNDlP7ZvyCV +eYCYitmJNbtRG6Q3ffyZO6v/v6wNj0OxmXsWEH4db0fEFY8ElggGQgT4hNYdvJGmQr5J1WqIP7wt +UdGejeBSzFfdNTVY27SPJIjki9/ca1TSgSuyzpJLHB9G+h3Ykst2Z7UJmQnlrBcUVXDGPKBWCgOz +3GIZ38i1MH/1PCZ1Eb3XG7OHngevZXHloM8apwkQHZOJZlvoPGIytbU6bumFAYueQ4xncyhZW+vj +3CzMpSZyYhK05pyDRPZRpOLAeiRXyg6lPzq1O4vldu5w5pLeFlwoW5cZJ5L+epJUzpM5ChaHvGOz +9bGTXOBut9Dq+WIyiET7vycotjCVXRIouZW+j1MY5aIYFuJWpLIsEPUdN6b4t/bQWVyJ98LVtZR0 +0dX+G7bw5tYee9I8y6jj9RjzIR9u701oBnstXW5DiabA+aC/gh7PU3+06yzbXfZqfUAkBXKJOAGT +y3HCOV0GEfZvePg3DTmEJwIDAQABo2MwYTAOBgNVHQ8BAf8EBAMCAQYwDwYDVR0TAQH/BAUwAwEB +/zAdBgNVHQ4EFgQUajn6QiL35okATV59M4PLuG53hq8wHwYDVR0jBBgwFoAUajn6QiL35okATV59 +M4PLuG53hq8wDQYJKoZIhvcNAQENBQADggIBAJjLq0A85TMCl38th6aP1F5Kr7ge57tx+4BkJamz +Gj5oXScmp7oq4fBXgwpkTx4idBvpkF/wrM//T2h6OKQQbA2xx6R3gBi2oihEdqc0nXGEL8pZ0keI +mUEiyTCYYW49qKgFbdEfwFFEVn8nNQLdXpgKQuswv42hm1GqO+qTRmTFAHneIWv2V6CG1wZy7HBG +S4tz3aAhdT7cHcCP009zHIXZ/n9iyJVvttN7jLpTwm+bREx50B1ws9efAvSyB7DH5fitIw6mVskp +EndI2S9G/Tvw/HRwkqWOOAgfZDC2t0v7NqwQjqBSM2OdAzVWxWm9xiNaJ5T2pBL4LTM8oValX9YZ +6e18CL13zSdkzJTaTkZQh+D5wVOAHrut+0dSixv9ovneDiK3PTNZbNTe9ZUGMg1RGUFcPk8G97kr +gCf2o6p6fAbhQ8MTOWIaNr3gKC6UAuQpLmBVrkA9sHSSXvAgZJY/X0VdiLWK2gKgW0VU3jg9CcCo +SmVGFvyqv1ROTVu+OEO3KMqLM6oaJbolXCkvW0pujOotnCr2BXbgd5eAiN1nE28daCSLT7d0geX0 +YJ96Vdc+N9oWaz53rK4YcJUIeSkDiv7BO7M/Gg+kO14fWKGVyasvc0rQLW6aWQ9VGHgtPFGml4vm +u7JwqkwR3v98KzfUetF3NI/n+UL3PIEMS1IK +-----END CERTIFICATE----- + +OpenTrust Root CA G3 +==================== +-----BEGIN CERTIFICATE----- +MIICITCCAaagAwIBAgISESDm+Ez8JLC+BUCs2oMbNGA/MAoGCCqGSM49BAMDMEAxCzAJBgNVBAYT +AkZSMRIwEAYDVQQKDAlPcGVuVHJ1c3QxHTAbBgNVBAMMFE9wZW5UcnVzdCBSb290IENBIEczMB4X +DTE0MDUyNjAwMDAwMFoXDTM4MDExNTAwMDAwMFowQDELMAkGA1UEBhMCRlIxEjAQBgNVBAoMCU9w +ZW5UcnVzdDEdMBsGA1UEAwwUT3BlblRydXN0IFJvb3QgQ0EgRzMwdjAQBgcqhkjOPQIBBgUrgQQA +IgNiAARK7liuTcpm3gY6oxH84Bjwbhy6LTAMidnW7ptzg6kjFYwvWYpa3RTqnVkrQ7cG7DK2uu5B +ta1doYXM6h0UZqNnfkbilPPntlahFVmhTzeXuSIevRHr9LIfXsMUmuXZl5mjYzBhMA4GA1UdDwEB +/wQEAwIBBjAPBgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBRHd8MUi2I5DMlv4VBN0BBY3JWIbTAf +BgNVHSMEGDAWgBRHd8MUi2I5DMlv4VBN0BBY3JWIbTAKBggqhkjOPQQDAwNpADBmAjEAj6jcnboM +BBf6Fek9LykBl7+BFjNAk2z8+e2AcG+qj9uEwov1NcoG3GRvaBbhj5G5AjEA2Euly8LQCGzpGPta +3U1fJAuwACEl74+nBCZx4nxp5V2a+EEfOzmTk51V6s2N8fvB +-----END CERTIFICATE----- + +ISRG Root X1 +============ +-----BEGIN CERTIFICATE----- +MIIFazCCA1OgAwIBAgIRAIIQz7DSQONZRGPgu2OCiwAwDQYJKoZIhvcNAQELBQAwTzELMAkGA1UE +BhMCVVMxKTAnBgNVBAoTIEludGVybmV0IFNlY3VyaXR5IFJlc2VhcmNoIEdyb3VwMRUwEwYDVQQD +EwxJU1JHIFJvb3QgWDEwHhcNMTUwNjA0MTEwNDM4WhcNMzUwNjA0MTEwNDM4WjBPMQswCQYDVQQG +EwJVUzEpMCcGA1UEChMgSW50ZXJuZXQgU2VjdXJpdHkgUmVzZWFyY2ggR3JvdXAxFTATBgNVBAMT +DElTUkcgUm9vdCBYMTCCAiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBAK3oJHP0FDfzm54r +Vygch77ct984kIxuPOZXoHj3dcKi/vVqbvYATyjb3miGbESTtrFj/RQSa78f0uoxmyF+0TM8ukj1 +3Xnfs7j/EvEhmkvBioZxaUpmZmyPfjxwv60pIgbz5MDmgK7iS4+3mX6UA5/TR5d8mUgjU+g4rk8K +b4Mu0UlXjIB0ttov0DiNewNwIRt18jA8+o+u3dpjq+sWT8KOEUt+zwvo/7V3LvSye0rgTBIlDHCN +Aymg4VMk7BPZ7hm/ELNKjD+Jo2FR3qyHB5T0Y3HsLuJvW5iB4YlcNHlsdu87kGJ55tukmi8mxdAQ +4Q7e2RCOFvu396j3x+UCB5iPNgiV5+I3lg02dZ77DnKxHZu8A/lJBdiB3QW0KtZB6awBdpUKD9jf +1b0SHzUvKBds0pjBqAlkd25HN7rOrFleaJ1/ctaJxQZBKT5ZPt0m9STJEadao0xAH0ahmbWnOlFu +hjuefXKnEgV4We0+UXgVCwOPjdAvBbI+e0ocS3MFEvzG6uBQE3xDk3SzynTnjh8BCNAw1FtxNrQH +usEwMFxIt4I7mKZ9YIqioymCzLq9gwQbooMDQaHWBfEbwrbwqHyGO0aoSCqI3Haadr8faqU9GY/r +OPNk3sgrDQoo//fb4hVC1CLQJ13hef4Y53CIrU7m2Ys6xt0nUW7/vGT1M0NPAgMBAAGjQjBAMA4G +A1UdDwEB/wQEAwIBBjAPBgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBR5tFnme7bl5AFzgAiIyBpY +9umbbjANBgkqhkiG9w0BAQsFAAOCAgEAVR9YqbyyqFDQDLHYGmkgJykIrGF1XIpu+ILlaS/V9lZL +ubhzEFnTIZd+50xx+7LSYK05qAvqFyFWhfFQDlnrzuBZ6brJFe+GnY+EgPbk6ZGQ3BebYhtF8GaV +0nxvwuo77x/Py9auJ/GpsMiu/X1+mvoiBOv/2X/qkSsisRcOj/KKNFtY2PwByVS5uCbMiogziUwt +hDyC3+6WVwW6LLv3xLfHTjuCvjHIInNzktHCgKQ5ORAzI4JMPJ+GslWYHb4phowim57iaztXOoJw +TdwJx4nLCgdNbOhdjsnvzqvHu7UrTkXWStAmzOVyyghqpZXjFaH3pO3JLF+l+/+sKAIuvtd7u+Nx +e5AW0wdeRlN8NwdCjNPElpzVmbUq4JUagEiuTDkHzsxHpFKVK7q4+63SM1N95R1NbdWhscdCb+ZA +JzVcoyi3B43njTOQ5yOf+1CceWxG1bQVs5ZufpsMljq4Ui0/1lvh+wjChP4kqKOJ2qxq4RgqsahD +YVvTH9w7jXbyLeiNdd8XM2w9U/t7y0Ff/9yi0GE44Za4rF2LN9d11TPAmRGunUHBcnWEvgJBQl9n +JEiU0Zsnvgc/ubhPgXRR4Xq37Z0j4r7g1SgEEzwxA57demyPxgcYxn/eR44/KJ4EBs+lVDR3veyJ +m+kXQ99b21/+jh5Xos1AnX5iItreGCc= +-----END CERTIFICATE----- + +AC RAIZ FNMT-RCM +================ +-----BEGIN CERTIFICATE----- +MIIFgzCCA2ugAwIBAgIPXZONMGc2yAYdGsdUhGkHMA0GCSqGSIb3DQEBCwUAMDsxCzAJBgNVBAYT +AkVTMREwDwYDVQQKDAhGTk1ULVJDTTEZMBcGA1UECwwQQUMgUkFJWiBGTk1ULVJDTTAeFw0wODEw +MjkxNTU5NTZaFw0zMDAxMDEwMDAwMDBaMDsxCzAJBgNVBAYTAkVTMREwDwYDVQQKDAhGTk1ULVJD +TTEZMBcGA1UECwwQQUMgUkFJWiBGTk1ULVJDTTCCAiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoC +ggIBALpxgHpMhm5/yBNtwMZ9HACXjywMI7sQmkCpGreHiPibVmr75nuOi5KOpyVdWRHbNi63URcf +qQgfBBckWKo3Shjf5TnUV/3XwSyRAZHiItQDwFj8d0fsjz50Q7qsNI1NOHZnjrDIbzAzWHFctPVr +btQBULgTfmxKo0nRIBnuvMApGGWn3v7v3QqQIecaZ5JCEJhfTzC8PhxFtBDXaEAUwED653cXeuYL +j2VbPNmaUtu1vZ5Gzz3rkQUCwJaydkxNEJY7kvqcfw+Z374jNUUeAlz+taibmSXaXvMiwzn15Cou +08YfxGyqxRxqAQVKL9LFwag0Jl1mpdICIfkYtwb1TplvqKtMUejPUBjFd8g5CSxJkjKZqLsXF3mw +WsXmo8RZZUc1g16p6DULmbvkzSDGm0oGObVo/CK67lWMK07q87Hj/LaZmtVC+nFNCM+HHmpxffnT +tOmlcYF7wk5HlqX2doWjKI/pgG6BU6VtX7hI+cL5NqYuSf+4lsKMB7ObiFj86xsc3i1w4peSMKGJ +47xVqCfWS+2QrYv6YyVZLag13cqXM7zlzced0ezvXg5KkAYmY6252TUtB7p2ZSysV4999AeU14EC +ll2jB0nVetBX+RvnU0Z1qrB5QstocQjpYL05ac70r8NWQMetUqIJ5G+GR4of6ygnXYMgrwTJbFaa +i0b1AgMBAAGjgYMwgYAwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0OBBYE +FPd9xf3E6Jobd2Sn9R2gzL+HYJptMD4GA1UdIAQ3MDUwMwYEVR0gADArMCkGCCsGAQUFBwIBFh1o +dHRwOi8vd3d3LmNlcnQuZm5tdC5lcy9kcGNzLzANBgkqhkiG9w0BAQsFAAOCAgEAB5BK3/MjTvDD +nFFlm5wioooMhfNzKWtN/gHiqQxjAb8EZ6WdmF/9ARP67Jpi6Yb+tmLSbkyU+8B1RXxlDPiyN8+s +D8+Nb/kZ94/sHvJwnvDKuO+3/3Y3dlv2bojzr2IyIpMNOmqOFGYMLVN0V2Ue1bLdI4E7pWYjJ2cJ +j+F3qkPNZVEI7VFY/uY5+ctHhKQV8Xa7pO6kO8Rf77IzlhEYt8llvhjho6Tc+hj507wTmzl6NLrT +Qfv6MooqtyuGC2mDOL7Nii4LcK2NJpLuHvUBKwrZ1pebbuCoGRw6IYsMHkCtA+fdZn71uSANA+iW ++YJF1DngoABd15jmfZ5nc8OaKveri6E6FO80vFIOiZiaBECEHX5FaZNXzuvO+FB8TxxuBEOb+dY7 +Ixjp6o7RTUaN8Tvkasq6+yO3m/qZASlaWFot4/nUbQ4mrcFuNLwy+AwF+mWj2zs3gyLp1txyM/1d +8iC9djwj2ij3+RvrWWTV3F9yfiD8zYm1kGdNYno/Tq0dwzn+evQoFt9B9kiABdcPUXmsEKvU7ANm +5mqwujGSQkBqvjrTcuFqN1W8rB2Vt2lh8kORdOag0wokRqEIr9baRRmW1FMdW4R58MD3R++Lj8UG +rp1MYp3/RgT408m2ECVAdf4WqslKYIYvuu8wd+RU4riEmViAqhOLUTpPSPaLtrM= +-----END CERTIFICATE----- + +Amazon Root CA 1 +================ +-----BEGIN CERTIFICATE----- +MIIDQTCCAimgAwIBAgITBmyfz5m/jAo54vB4ikPmljZbyjANBgkqhkiG9w0BAQsFADA5MQswCQYD +VQQGEwJVUzEPMA0GA1UEChMGQW1hem9uMRkwFwYDVQQDExBBbWF6b24gUm9vdCBDQSAxMB4XDTE1 +MDUyNjAwMDAwMFoXDTM4MDExNzAwMDAwMFowOTELMAkGA1UEBhMCVVMxDzANBgNVBAoTBkFtYXpv +bjEZMBcGA1UEAxMQQW1hem9uIFJvb3QgQ0EgMTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoC +ggEBALJ4gHHKeNXjca9HgFB0fW7Y14h29Jlo91ghYPl0hAEvrAIthtOgQ3pOsqTQNroBvo3bSMgH +FzZM9O6II8c+6zf1tRn4SWiw3te5djgdYZ6k/oI2peVKVuRF4fn9tBb6dNqcmzU5L/qwIFAGbHrQ +gLKm+a/sRxmPUDgH3KKHOVj4utWp+UhnMJbulHheb4mjUcAwhmahRWa6VOujw5H5SNz/0egwLX0t +dHA114gk957EWW67c4cX8jJGKLhD+rcdqsq08p8kDi1L93FcXmn/6pUCyziKrlA4b9v7LWIbxcce +VOF34GfID5yHI9Y/QCB/IIDEgEw+OyQmjgSubJrIqg0CAwEAAaNCMEAwDwYDVR0TAQH/BAUwAwEB +/zAOBgNVHQ8BAf8EBAMCAYYwHQYDVR0OBBYEFIQYzIU07LwMlJQuCFmcx7IQTgoIMA0GCSqGSIb3 +DQEBCwUAA4IBAQCY8jdaQZChGsV2USggNiMOruYou6r4lK5IpDB/G/wkjUu0yKGX9rbxenDIU5PM +CCjjmCXPI6T53iHTfIUJrU6adTrCC2qJeHZERxhlbI1Bjjt/msv0tadQ1wUsN+gDS63pYaACbvXy +8MWy7Vu33PqUXHeeE6V/Uq2V8viTO96LXFvKWlJbYK8U90vvo/ufQJVtMVT8QtPHRh8jrdkPSHCa +2XV4cdFyQzR1bldZwgJcJmApzyMZFo6IQ6XU5MsI+yMRQ+hDKXJioaldXgjUkK642M4UwtBV8ob2 +xJNDd2ZhwLnoQdeXeGADbkpyrqXRfboQnoZsG4q5WTP468SQvvG5 +-----END CERTIFICATE----- + +Amazon Root CA 2 +================ +-----BEGIN CERTIFICATE----- +MIIFQTCCAymgAwIBAgITBmyf0pY1hp8KD+WGePhbJruKNzANBgkqhkiG9w0BAQwFADA5MQswCQYD +VQQGEwJVUzEPMA0GA1UEChMGQW1hem9uMRkwFwYDVQQDExBBbWF6b24gUm9vdCBDQSAyMB4XDTE1 +MDUyNjAwMDAwMFoXDTQwMDUyNjAwMDAwMFowOTELMAkGA1UEBhMCVVMxDzANBgNVBAoTBkFtYXpv +bjEZMBcGA1UEAxMQQW1hem9uIFJvb3QgQ0EgMjCCAiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoC +ggIBAK2Wny2cSkxKgXlRmeyKy2tgURO8TW0G/LAIjd0ZEGrHJgw12MBvIITplLGbhQPDW9tK6Mj4 +kHbZW0/jTOgGNk3Mmqw9DJArktQGGWCsN0R5hYGCrVo34A3MnaZMUnbqQ523BNFQ9lXg1dKmSYXp +N+nKfq5clU1Imj+uIFptiJXZNLhSGkOQsL9sBbm2eLfq0OQ6PBJTYv9K8nu+NQWpEjTj82R0Yiw9 +AElaKP4yRLuH3WUnAnE72kr3H9rN9yFVkE8P7K6C4Z9r2UXTu/Bfh+08LDmG2j/e7HJV63mjrdvd +fLC6HM783k81ds8P+HgfajZRRidhW+mez/CiVX18JYpvL7TFz4QuK/0NURBs+18bvBt+xa47mAEx +kv8LV/SasrlX6avvDXbR8O70zoan4G7ptGmh32n2M8ZpLpcTnqWHsFcQgTfJU7O7f/aS0ZzQGPSS +btqDT6ZjmUyl+17vIWR6IF9sZIUVyzfpYgwLKhbcAS4y2j5L9Z469hdAlO+ekQiG+r5jqFoz7Mt0 +Q5X5bGlSNscpb/xVA1wf+5+9R+vnSUeVC06JIglJ4PVhHvG/LopyboBZ/1c6+XUyo05f7O0oYtlN +c/LMgRdg7c3r3NunysV+Ar3yVAhU/bQtCSwXVEqY0VThUWcI0u1ufm8/0i2BWSlmy5A5lREedCf+ +3euvAgMBAAGjQjBAMA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgGGMB0GA1UdDgQWBBSw +DPBMMPQFWAJI/TPlUq9LhONmUjANBgkqhkiG9w0BAQwFAAOCAgEAqqiAjw54o+Ci1M3m9Zh6O+oA +A7CXDpO8Wqj2LIxyh6mx/H9z/WNxeKWHWc8w4Q0QshNabYL1auaAn6AFC2jkR2vHat+2/XcycuUY ++gn0oJMsXdKMdYV2ZZAMA3m3MSNjrXiDCYZohMr/+c8mmpJ5581LxedhpxfL86kSk5Nrp+gvU5LE +YFiwzAJRGFuFjWJZY7attN6a+yb3ACfAXVU3dJnJUH/jWS5E4ywl7uxMMne0nxrpS10gxdr9HIcW +xkPo1LsmmkVwXqkLN1PiRnsn/eBG8om3zEK2yygmbtmlyTrIQRNg91CMFa6ybRoVGld45pIq2WWQ +gj9sAq+uEjonljYE1x2igGOpm/HlurR8FLBOybEfdF849lHqm/osohHUqS0nGkWxr7JOcQ3AWEbW +aQbLU8uz/mtBzUF+fUwPfHJ5elnNXkoOrJupmHN5fLT0zLm4BwyydFy4x2+IoZCn9Kr5v2c69BoV +Yh63n749sSmvZ6ES8lgQGVMDMBu4Gon2nL2XA46jCfMdiyHxtN/kHNGfZQIG6lzWE7OE76KlXIx3 +KadowGuuQNKotOrN8I1LOJwZmhsoVLiJkO/KdYE+HvJkJMcYr07/R54H9jVlpNMKVv/1F2Rs76gi +JUmTtt8AF9pYfl3uxRuw0dFfIRDH+fO6AgonB8Xx1sfT4PsJYGw= +-----END CERTIFICATE----- + +Amazon Root CA 3 +================ +-----BEGIN CERTIFICATE----- +MIIBtjCCAVugAwIBAgITBmyf1XSXNmY/Owua2eiedgPySjAKBggqhkjOPQQDAjA5MQswCQYDVQQG +EwJVUzEPMA0GA1UEChMGQW1hem9uMRkwFwYDVQQDExBBbWF6b24gUm9vdCBDQSAzMB4XDTE1MDUy +NjAwMDAwMFoXDTQwMDUyNjAwMDAwMFowOTELMAkGA1UEBhMCVVMxDzANBgNVBAoTBkFtYXpvbjEZ +MBcGA1UEAxMQQW1hem9uIFJvb3QgQ0EgMzBZMBMGByqGSM49AgEGCCqGSM49AwEHA0IABCmXp8ZB +f8ANm+gBG1bG8lKlui2yEujSLtf6ycXYqm0fc4E7O5hrOXwzpcVOho6AF2hiRVd9RFgdszflZwjr +Zt6jQjBAMA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgGGMB0GA1UdDgQWBBSrttvXBp43 +rDCGB5Fwx5zEGbF4wDAKBggqhkjOPQQDAgNJADBGAiEA4IWSoxe3jfkrBqWTrBqYaGFy+uGh0Psc +eGCmQ5nFuMQCIQCcAu/xlJyzlvnrxir4tiz+OpAUFteMYyRIHN8wfdVoOw== +-----END CERTIFICATE----- + +Amazon Root CA 4 +================ +-----BEGIN CERTIFICATE----- +MIIB8jCCAXigAwIBAgITBmyf18G7EEwpQ+Vxe3ssyBrBDjAKBggqhkjOPQQDAzA5MQswCQYDVQQG +EwJVUzEPMA0GA1UEChMGQW1hem9uMRkwFwYDVQQDExBBbWF6b24gUm9vdCBDQSA0MB4XDTE1MDUy +NjAwMDAwMFoXDTQwMDUyNjAwMDAwMFowOTELMAkGA1UEBhMCVVMxDzANBgNVBAoTBkFtYXpvbjEZ +MBcGA1UEAxMQQW1hem9uIFJvb3QgQ0EgNDB2MBAGByqGSM49AgEGBSuBBAAiA2IABNKrijdPo1MN +/sGKe0uoe0ZLY7Bi9i0b2whxIdIA6GO9mif78DluXeo9pcmBqqNbIJhFXRbb/egQbeOc4OO9X4Ri +83BkM6DLJC9wuoihKqB1+IGuYgbEgds5bimwHvouXKNCMEAwDwYDVR0TAQH/BAUwAwEB/zAOBgNV +HQ8BAf8EBAMCAYYwHQYDVR0OBBYEFNPsxzplbszh2naaVvuc84ZtV+WBMAoGCCqGSM49BAMDA2gA +MGUCMDqLIfG9fhGt0O9Yli/W651+kI0rz2ZVwyzjKKlwCkcO8DdZEv8tmZQoTipPNU0zWgIxAOp1 +AE47xDqUEpHJWEadIRNyp4iciuRMStuW1KyLa2tJElMzrdfkviT8tQp21KW8EA== +-----END CERTIFICATE----- + +LuxTrust Global Root 2 +====================== +-----BEGIN CERTIFICATE----- +MIIFwzCCA6ugAwIBAgIUCn6m30tEntpqJIWe5rgV0xZ/u7EwDQYJKoZIhvcNAQELBQAwRjELMAkG +A1UEBhMCTFUxFjAUBgNVBAoMDUx1eFRydXN0IFMuQS4xHzAdBgNVBAMMFkx1eFRydXN0IEdsb2Jh +bCBSb290IDIwHhcNMTUwMzA1MTMyMTU3WhcNMzUwMzA1MTMyMTU3WjBGMQswCQYDVQQGEwJMVTEW +MBQGA1UECgwNTHV4VHJ1c3QgUy5BLjEfMB0GA1UEAwwWTHV4VHJ1c3QgR2xvYmFsIFJvb3QgMjCC +AiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBANeFl78RmOnwYoNMPIf5U2o3C/IPPIfOb9wm +Kb3FibrJgz337spbxm1Jc7TJRqMbNBM/wYlFV/TZsfs2ZUv7COJIcRHIbjuend+JZTemhfY7RBi2 +xjcwYkSSl2l9QjAk5A0MiWtj3sXh306pFGxT4GHO9hcvHTy95iJMHZP1EMShduxq3sVs35a0VkBC +wGKSMKEtFZSg0iAGCW5qbeXrt77U8PEVfIvmTroTzEsnXpk8F12PgX8zPU/TPxvsXD/wPEx1bvKm +1Z3aLQdjAsZy6ZS8TEmVT4hSyNvoaYL4zDRbIvCGp4m9SAptZoFtyMhk+wHh9OHe2Z7d21vUKpkm +FRseTJIpgp7VkoGSQXAZ96Tlk0u8d2cx3Rz9MXANF5kM+Qw5GSoXtTBxVdUPrljhPS80m8+f9niF +wpN6cj5mj5wWEWCPnolvZ77gR1o7DJpni89Gxq44o/KnvObWhWszJHAiS8sIm7vI+AIpHb4gDEa/ +a4ebsypmQjVGbKq6rfmYe+lQVRQxv7HaLe2ArWgk+2mr2HETMOZns4dA/Yl+8kPREd8vZS9kzl8U +ubG/Mb2HeFpZZYiq/FkySIbWTLkpS5XTdvN3JW1CHDiDTf2jX5t/Lax5Gw5CMZdjpPuKadUiDTSQ +MC6otOBttpSsvItO13D8xTiOZCXhTTmQzsmHhFhxAgMBAAGjgagwgaUwDwYDVR0TAQH/BAUwAwEB +/zBCBgNVHSAEOzA5MDcGByuBKwEBAQowLDAqBggrBgEFBQcCARYeaHR0cHM6Ly9yZXBvc2l0b3J5 +Lmx1eHRydXN0Lmx1MA4GA1UdDwEB/wQEAwIBBjAfBgNVHSMEGDAWgBT/GCh2+UgFLKGu8SsbK7JT ++Et8szAdBgNVHQ4EFgQU/xgodvlIBSyhrvErGyuyU/hLfLMwDQYJKoZIhvcNAQELBQADggIBAGoZ +FO1uecEsh9QNcH7X9njJCwROxLHOk3D+sFTAMs2ZMGQXvw/l4jP9BzZAcg4atmpZ1gDlaCDdLnIN +H2pkMSCEfUmmWjfrRcmF9dTHF5kH5ptV5AzoqbTOjFu1EVzPig4N1qx3gf4ynCSecs5U89BvolbW +7MM3LGVYvlcAGvI1+ut7MV3CwRI9loGIlonBWVx65n9wNOeD4rHh4bhY79SV5GCc8JaXcozrhAIu +ZY+kt9J/Z93I055cqqmkoCUUBpvsT34tC38ddfEz2O3OuHVtPlu5mB0xDVbYQw8wkbIEa91WvpWA +VWe+2M2D2RjuLg+GLZKecBPs3lHJQ3gCpU3I+V/EkVhGFndadKpAvAefMLmx9xIX3eP/JEAdemrR +TxgKqpAd60Ae36EeRJIQmvKN4dFLRp7oRUKX6kWZ8+xm1QL68qZKJKrezrnK+T+Tb/mjuuqlPpmt +/f97mfVl7vBZKGfXkJWkE4SphMHozs51k2MavDzq1WQfLSoSOcbDWjLtR5EWDrw4wVDej8oqkDQc +7kGUnF4ZLvhFSZl0kbAEb+MEWrGrKqv+x9CWttrhSmQGbmBNvUJO/3jaJMobtNeWOWyu8Q6qp31I +iyBMz2TWuJdGsE7RKlY6oJO9r4Ak4Ap+58rVyuiFVdw2KuGUaJPHZnJED4AhMmwlxyOAgwrr +-----END CERTIFICATE----- + +TUBITAK Kamu SM SSL Kok Sertifikasi - Surum 1 +============================================= +-----BEGIN CERTIFICATE----- +MIIEYzCCA0ugAwIBAgIBATANBgkqhkiG9w0BAQsFADCB0jELMAkGA1UEBhMCVFIxGDAWBgNVBAcT +D0dlYnplIC0gS29jYWVsaTFCMEAGA1UEChM5VHVya2l5ZSBCaWxpbXNlbCB2ZSBUZWtub2xvamlr +IEFyYXN0aXJtYSBLdXJ1bXUgLSBUVUJJVEFLMS0wKwYDVQQLEyRLYW11IFNlcnRpZmlrYXN5b24g +TWVya2V6aSAtIEthbXUgU00xNjA0BgNVBAMTLVRVQklUQUsgS2FtdSBTTSBTU0wgS29rIFNlcnRp +ZmlrYXNpIC0gU3VydW0gMTAeFw0xMzExMjUwODI1NTVaFw00MzEwMjUwODI1NTVaMIHSMQswCQYD +VQQGEwJUUjEYMBYGA1UEBxMPR2ViemUgLSBLb2NhZWxpMUIwQAYDVQQKEzlUdXJraXllIEJpbGlt +c2VsIHZlIFRla25vbG9qaWsgQXJhc3Rpcm1hIEt1cnVtdSAtIFRVQklUQUsxLTArBgNVBAsTJEth +bXUgU2VydGlmaWthc3lvbiBNZXJrZXppIC0gS2FtdSBTTTE2MDQGA1UEAxMtVFVCSVRBSyBLYW11 +IFNNIFNTTCBLb2sgU2VydGlmaWthc2kgLSBTdXJ1bSAxMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8A +MIIBCgKCAQEAr3UwM6q7a9OZLBI3hNmNe5eA027n/5tQlT6QlVZC1xl8JoSNkvoBHToP4mQ4t4y8 +6Ij5iySrLqP1N+RAjhgleYN1Hzv/bKjFxlb4tO2KRKOrbEz8HdDc72i9z+SqzvBV96I01INrN3wc +wv61A+xXzry0tcXtAA9TNypN9E8Mg/uGz8v+jE69h/mniyFXnHrfA2eJLJ2XYacQuFWQfw4tJzh0 +3+f92k4S400VIgLI4OD8D62K18lUUMw7D8oWgITQUVbDjlZ/iSIzL+aFCr2lqBs23tPcLG07xxO9 +WSMs5uWk99gL7eqQQESolbuT1dCANLZGeA4fAJNG4e7p+exPFwIDAQABo0IwQDAdBgNVHQ4EFgQU +ZT/HiobGPN08VFw1+DrtUgxHV8gwDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wDQYJ +KoZIhvcNAQELBQADggEBACo/4fEyjq7hmFxLXs9rHmoJ0iKpEsdeV31zVmSAhHqT5Am5EM2fKifh +AHe+SMg1qIGf5LgsyX8OsNJLN13qudULXjS99HMpw+0mFZx+CFOKWI3QSyjfwbPfIPP54+M638yc +lNhOT8NrF7f3cuitZjO1JVOr4PhMqZ398g26rrnZqsZr+ZO7rqu4lzwDGrpDxpa5RXI4s6ehlj2R +e37AIVNMh+3yC1SVUZPVIqUNivGTDj5UDrDYyU7c8jEyVupk+eq1nRZmQnLzf9OxMUP8pI4X8W0j +q5Rm+K37DwhuJi1/FwcJsoz7UMCflo3Ptv0AnVoUmr8CRPXBwp8iXqIPoeM= +-----END CERTIFICATE----- + +GDCA TrustAUTH R5 ROOT +====================== +-----BEGIN CERTIFICATE----- +MIIFiDCCA3CgAwIBAgIIfQmX/vBH6nowDQYJKoZIhvcNAQELBQAwYjELMAkGA1UEBhMCQ04xMjAw +BgNVBAoMKUdVQU5HIERPTkcgQ0VSVElGSUNBVEUgQVVUSE9SSVRZIENPLixMVEQuMR8wHQYDVQQD +DBZHRENBIFRydXN0QVVUSCBSNSBST09UMB4XDTE0MTEyNjA1MTMxNVoXDTQwMTIzMTE1NTk1OVow +YjELMAkGA1UEBhMCQ04xMjAwBgNVBAoMKUdVQU5HIERPTkcgQ0VSVElGSUNBVEUgQVVUSE9SSVRZ +IENPLixMVEQuMR8wHQYDVQQDDBZHRENBIFRydXN0QVVUSCBSNSBST09UMIICIjANBgkqhkiG9w0B +AQEFAAOCAg8AMIICCgKCAgEA2aMW8Mh0dHeb7zMNOwZ+Vfy1YI92hhJCfVZmPoiC7XJjDp6L3TQs +AlFRwxn9WVSEyfFrs0yw6ehGXTjGoqcuEVe6ghWinI9tsJlKCvLriXBjTnnEt1u9ol2x8kECK62p +OqPseQrsXzrj/e+APK00mxqriCZ7VqKChh/rNYmDf1+uKU49tm7srsHwJ5uu4/Ts765/94Y9cnrr +pftZTqfrlYwiOXnhLQiPzLyRuEH3FMEjqcOtmkVEs7LXLM3GKeJQEK5cy4KOFxg2fZfmiJqwTTQJ +9Cy5WmYqsBebnh52nUpmMUHfP/vFBu8btn4aRjb3ZGM74zkYI+dndRTVdVeSN72+ahsmUPI2JgaQ +xXABZG12ZuGR224HwGGALrIuL4xwp9E7PLOR5G62xDtw8mySlwnNR30YwPO7ng/Wi64HtloPzgsM +R6flPri9fcebNaBhlzpBdRfMK5Z3KpIhHtmVdiBnaM8Nvd/WHwlqmuLMc3GkL30SgLdTMEZeS1SZ +D2fJpcjyIMGC7J0R38IC+xo70e0gmu9lZJIQDSri3nDxGGeCjGHeuLzRL5z7D9Ar7Rt2ueQ5Vfj4 +oR24qoAATILnsn8JuLwwoC8N9VKejveSswoAHQBUlwbgsQfZxw9cZX08bVlX5O2ljelAU58VS6Bx +9hoh49pwBiFYFIeFd3mqgnkCAwEAAaNCMEAwHQYDVR0OBBYEFOLJQJ9NzuiaoXzPDj9lxSmIahlR +MA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgGGMA0GCSqGSIb3DQEBCwUAA4ICAQDRSVfg +p8xoWLoBDysZzY2wYUWsEe1jUGn4H3++Fo/9nesLqjJHdtJnJO29fDMylyrHBYZmDRd9FBUb1Ov9 +H5r2XpdptxolpAqzkT9fNqyL7FeoPueBihhXOYV0GkLH6VsTX4/5COmSdI31R9KrO9b7eGZONn35 +6ZLpBN79SWP8bfsUcZNnL0dKt7n/HipzcEYwv1ryL3ml4Y0M2fmyYzeMN2WFcGpcWwlyua1jPLHd ++PwyvzeG5LuOmCd+uh8W4XAR8gPfJWIyJyYYMoSf/wA6E7qaTfRPuBRwIrHKK5DOKcFw9C+df/KQ +HtZa37dG/OaG+svgIHZ6uqbL9XzeYqWxi+7egmaKTjowHz+Ay60nugxe19CxVsp3cbK1daFQqUBD +F8Io2c9Si1vIY9RCPqAzekYu9wogRlR+ak8x8YF+QnQ4ZXMn7sZ8uI7XpTrXmKGcjBBV09tL7ECQ +8s1uV9JiDnxXk7Gnbc2dg7sq5+W2O3FYrf3RRbxake5TFW/TRQl1brqQXR4EzzffHqhmsYzmIGrv +/EhOdJhCrylvLmrH+33RZjEizIYAfmaDDEL0vTSSwxrqT8p+ck0LcIymSLumoRT2+1hEmRSuqguT +aaApJUqlyyvdimYHFngVV3Eb7PVHhPOeMTd61X8kreS8/f3MboPoDKi3QWwH3b08hpcv0g== +-----END CERTIFICATE----- + +TrustCor RootCert CA-1 +====================== +-----BEGIN CERTIFICATE----- +MIIEMDCCAxigAwIBAgIJANqb7HHzA7AZMA0GCSqGSIb3DQEBCwUAMIGkMQswCQYDVQQGEwJQQTEP +MA0GA1UECAwGUGFuYW1hMRQwEgYDVQQHDAtQYW5hbWEgQ2l0eTEkMCIGA1UECgwbVHJ1c3RDb3Ig +U3lzdGVtcyBTLiBkZSBSLkwuMScwJQYDVQQLDB5UcnVzdENvciBDZXJ0aWZpY2F0ZSBBdXRob3Jp +dHkxHzAdBgNVBAMMFlRydXN0Q29yIFJvb3RDZXJ0IENBLTEwHhcNMTYwMjA0MTIzMjE2WhcNMjkx +MjMxMTcyMzE2WjCBpDELMAkGA1UEBhMCUEExDzANBgNVBAgMBlBhbmFtYTEUMBIGA1UEBwwLUGFu +YW1hIENpdHkxJDAiBgNVBAoMG1RydXN0Q29yIFN5c3RlbXMgUy4gZGUgUi5MLjEnMCUGA1UECwwe +VHJ1c3RDb3IgQ2VydGlmaWNhdGUgQXV0aG9yaXR5MR8wHQYDVQQDDBZUcnVzdENvciBSb290Q2Vy +dCBDQS0xMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAv463leLCJhJrMxnHQFgKq1mq +jQCj/IDHUHuO1CAmujIS2CNUSSUQIpidRtLByZ5OGy4sDjjzGiVoHKZaBeYei0i/mJZ0PmnK6bV4 +pQa81QBeCQryJ3pS/C3Vseq0iWEk8xoT26nPUu0MJLq5nux+AHT6k61sKZKuUbS701e/s/OojZz0 +JEsq1pme9J7+wH5COucLlVPat2gOkEz7cD+PSiyU8ybdY2mplNgQTsVHCJCZGxdNuWxu72CVEY4h +gLW9oHPY0LJ3xEXqWib7ZnZ2+AYfYW0PVcWDtxBWcgYHpfOxGgMFZA6dWorWhnAbJN7+KIor0Gqw +/Hqi3LJ5DotlDwIDAQABo2MwYTAdBgNVHQ4EFgQU7mtJPHo/DeOxCbeKyKsZn3MzUOcwHwYDVR0j +BBgwFoAU7mtJPHo/DeOxCbeKyKsZn3MzUOcwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMC +AYYwDQYJKoZIhvcNAQELBQADggEBACUY1JGPE+6PHh0RU9otRCkZoB5rMZ5NDp6tPVxBb5UrJKF5 +mDo4Nvu7Zp5I/5CQ7z3UuJu0h3U/IJvOcs+hVcFNZKIZBqEHMwwLKeXx6quj7LUKdJDHfXLy11yf +ke+Ri7fc7Waiz45mO7yfOgLgJ90WmMCV1Aqk5IGadZQ1nJBfiDcGrVmVCrDRZ9MZyonnMlo2HD6C +qFqTvsbQZJG2z9m2GM/bftJlo6bEjhcxwft+dtvTheNYsnd6djtsL1Ac59v2Z3kf9YKVmgenFK+P +3CghZwnS1k1aHBkcjndcw5QkPTJrS37UeJSDvjdNzl/HHk484IkzlQsPpTLWPFp5LBk= +-----END CERTIFICATE----- + +TrustCor RootCert CA-2 +====================== +-----BEGIN CERTIFICATE----- +MIIGLzCCBBegAwIBAgIIJaHfyjPLWQIwDQYJKoZIhvcNAQELBQAwgaQxCzAJBgNVBAYTAlBBMQ8w +DQYDVQQIDAZQYW5hbWExFDASBgNVBAcMC1BhbmFtYSBDaXR5MSQwIgYDVQQKDBtUcnVzdENvciBT +eXN0ZW1zIFMuIGRlIFIuTC4xJzAlBgNVBAsMHlRydXN0Q29yIENlcnRpZmljYXRlIEF1dGhvcml0 +eTEfMB0GA1UEAwwWVHJ1c3RDb3IgUm9vdENlcnQgQ0EtMjAeFw0xNjAyMDQxMjMyMjNaFw0zNDEy +MzExNzI2MzlaMIGkMQswCQYDVQQGEwJQQTEPMA0GA1UECAwGUGFuYW1hMRQwEgYDVQQHDAtQYW5h +bWEgQ2l0eTEkMCIGA1UECgwbVHJ1c3RDb3IgU3lzdGVtcyBTLiBkZSBSLkwuMScwJQYDVQQLDB5U +cnVzdENvciBDZXJ0aWZpY2F0ZSBBdXRob3JpdHkxHzAdBgNVBAMMFlRydXN0Q29yIFJvb3RDZXJ0 +IENBLTIwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCnIG7CKqJiJJWQdsg4foDSq8Gb +ZQWU9MEKENUCrO2fk8eHyLAnK0IMPQo+QVqedd2NyuCb7GgypGmSaIwLgQ5WoD4a3SwlFIIvl9Nk +RvRUqdw6VC0xK5mC8tkq1+9xALgxpL56JAfDQiDyitSSBBtlVkxs1Pu2YVpHI7TYabS3OtB0PAx1 +oYxOdqHp2yqlO/rOsP9+aij9JxzIsekp8VduZLTQwRVtDr4uDkbIXvRR/u8OYzo7cbrPb1nKDOOb +XUm4TOJXsZiKQlecdu/vvdFoqNL0Cbt3Nb4lggjEFixEIFapRBF37120Hapeaz6LMvYHL1cEksr1 +/p3C6eizjkxLAjHZ5DxIgif3GIJ2SDpxsROhOdUuxTTCHWKF3wP+TfSvPd9cW436cOGlfifHhi5q +jxLGhF5DUVCcGZt45vz27Ud+ez1m7xMTiF88oWP7+ayHNZ/zgp6kPwqcMWmLmaSISo5uZk3vFsQP +eSghYA2FFn3XVDjxklb9tTNMg9zXEJ9L/cb4Qr26fHMC4P99zVvh1Kxhe1fVSntb1IVYJ12/+Ctg +rKAmrhQhJ8Z3mjOAPF5GP/fDsaOGM8boXg25NSyqRsGFAnWAoOsk+xWq5Gd/bnc/9ASKL3x74xdh +8N0JqSDIvgmk0H5Ew7IwSjiqqewYmgeCK9u4nBit2uBGF6zPXQIDAQABo2MwYTAdBgNVHQ4EFgQU +2f4hQG6UnrybPZx9mCAZ5YwwYrIwHwYDVR0jBBgwFoAU2f4hQG6UnrybPZx9mCAZ5YwwYrIwDwYD +VR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAYYwDQYJKoZIhvcNAQELBQADggIBAJ5Fngw7tu/h +Osh80QA9z+LqBrWyOrsGS2h60COXdKcs8AjYeVrXWoSK2BKaG9l9XE1wxaX5q+WjiYndAfrs3fnp +kpfbsEZC89NiqpX+MWcUaViQCqoL7jcjx1BRtPV+nuN79+TMQjItSQzL/0kMmx40/W5ulop5A7Zv +2wnL/V9lFDfhOPXzYRZY5LVtDQsEGz9QLX+zx3oaFoBg+Iof6Rsqxvm6ARppv9JYx1RXCI/hOWB3 +S6xZhBqI8d3LT3jX5+EzLfzuQfogsL7L9ziUwOHQhQ+77Sxzq+3+knYaZH9bDTMJBzN7Bj8RpFxw +PIXAz+OQqIN3+tvmxYxoZxBnpVIt8MSZj3+/0WvitUfW2dCFmU2Umw9Lje4AWkcdEQOsQRivh7dv +DDqPys/cA8GiCcjl/YBeyGBCARsaU1q7N6a3vLqE6R5sGtRk2tRD/pOLS/IseRYQ1JMLiI+h2IYU +RpFHmygk71dSTlxCnKr3Sewn6EAes6aJInKc9Q0ztFijMDvd1GpUk74aTfOTlPf8hAs/hCBcNANE +xdqtvArBAs8e5ZTZ845b2EzwnexhF7sUMlQMAimTHpKG9n/v55IFDlndmQguLvqcAFLTxWYp5KeX +RKQOKIETNcX2b2TmQcTVL8w0RSXPQQCWPUouwpaYT05KnJe32x+SMsj/D1Fu1uwJ +-----END CERTIFICATE----- + +TrustCor ECA-1 +============== +-----BEGIN CERTIFICATE----- +MIIEIDCCAwigAwIBAgIJAISCLF8cYtBAMA0GCSqGSIb3DQEBCwUAMIGcMQswCQYDVQQGEwJQQTEP +MA0GA1UECAwGUGFuYW1hMRQwEgYDVQQHDAtQYW5hbWEgQ2l0eTEkMCIGA1UECgwbVHJ1c3RDb3Ig +U3lzdGVtcyBTLiBkZSBSLkwuMScwJQYDVQQLDB5UcnVzdENvciBDZXJ0aWZpY2F0ZSBBdXRob3Jp +dHkxFzAVBgNVBAMMDlRydXN0Q29yIEVDQS0xMB4XDTE2MDIwNDEyMzIzM1oXDTI5MTIzMTE3Mjgw +N1owgZwxCzAJBgNVBAYTAlBBMQ8wDQYDVQQIDAZQYW5hbWExFDASBgNVBAcMC1BhbmFtYSBDaXR5 +MSQwIgYDVQQKDBtUcnVzdENvciBTeXN0ZW1zIFMuIGRlIFIuTC4xJzAlBgNVBAsMHlRydXN0Q29y +IENlcnRpZmljYXRlIEF1dGhvcml0eTEXMBUGA1UEAwwOVHJ1c3RDb3IgRUNBLTEwggEiMA0GCSqG +SIb3DQEBAQUAA4IBDwAwggEKAoIBAQDPj+ARtZ+odnbb3w9U73NjKYKtR8aja+3+XzP4Q1HpGjOR +MRegdMTUpwHmspI+ap3tDvl0mEDTPwOABoJA6LHip1GnHYMma6ve+heRK9jGrB6xnhkB1Zem6g23 +xFUfJ3zSCNV2HykVh0A53ThFEXXQmqc04L/NyFIduUd+Dbi7xgz2c1cWWn5DkR9VOsZtRASqnKmc +p0yJF4OuowReUoCLHhIlERnXDH19MURB6tuvsBzvgdAsxZohmz3tQjtQJvLsznFhBmIhVE5/wZ0+ +fyCMgMsq2JdiyIMzkX2woloPV+g7zPIlstR8L+xNxqE6FXrntl019fZISjZFZtS6mFjBAgMBAAGj +YzBhMB0GA1UdDgQWBBREnkj1zG1I1KBLf/5ZJC+Dl5mahjAfBgNVHSMEGDAWgBREnkj1zG1I1KBL +f/5ZJC+Dl5mahjAPBgNVHRMBAf8EBTADAQH/MA4GA1UdDwEB/wQEAwIBhjANBgkqhkiG9w0BAQsF +AAOCAQEABT41XBVwm8nHc2FvcivUwo/yQ10CzsSUuZQRg2dd4mdsdXa/uwyqNsatR5Nj3B5+1t4u +/ukZMjgDfxT2AHMsWbEhBuH7rBiVDKP/mZb3Kyeb1STMHd3BOuCYRLDE5D53sXOpZCz2HAF8P11F +hcCF5yWPldwX8zyfGm6wyuMdKulMY/okYWLW2n62HGz1Ah3UKt1VkOsqEUc8Ll50soIipX1TH0Xs +J5F95yIW6MBoNtjG8U+ARDL54dHRHareqKucBK+tIA5kmE2la8BIWJZpTdwHjFGTot+fDz2LYLSC +jaoITmJF4PkL0uDgPFveXHEnJcLmA4GLEFPjx1WitJ/X5g== +-----END CERTIFICATE----- + +SSL.com Root Certification Authority RSA +======================================== +-----BEGIN CERTIFICATE----- +MIIF3TCCA8WgAwIBAgIIeyyb0xaAMpkwDQYJKoZIhvcNAQELBQAwfDELMAkGA1UEBhMCVVMxDjAM +BgNVBAgMBVRleGFzMRAwDgYDVQQHDAdIb3VzdG9uMRgwFgYDVQQKDA9TU0wgQ29ycG9yYXRpb24x +MTAvBgNVBAMMKFNTTC5jb20gUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eSBSU0EwHhcNMTYw +MjEyMTczOTM5WhcNNDEwMjEyMTczOTM5WjB8MQswCQYDVQQGEwJVUzEOMAwGA1UECAwFVGV4YXMx +EDAOBgNVBAcMB0hvdXN0b24xGDAWBgNVBAoMD1NTTCBDb3Jwb3JhdGlvbjExMC8GA1UEAwwoU1NM +LmNvbSBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5IFJTQTCCAiIwDQYJKoZIhvcNAQEBBQAD +ggIPADCCAgoCggIBAPkP3aMrfcvQKv7sZ4Wm5y4bunfh4/WvpOz6Sl2RxFdHaxh3a3by/ZPkPQ/C +Fp4LZsNWlJ4Xg4XOVu/yFv0AYvUiCVToZRdOQbngT0aXqhvIuG5iXmmxX9sqAn78bMrzQdjt0Oj8 +P2FI7bADFB0QDksZ4LtO7IZl/zbzXmcCC52GVWH9ejjt/uIZALdvoVBidXQ8oPrIJZK0bnoix/ge +oeOy3ZExqysdBP+lSgQ36YWkMyv94tZVNHwZpEpox7Ko07fKoZOI68GXvIz5HdkihCR0xwQ9aqkp +k8zruFvh/l8lqjRYyMEjVJ0bmBHDOJx+PYZspQ9AhnwC9FwCTyjLrnGfDzrIM/4RJTXq/LrFYD3Z +fBjVsqnTdXgDciLKOsMf7yzlLqn6niy2UUb9rwPW6mBo6oUWNmuF6R7As93EJNyAKoFBbZQ+yODJ +gUEAnl6/f8UImKIYLEJAs/lvOCdLToD0PYFH4Ih86hzOtXVcUS4cK38acijnALXRdMbX5J+tB5O2 +UzU1/Dfkw/ZdFr4hc96SCvigY2q8lpJqPvi8ZVWb3vUNiSYE/CUapiVpy8JtynziWV+XrOvvLsi8 +1xtZPCvM8hnIk2snYxnP/Okm+Mpxm3+T/jRnhE6Z6/yzeAkzcLpmpnbtG3PrGqUNxCITIJRWCk4s +bE6x/c+cCbqiM+2HAgMBAAGjYzBhMB0GA1UdDgQWBBTdBAkHovV6fVJTEpKV7jiAJQ2mWTAPBgNV +HRMBAf8EBTADAQH/MB8GA1UdIwQYMBaAFN0ECQei9Xp9UlMSkpXuOIAlDaZZMA4GA1UdDwEB/wQE +AwIBhjANBgkqhkiG9w0BAQsFAAOCAgEAIBgRlCn7Jp0cHh5wYfGVcpNxJK1ok1iOMq8bs3AD/CUr +dIWQPXhq9LmLpZc7tRiRux6n+UBbkflVma8eEdBcHadm47GUBwwyOabqG7B52B2ccETjit3E+ZUf +ijhDPwGFpUenPUayvOUiaPd7nNgsPgohyC0zrL/FgZkxdMF1ccW+sfAjRfSda/wZY52jvATGGAsl +u1OJD7OAUN5F7kR/q5R4ZJjT9ijdh9hwZXT7DrkT66cPYakylszeu+1jTBi7qUD3oFRuIIhxdRjq +erQ0cuAjJ3dctpDqhiVAq+8zD8ufgr6iIPv2tS0a5sKFsXQP+8hlAqRSAUfdSSLBv9jra6x+3uxj +MxW3IwiPxg+NQVrdjsW5j+VFP3jbutIbQLH+cU0/4IGiul607BXgk90IH37hVZkLId6Tngr75qNJ +vTYw/ud3sqB1l7UtgYgXZSD32pAAn8lSzDLKNXz1PQ/YK9f1JmzJBjSWFupwWRoyeXkLtoh/D1JI +Pb9s2KJELtFOt3JY04kTlf5Eq/jXixtunLwsoFvVagCvXzfh1foQC5ichucmj87w7G6KVwuA406y +wKBjYZC6VWg3dGq2ktufoYYitmUnDuy2n0Jg5GfCtdpBC8TTi2EbvPofkSvXRAdeuims2cXp71NI +WuuA8ShYIc2wBlX7Jz9TkHCpBB5XJ7k= +-----END CERTIFICATE----- + +SSL.com Root Certification Authority ECC +======================================== +-----BEGIN CERTIFICATE----- +MIICjTCCAhSgAwIBAgIIdebfy8FoW6gwCgYIKoZIzj0EAwIwfDELMAkGA1UEBhMCVVMxDjAMBgNV +BAgMBVRleGFzMRAwDgYDVQQHDAdIb3VzdG9uMRgwFgYDVQQKDA9TU0wgQ29ycG9yYXRpb24xMTAv +BgNVBAMMKFNTTC5jb20gUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eSBFQ0MwHhcNMTYwMjEy +MTgxNDAzWhcNNDEwMjEyMTgxNDAzWjB8MQswCQYDVQQGEwJVUzEOMAwGA1UECAwFVGV4YXMxEDAO +BgNVBAcMB0hvdXN0b24xGDAWBgNVBAoMD1NTTCBDb3Jwb3JhdGlvbjExMC8GA1UEAwwoU1NMLmNv +bSBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5IEVDQzB2MBAGByqGSM49AgEGBSuBBAAiA2IA +BEVuqVDEpiM2nl8ojRfLliJkP9x6jh3MCLOicSS6jkm5BBtHllirLZXI7Z4INcgn64mMU1jrYor+ +8FsPazFSY0E7ic3s7LaNGdM0B9y7xgZ/wkWV7Mt/qCPgCemB+vNH06NjMGEwHQYDVR0OBBYEFILR +hXMw5zUE044CkvvlpNHEIejNMA8GA1UdEwEB/wQFMAMBAf8wHwYDVR0jBBgwFoAUgtGFczDnNQTT +jgKS++Wk0cQh6M0wDgYDVR0PAQH/BAQDAgGGMAoGCCqGSM49BAMCA2cAMGQCMG/n61kRpGDPYbCW +e+0F+S8Tkdzt5fxQaxFGRrMcIQBiu77D5+jNB5n5DQtdcj7EqgIwH7y6C+IwJPt8bYBVCpk+gA0z +5Wajs6O7pdWLjwkspl1+4vAHCGht0nxpbl/f5Wpl +-----END CERTIFICATE----- + +SSL.com EV Root Certification Authority RSA R2 +============================================== +-----BEGIN CERTIFICATE----- +MIIF6zCCA9OgAwIBAgIIVrYpzTS8ePYwDQYJKoZIhvcNAQELBQAwgYIxCzAJBgNVBAYTAlVTMQ4w +DAYDVQQIDAVUZXhhczEQMA4GA1UEBwwHSG91c3RvbjEYMBYGA1UECgwPU1NMIENvcnBvcmF0aW9u +MTcwNQYDVQQDDC5TU0wuY29tIEVWIFJvb3QgQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkgUlNBIFIy +MB4XDTE3MDUzMTE4MTQzN1oXDTQyMDUzMDE4MTQzN1owgYIxCzAJBgNVBAYTAlVTMQ4wDAYDVQQI +DAVUZXhhczEQMA4GA1UEBwwHSG91c3RvbjEYMBYGA1UECgwPU1NMIENvcnBvcmF0aW9uMTcwNQYD +VQQDDC5TU0wuY29tIEVWIFJvb3QgQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkgUlNBIFIyMIICIjAN +BgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEAjzZlQOHWTcDXtOlG2mvqM0fNTPl9fb69LT3w23jh +hqXZuglXaO1XPqDQCEGD5yhBJB/jchXQARr7XnAjssufOePPxU7Gkm0mxnu7s9onnQqG6YE3Bf7w +cXHswxzpY6IXFJ3vG2fThVUCAtZJycxa4bH3bzKfydQ7iEGonL3Lq9ttewkfokxykNorCPzPPFTO +Zw+oz12WGQvE43LrrdF9HSfvkusQv1vrO6/PgN3B0pYEW3p+pKk8OHakYo6gOV7qd89dAFmPZiw+ +B6KjBSYRaZfqhbcPlgtLyEDhULouisv3D5oi53+aNxPN8k0TayHRwMwi8qFG9kRpnMphNQcAb9Zh +CBHqurj26bNg5U257J8UZslXWNvNh2n4ioYSA0e/ZhN2rHd9NCSFg83XqpyQGp8hLH94t2S42Oim +9HizVcuE0jLEeK6jj2HdzghTreyI/BXkmg3mnxp3zkyPuBQVPWKchjgGAGYS5Fl2WlPAApiiECto +RHuOec4zSnaqW4EWG7WK2NAAe15itAnWhmMOpgWVSbooi4iTsjQc2KRVbrcc0N6ZVTsj9CLg+Slm +JuwgUHfbSguPvuUCYHBBXtSuUDkiFCbLsjtzdFVHB3mBOagwE0TlBIqulhMlQg+5U8Sb/M3kHN48 ++qvWBkofZ6aYMBzdLNvcGJVXZsb/XItW9XcCAwEAAaNjMGEwDwYDVR0TAQH/BAUwAwEB/zAfBgNV +HSMEGDAWgBT5YLvU49U09rj1BoAlp3PbRmmonjAdBgNVHQ4EFgQU+WC71OPVNPa49QaAJadz20Zp +qJ4wDgYDVR0PAQH/BAQDAgGGMA0GCSqGSIb3DQEBCwUAA4ICAQBWs47LCp1Jjr+kxJG7ZhcFUZh1 +++VQLHqe8RT6q9OKPv+RKY9ji9i0qVQBDb6Thi/5Sm3HXvVX+cpVHBK+Rw82xd9qt9t1wkclf7nx +Y/hoLVUE0fKNsKTPvDxeH3jnpaAgcLAExbf3cqfeIg29MyVGjGSSJuM+LmOW2puMPfgYCdcDzH2G +guDKBAdRUNf/ktUM79qGn5nX67evaOI5JpS6aLe/g9Pqemc9YmeuJeVy6OLk7K4S9ksrPJ/psEDz +OFSz/bdoyNrGj1E8svuR3Bznm53htw1yj+KkxKl4+esUrMZDBcJlOSgYAsOCsp0FvmXtll9ldDz7 +CTUue5wT/RsPXcdtgTpWD8w74a8CLyKsRspGPKAcTNZEtF4uXBVmCeEmKf7GUmG6sXP/wwyc5Wxq +lD8UykAWlYTzWamsX0xhk23RO8yilQwipmdnRC652dKKQbNmC1r7fSOl8hqw/96bg5Qu0T/fkreR +rwU7ZcegbLHNYhLDkBvjJc40vG93drEQw/cFGsDWr3RiSBd3kmmQYRzelYB0VI8YHMPzA9C/pEN1 +hlMYegouCRw2n5H9gooiS9EOUCXdywMMF8mDAAhONU2Ki+3wApRmLER/y5UnlhetCTCstnEXbosX +9hwJ1C07mKVx01QT2WDz9UtmT/rx7iASjbSsV7FFY6GsdqnC+w== +-----END CERTIFICATE----- + +SSL.com EV Root Certification Authority ECC +=========================================== +-----BEGIN CERTIFICATE----- +MIIClDCCAhqgAwIBAgIILCmcWxbtBZUwCgYIKoZIzj0EAwIwfzELMAkGA1UEBhMCVVMxDjAMBgNV +BAgMBVRleGFzMRAwDgYDVQQHDAdIb3VzdG9uMRgwFgYDVQQKDA9TU0wgQ29ycG9yYXRpb24xNDAy +BgNVBAMMK1NTTC5jb20gRVYgUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eSBFQ0MwHhcNMTYw +MjEyMTgxNTIzWhcNNDEwMjEyMTgxNTIzWjB/MQswCQYDVQQGEwJVUzEOMAwGA1UECAwFVGV4YXMx +EDAOBgNVBAcMB0hvdXN0b24xGDAWBgNVBAoMD1NTTCBDb3Jwb3JhdGlvbjE0MDIGA1UEAwwrU1NM +LmNvbSBFViBSb290IENlcnRpZmljYXRpb24gQXV0aG9yaXR5IEVDQzB2MBAGByqGSM49AgEGBSuB +BAAiA2IABKoSR5CYG/vvw0AHgyBO8TCCogbR8pKGYfL2IWjKAMTH6kMAVIbc/R/fALhBYlzccBYy +3h+Z1MzFB8gIH2EWB1E9fVwHU+M1OIzfzZ/ZLg1KthkuWnBaBu2+8KGwytAJKaNjMGEwHQYDVR0O +BBYEFFvKXuXe0oGqzagtZFG22XKbl+ZPMA8GA1UdEwEB/wQFMAMBAf8wHwYDVR0jBBgwFoAUW8pe +5d7SgarNqC1kUbbZcpuX5k8wDgYDVR0PAQH/BAQDAgGGMAoGCCqGSM49BAMCA2gAMGUCMQCK5kCJ +N+vp1RPZytRrJPOwPYdGWBrssd9v+1a6cGvHOMzosYxPD/fxZ3YOg9AeUY8CMD32IygmTMZgh5Mm +m7I1HrrW9zzRHM76JTymGoEVW/MSD2zuZYrJh6j5B+BimoxcSg== +-----END CERTIFICATE----- diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Mozilla/mk-ca-bundle.pl b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Mozilla/mk-ca-bundle.pl new file mode 100644 index 0000000000..5a84f6b0b1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Mozilla/mk-ca-bundle.pl @@ -0,0 +1,553 @@ +#!/usr/bin/env perl +# *************************************************************************** +# * _ _ ____ _ +# * Project ___| | | | _ \| | +# * / __| | | | |_) | | +# * | (__| |_| | _ <| |___ +# * \___|\___/|_| \_\_____| +# * +# * Copyright (C) 1998 - 2016, Daniel Stenberg, <daniel@haxx.se>, et al. +# * +# * This software is licensed as described in the file COPYING, which +# * you should have received as part of this distribution. The terms +# * are also available at https://curl.haxx.se/docs/copyright.html. +# * +# * You may opt to use, copy, modify, merge, publish, distribute and/or sell +# * copies of the Software, and permit persons to whom the Software is +# * furnished to do so, under the terms of the COPYING file. +# * +# * This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY +# * KIND, either express or implied. +# * +# *************************************************************************** +# This Perl script creates a fresh ca-bundle.crt file for use with libcurl. +# It downloads certdata.txt from Mozilla's source tree (see URL below), +# then parses certdata.txt and extracts CA Root Certificates into PEM format. +# These are then processed with the OpenSSL commandline tool to produce the +# final ca-bundle.crt file. +# The script is based on the parse-certs script written by Roland Krikava. +# This Perl script works on almost any platform since its only external +# dependency is the OpenSSL commandline tool for optional text listing. +# Hacked by Guenter Knauf. +# +use Encode; +use Getopt::Std; +use MIME::Base64; +use strict; +use warnings; +use vars qw($opt_b $opt_d $opt_f $opt_h $opt_i $opt_k $opt_l $opt_m $opt_n $opt_p $opt_q $opt_s $opt_t $opt_u $opt_v $opt_w); +use List::Util; +use Text::Wrap; +my $MOD_SHA = "Digest::SHA"; +eval "require $MOD_SHA"; +if ($@) { + $MOD_SHA = "Digest::SHA::PurePerl"; + eval "require $MOD_SHA"; +} +eval "require LWP::UserAgent"; + +my %urls = ( + 'nss' => + 'https://hg.mozilla.org/projects/nss/raw-file/default/lib/ckfw/builtins/certdata.txt', + 'central' => + 'https://hg.mozilla.org/mozilla-central/raw-file/default/security/nss/lib/ckfw/builtins/certdata.txt', + 'beta' => + 'https://hg.mozilla.org/releases/mozilla-beta/raw-file/default/security/nss/lib/ckfw/builtins/certdata.txt', + 'release' => + 'https://hg.mozilla.org/releases/mozilla-release/raw-file/default/security/nss/lib/ckfw/builtins/certdata.txt', +); + +$opt_d = 'release'; + +# If the OpenSSL commandline is not in search path you can configure it here! +my $openssl = 'openssl'; + +my $version = '1.27'; + +$opt_w = 76; # default base64 encoded lines length + +# default cert types to include in the output (default is to include CAs which may issue SSL server certs) +my $default_mozilla_trust_purposes = "SERVER_AUTH"; +my $default_mozilla_trust_levels = "TRUSTED_DELEGATOR"; +$opt_p = $default_mozilla_trust_purposes . ":" . $default_mozilla_trust_levels; + +my @valid_mozilla_trust_purposes = ( + "DIGITAL_SIGNATURE", + "NON_REPUDIATION", + "KEY_ENCIPHERMENT", + "DATA_ENCIPHERMENT", + "KEY_AGREEMENT", + "KEY_CERT_SIGN", + "CRL_SIGN", + "SERVER_AUTH", + "CLIENT_AUTH", + "CODE_SIGNING", + "EMAIL_PROTECTION", + "IPSEC_END_SYSTEM", + "IPSEC_TUNNEL", + "IPSEC_USER", + "TIME_STAMPING", + "STEP_UP_APPROVED" +); + +my @valid_mozilla_trust_levels = ( + "TRUSTED_DELEGATOR", # CAs + "NOT_TRUSTED", # Don't trust these certs. + "MUST_VERIFY_TRUST", # This explicitly tells us that it ISN'T a CA but is otherwise ok. In other words, this should tell the app to ignore any other sources that claim this is a CA. + "TRUSTED" # This cert is trusted, but only for itself and not for delegates (i.e. it is not a CA). +); + +my $default_signature_algorithms = $opt_s = "MD5"; + +my @valid_signature_algorithms = ( + "MD5", + "SHA1", + "SHA256", + "SHA384", + "SHA512" +); + +$0 =~ s@.*(/|\\)@@; +$Getopt::Std::STANDARD_HELP_VERSION = 1; +getopts('bd:fhiklmnp:qs:tuvw:'); + +if(!defined($opt_d)) { + # to make plain "-d" use not cause warnings, and actually still work + $opt_d = 'release'; +} + +# Use predefined URL or else custom URL specified on command line. +my $url; +if(defined($urls{$opt_d})) { + $url = $urls{$opt_d}; + if(!$opt_k && $url !~ /^https:\/\//i) { + die "The URL for '$opt_d' is not HTTPS. Use -k to override (insecure).\n"; + } +} +else { + $url = $opt_d; +} + +my $curl = `curl -V`; + +if ($opt_i) { + print ("=" x 78 . "\n"); + print "Script Version : $version\n"; + print "Perl Version : $]\n"; + print "Operating System Name : $^O\n"; + print "Getopt::Std.pm Version : ${Getopt::Std::VERSION}\n"; + print "MIME::Base64.pm Version : ${MIME::Base64::VERSION}\n"; + print "LWP::UserAgent.pm Version : ${LWP::UserAgent::VERSION}\n" if($LWP::UserAgent::VERSION); + print "LWP.pm Version : ${LWP::VERSION}\n" if($LWP::VERSION); + print "Digest::SHA.pm Version : ${Digest::SHA::VERSION}\n" if ($Digest::SHA::VERSION); + print "Digest::SHA::PurePerl.pm Version : ${Digest::SHA::PurePerl::VERSION}\n" if ($Digest::SHA::PurePerl::VERSION); + print ("=" x 78 . "\n"); +} + +sub warning_message() { + if ( $opt_d =~ m/^risk$/i ) { # Long Form Warning and Exit + print "Warning: Use of this script may pose some risk:\n"; + print "\n"; + print " 1) If you use HTTP URLs they are subject to a man in the middle attack\n"; + print " 2) Default to 'release', but more recent updates may be found in other trees\n"; + print " 3) certdata.txt file format may change, lag time to update this script\n"; + print " 4) Generally unwise to blindly trust CAs without manual review & verification\n"; + print " 5) Mozilla apps use additional security checks aren't represented in certdata\n"; + print " 6) Use of this script will make a security engineer grind his teeth and\n"; + print " swear at you. ;)\n"; + exit; + } else { # Short Form Warning + print "Warning: Use of this script may pose some risk, -d risk for more details.\n"; + } +} + +sub HELP_MESSAGE() { + print "Usage:\t${0} [-b] [-d<certdata>] [-f] [-i] [-k] [-l] [-n] [-p<purposes:levels>] [-q] [-s<algorithms>] [-t] [-u] [-v] [-w<l>] [<outputfile>]\n"; + print "\t-b\tbackup an existing version of ca-bundle.crt\n"; + print "\t-d\tspecify Mozilla tree to pull certdata.txt or custom URL\n"; + print "\t\t Valid names are:\n"; + print "\t\t ", join( ", ", map { ( $_ =~ m/$opt_d/ ) ? "$_ (default)" : "$_" } sort keys %urls ), "\n"; + print "\t-f\tforce rebuild even if certdata.txt is current\n"; + print "\t-i\tprint version info about used modules\n"; + print "\t-k\tallow URLs other than HTTPS, enable HTTP fallback (insecure)\n"; + print "\t-l\tprint license info about certdata.txt\n"; + print "\t-m\tinclude meta data in output\n"; + print "\t-n\tno download of certdata.txt (to use existing)\n"; + print wrap("\t","\t\t", "-p\tlist of Mozilla trust purposes and levels for certificates to include in output. Takes the form of a comma separated list of purposes, a colon, and a comma separated list of levels. (default: $default_mozilla_trust_purposes:$default_mozilla_trust_levels)"), "\n"; + print "\t\t Valid purposes are:\n"; + print wrap("\t\t ","\t\t ", join( ", ", "ALL", @valid_mozilla_trust_purposes ) ), "\n"; + print "\t\t Valid levels are:\n"; + print wrap("\t\t ","\t\t ", join( ", ", "ALL", @valid_mozilla_trust_levels ) ), "\n"; + print "\t-q\tbe really quiet (no progress output at all)\n"; + print wrap("\t","\t\t", "-s\tcomma separated list of certificate signatures/hashes to output in plain text mode. (default: $default_signature_algorithms)\n"); + print "\t\t Valid signature algorithms are:\n"; + print wrap("\t\t ","\t\t ", join( ", ", "ALL", @valid_signature_algorithms ) ), "\n"; + print "\t-t\tinclude plain text listing of certificates\n"; + print "\t-u\tunlink (remove) certdata.txt after processing\n"; + print "\t-v\tbe verbose and print out processed CAs\n"; + print "\t-w <l>\twrap base64 output lines after <l> chars (default: ${opt_w})\n"; + exit; +} + +sub VERSION_MESSAGE() { + print "${0} version ${version} running Perl ${]} on ${^O}\n"; +} + +warning_message() unless ($opt_q || $url =~ m/^(ht|f)tps:/i ); +HELP_MESSAGE() if ($opt_h); + +sub report($@) { + my $output = shift; + + print STDERR $output . "\n" unless $opt_q; +} + +sub is_in_list($@) { + my $target = shift; + + return defined(List::Util::first { $target eq $_ } @_); +} + +# Parses $param_string as a case insensitive comma separated list with optional whitespace +# validates that only allowed parameters are supplied +sub parse_csv_param($$@) { + my $description = shift; + my $param_string = shift; + my @valid_values = @_; + + my @values = map { + s/^\s+//; # strip leading spaces + s/\s+$//; # strip trailing spaces + uc $_ # return the modified string as upper case + } split( ',', $param_string ); + + # Find all values which are not in the list of valid values or "ALL" + my @invalid = grep { !is_in_list($_,"ALL",@valid_values) } @values; + + if ( scalar(@invalid) > 0 ) { + # Tell the user which parameters were invalid and print the standard help message which will exit + print "Error: Invalid ", $description, scalar(@invalid) == 1 ? ": " : "s: ", join( ", ", map { "\"$_\"" } @invalid ), "\n"; + HELP_MESSAGE(); + } + + @values = @valid_values if ( is_in_list("ALL",@values) ); + + return @values; +} + +sub sha256 { + my $result; + if ($Digest::SHA::VERSION || $Digest::SHA::PurePerl::VERSION) { + open(FILE, $_[0]) or die "Can't open '$_[0]': $!"; + binmode(FILE); + $result = $MOD_SHA->new(256)->addfile(*FILE)->hexdigest; + close(FILE); + } else { + # Use OpenSSL command if Perl Digest::SHA modules not available + $result = `"$openssl" dgst -r -sha256 "$_[0]"`; + $result =~ s/^([0-9a-f]{64}) .+/$1/is; + } + return $result; +} + + +sub oldhash { + my $hash = ""; + open(C, "<$_[0]") || return 0; + while(<C>) { + chomp; + if($_ =~ /^\#\# SHA256: (.*)/) { + $hash = $1; + last; + } + } + close(C); + return $hash; +} + +if ( $opt_p !~ m/:/ ) { + print "Error: Mozilla trust identifier list must include both purposes and levels\n"; + HELP_MESSAGE(); +} + +(my $included_mozilla_trust_purposes_string, my $included_mozilla_trust_levels_string) = split( ':', $opt_p ); +my @included_mozilla_trust_purposes = parse_csv_param( "trust purpose", $included_mozilla_trust_purposes_string, @valid_mozilla_trust_purposes ); +my @included_mozilla_trust_levels = parse_csv_param( "trust level", $included_mozilla_trust_levels_string, @valid_mozilla_trust_levels ); + +my @included_signature_algorithms = parse_csv_param( "signature algorithm", $opt_s, @valid_signature_algorithms ); + +sub should_output_cert(%) { + my %trust_purposes_by_level = @_; + + foreach my $level (@included_mozilla_trust_levels) { + # for each level we want to output, see if any of our desired purposes are included + return 1 if ( defined( List::Util::first { is_in_list( $_, @included_mozilla_trust_purposes ) } @{$trust_purposes_by_level{$level}} ) ); + } + + return 0; +} + +my $crt = $ARGV[0] || 'ca-bundle.crt'; +(my $txt = $url) =~ s@(.*/|\?.*)@@g; + +my $stdout = $crt eq '-'; +my $resp; +my $fetched; + +my $oldhash = oldhash($crt); + +report "SHA256 of old file: $oldhash"; + +if(!$opt_n) { + report "Downloading $txt ..."; + + # If we have an HTTPS URL then use curl + if($url =~ /^https:\/\//i) { + if($curl) { + if($curl =~ /^Protocols:.* https( |$)/m) { + report "Get certdata with curl!"; + my $proto = !$opt_k ? "--proto =https" : ""; + my $quiet = $opt_q ? "-s" : ""; + my @out = `curl -w %{response_code} $proto $quiet -o "$txt" "$url"`; + if(!$? && @out && $out[0] == 200) { + $fetched = 1; + report "Downloaded $txt"; + } + else { + report "Failed downloading via HTTPS with curl"; + if(-e $txt && !unlink($txt)) { + report "Failed to remove '$txt': $!"; + } + } + } + else { + report "curl lacks https support"; + } + } + else { + report "curl not found"; + } + } + + # If nothing was fetched then use LWP + if(!$fetched) { + if($url =~ /^https:\/\//i) { + report "Falling back to HTTP"; + $url =~ s/^https:\/\//http:\/\//i; + } + if(!$opt_k) { + report "URLs other than HTTPS are disabled by default, to enable use -k"; + exit 1; + } + report "Get certdata with LWP!"; + if(!defined(${LWP::UserAgent::VERSION})) { + report "LWP is not available (LWP::UserAgent not found)"; + exit 1; + } + my $ua = new LWP::UserAgent(agent => "$0/$version"); + $ua->env_proxy(); + $resp = $ua->mirror($url, $txt); + if($resp && $resp->code eq '304') { + report "Not modified"; + exit 0 if -e $crt && !$opt_f; + } + else { + $fetched = 1; + report "Downloaded $txt"; + } + if(!$resp || $resp->code !~ /^(?:200|304)$/) { + report "Unable to download latest data: " + . ($resp? $resp->code . ' - ' . $resp->message : "LWP failed"); + exit 1 if -e $crt || ! -r $txt; + } + } +} + +my $filedate = $resp ? $resp->last_modified : (stat($txt))[9]; +my $datesrc = "as of"; +if(!$filedate) { + # mxr.mozilla.org gave us a time, hg.mozilla.org does not! + $filedate = time(); + $datesrc="downloaded on"; +} + +# get the hash from the download file +my $newhash= sha256($txt); + +if(!$opt_f && $oldhash eq $newhash) { + report "Downloaded file identical to previous run\'s source file. Exiting"; + exit; +} + +report "SHA256 of new file: $newhash"; + +my $currentdate = scalar gmtime($filedate); + +my $format = $opt_t ? "plain text and " : ""; +if( $stdout ) { + open(CRT, '> -') or die "Couldn't open STDOUT: $!\n"; +} else { + open(CRT,">$crt.~") or die "Couldn't open $crt.~: $!\n"; +} +print CRT <<EOT; +## +## Bundle of CA Root Certificates +## +## Certificate data from Mozilla ${datesrc}: ${currentdate} GMT +## +## This is a bundle of X.509 certificates of public Certificate Authorities +## (CA). These were automatically extracted from Mozilla's root certificates +## file (certdata.txt). This file can be found in the mozilla source tree: +## ${url} +## +## It contains the certificates in ${format}PEM format and therefore +## can be directly used with curl / libcurl / php_curl, or with +## an Apache+mod_ssl webserver for SSL client authentication. +## Just configure this file as the SSLCACertificateFile. +## +## Conversion done with mk-ca-bundle.pl version $version. +## SHA256: $newhash +## + +EOT + +report "Processing '$txt' ..."; +my $caname; +my $certnum = 0; +my $skipnum = 0; +my $start_of_cert = 0; +my @precert; + +open(TXT,"$txt") or die "Couldn't open $txt: $!\n"; +while (<TXT>) { + if (/\*\*\*\*\* BEGIN LICENSE BLOCK \*\*\*\*\*/) { + print CRT; + print if ($opt_l); + while (<TXT>) { + print CRT; + print if ($opt_l); + last if (/\*\*\*\*\* END LICENSE BLOCK \*\*\*\*\*/); + } + } + elsif(/^# (Issuer|Serial Number|Subject|Not Valid Before|Not Valid After |Fingerprint \(MD5\)|Fingerprint \(SHA1\)):/) { + push @precert, $_; + next; + } + elsif(/^#|^\s*$/) { + undef @precert; + next; + } + chomp; + + # this is a match for the start of a certificate + if (/^CKA_CLASS CK_OBJECT_CLASS CKO_CERTIFICATE/) { + $start_of_cert = 1 + } + if ($start_of_cert && /^CKA_LABEL UTF8 \"(.*)\"/) { + $caname = $1; + } + my %trust_purposes_by_level; + if ($start_of_cert && /^CKA_VALUE MULTILINE_OCTAL/) { + my $data; + while (<TXT>) { + last if (/^END/); + chomp; + my @octets = split(/\\/); + shift @octets; + for (@octets) { + $data .= chr(oct); + } + } + # scan forwards until the trust part + while (<TXT>) { + last if (/^CKA_CLASS CK_OBJECT_CLASS CKO_NSS_TRUST/); + chomp; + } + # now scan the trust part to determine how we should trust this cert + while (<TXT>) { + last if (/^#/); + if (/^CKA_TRUST_([A-Z_]+)\s+CK_TRUST\s+CKT_NSS_([A-Z_]+)\s*$/) { + if ( !is_in_list($1,@valid_mozilla_trust_purposes) ) { + report "Warning: Unrecognized trust purpose for cert: $caname. Trust purpose: $1. Trust Level: $2"; + } elsif ( !is_in_list($2,@valid_mozilla_trust_levels) ) { + report "Warning: Unrecognized trust level for cert: $caname. Trust purpose: $1. Trust Level: $2"; + } else { + push @{$trust_purposes_by_level{$2}}, $1; + } + } + } + + if ( !should_output_cert(%trust_purposes_by_level) ) { + $skipnum ++; + } else { + my $encoded = MIME::Base64::encode_base64($data, ''); + $encoded =~ s/(.{1,${opt_w}})/$1\n/g; + my $pem = "-----BEGIN CERTIFICATE-----\n" + . $encoded + . "-----END CERTIFICATE-----\n"; + print CRT "\n$caname\n"; + print CRT @precert if($opt_m); + my $maxStringLength = length(decode('UTF-8', $caname, Encode::FB_CROAK)); + if ($opt_t) { + foreach my $key (keys %trust_purposes_by_level) { + my $string = $key . ": " . join(", ", @{$trust_purposes_by_level{$key}}); + $maxStringLength = List::Util::max( length($string), $maxStringLength ); + print CRT $string . "\n"; + } + } + print CRT ("=" x $maxStringLength . "\n"); + if (!$opt_t) { + print CRT $pem; + } else { + my $pipe = ""; + foreach my $hash (@included_signature_algorithms) { + $pipe = "|$openssl x509 -" . $hash . " -fingerprint -noout -inform PEM"; + if (!$stdout) { + $pipe .= " >> $crt.~"; + close(CRT) or die "Couldn't close $crt.~: $!"; + } + open(TMP, $pipe) or die "Couldn't open openssl pipe: $!"; + print TMP $pem; + close(TMP) or die "Couldn't close openssl pipe: $!"; + if (!$stdout) { + open(CRT, ">>$crt.~") or die "Couldn't open $crt.~: $!"; + } + } + $pipe = "|$openssl x509 -text -inform PEM"; + if (!$stdout) { + $pipe .= " >> $crt.~"; + close(CRT) or die "Couldn't close $crt.~: $!"; + } + open(TMP, $pipe) or die "Couldn't open openssl pipe: $!"; + print TMP $pem; + close(TMP) or die "Couldn't close openssl pipe: $!"; + if (!$stdout) { + open(CRT, ">>$crt.~") or die "Couldn't open $crt.~: $!"; + } + } + report "Parsing: $caname" if ($opt_v); + $certnum ++; + $start_of_cert = 0; + } + undef @precert; + } + +} +close(TXT) or die "Couldn't close $txt: $!\n"; +close(CRT) or die "Couldn't close $crt.~: $!\n"; +unless( $stdout ) { + if ($opt_b && -e $crt) { + my $bk = 1; + while (-e "$crt.~${bk}~") { + $bk++; + } + rename $crt, "$crt.~${bk}~" or die "Failed to create backup $crt.~$bk}~: $!\n"; + } elsif( -e $crt ) { + unlink( $crt ) or die "Failed to remove $crt: $!\n"; + } + rename "$crt.~", $crt or die "Failed to rename $crt.~ to $crt: $!\n"; +} +if($opt_u && -e $txt && !unlink($txt)) { + report "Failed to remove $txt: $!\n"; +} +report "Done ($certnum CA certs processed, $skipnum skipped)."; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTP.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTP.pm new file mode 100644 index 0000000000..fecfc38446 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTP.pm @@ -0,0 +1,307 @@ +package Net::HTTP; +our $VERSION = '6.18'; +use strict; +use warnings; + +use vars qw($SOCKET_CLASS); +unless ($SOCKET_CLASS) { + # Try several, in order of capability and preference + if (eval { require IO::Socket::IP }) { + $SOCKET_CLASS = "IO::Socket::IP"; # IPv4+IPv6 + } elsif (eval { require IO::Socket::INET6 }) { + $SOCKET_CLASS = "IO::Socket::INET6"; # IPv4+IPv6 + } elsif (eval { require IO::Socket::INET }) { + $SOCKET_CLASS = "IO::Socket::INET"; # IPv4 only + } else { + require IO::Socket; + $SOCKET_CLASS = "IO::Socket::INET"; + } +} +require Net::HTTP::Methods; +require Carp; + +our @ISA = ($SOCKET_CLASS, 'Net::HTTP::Methods'); + +sub new { + my $class = shift; + Carp::croak("No Host option provided") unless @_; + $class->SUPER::new(@_); +} + +sub configure { + my($self, $cnf) = @_; + $self->http_configure($cnf); +} + +sub http_connect { + my($self, $cnf) = @_; + $self->SUPER::configure($cnf); +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Net::HTTP - Low-level HTTP connection (client) + +=head1 VERSION + +version 6.18 + +=head1 SYNOPSIS + + use Net::HTTP; + my $s = Net::HTTP->new(Host => "www.perl.com") || die $@; + $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0"); + my($code, $mess, %h) = $s->read_response_headers; + + while (1) { + my $buf; + my $n = $s->read_entity_body($buf, 1024); + die "read failed: $!" unless defined $n; + last unless $n; + print $buf; + } + +=head1 DESCRIPTION + +The C<Net::HTTP> class is a low-level HTTP client. An instance of the +C<Net::HTTP> class represents a connection to an HTTP server. The +HTTP protocol is described in RFC 2616. The C<Net::HTTP> class +supports C<HTTP/1.0> and C<HTTP/1.1>. + +C<Net::HTTP> is a sub-class of one of C<IO::Socket::IP> (IPv6+IPv4), +C<IO::Socket::INET6> (IPv6+IPv4), or C<IO::Socket::INET> (IPv4 only). +You can mix the methods described below with reading and writing from the +socket directly. This is not necessary a good idea, unless you know what +you are doing. + +The following methods are provided (in addition to those of +C<IO::Socket::INET>): + +=over + +=item $s = Net::HTTP->new( %options ) + +The C<Net::HTTP> constructor method takes the same options as +C<IO::Socket::INET>'s as well as these: + + Host: Initial host attribute value + KeepAlive: Initial keep_alive attribute value + SendTE: Initial send_te attribute_value + HTTPVersion: Initial http_version attribute value + PeerHTTPVersion: Initial peer_http_version attribute value + MaxLineLength: Initial max_line_length attribute value + MaxHeaderLines: Initial max_header_lines attribute value + +The C<Host> option is also the default for C<IO::Socket::INET>'s +C<PeerAddr>. The C<PeerPort> defaults to 80 if not provided. +The C<PeerPort> specification can also be embedded in the C<PeerAddr> +by preceding it with a ":", and closing the IPv6 address on brackets "[]" if +necessary: "192.0.2.1:80","[2001:db8::1]:80","any.example.com:80". + +The C<Listen> option provided by C<IO::Socket::INET>'s constructor +method is not allowed. + +If unable to connect to the given HTTP server then the constructor +returns C<undef> and $@ contains the reason. After a successful +connect, a C<Net:HTTP> object is returned. + +=item $s->host + +Get/set the default value of the C<Host> header to send. The $host +must not be set to an empty string (or C<undef>) for HTTP/1.1. + +=item $s->keep_alive + +Get/set the I<keep-alive> value. If this value is TRUE then the +request will be sent with headers indicating that the server should try +to keep the connection open so that multiple requests can be sent. + +The actual headers set will depend on the value of the C<http_version> +and C<peer_http_version> attributes. + +=item $s->send_te + +Get/set the a value indicating if the request will be sent with a "TE" +header to indicate the transfer encodings that the server can choose to +use. The list of encodings announced as accepted by this client depends +on availability of the following modules: C<Compress::Raw::Zlib> for +I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>. + +=item $s->http_version + +Get/set the HTTP version number that this client should announce. +This value can only be set to "1.0" or "1.1". The default is "1.1". + +=item $s->peer_http_version + +Get/set the protocol version number of our peer. This value will +initially be "1.0", but will be updated by a successful +read_response_headers() method call. + +=item $s->max_line_length + +Get/set a limit on the length of response line and response header +lines. The default is 8192. A value of 0 means no limit. + +=item $s->max_header_length + +Get/set a limit on the number of header lines that a response can +have. The default is 128. A value of 0 means no limit. + +=item $s->format_request($method, $uri, %headers, [$content]) + +Format a request message and return it as a string. If the headers do +not include a C<Host> header, then a header is inserted with the value +of the C<host> attribute. Headers like C<Connection> and +C<Keep-Alive> might also be added depending on the status of the +C<keep_alive> attribute. + +If $content is given (and it is non-empty), then a C<Content-Length> +header is automatically added unless it was already present. + +=item $s->write_request($method, $uri, %headers, [$content]) + +Format and send a request message. Arguments are the same as for +format_request(). Returns true if successful. + +=item $s->format_chunk( $data ) + +Returns the string to be written for the given chunk of data. + +=item $s->write_chunk($data) + +Will write a new chunk of request entity body data. This method +should only be used if the C<Transfer-Encoding> header with a value of +C<chunked> was sent in the request. Note, writing zero-length data is +a no-op. Use the write_chunk_eof() method to signal end of entity +body data. + +Returns true if successful. + +=item $s->format_chunk_eof( %trailers ) + +Returns the string to be written for signaling EOF when a +C<Transfer-Encoding> of C<chunked> is used. + +=item $s->write_chunk_eof( %trailers ) + +Will write eof marker for chunked data and optional trailers. Note +that trailers should not really be used unless is was signaled +with a C<Trailer> header. + +Returns true if successful. + +=item ($code, $mess, %headers) = $s->read_response_headers( %opts ) + +Read response headers from server and return it. The $code is the 3 +digit HTTP status code (see L<HTTP::Status>) and $mess is the textual +message that came with it. Headers are then returned as key/value +pairs. Since key letter casing is not normalized and the same key can +even occur multiple times, assigning these values directly to a hash +is not wise. Only the $code is returned if this method is called in +scalar context. + +As a side effect this method updates the 'peer_http_version' +attribute. + +Options might be passed in as key/value pairs. There are currently +only two options supported; C<laxed> and C<junk_out>. + +The C<laxed> option will make read_response_headers() more forgiving +towards servers that have not learned how to speak HTTP properly. The +C<laxed> option is a boolean flag, and is enabled by passing in a TRUE +value. The C<junk_out> option can be used to capture bad header lines +when C<laxed> is enabled. The value should be an array reference. +Bad header lines will be pushed onto the array. + +The C<laxed> option must be specified in order to communicate with +pre-HTTP/1.0 servers that don't describe the response outcome or the +data they send back with a header block. For these servers +peer_http_version is set to "0.9" and this method returns (200, +"Assumed OK"). + +The method will raise an exception (die) if the server does not speak +proper HTTP or if the C<max_line_length> or C<max_header_length> +limits are reached. If the C<laxed> option is turned on and +C<max_line_length> and C<max_header_length> checks are turned off, +then no exception will be raised and this method will always +return a response code. + +=item $n = $s->read_entity_body($buf, $size); + +Reads chunks of the entity body content. Basically the same interface +as for read() and sysread(), but the buffer offset argument is not +supported yet. This method should only be called after a successful +read_response_headers() call. + +The return value will be C<undef> on read errors, 0 on EOF, -1 if no data +could be returned this time, otherwise the number of bytes assigned +to $buf. The $buf is set to "" when the return value is -1. + +You normally want to retry this call if this function returns either +-1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>). EINTR +can happen if the application catches signals and EAGAIN can happen if +you made the socket non-blocking. + +This method will raise exceptions (die) if the server does not speak +proper HTTP. This can only happen when reading chunked data. + +=item %headers = $s->get_trailers + +After read_entity_body() has returned 0 to indicate end of the entity +body, you might call this method to pick up any trailers. + +=item $s->_rbuf + +Get/set the read buffer content. The read_response_headers() and +read_entity_body() methods use an internal buffer which they will look +for data before they actually sysread more from the socket itself. If +they read too much, the remaining data will be left in this buffer. + +=item $s->_rbuf_length + +Returns the number of bytes in the read buffer. This should always be +the same as: + + length($s->_rbuf) + +but might be more efficient. + +=back + +=head1 SUBCLASSING + +The read_response_headers() and read_entity_body() will invoke the +sysread() method when they need more data. Subclasses might want to +override this method to control how reading takes place. + +The object itself is a glob. Subclasses should avoid using hash key +names prefixed with C<http_> and C<io_>. + +=head1 SEE ALSO + +L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB> + +=head1 AUTHOR + +Gisle Aas <gisle@activestate.com> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2001-2017 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: Low-level HTTP connection (client) + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTP/Methods.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTP/Methods.pm new file mode 100644 index 0000000000..c682e3fc25 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTP/Methods.pm @@ -0,0 +1,669 @@ +package Net::HTTP::Methods; +our $VERSION = '6.18'; +use strict; +use warnings; +use URI; + +my $CRLF = "\015\012"; # "\r\n" is not portable + +*_bytes = defined(&utf8::downgrade) ? + sub { + unless (utf8::downgrade($_[0], 1)) { + require Carp; + Carp::croak("Wide character in HTTP request (bytes required)"); + } + return $_[0]; + } + : + sub { + return $_[0]; + }; + + +sub new { + my $class = shift; + unshift(@_, "Host") if @_ == 1; + my %cnf = @_; + require Symbol; + my $self = bless Symbol::gensym(), $class; + return $self->http_configure(\%cnf); +} + +sub http_configure { + my($self, $cnf) = @_; + + die "Listen option not allowed" if $cnf->{Listen}; + my $explicit_host = (exists $cnf->{Host}); + my $host = delete $cnf->{Host}; + my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost}; + if (!$peer) { + die "No Host option provided" unless $host; + $cnf->{PeerAddr} = $peer = $host; + } + + # CONNECTIONS + # PREFER: port number from PeerAddr, then PeerPort, then http_default_port + my $peer_uri = URI->new("http://$peer"); + $cnf->{"PeerPort"} = $peer_uri->_port || $cnf->{PeerPort} || $self->http_default_port; + $cnf->{"PeerAddr"} = $peer_uri->host; + + # HOST header: + # If specified but blank, ignore. + # If specified with a value, add the port number + # If not specified, set to PeerAddr and port number + # ALWAYS: If IPv6 address, use [brackets] (thanks to the URI package) + # ALWAYS: omit port number if http_default_port + if (($host) || (! $explicit_host)) { + my $uri = ($explicit_host) ? URI->new("http://$host") : $peer_uri->clone; + if (!$uri->_port) { + # Always use *our* $self->http_default_port instead of URI's (Covers HTTP, HTTPS) + $uri->port( $cnf->{PeerPort} || $self->http_default_port); + } + my $host_port = $uri->host_port; # Returns host:port or [ipv6]:port + my $remove = ":" . $self->http_default_port; # we want to remove the default port number + if (substr($host_port,0-length($remove)) eq $remove) { + substr($host_port,0-length($remove)) = ""; + } + $host = $host_port; + } + + $cnf->{Proto} = 'tcp'; + + my $keep_alive = delete $cnf->{KeepAlive}; + my $http_version = delete $cnf->{HTTPVersion}; + $http_version = "1.1" unless defined $http_version; + my $peer_http_version = delete $cnf->{PeerHTTPVersion}; + $peer_http_version = "1.0" unless defined $peer_http_version; + my $send_te = delete $cnf->{SendTE}; + my $max_line_length = delete $cnf->{MaxLineLength}; + $max_line_length = 8*1024 unless defined $max_line_length; + my $max_header_lines = delete $cnf->{MaxHeaderLines}; + $max_header_lines = 128 unless defined $max_header_lines; + + return undef unless $self->http_connect($cnf); + + $self->host($host); + $self->keep_alive($keep_alive); + $self->send_te($send_te); + $self->http_version($http_version); + $self->peer_http_version($peer_http_version); + $self->max_line_length($max_line_length); + $self->max_header_lines($max_header_lines); + + ${*$self}{'http_buf'} = ""; + + return $self; +} + +sub http_default_port { + 80; +} + +# set up property accessors +for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) { + my $prop_name = "http_" . $method; + no strict 'refs'; + *$method = sub { + my $self = shift; + my $old = ${*$self}{$prop_name}; + ${*$self}{$prop_name} = shift if @_; + return $old; + }; +} + +# we want this one to be a bit smarter +sub http_version { + my $self = shift; + my $old = ${*$self}{'http_version'}; + if (@_) { + my $v = shift; + $v = "1.0" if $v eq "1"; # float + unless ($v eq "1.0" or $v eq "1.1") { + require Carp; + Carp::croak("Unsupported HTTP version '$v'"); + } + ${*$self}{'http_version'} = $v; + } + $old; +} + +sub format_request { + my $self = shift; + my $method = shift; + my $uri = shift; + + my $content = (@_ % 2) ? pop : ""; + + for ($method, $uri) { + require Carp; + Carp::croak("Bad method or uri") if /\s/ || !length; + } + + push(@{${*$self}{'http_request_method'}}, $method); + my $ver = ${*$self}{'http_version'}; + my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0"; + + my @h; + my @connection; + my %given = (host => 0, "content-length" => 0, "te" => 0); + while (@_) { + my($k, $v) = splice(@_, 0, 2); + my $lc_k = lc($k); + if ($lc_k eq "connection") { + $v =~ s/^\s+//; + $v =~ s/\s+$//; + push(@connection, split(/\s*,\s*/, $v)); + next; + } + if (exists $given{$lc_k}) { + $given{$lc_k}++; + } + push(@h, "$k: $v"); + } + + if (length($content) && !$given{'content-length'}) { + push(@h, "Content-Length: " . length($content)); + } + + my @h2; + if ($given{te}) { + push(@connection, "TE") unless grep lc($_) eq "te", @connection; + } + elsif ($self->send_te && gunzip_ok()) { + # gzip is less wanted since the IO::Uncompress::Gunzip interface for + # it does not really allow chunked decoding to take place easily. + push(@h2, "TE: deflate,gzip;q=0.3"); + push(@connection, "TE"); + } + + unless (grep lc($_) eq "close", @connection) { + if ($self->keep_alive) { + if ($peer_ver eq "1.0") { + # from looking at Netscape's headers + push(@h2, "Keep-Alive: 300"); + unshift(@connection, "Keep-Alive"); + } + } + else { + push(@connection, "close") if $ver ge "1.1"; + } + } + push(@h2, "Connection: " . join(", ", @connection)) if @connection; + unless ($given{host}) { + my $h = ${*$self}{'http_host'}; + push(@h2, "Host: $h") if $h; + } + + return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content)); +} + + +sub write_request { + my $self = shift; + $self->print($self->format_request(@_)); +} + +sub format_chunk { + my $self = shift; + return $_[0] unless defined($_[0]) && length($_[0]); + return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF); +} + +sub write_chunk { + my $self = shift; + return 1 unless defined($_[0]) && length($_[0]); + $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF)); +} + +sub format_chunk_eof { + my $self = shift; + my @h; + while (@_) { + push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2)); + } + return _bytes(join("", "0$CRLF", @h, $CRLF)); +} + +sub write_chunk_eof { + my $self = shift; + $self->print($self->format_chunk_eof(@_)); +} + + +sub my_read { + die if @_ > 3; + my $self = shift; + my $len = $_[1]; + for (${*$self}{'http_buf'}) { + if (length) { + $_[0] = substr($_, 0, $len, ""); + return length($_[0]); + } + else { + die "read timeout" unless $self->can_read; + return $self->sysread($_[0], $len); + } + } +} + + +sub my_readline { + my $self = shift; + my $what = shift; + for (${*$self}{'http_buf'}) { + my $max_line_length = ${*$self}{'http_max_line_length'}; + my $pos; + while (1) { + # find line ending + $pos = index($_, "\012"); + last if $pos >= 0; + die "$what line too long (limit is $max_line_length)" + if $max_line_length && length($_) > $max_line_length; + + # need to read more data to find a line ending + my $new_bytes = 0; + + READ: + { # wait until bytes start arriving + $self->can_read + or die "read timeout"; + + # consume all incoming bytes + my $bytes_read = $self->sysread($_, 1024, length); + if(defined $bytes_read) { + $new_bytes += $bytes_read; + } + elsif($!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK}) { + redo READ; + } + else { + # if we have already accumulated some data let's at + # least return that as a line + length or die "$what read failed: $!"; + } + + # no line-ending, no new bytes + return length($_) ? substr($_, 0, length($_), "") : undef + if $new_bytes==0; + } + } + die "$what line too long ($pos; limit is $max_line_length)" + if $max_line_length && $pos > $max_line_length; + + my $line = substr($_, 0, $pos+1, ""); + $line =~ s/(\015?\012)\z// || die "Assert"; + return wantarray ? ($line, $1) : $line; + } +} + + +sub can_read { + my $self = shift; + return 1 unless defined(fileno($self)); + return 1 if $self->isa('IO::Socket::SSL') && $self->pending; + return 1 if $self->isa('Net::SSL') && $self->can('pending') && $self->pending; + + # With no timeout, wait forever. An explicit timeout of 0 can be + # used to just check if the socket is readable without waiting. + my $timeout = @_ ? shift : (${*$self}{io_socket_timeout} || undef); + + my $fbits = ''; + vec($fbits, fileno($self), 1) = 1; + SELECT: + { + my $before; + $before = time if $timeout; + my $nfound = select($fbits, undef, undef, $timeout); + if ($nfound < 0) { + if ($!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK}) { + # don't really think EAGAIN/EWOULDBLOCK can happen here + if ($timeout) { + $timeout -= time - $before; + $timeout = 0 if $timeout < 0; + } + redo SELECT; + } + die "select failed: $!"; + } + return $nfound > 0; + } +} + + +sub _rbuf { + my $self = shift; + if (@_) { + for (${*$self}{'http_buf'}) { + my $old; + $old = $_ if defined wantarray; + $_ = shift; + return $old; + } + } + else { + return ${*$self}{'http_buf'}; + } +} + +sub _rbuf_length { + my $self = shift; + return length ${*$self}{'http_buf'}; +} + + +sub _read_header_lines { + my $self = shift; + my $junk_out = shift; + + my @headers; + my $line_count = 0; + my $max_header_lines = ${*$self}{'http_max_header_lines'}; + while (my $line = my_readline($self, 'Header')) { + if ($line =~ /^(\S+?)\s*:\s*(.*)/s) { + push(@headers, $1, $2); + } + elsif (@headers && $line =~ s/^\s+//) { + $headers[-1] .= " " . $line; + } + elsif ($junk_out) { + push(@$junk_out, $line); + } + else { + die "Bad header: '$line'\n"; + } + if ($max_header_lines) { + $line_count++; + if ($line_count >= $max_header_lines) { + die "Too many header lines (limit is $max_header_lines)"; + } + } + } + return @headers; +} + + +sub read_response_headers { + my($self, %opt) = @_; + my $laxed = $opt{laxed}; + + my($status, $eol) = my_readline($self, 'Status'); + unless (defined $status) { + die "Server closed connection without sending any data back"; + } + + my($peer_ver, $code, $message) = split(/\s+/, $status, 3); + if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) { + die "Bad response status line: '$status'" unless $laxed; + # assume HTTP/0.9 + ${*$self}{'http_peer_http_version'} = "0.9"; + ${*$self}{'http_status'} = "200"; + substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || ""); + return 200 unless wantarray; + return (200, "Assumed OK"); + }; + + ${*$self}{'http_peer_http_version'} = $peer_ver; + ${*$self}{'http_status'} = $code; + + my $junk_out; + if ($laxed) { + $junk_out = $opt{junk_out} || []; + } + my @headers = $self->_read_header_lines($junk_out); + + # pick out headers that read_entity_body might need + my @te; + my $content_length; + for (my $i = 0; $i < @headers; $i += 2) { + my $h = lc($headers[$i]); + if ($h eq 'transfer-encoding') { + my $te = $headers[$i+1]; + $te =~ s/^\s+//; + $te =~ s/\s+$//; + push(@te, $te) if length($te); + } + elsif ($h eq 'content-length') { + # ignore bogus and overflow values + if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) { + $content_length = $1; + } + } + } + ${*$self}{'http_te'} = join(",", @te); + ${*$self}{'http_content_length'} = $content_length; + ${*$self}{'http_first_body'}++; + delete ${*$self}{'http_trailers'}; + return $code unless wantarray; + return ($code, $message, @headers); +} + + +sub read_entity_body { + my $self = shift; + my $buf_ref = \$_[0]; + my $size = $_[1]; + die "Offset not supported yet" if $_[2]; + + my $chunked; + my $bytes; + + if (${*$self}{'http_first_body'}) { + ${*$self}{'http_first_body'} = 0; + delete ${*$self}{'http_chunked'}; + delete ${*$self}{'http_bytes'}; + my $method = shift(@{${*$self}{'http_request_method'}}); + my $status = ${*$self}{'http_status'}; + if ($method eq "HEAD") { + # this response is always empty regardless of other headers + $bytes = 0; + } + elsif (my $te = ${*$self}{'http_te'}) { + my @te = split(/\s*,\s*/, lc($te)); + die "Chunked must be last Transfer-Encoding '$te'" + unless pop(@te) eq "chunked"; + pop(@te) while @te && $te[-1] eq "chunked"; # ignore repeated chunked spec + + for (@te) { + if ($_ eq "deflate" && inflate_ok()) { + #require Compress::Raw::Zlib; + my ($i, $status) = Compress::Raw::Zlib::Inflate->new(); + die "Can't make inflator: $status" unless $i; + $_ = sub { my $out; $i->inflate($_[0], \$out); $out } + } + elsif ($_ eq "gzip" && gunzip_ok()) { + #require IO::Uncompress::Gunzip; + my @buf; + $_ = sub { + push(@buf, $_[0]); + return "" unless $_[1]; + my $input = join("", @buf); + my $output; + IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0) + or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError"; + return \$output; + }; + } + elsif ($_ eq "identity") { + $_ = sub { $_[0] }; + } + else { + die "Can't handle transfer encoding '$te'"; + } + } + + @te = reverse(@te); + + ${*$self}{'http_te2'} = @te ? \@te : ""; + $chunked = -1; + } + elsif (defined(my $content_length = ${*$self}{'http_content_length'})) { + $bytes = $content_length; + } + elsif ($status =~ /^(?:1|[23]04)/) { + # RFC 2616 says that these responses should always be empty + # but that does not appear to be true in practice [RT#17907] + $bytes = 0; + } + else { + # XXX Multi-Part types are self delimiting, but RFC 2616 says we + # only has to deal with 'multipart/byteranges' + + # Read until EOF + } + } + else { + $chunked = ${*$self}{'http_chunked'}; + $bytes = ${*$self}{'http_bytes'}; + } + + if (defined $chunked) { + # The state encoded in $chunked is: + # $chunked == 0: read CRLF after chunk, then chunk header + # $chunked == -1: read chunk header + # $chunked > 0: bytes left in current chunk to read + + if ($chunked <= 0) { + my $line = my_readline($self, 'Entity body'); + if ($chunked == 0) { + die "Missing newline after chunk data: '$line'" + if !defined($line) || $line ne ""; + $line = my_readline($self, 'Entity body'); + } + die "EOF when chunk header expected" unless defined($line); + my $chunk_len = $line; + $chunk_len =~ s/;.*//; # ignore potential chunk parameters + unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) { + die "Bad chunk-size in HTTP response: $line"; + } + $chunked = hex($1); + ${*$self}{'http_chunked'} = $chunked; + if ($chunked == 0) { + ${*$self}{'http_trailers'} = [$self->_read_header_lines]; + $$buf_ref = ""; + + my $n = 0; + if (my $transforms = delete ${*$self}{'http_te2'}) { + for (@$transforms) { + $$buf_ref = &$_($$buf_ref, 1); + } + $n = length($$buf_ref); + } + + # in case somebody tries to read more, make sure we continue + # to return EOF + delete ${*$self}{'http_chunked'}; + ${*$self}{'http_bytes'} = 0; + + return $n; + } + } + + my $n = $chunked; + $n = $size if $size && $size < $n; + $n = my_read($self, $$buf_ref, $n); + return undef unless defined $n; + + ${*$self}{'http_chunked'} = $chunked - $n; + + if ($n > 0) { + if (my $transforms = ${*$self}{'http_te2'}) { + for (@$transforms) { + $$buf_ref = &$_($$buf_ref, 0); + } + $n = length($$buf_ref); + $n = -1 if $n == 0; + } + } + return $n; + } + elsif (defined $bytes) { + unless ($bytes) { + $$buf_ref = ""; + return 0; + } + my $n = $bytes; + $n = $size if $size && $size < $n; + $n = my_read($self, $$buf_ref, $n); + ${*$self}{'http_bytes'} = defined $n ? $bytes - $n : $bytes; + return $n; + } + else { + # read until eof + $size ||= 8*1024; + return my_read($self, $$buf_ref, $size); + } +} + +sub get_trailers { + my $self = shift; + @{${*$self}{'http_trailers'} || []}; +} + +BEGIN { +my $gunzip_ok; +my $inflate_ok; + +sub gunzip_ok { + return $gunzip_ok if defined $gunzip_ok; + + # Try to load IO::Uncompress::Gunzip. + local $@; + local $SIG{__DIE__}; + $gunzip_ok = 0; + + eval { + require IO::Uncompress::Gunzip; + $gunzip_ok++; + }; + + return $gunzip_ok; +} + +sub inflate_ok { + return $inflate_ok if defined $inflate_ok; + + # Try to load Compress::Raw::Zlib. + local $@; + local $SIG{__DIE__}; + $inflate_ok = 0; + + eval { + require Compress::Raw::Zlib; + $inflate_ok++; + }; + + return $inflate_ok; +} + +} # BEGIN + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Net::HTTP::Methods - Methods shared by Net::HTTP and Net::HTTPS + +=head1 VERSION + +version 6.18 + +=head1 AUTHOR + +Gisle Aas <gisle@activestate.com> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2001-2017 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: Methods shared by Net::HTTP and Net::HTTPS diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTP/NB.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTP/NB.pm new file mode 100644 index 0000000000..ff70563409 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTP/NB.pm @@ -0,0 +1,121 @@ +package Net::HTTP::NB; +our $VERSION = '6.18'; +use strict; +use warnings; + +use base 'Net::HTTP'; + +sub can_read { + return 1; +} + +sub sysread { + my $self = $_[0]; + if (${*$self}{'httpnb_read_count'}++) { + ${*$self}{'http_buf'} = ${*$self}{'httpnb_save'}; + die "Multi-read\n"; + } + my $buf; + my $offset = $_[3] || 0; + my $n = sysread($self, $_[1], $_[2], $offset); + ${*$self}{'httpnb_save'} .= substr($_[1], $offset); + return $n; +} + +sub read_response_headers { + my $self = shift; + ${*$self}{'httpnb_read_count'} = 0; + ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'}; + my @h = eval { $self->SUPER::read_response_headers(@_) }; + if ($@) { + return if $@ eq "Multi-read\n"; + die; + } + return @h; +} + +sub read_entity_body { + my $self = shift; + ${*$self}{'httpnb_read_count'} = 0; + ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'}; + # XXX I'm not so sure this does the correct thing in case of + # transfer-encoding transforms + my $n = eval { $self->SUPER::read_entity_body(@_); }; + if ($@) { + $_[0] = ""; + return -1; + } + return $n; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Net::HTTP::NB - Non-blocking HTTP client + +=head1 VERSION + +version 6.18 + +=head1 SYNOPSIS + + use Net::HTTP::NB; + my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@; + $s->write_request(GET => "/"); + + use IO::Select; + my $sel = IO::Select->new($s); + + READ_HEADER: { + die "Header timeout" unless $sel->can_read(10); + my($code, $mess, %h) = $s->read_response_headers; + redo READ_HEADER unless $code; + } + + while (1) { + die "Body timeout" unless $sel->can_read(10); + my $buf; + my $n = $s->read_entity_body($buf, 1024); + last unless $n; + print $buf; + } + +=head1 DESCRIPTION + +Same interface as C<Net::HTTP> but it will never try multiple reads +when the read_response_headers() or read_entity_body() methods are +invoked. This make it possible to multiplex multiple Net::HTTP::NB +using select without risk blocking. + +If read_response_headers() did not see enough data to complete the +headers an empty list is returned. + +If read_entity_body() did not see new entity data in its read +the value -1 is returned. + +=head1 SEE ALSO + +L<Net::HTTP> + +=head1 AUTHOR + +Gisle Aas <gisle@activestate.com> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2001-2017 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: Non-blocking HTTP client + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTPS.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTPS.pm new file mode 100644 index 0000000000..2ec04b6e0f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Net/HTTPS.pm @@ -0,0 +1,135 @@ +package Net::HTTPS; +our $VERSION = '6.18'; +use strict; +use warnings; + +# Figure out which SSL implementation to use +use vars qw($SSL_SOCKET_CLASS); +if ($SSL_SOCKET_CLASS) { + # somebody already set it +} +elsif ($SSL_SOCKET_CLASS = $ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS}) { + unless ($SSL_SOCKET_CLASS =~ /^(IO::Socket::SSL|Net::SSL)\z/) { + die "Bad socket class [$SSL_SOCKET_CLASS]"; + } + eval "require $SSL_SOCKET_CLASS"; + die $@ if $@; +} +elsif ($IO::Socket::SSL::VERSION) { + $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded +} +elsif ($Net::SSL::VERSION) { + $SSL_SOCKET_CLASS = "Net::SSL"; +} +else { + eval { require IO::Socket::SSL; }; + if ($@) { + my $old_errsv = $@; + eval { + require Net::SSL; # from Crypt-SSLeay + }; + if ($@) { + $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g; + die $old_errsv . $@; + } + $SSL_SOCKET_CLASS = "Net::SSL"; + } + else { + $SSL_SOCKET_CLASS = "IO::Socket::SSL"; + } +} + +require Net::HTTP::Methods; + +our @ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods'); + +sub configure { + my($self, $cnf) = @_; + $self->http_configure($cnf); +} + +sub http_connect { + my($self, $cnf) = @_; + if ($self->isa("Net::SSL")) { + if ($cnf->{SSL_verify_mode}) { + if (my $f = $cnf->{SSL_ca_file}) { + $ENV{HTTPS_CA_FILE} = $f; + } + if (my $f = $cnf->{SSL_ca_path}) { + $ENV{HTTPS_CA_DIR} = $f; + } + } + if ($cnf->{SSL_verifycn_scheme}) { + $@ = "Net::SSL from Crypt-SSLeay can't verify hostnames; either install IO::Socket::SSL or turn off verification by setting the PERL_LWP_SSL_VERIFY_HOSTNAME environment variable to 0"; + return undef; + } + } + $self->SUPER::configure($cnf); +} + +sub http_default_port { + 443; +} + +if ($SSL_SOCKET_CLASS eq "Net::SSL") { + # The underlying SSLeay classes fails to work if the socket is + # placed in non-blocking mode. This override of the blocking + # method makes sure it stays the way it was created. + *blocking = sub { }; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Net::HTTPS - Low-level HTTP over SSL/TLS connection (client) + +=head1 VERSION + +version 6.18 + +=head1 DESCRIPTION + +The C<Net::HTTPS> is a low-level HTTP over SSL/TLS client. The interface is the same +as the interface for C<Net::HTTP>, but the constructor takes additional parameters +as accepted by L<IO::Socket::SSL>. The C<Net::HTTPS> object is an C<IO::Socket::SSL> +too, which makes it inherit additional methods from that base class. + +For historical reasons this module also supports using C<Net::SSL> (from the +Crypt-SSLeay distribution) as its SSL driver and base class. This base is +automatically selected if available and C<IO::Socket::SSL> isn't. You might +also force which implementation to use by setting $Net::HTTPS::SSL_SOCKET_CLASS +before loading this module. If not set this variable is initialized from the +C<PERL_NET_HTTPS_SSL_SOCKET_CLASS> environment variable. + +=head1 ENVIRONMENT + +You might set the C<PERL_NET_HTTPS_SSL_SOCKET_CLASS> environment variable to the name +of the base SSL implementation (and Net::HTTPS base class) to use. The default +is C<IO::Socket::SSL>. Currently the only other supported value is C<Net::SSL>. + +=head1 SEE ALSO + +L<Net::HTTP>, L<IO::Socket::SSL> + +=head1 AUTHOR + +Gisle Aas <gisle@activestate.com> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2001-2017 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: Low-level HTTP over SSL/TLS connection (client) + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/OLE.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/OLE.pm new file mode 100644 index 0000000000..234f6986ab --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/OLE.pm @@ -0,0 +1,177 @@ +# Compatibility layer for applications using the old toplevel OLE.pm. +# New code should use Win32::OLE + +# This file is based on ../lib/OLE.pm from ActiveState build 315. + +# Compatibility notes: +# - "GetObject" -> "GetActiveObject" +# - "keys %$collection" -> "Win32::OLE::Enum->All($collection)" +# or "in $Collection" +# - "unnamed" default method retries + +######################################################################## +# package Win32; +######################################################################## + +*Win32::OLELastError = sub { return OLE->LastError() }; + + +######################################################################## +package OLE::Variant; +######################################################################## + +use Win32::OLE qw(CP_ACP); +use Win32::OLE::Variant; + +use strict; +use vars qw($AUTOLOAD @ISA $LCID $CP $Warn $LastError $_NewEnum $_Unique); +@ISA = qw(Win32::OLE::Variant); + +$Warn = 0; +$LCID = 2 << 10; # LOCALE_SYSTEM_DEFAULT +$CP = CP_ACP; +$_NewEnum = 0; +$_Unique = 0; + +sub new { + my $self = shift; + my $variant = $self->SUPER::new(@_); + $OLE::LastError = $Win32::OLE->LastError unless defined $variant; + return $variant; +} + + +######################################################################## +package OLE::Tie; +######################################################################## +use strict; +use vars qw(@ISA); +@ISA = qw(Win32::OLE::Tie); + +# !!! It is VERY important that Win32::OLE::Tie::DESTROY gets called. !!! +# If you subclass DESTROY, don't forget to call $self->SUPER::DESTROY. +# Otherwise the OLE interfaces will not be released until process termination! + +# Retry default method if property doesn't exist +sub FETCH { + my ($self,$key) = @_; + return $self->SUPER::Fetch($key, 1); +} + +sub STORE { + my ($self,$key,$value) = @_; + $self->SUPER::Store($key, $value, 1); +} + +# Enumerate collection members, not object properties +*FIRSTKEY = *Win32::OLE::Tie::FIRSTENUM; +*NEXTKEY = *Win32::OLE::Tie::NEXTENUM; + + +######################################################################## +package OLE; +######################################################################## +use Win32::OLE qw(CP_ACP); + +# Use OleInitialize() instead of CoInitializeEx: +Win32::OLE->Initialize(Win32::OLE::COINIT_OLEINITIALIZE); + +use strict; + +# Disable overload; unfortunately "no overload" doesn't do it :-( +# Overloading is no longer enabled by default in Win32::OLE +#use overload '""' => sub {overload::StrVal($_[0])}, +# '0+' => sub {overload::StrVal($_[0])}; + +use vars qw($AUTOLOAD @ISA $LCID $CP $Warn $LastError $Tie); +@ISA = qw(Win32::OLE); + +$Warn = 0; +$LCID = 2 << 10; # LOCALE_SYSTEM_DEFAULT +$CP = CP_ACP; +$Tie = 'OLE::Tie'; + +sub new { + my $class = shift; + $class = shift if $class eq 'OLE'; + return OLE->SUPER::new($class); +} + +sub copy { + my $class = shift; + $class = shift if $class eq 'OLE'; + return OLE->SUPER::GetActiveObject($class); +} + +sub AUTOLOAD { + my $self = shift; + my $retval; + $AUTOLOAD =~ s/.*:://o; + + Carp::croak("Cannot autoload class method \"$AUTOLOAD\"") + unless ref($self) && UNIVERSAL::isa($self,'OLE'); + + local $^H = 0; # !hack alert! + unless (defined $self->Dispatch($AUTOLOAD, $retval, @_)) { + # Retry default method + $self->Dispatch(undef, $retval, $AUTOLOAD, @_); + } + return $retval; +} + +*CreateObject = \&new; +*GetObject = \© + +# Automation data types. + +sub VT_EMPTY {0;} +sub VT_NULL {1;} +sub VT_I2 {2;} +sub VT_I4 {3;} +sub VT_R4 {4;} +sub VT_R8 {5;} +sub VT_CY {6;} +sub VT_DATE {7;} +sub VT_BSTR {8;} +sub VT_DISPATCH {9;} +sub VT_ERROR {10;} +sub VT_BOOL {11;} +sub VT_VARIANT {12;} +sub VT_UNKNOWN {13;} +sub VT_I1 {16;} +sub VT_UI1 {17;} +sub VT_UI2 {18;} +sub VT_UI4 {19;} +sub VT_I8 {20;} +sub VT_UI8 {21;} +sub VT_INT {22;} +sub VT_UINT {23;} +sub VT_VOID {24;} +sub VT_HRESULT {25;} +sub VT_PTR {26;} +sub VT_SAFEARRAY {27;} +sub VT_CARRAY {28;} +sub VT_USERDEFINED {29;} +sub VT_LPSTR {30;} +sub VT_LPWSTR {31;} +sub VT_FILETIME {64;} +sub VT_BLOB {65;} +sub VT_STREAM {66;} +sub VT_STORAGE {67;} +sub VT_STREAMED_OBJECT {68;} +sub VT_STORED_OBJECT {69;} +sub VT_BLOB_OBJECT {70;} +sub VT_CF {71;} +sub VT_CLSID {72;} + +sub TKIND_ENUM {0;} +sub TKIND_RECORD {1;} +sub TKIND_MODULE {2;} +sub TKIND_INTERFACE {3;} +sub TKIND_DISPATCH {4;} +sub TKIND_COCLASS {5;} +sub TKIND_ALIAS {6;} +sub TKIND_UNION {7;} +sub TKIND_MAX {8;} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Socket.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Socket.pm new file mode 100644 index 0000000000..2c6b5e45d0 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Socket.pm @@ -0,0 +1,1138 @@ +package Socket; + +use strict; +{ use 5.006001; } + +our $VERSION = '2.029'; + +=head1 NAME + +C<Socket> - networking constants and support functions + +=head1 SYNOPSIS + +C<Socket> a low-level module used by, among other things, the L<IO::Socket> +family of modules. The following examples demonstrate some low-level uses but +a practical program would likely use the higher-level API provided by +C<IO::Socket> or similar instead. + + use Socket qw(PF_INET SOCK_STREAM pack_sockaddr_in inet_aton); + + socket(my $socket, PF_INET, SOCK_STREAM, 0) + or die "socket: $!"; + + my $port = getservbyname "echo", "tcp"; + connect($socket, pack_sockaddr_in($port, inet_aton("localhost"))) + or die "connect: $!"; + + print $socket "Hello, world!\n"; + print <$socket>; + +See also the L</EXAMPLES> section. + +=head1 DESCRIPTION + +This module provides a variety of constants, structure manipulators and other +functions related to socket-based networking. The values and functions +provided are useful when used in conjunction with Perl core functions such as +socket(), setsockopt() and bind(). It also provides several other support +functions, mostly for dealing with conversions of network addresses between +human-readable and native binary forms, and for hostname resolver operations. + +Some constants and functions are exported by default by this module; but for +backward-compatibility any recently-added symbols are not exported by default +and must be requested explicitly. When an import list is provided to the +C<use Socket> line, the default exports are not automatically imported. It is +therefore best practice to always to explicitly list all the symbols required. + +Also, some common socket "newline" constants are provided: the constants +C<CR>, C<LF>, and C<CRLF>, as well as C<$CR>, C<$LF>, and C<$CRLF>, which map +to C<\015>, C<\012>, and C<\015\012>. If you do not want to use the literal +characters in your programs, then use the constants provided here. They are +not exported by default, but can be imported individually, and with the +C<:crlf> export tag: + + use Socket qw(:DEFAULT :crlf); + + $sock->print("GET / HTTP/1.0$CRLF"); + +The entire getaddrinfo() subsystem can be exported using the tag C<:addrinfo>; +this exports the getaddrinfo() and getnameinfo() functions, and all the +C<AI_*>, C<NI_*>, C<NIx_*> and C<EAI_*> constants. + +=cut + +=head1 CONSTANTS + +In each of the following groups, there may be many more constants provided +than just the ones given as examples in the section heading. If the heading +ends C<...> then this means there are likely more; the exact constants +provided will depend on the OS and headers found at compile-time. + +=cut + +=head2 PF_INET, PF_INET6, PF_UNIX, ... + +Protocol family constants to use as the first argument to socket() or the +value of the C<SO_DOMAIN> or C<SO_FAMILY> socket option. + +=head2 AF_INET, AF_INET6, AF_UNIX, ... + +Address family constants used by the socket address structures, to pass to +such functions as inet_pton() or getaddrinfo(), or are returned by such +functions as sockaddr_family(). + +=head2 SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, ... + +Socket type constants to use as the second argument to socket(), or the value +of the C<SO_TYPE> socket option. + +=head2 SOCK_NONBLOCK. SOCK_CLOEXEC + +Linux-specific shortcuts to specify the C<O_NONBLOCK> and C<FD_CLOEXEC> flags +during a C<socket(2)> call. + + socket( my $sockh, PF_INET, SOCK_DGRAM|SOCK_NONBLOCK, 0 ) + +=head2 SOL_SOCKET + +Socket option level constant for setsockopt() and getsockopt(). + +=head2 SO_ACCEPTCONN, SO_BROADCAST, SO_ERROR, ... + +Socket option name constants for setsockopt() and getsockopt() at the +C<SOL_SOCKET> level. + +=head2 IP_OPTIONS, IP_TOS, IP_TTL, ... + +Socket option name constants for IPv4 socket options at the C<IPPROTO_IP> +level. + +=head2 IP_PMTUDISC_WANT, IP_PMTUDISC_DONT, ... + +Socket option value contants for C<IP_MTU_DISCOVER> socket option. + +=head2 IPTOS_LOWDELAY, IPTOS_THROUGHPUT, IPTOS_RELIABILITY, ... + +Socket option value constants for C<IP_TOS> socket option. + +=head2 MSG_BCAST, MSG_OOB, MSG_TRUNC, ... + +Message flag constants for send() and recv(). + +=head2 SHUT_RD, SHUT_RDWR, SHUT_WR + +Direction constants for shutdown(). + +=head2 INADDR_ANY, INADDR_BROADCAST, INADDR_LOOPBACK, INADDR_NONE + +Constants giving the special C<AF_INET> addresses for wildcard, broadcast, +local loopback, and invalid addresses. + +Normally equivalent to inet_aton('0.0.0.0'), inet_aton('255.255.255.255'), +inet_aton('localhost') and inet_aton('255.255.255.255') respectively. + +=head2 IPPROTO_IP, IPPROTO_IPV6, IPPROTO_TCP, ... + +IP protocol constants to use as the third argument to socket(), the level +argument to getsockopt() or setsockopt(), or the value of the C<SO_PROTOCOL> +socket option. + +=head2 TCP_CORK, TCP_KEEPALIVE, TCP_NODELAY, ... + +Socket option name constants for TCP socket options at the C<IPPROTO_TCP> +level. + +=head2 IN6ADDR_ANY, IN6ADDR_LOOPBACK + +Constants giving the special C<AF_INET6> addresses for wildcard and local +loopback. + +Normally equivalent to inet_pton(AF_INET6, "::") and +inet_pton(AF_INET6, "::1") respectively. + +=head2 IPV6_ADD_MEMBERSHIP, IPV6_MTU, IPV6_V6ONLY, ... + +Socket option name constants for IPv6 socket options at the C<IPPROTO_IPV6> +level. + +=cut + +# Still undocumented: SCM_*, SOMAXCONN, IOV_MAX, UIO_MAXIOV + +=head1 STRUCTURE MANIPULATORS + +The following functions convert between lists of Perl values and packed binary +strings representing structures. + +=cut + +=head2 $family = sockaddr_family $sockaddr + +Takes a packed socket address (as returned by pack_sockaddr_in(), +pack_sockaddr_un() or the perl builtin functions getsockname() and +getpeername()). Returns the address family tag. This will be one of the +C<AF_*> constants, such as C<AF_INET> for a C<sockaddr_in> addresses or +C<AF_UNIX> for a C<sockaddr_un>. It can be used to figure out what unpack to +use for a sockaddr of unknown type. + +=head2 $sockaddr = pack_sockaddr_in $port, $ip_address + +Takes two arguments, a port number and an opaque string (as returned by +inet_aton(), or a v-string). Returns the C<sockaddr_in> structure with those +arguments packed in and C<AF_INET> filled in. For Internet domain sockets, +this structure is normally what you need for the arguments in bind(), +connect(), and send(). + +An undefined $port argument is taken as zero; an undefined $ip_address is +considered a fatal error. + +=head2 ($port, $ip_address) = unpack_sockaddr_in $sockaddr + +Takes a C<sockaddr_in> structure (as returned by pack_sockaddr_in(), +getpeername() or recv()). Returns a list of two elements: the port and an +opaque string representing the IP address (you can use inet_ntoa() to convert +the address to the four-dotted numeric format). Will croak if the structure +does not represent an C<AF_INET> address. + +In scalar context will return just the IP address. + +=head2 $sockaddr = sockaddr_in $port, $ip_address + +=head2 ($port, $ip_address) = sockaddr_in $sockaddr + +A wrapper of pack_sockaddr_in() or unpack_sockaddr_in(). In list context, +unpacks its argument and returns a list consisting of the port and IP address. +In scalar context, packs its port and IP address arguments as a C<sockaddr_in> +and returns it. + +Provided largely for legacy compatibility; it is better to use +pack_sockaddr_in() or unpack_sockaddr_in() explicitly. + +=head2 $sockaddr = pack_sockaddr_in6 $port, $ip6_address, [$scope_id, [$flowinfo]] + +Takes two to four arguments, a port number, an opaque string (as returned by +inet_pton()), optionally a scope ID number, and optionally a flow label +number. Returns the C<sockaddr_in6> structure with those arguments packed in +and C<AF_INET6> filled in. IPv6 equivalent of pack_sockaddr_in(). + +An undefined $port argument is taken as zero; an undefined $ip6_address is +considered a fatal error. + +=head2 ($port, $ip6_address, $scope_id, $flowinfo) = unpack_sockaddr_in6 $sockaddr + +Takes a C<sockaddr_in6> structure. Returns a list of four elements: the port +number, an opaque string representing the IPv6 address, the scope ID, and the +flow label. (You can use inet_ntop() to convert the address to the usual +string format). Will croak if the structure does not represent an C<AF_INET6> +address. + +In scalar context will return just the IP address. + +=head2 $sockaddr = sockaddr_in6 $port, $ip6_address, [$scope_id, [$flowinfo]] + +=head2 ($port, $ip6_address, $scope_id, $flowinfo) = sockaddr_in6 $sockaddr + +A wrapper of pack_sockaddr_in6() or unpack_sockaddr_in6(). In list context, +unpacks its argument according to unpack_sockaddr_in6(). In scalar context, +packs its arguments according to pack_sockaddr_in6(). + +Provided largely for legacy compatibility; it is better to use +pack_sockaddr_in6() or unpack_sockaddr_in6() explicitly. + +=head2 $sockaddr = pack_sockaddr_un $path + +Takes one argument, a pathname. Returns the C<sockaddr_un> structure with that +path packed in with C<AF_UNIX> filled in. For C<PF_UNIX> sockets, this +structure is normally what you need for the arguments in bind(), connect(), +and send(). + +=head2 ($path) = unpack_sockaddr_un $sockaddr + +Takes a C<sockaddr_un> structure (as returned by pack_sockaddr_un(), +getpeername() or recv()). Returns a list of one element: the pathname. Will +croak if the structure does not represent an C<AF_UNIX> address. + +=head2 $sockaddr = sockaddr_un $path + +=head2 ($path) = sockaddr_un $sockaddr + +A wrapper of pack_sockaddr_un() or unpack_sockaddr_un(). In a list context, +unpacks its argument and returns a list consisting of the pathname. In a +scalar context, packs its pathname as a C<sockaddr_un> and returns it. + +Provided largely for legacy compatibility; it is better to use +pack_sockaddr_un() or unpack_sockaddr_un() explicitly. + +These are only supported if your system has E<lt>F<sys/un.h>E<gt>. + +=head2 $ip_mreq = pack_ip_mreq $multiaddr, $interface + +Takes an IPv4 multicast address and optionally an interface address (or +C<INADDR_ANY>). Returns the C<ip_mreq> structure with those arguments packed +in. Suitable for use with the C<IP_ADD_MEMBERSHIP> and C<IP_DROP_MEMBERSHIP> +sockopts. + +=head2 ($multiaddr, $interface) = unpack_ip_mreq $ip_mreq + +Takes an C<ip_mreq> structure. Returns a list of two elements; the IPv4 +multicast address and interface address. + +=head2 $ip_mreq_source = pack_ip_mreq_source $multiaddr, $source, $interface + +Takes an IPv4 multicast address, source address, and optionally an interface +address (or C<INADDR_ANY>). Returns the C<ip_mreq_source> structure with those +arguments packed in. Suitable for use with the C<IP_ADD_SOURCE_MEMBERSHIP> +and C<IP_DROP_SOURCE_MEMBERSHIP> sockopts. + +=head2 ($multiaddr, $source, $interface) = unpack_ip_mreq_source $ip_mreq + +Takes an C<ip_mreq_source> structure. Returns a list of three elements; the +IPv4 multicast address, source address and interface address. + +=head2 $ipv6_mreq = pack_ipv6_mreq $multiaddr6, $ifindex + +Takes an IPv6 multicast address and an interface number. Returns the +C<ipv6_mreq> structure with those arguments packed in. Suitable for use with +the C<IPV6_ADD_MEMBERSHIP> and C<IPV6_DROP_MEMBERSHIP> sockopts. + +=head2 ($multiaddr6, $ifindex) = unpack_ipv6_mreq $ipv6_mreq + +Takes an C<ipv6_mreq> structure. Returns a list of two elements; the IPv6 +address and an interface number. + +=cut + +=head1 FUNCTIONS + +=cut + +=head2 $ip_address = inet_aton $string + +Takes a string giving the name of a host, or a textual representation of an IP +address and translates that to an packed binary address structure suitable to +pass to pack_sockaddr_in(). If passed a hostname that cannot be resolved, +returns C<undef>. For multi-homed hosts (hosts with more than one address), +the first address found is returned. + +For portability do not assume that the result of inet_aton() is 32 bits wide, +in other words, that it would contain only the IPv4 address in network order. + +This IPv4-only function is provided largely for legacy reasons. Newly-written +code should use getaddrinfo() or inet_pton() instead for IPv6 support. + +=head2 $string = inet_ntoa $ip_address + +Takes a packed binary address structure such as returned by +unpack_sockaddr_in() (or a v-string representing the four octets of the IPv4 +address in network order) and translates it into a string of the form +C<d.d.d.d> where the C<d>s are numbers less than 256 (the normal +human-readable four dotted number notation for Internet addresses). + +This IPv4-only function is provided largely for legacy reasons. Newly-written +code should use getnameinfo() or inet_ntop() instead for IPv6 support. + +=head2 $address = inet_pton $family, $string + +Takes an address family (such as C<AF_INET> or C<AF_INET6>) and a string +containing a textual representation of an address in that family and +translates that to an packed binary address structure. + +See also getaddrinfo() for a more powerful and flexible function to look up +socket addresses given hostnames or textual addresses. + +=head2 $string = inet_ntop $family, $address + +Takes an address family and a packed binary address structure and translates +it into a human-readable textual representation of the address; typically in +C<d.d.d.d> form for C<AF_INET> or C<hhhh:hhhh::hhhh> form for C<AF_INET6>. + +See also getnameinfo() for a more powerful and flexible function to turn +socket addresses into human-readable textual representations. + +=head2 ($err, @result) = getaddrinfo $host, $service, [$hints] + +Given both a hostname and service name, this function attempts to resolve the +host name into a list of network addresses, and the service name into a +protocol and port number, and then returns a list of address structures +suitable to connect() to it. + +Given just a host name, this function attempts to resolve it to a list of +network addresses, and then returns a list of address structures giving these +addresses. + +Given just a service name, this function attempts to resolve it to a protocol +and port number, and then returns a list of address structures that represent +it suitable to bind() to. This use should be combined with the C<AI_PASSIVE> +flag; see below. + +Given neither name, it generates an error. + +If present, $hints should be a reference to a hash, where the following keys +are recognised: + +=over 4 + +=item flags => INT + +A bitfield containing C<AI_*> constants; see below. + +=item family => INT + +Restrict to only generating addresses in this address family + +=item socktype => INT + +Restrict to only generating addresses of this socket type + +=item protocol => INT + +Restrict to only generating addresses for this protocol + +=back + +The return value will be a list; the first value being an error indication, +followed by a list of address structures (if no error occurred). + +The error value will be a dualvar; comparable to the C<EAI_*> error constants, +or printable as a human-readable error message string. If no error occurred it +will be zero numerically and an empty string. + +Each value in the results list will be a hash reference containing the following +fields: + +=over 4 + +=item family => INT + +The address family (e.g. C<AF_INET>) + +=item socktype => INT + +The socket type (e.g. C<SOCK_STREAM>) + +=item protocol => INT + +The protocol (e.g. C<IPPROTO_TCP>) + +=item addr => STRING + +The address in a packed string (such as would be returned by +pack_sockaddr_in()) + +=item canonname => STRING + +The canonical name for the host if the C<AI_CANONNAME> flag was provided, or +C<undef> otherwise. This field will only be present on the first returned +address. + +=back + +The following flag constants are recognised in the $hints hash. Other flag +constants may exist as provided by the OS. + +=over 4 + +=item AI_PASSIVE + +Indicates that this resolution is for a local bind() for a passive (i.e. +listening) socket, rather than an active (i.e. connecting) socket. + +=item AI_CANONNAME + +Indicates that the caller wishes the canonical hostname (C<canonname>) field +of the result to be filled in. + +=item AI_NUMERICHOST + +Indicates that the caller will pass a numeric address, rather than a hostname, +and that getaddrinfo() must not perform a resolve operation on this name. This +flag will prevent a possibly-slow network lookup operation, and instead return +an error if a hostname is passed. + +=back + +=head2 ($err, $hostname, $servicename) = getnameinfo $sockaddr, [$flags, [$xflags]] + +Given a packed socket address (such as from getsockname(), getpeername(), or +returned by getaddrinfo() in a C<addr> field), returns the hostname and +symbolic service name it represents. $flags may be a bitmask of C<NI_*> +constants, or defaults to 0 if unspecified. + +The return value will be a list; the first value being an error condition, +followed by the hostname and service name. + +The error value will be a dualvar; comparable to the C<EAI_*> error constants, +or printable as a human-readable error message string. The host and service +names will be plain strings. + +The following flag constants are recognised as $flags. Other flag constants may +exist as provided by the OS. + +=over 4 + +=item NI_NUMERICHOST + +Requests that a human-readable string representation of the numeric address be +returned directly, rather than performing a name resolve operation that may +convert it into a hostname. This will also avoid potentially-blocking network +IO. + +=item NI_NUMERICSERV + +Requests that the port number be returned directly as a number representation +rather than performing a name resolve operation that may convert it into a +service name. + +=item NI_NAMEREQD + +If a name resolve operation fails to provide a name, then this flag will cause +getnameinfo() to indicate an error, rather than returning the numeric +representation as a human-readable string. + +=item NI_DGRAM + +Indicates that the socket address relates to a C<SOCK_DGRAM> socket, for the +services whose name differs between TCP and UDP protocols. + +=back + +The following constants may be supplied as $xflags. + +=over 4 + +=item NIx_NOHOST + +Indicates that the caller is not interested in the hostname of the result, so +it does not have to be converted. C<undef> will be returned as the hostname. + +=item NIx_NOSERV + +Indicates that the caller is not interested in the service name of the result, +so it does not have to be converted. C<undef> will be returned as the service +name. + +=back + +=head1 getaddrinfo() / getnameinfo() ERROR CONSTANTS + +The following constants may be returned by getaddrinfo() or getnameinfo(). +Others may be provided by the OS. + +=over 4 + +=item EAI_AGAIN + +A temporary failure occurred during name resolution. The operation may be +successful if it is retried later. + +=item EAI_BADFLAGS + +The value of the C<flags> hint to getaddrinfo(), or the $flags parameter to +getnameinfo() contains unrecognised flags. + +=item EAI_FAMILY + +The C<family> hint to getaddrinfo(), or the family of the socket address +passed to getnameinfo() is not supported. + +=item EAI_NODATA + +The host name supplied to getaddrinfo() did not provide any usable address +data. + +=item EAI_NONAME + +The host name supplied to getaddrinfo() does not exist, or the address +supplied to getnameinfo() is not associated with a host name and the +C<NI_NAMEREQD> flag was supplied. + +=item EAI_SERVICE + +The service name supplied to getaddrinfo() is not available for the socket +type given in the $hints. + +=back + +=cut + +=head1 EXAMPLES + +=head2 Lookup for connect() + +The getaddrinfo() function converts a hostname and a service name into a list +of structures, each containing a potential way to connect() to the named +service on the named host. + + use IO::Socket; + use Socket qw(SOCK_STREAM getaddrinfo); + + my %hints = (socktype => SOCK_STREAM); + my ($err, @res) = getaddrinfo("localhost", "echo", \%hints); + die "Cannot getaddrinfo - $err" if $err; + + my $sock; + + foreach my $ai (@res) { + my $candidate = IO::Socket->new(); + + $candidate->socket($ai->{family}, $ai->{socktype}, $ai->{protocol}) + or next; + + $candidate->connect($ai->{addr}) + or next; + + $sock = $candidate; + last; + } + + die "Cannot connect to localhost:echo" unless $sock; + + $sock->print("Hello, world!\n"); + print <$sock>; + +Because a list of potential candidates is returned, the C<while> loop tries +each in turn until it finds one that succeeds both the socket() and connect() +calls. + +This function performs the work of the legacy functions gethostbyname(), +getservbyname(), inet_aton() and pack_sockaddr_in(). + +In practice this logic is better performed by L<IO::Socket::IP>. + +=head2 Making a human-readable string out of an address + +The getnameinfo() function converts a socket address, such as returned by +getsockname() or getpeername(), into a pair of human-readable strings +representing the address and service name. + + use IO::Socket::IP; + use Socket qw(getnameinfo); + + my $server = IO::Socket::IP->new(LocalPort => 12345, Listen => 1) or + die "Cannot listen - $@"; + + my $socket = $server->accept or die "accept: $!"; + + my ($err, $hostname, $servicename) = getnameinfo($socket->peername); + die "Cannot getnameinfo - $err" if $err; + + print "The peer is connected from $hostname\n"; + +Since in this example only the hostname was used, the redundant conversion of +the port number into a service name may be omitted by passing the +C<NIx_NOSERV> flag. + + use Socket qw(getnameinfo NIx_NOSERV); + + my ($err, $hostname) = getnameinfo($socket->peername, 0, NIx_NOSERV); + +This function performs the work of the legacy functions unpack_sockaddr_in(), +inet_ntoa(), gethostbyaddr() and getservbyport(). + +In practice this logic is better performed by L<IO::Socket::IP>. + +=head2 Resolving hostnames into IP addresses + +To turn a hostname into a human-readable plain IP address use getaddrinfo() +to turn the hostname into a list of socket structures, then getnameinfo() on +each one to make it a readable IP address again. + + use Socket qw(:addrinfo SOCK_RAW); + + my ($err, @res) = getaddrinfo($hostname, "", {socktype => SOCK_RAW}); + die "Cannot getaddrinfo - $err" if $err; + + while( my $ai = shift @res ) { + my ($err, $ipaddr) = getnameinfo($ai->{addr}, NI_NUMERICHOST, NIx_NOSERV); + die "Cannot getnameinfo - $err" if $err; + + print "$ipaddr\n"; + } + +The C<socktype> hint to getaddrinfo() filters the results to only include one +socket type and protocol. Without this most OSes return three combinations, +for C<SOCK_STREAM>, C<SOCK_DGRAM> and C<SOCK_RAW>, resulting in triplicate +output of addresses. The C<NI_NUMERICHOST> flag to getnameinfo() causes it to +return a string-formatted plain IP address, rather than reverse resolving it +back into a hostname. + +This combination performs the work of the legacy functions gethostbyname() +and inet_ntoa(). + +=head2 Accessing socket options + +The many C<SO_*> and other constants provide the socket option names for +getsockopt() and setsockopt(). + + use IO::Socket::INET; + use Socket qw(SOL_SOCKET SO_RCVBUF IPPROTO_IP IP_TTL); + + my $socket = IO::Socket::INET->new(LocalPort => 0, Proto => 'udp') + or die "Cannot create socket: $@"; + + $socket->setsockopt(SOL_SOCKET, SO_RCVBUF, 64*1024) or + die "setsockopt: $!"; + + print "Receive buffer is ", $socket->getsockopt(SOL_SOCKET, SO_RCVBUF), + " bytes\n"; + + print "IP TTL is ", $socket->getsockopt(IPPROTO_IP, IP_TTL), "\n"; + +As a convenience, L<IO::Socket>'s setsockopt() method will convert a number +into a packed byte buffer, and getsockopt() will unpack a byte buffer of the +correct size back into a number. + +=cut + +=head1 AUTHOR + +This module was originally maintained in Perl core by the Perl 5 Porters. + +It was extracted to dual-life on CPAN at version 1.95 by +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +use Carp; +use warnings::register; + +require Exporter; +require XSLoader; +our @ISA = qw(Exporter); + +# <@Nicholas> you can't change @EXPORT without breaking the implicit API +# Please put any new constants in @EXPORT_OK! + +# List re-ordered to match documentation above. Try to keep the ordering +# consistent so it's easier to see which ones are or aren't documented. +our @EXPORT = qw( + PF_802 PF_AAL PF_APPLETALK PF_CCITT PF_CHAOS PF_CTF PF_DATAKIT + PF_DECnet PF_DLI PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_INET6 + PF_ISO PF_KEY PF_LAST PF_LAT PF_LINK PF_MAX PF_NBS PF_NIT PF_NS PF_OSI + PF_OSINET PF_PUP PF_ROUTE PF_SNA PF_UNIX PF_UNSPEC PF_USER PF_WAN + PF_X25 + + AF_802 AF_AAL AF_APPLETALK AF_CCITT AF_CHAOS AF_CTF AF_DATAKIT + AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_INET6 + AF_ISO AF_KEY AF_LAST AF_LAT AF_LINK AF_MAX AF_NBS AF_NIT AF_NS AF_OSI + AF_OSINET AF_PUP AF_ROUTE AF_SNA AF_UNIX AF_UNSPEC AF_USER AF_WAN + AF_X25 + + SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM + + SOL_SOCKET + + SO_ACCEPTCONN SO_ATTACH_FILTER SO_BACKLOG SO_BROADCAST SO_CHAMELEON + SO_DEBUG SO_DETACH_FILTER SO_DGRAM_ERRIND SO_DOMAIN SO_DONTLINGER + SO_DONTROUTE SO_ERROR SO_FAMILY SO_KEEPALIVE SO_LINGER SO_OOBINLINE + SO_PASSCRED SO_PASSIFNAME SO_PEERCRED SO_PROTOCOL SO_PROTOTYPE + SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT + SO_SECURITY_AUTHENTICATION SO_SECURITY_ENCRYPTION_NETWORK + SO_SECURITY_ENCRYPTION_TRANSPORT SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO + SO_STATE SO_TYPE SO_USELOOPBACK SO_XOPEN SO_XSE + + IP_HDRINCL IP_OPTIONS IP_RECVOPTS IP_RECVRETOPTS IP_RETOPTS IP_TOS + IP_TTL + + MSG_BCAST MSG_BTAG MSG_CTLFLAGS MSG_CTLIGNORE MSG_CTRUNC MSG_DONTROUTE + MSG_DONTWAIT MSG_EOF MSG_EOR MSG_ERRQUEUE MSG_ETAG MSG_FASTOPEN MSG_FIN + MSG_MAXIOVLEN MSG_MCAST MSG_NOSIGNAL MSG_OOB MSG_PEEK MSG_PROXY MSG_RST + MSG_SYN MSG_TRUNC MSG_URG MSG_WAITALL MSG_WIRE + + SHUT_RD SHUT_RDWR SHUT_WR + + INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE + + SCM_CONNECT SCM_CREDENTIALS SCM_CREDS SCM_RIGHTS SCM_TIMESTAMP + + SOMAXCONN + + IOV_MAX + UIO_MAXIOV + + sockaddr_family + pack_sockaddr_in unpack_sockaddr_in sockaddr_in + pack_sockaddr_in6 unpack_sockaddr_in6 sockaddr_in6 + pack_sockaddr_un unpack_sockaddr_un sockaddr_un + + inet_aton inet_ntoa +); + +# List re-ordered to match documentation above. Try to keep the ordering +# consistent so it's easier to see which ones are or aren't documented. +our @EXPORT_OK = qw( + CR LF CRLF $CR $LF $CRLF + + SOCK_NONBLOCK SOCK_CLOEXEC + + IP_ADD_MEMBERSHIP IP_ADD_SOURCE_MEMBERSHIP IP_BIND_ADDRESS_NO_PORT + IP_DROP_MEMBERSHIP IP_DROP_SOURCE_MEMBERSHIP IP_FREEBIND + IP_MULTICAST_ALL IP_MULTICAST_IF IP_MULTICAST_LOOP IP_MULTICAST_TTL + IP_MTU IP_MTU_DISCOVER IP_NODEFRAG IP_RECVERR IP_TRANSPARENT + + IPPROTO_IP IPPROTO_IPV6 IPPROTO_RAW IPPROTO_ICMP IPPROTO_IGMP + IPPROTO_TCP IPPROTO_UDP IPPROTO_GRE IPPROTO_ESP IPPROTO_AH + IPPROTO_ICMPV6 IPPROTO_SCTP + + IP_PMTUDISC_DO IP_PMTUDISC_DONT IP_PMTUDISC_PROBE IP_PMTUDISC_WANT + + IPTOS_LOWDELAY IPTOS_THROUGHPUT IPTOS_RELIABILITY IPTOS_MINCOST + + TCP_CONGESTION TCP_CONNECTIONTIMEOUT TCP_CORK TCP_DEFER_ACCEPT + TCP_FASTOPEN TCP_INFO TCP_INIT_CWND TCP_KEEPALIVE TCP_KEEPCNT + TCP_KEEPIDLE TCP_KEEPINTVL TCP_LINGER2 TCP_MAXRT TCP_MAXSEG + TCP_MD5SIG TCP_NODELAY TCP_NOOPT TCP_NOPUSH TCP_QUICKACK + TCP_SACK_ENABLE TCP_STDURG TCP_SYNCNT TCP_USER_TIMEOUT + TCP_WINDOW_CLAMP + + IN6ADDR_ANY IN6ADDR_LOOPBACK + + IPV6_ADDRFROM IPV6_ADD_MEMBERSHIP IPV6_DROP_MEMBERSHIP IPV6_JOIN_GROUP + IPV6_LEAVE_GROUP IPV6_MTU IPV6_MTU_DISCOVER IPV6_MULTICAST_HOPS + IPV6_MULTICAST_IF IPV6_MULTICAST_LOOP IPV6_RECVERR IPV6_ROUTER_ALERT + IPV6_UNICAST_HOPS IPV6_V6ONLY + + SO_LOCK_FILTER SO_RCVBUFFORCE SO_SNDBUFFORCE + + pack_ip_mreq unpack_ip_mreq pack_ip_mreq_source unpack_ip_mreq_source + + pack_ipv6_mreq unpack_ipv6_mreq + + inet_pton inet_ntop + + getaddrinfo getnameinfo + + AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN + AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES AI_NUMERICHOST + AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED + + NI_DGRAM NI_IDN NI_IDN_ALLOW_UNASSIGNED NI_IDN_USE_STD3_ASCII_RULES + NI_NAMEREQD NI_NOFQDN NI_NUMERICHOST NI_NUMERICSERV + + NIx_NOHOST NIx_NOSERV + + EAI_ADDRFAMILY EAI_AGAIN EAI_BADFLAGS EAI_BADHINTS EAI_FAIL EAI_FAMILY + EAI_NODATA EAI_NONAME EAI_PROTOCOL EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM +); + +our %EXPORT_TAGS = ( + crlf => [qw(CR LF CRLF $CR $LF $CRLF)], + addrinfo => [qw(getaddrinfo getnameinfo), grep m/^(?:AI|NI|NIx|EAI)_/, @EXPORT_OK], + all => [@EXPORT, @EXPORT_OK], +); + +BEGIN { + sub CR () {"\015"} + sub LF () {"\012"} + sub CRLF () {"\015\012"} + + # These are not gni() constants; they're extensions for the perl API + # The definitions in Socket.pm and Socket.xs must match + sub NIx_NOHOST() {1 << 0} + sub NIx_NOSERV() {1 << 1} +} + +*CR = \CR(); +*LF = \LF(); +*CRLF = \CRLF(); + +sub sockaddr_in { + if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die + my($af, $port, @quad) = @_; + warnings::warn "6-ARG sockaddr_in call is deprecated" + if warnings::enabled(); + pack_sockaddr_in($port, inet_aton(join('.', @quad))); + } elsif (wantarray) { + croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1; + unpack_sockaddr_in(@_); + } else { + croak "usage: sin_sv = sockaddr_in(port,iaddr))" unless @_ == 2; + pack_sockaddr_in(@_); + } +} + +sub sockaddr_in6 { + if (wantarray) { + croak "usage: (port,in6addr,scope_id,flowinfo) = sockaddr_in6(sin6_sv)" unless @_ == 1; + unpack_sockaddr_in6(@_); + } + else { + croak "usage: sin6_sv = sockaddr_in6(port,in6addr,[scope_id,[flowinfo]])" unless @_ >= 2 and @_ <= 4; + pack_sockaddr_in6(@_); + } +} + +sub sockaddr_un { + if (wantarray) { + croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1; + unpack_sockaddr_un(@_); + } else { + croak "usage: sun_sv = sockaddr_un(filename)" unless @_ == 1; + pack_sockaddr_un(@_); + } +} + +XSLoader::load(__PACKAGE__, $VERSION); + +my %errstr; + +if( defined &getaddrinfo ) { + # These are not part of the API, nothing uses them, and deleting them + # reduces the size of %Socket:: by about 12K + delete $Socket::{fake_getaddrinfo}; + delete $Socket::{fake_getnameinfo}; +} else { + require Scalar::Util; + + *getaddrinfo = \&fake_getaddrinfo; + *getnameinfo = \&fake_getnameinfo; + + # These numbers borrowed from GNU libc's implementation, but since + # they're only used by our emulation, it doesn't matter if the real + # platform's values differ + my %constants = ( + AI_PASSIVE => 1, + AI_CANONNAME => 2, + AI_NUMERICHOST => 4, + AI_V4MAPPED => 8, + AI_ALL => 16, + AI_ADDRCONFIG => 32, + # RFC 2553 doesn't define this but Linux does - lets be nice and + # provide it since we can + AI_NUMERICSERV => 1024, + + EAI_BADFLAGS => -1, + EAI_NONAME => -2, + EAI_NODATA => -5, + EAI_FAMILY => -6, + EAI_SERVICE => -8, + + NI_NUMERICHOST => 1, + NI_NUMERICSERV => 2, + NI_NOFQDN => 4, + NI_NAMEREQD => 8, + NI_DGRAM => 16, + + # Constants we don't support. Export them, but croak if anyone tries to + # use them + AI_IDN => 64, + AI_CANONIDN => 128, + AI_IDN_ALLOW_UNASSIGNED => 256, + AI_IDN_USE_STD3_ASCII_RULES => 512, + NI_IDN => 32, + NI_IDN_ALLOW_UNASSIGNED => 64, + NI_IDN_USE_STD3_ASCII_RULES => 128, + + # Error constants we'll never return, so it doesn't matter what value + # these have, nor that we don't provide strings for them + EAI_SYSTEM => -11, + EAI_BADHINTS => -1000, + EAI_PROTOCOL => -1001 + ); + + foreach my $name ( keys %constants ) { + my $value = $constants{$name}; + + no strict 'refs'; + defined &$name or *$name = sub () { $value }; + } + + %errstr = ( + # These strings from RFC 2553 + EAI_BADFLAGS() => "invalid value for ai_flags", + EAI_NONAME() => "nodename nor servname provided, or not known", + EAI_NODATA() => "no address associated with nodename", + EAI_FAMILY() => "ai_family not supported", + EAI_SERVICE() => "servname not supported for ai_socktype", + ); +} + +# The following functions are used if the system does not have a +# getaddrinfo(3) function in libc; and are used to emulate it for the AF_INET +# family + +# Borrowed from Regexp::Common::net +my $REGEXP_IPv4_DECIMAL = qr/25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}/; +my $REGEXP_IPv4_DOTTEDQUAD = qr/$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL/; + +sub fake_makeerr +{ + my ( $errno ) = @_; + my $errstr = $errno == 0 ? "" : ( $errstr{$errno} || $errno ); + return Scalar::Util::dualvar( $errno, $errstr ); +} + +sub fake_getaddrinfo +{ + my ( $node, $service, $hints ) = @_; + + $node = "" unless defined $node; + + $service = "" unless defined $service; + + my ( $family, $socktype, $protocol, $flags ) = @$hints{qw( family socktype protocol flags )}; + + $family ||= Socket::AF_INET(); # 0 == AF_UNSPEC, which we want too + $family == Socket::AF_INET() or return fake_makeerr( EAI_FAMILY() ); + + $socktype ||= 0; + + $protocol ||= 0; + + $flags ||= 0; + + my $flag_passive = $flags & AI_PASSIVE(); $flags &= ~AI_PASSIVE(); + my $flag_canonname = $flags & AI_CANONNAME(); $flags &= ~AI_CANONNAME(); + my $flag_numerichost = $flags & AI_NUMERICHOST(); $flags &= ~AI_NUMERICHOST(); + my $flag_numericserv = $flags & AI_NUMERICSERV(); $flags &= ~AI_NUMERICSERV(); + + # These constants don't apply to AF_INET-only lookups, so we might as well + # just ignore them. For AI_ADDRCONFIG we just presume the host has ability + # to talk AF_INET. If not we'd have to return no addresses at all. :) + $flags &= ~(AI_V4MAPPED()|AI_ALL()|AI_ADDRCONFIG()); + + $flags & (AI_IDN()|AI_CANONIDN()|AI_IDN_ALLOW_UNASSIGNED()|AI_IDN_USE_STD3_ASCII_RULES()) and + croak "Socket::getaddrinfo() does not support IDN"; + + $flags == 0 or return fake_makeerr( EAI_BADFLAGS() ); + + $node eq "" and $service eq "" and return fake_makeerr( EAI_NONAME() ); + + my $canonname; + my @addrs; + if( $node ne "" ) { + return fake_makeerr( EAI_NONAME() ) if( $flag_numerichost and $node !~ m/^$REGEXP_IPv4_DOTTEDQUAD$/ ); + ( $canonname, undef, undef, undef, @addrs ) = gethostbyname( $node ); + defined $canonname or return fake_makeerr( EAI_NONAME() ); + + undef $canonname unless $flag_canonname; + } + else { + $addrs[0] = $flag_passive ? Socket::inet_aton( "0.0.0.0" ) + : Socket::inet_aton( "127.0.0.1" ); + } + + my @ports; # Actually ARRAYrefs of [ socktype, protocol, port ] + my $protname = ""; + if( $protocol ) { + $protname = eval { getprotobynumber( $protocol ) }; + } + + if( $service ne "" and $service !~ m/^\d+$/ ) { + return fake_makeerr( EAI_NONAME() ) if( $flag_numericserv ); + getservbyname( $service, $protname ) or return fake_makeerr( EAI_SERVICE() ); + } + + foreach my $this_socktype ( Socket::SOCK_STREAM(), Socket::SOCK_DGRAM(), Socket::SOCK_RAW() ) { + next if $socktype and $this_socktype != $socktype; + + my $this_protname = "raw"; + $this_socktype == Socket::SOCK_STREAM() and $this_protname = "tcp"; + $this_socktype == Socket::SOCK_DGRAM() and $this_protname = "udp"; + + next if $protname and $this_protname ne $protname; + + my $port; + if( $service ne "" ) { + if( $service =~ m/^\d+$/ ) { + $port = "$service"; + } + else { + ( undef, undef, $port, $this_protname ) = getservbyname( $service, $this_protname ); + next unless defined $port; + } + } + else { + $port = 0; + } + + push @ports, [ $this_socktype, eval { scalar getprotobyname( $this_protname ) } || 0, $port ]; + } + + my @ret; + foreach my $addr ( @addrs ) { + foreach my $portspec ( @ports ) { + my ( $socktype, $protocol, $port ) = @$portspec; + push @ret, { + family => $family, + socktype => $socktype, + protocol => $protocol, + addr => Socket::pack_sockaddr_in( $port, $addr ), + canonname => undef, + }; + } + } + + # Only supply canonname for the first result + if( defined $canonname ) { + $ret[0]->{canonname} = $canonname; + } + + return ( fake_makeerr( 0 ), @ret ); +} + +sub fake_getnameinfo +{ + my ( $addr, $flags, $xflags ) = @_; + + my ( $port, $inetaddr ); + eval { ( $port, $inetaddr ) = Socket::unpack_sockaddr_in( $addr ) } + or return fake_makeerr( EAI_FAMILY() ); + + my $family = Socket::AF_INET(); + + $flags ||= 0; + + my $flag_numerichost = $flags & NI_NUMERICHOST(); $flags &= ~NI_NUMERICHOST(); + my $flag_numericserv = $flags & NI_NUMERICSERV(); $flags &= ~NI_NUMERICSERV(); + my $flag_nofqdn = $flags & NI_NOFQDN(); $flags &= ~NI_NOFQDN(); + my $flag_namereqd = $flags & NI_NAMEREQD(); $flags &= ~NI_NAMEREQD(); + my $flag_dgram = $flags & NI_DGRAM() ; $flags &= ~NI_DGRAM(); + + $flags & (NI_IDN()|NI_IDN_ALLOW_UNASSIGNED()|NI_IDN_USE_STD3_ASCII_RULES()) and + croak "Socket::getnameinfo() does not support IDN"; + + $flags == 0 or return fake_makeerr( EAI_BADFLAGS() ); + + $xflags ||= 0; + + my $node; + if( $xflags & NIx_NOHOST ) { + $node = undef; + } + elsif( $flag_numerichost ) { + $node = Socket::inet_ntoa( $inetaddr ); + } + else { + $node = gethostbyaddr( $inetaddr, $family ); + if( !defined $node ) { + return fake_makeerr( EAI_NONAME() ) if $flag_namereqd; + $node = Socket::inet_ntoa( $inetaddr ); + } + elsif( $flag_nofqdn ) { + my ( $shortname ) = split m/\./, $node; + my ( $fqdn ) = gethostbyname $shortname; + $node = $shortname if defined $fqdn and $fqdn eq $node; + } + } + + my $service; + if( $xflags & NIx_NOSERV ) { + $service = undef; + } + elsif( $flag_numericserv ) { + $service = "$port"; + } + else { + my $protname = $flag_dgram ? "udp" : ""; + $service = getservbyport( $port, $protname ); + if( !defined $service ) { + $service = "$port"; + } + } + + return ( fake_makeerr( 0 ), $node, $service ); +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Fatal.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Fatal.pm new file mode 100644 index 0000000000..29aa6629fb --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Fatal.pm @@ -0,0 +1,364 @@ +use strict; +use warnings; +package Test::Fatal; +# ABSTRACT: incredibly simple helpers for testing code with exceptions +$Test::Fatal::VERSION = '0.014'; +#pod =head1 SYNOPSIS +#pod +#pod use Test::More; +#pod use Test::Fatal; +#pod +#pod use System::Under::Test qw(might_die); +#pod +#pod is( +#pod exception { might_die; }, +#pod undef, +#pod "the code lived", +#pod ); +#pod +#pod like( +#pod exception { might_die; }, +#pod qr/turns out it died/, +#pod "the code died as expected", +#pod ); +#pod +#pod isa_ok( +#pod exception { might_die; }, +#pod 'Exception::Whatever', +#pod 'the thrown exception', +#pod ); +#pod +#pod =head1 DESCRIPTION +#pod +#pod Test::Fatal is an alternative to the popular L<Test::Exception>. It does much +#pod less, but should allow greater flexibility in testing exception-throwing code +#pod with about the same amount of typing. +#pod +#pod It exports one routine by default: C<exception>. +#pod +#pod =cut + +use Carp (); +use Try::Tiny 0.07; + +use Exporter 5.57 'import'; + +our @EXPORT = qw(exception); +our @EXPORT_OK = qw(exception success dies_ok lives_ok); + +#pod =func exception +#pod +#pod my $exception = exception { ... }; +#pod +#pod C<exception> takes a bare block of code and returns the exception thrown by +#pod that block. If no exception was thrown, it returns undef. +#pod +#pod B<Achtung!> If the block results in a I<false> exception, such as 0 or the +#pod empty string, Test::Fatal itself will die. Since either of these cases +#pod indicates a serious problem with the system under testing, this behavior is +#pod considered a I<feature>. If you must test for these conditions, you should use +#pod L<Try::Tiny>'s try/catch mechanism. (Try::Tiny is the underlying exception +#pod handling system of Test::Fatal.) +#pod +#pod Note that there is no TAP assert being performed. In other words, no "ok" or +#pod "not ok" line is emitted. It's up to you to use the rest of C<exception> in an +#pod existing test like C<ok>, C<isa_ok>, C<is>, et cetera. Or you may wish to use +#pod the C<dies_ok> and C<lives_ok> wrappers, which do provide TAP output. +#pod +#pod C<exception> does I<not> alter the stack presented to the called block, meaning +#pod that if the exception returned has a stack trace, it will include some frames +#pod between the code calling C<exception> and the thing throwing the exception. +#pod This is considered a I<feature> because it avoids the occasionally twitchy +#pod C<Sub::Uplevel> mechanism. +#pod +#pod B<Achtung!> This is not a great idea: +#pod +#pod sub exception_like(&$;$) { +#pod my ($code, $pattern, $name) = @_; +#pod like( &exception($code), $pattern, $name ); +#pod } +#pod +#pod exception_like(sub { }, qr/foo/, 'foo appears in the exception'); +#pod +#pod If the code in the C<...> is going to throw a stack trace with the arguments to +#pod each subroutine in its call stack (for example via C<Carp::confess>, +#pod the test name, "foo appears in the exception" will itself be matched by the +#pod regex. Instead, write this: +#pod +#pod like( exception { ... }, qr/foo/, 'foo appears in the exception' ); +#pod +#pod B<Achtung>: One final bad idea: +#pod +#pod isnt( exception { ... }, undef, "my code died!"); +#pod +#pod It's true that this tests that your code died, but you should really test that +#pod it died I<for the right reason>. For example, if you make an unrelated mistake +#pod in the block, like using the wrong dereference, your test will pass even though +#pod the code to be tested isn't really run at all. If you're expecting an +#pod inspectable exception with an identifier or class, test that. If you're +#pod expecting a string exception, consider using C<like>. +#pod +#pod =cut + +our ($REAL_TBL, $REAL_CALCULATED_TBL) = (1, 1); + +sub exception (&) { + my $code = shift; + + return try { + my $incremented = $Test::Builder::Level - $REAL_CALCULATED_TBL; + local $Test::Builder::Level = $REAL_CALCULATED_TBL; + if ($incremented) { + # each call to exception adds 5 stack frames + $Test::Builder::Level += 5; + for my $i (1..$incremented) { + # -2 because we want to see it from the perspective of the call to + # is() within the call to $code->() + my $caller = caller($Test::Builder::Level - 2); + if ($caller eq __PACKAGE__) { + # each call to exception adds 5 stack frames + $Test::Builder::Level = $Test::Builder::Level + 5; + } + else { + $Test::Builder::Level = $Test::Builder::Level + 1; + } + } + } + + local $REAL_CALCULATED_TBL = $Test::Builder::Level; + $code->(); + return undef; + } catch { + return $_ if $_; + + my $problem = defined $_ ? 'false' : 'undef'; + Carp::confess("$problem exception caught by Test::Fatal::exception"); + }; +} + +#pod =func success +#pod +#pod try { +#pod should_live; +#pod } catch { +#pod fail("boo, we died"); +#pod } success { +#pod pass("hooray, we lived"); +#pod }; +#pod +#pod C<success>, exported only by request, is a L<Try::Tiny> helper with semantics +#pod identical to L<C<finally>|Try::Tiny/finally>, but the body of the block will +#pod only be run if the C<try> block ran without error. +#pod +#pod Although almost any needed exception tests can be performed with C<exception>, +#pod success blocks may sometimes help organize complex testing. +#pod +#pod =cut + +sub success (&;@) { + my $code = shift; + return finally( sub { + return if @_; # <-- only run on success + $code->(); + }, @_ ); +} + +#pod =func dies_ok +#pod +#pod =func lives_ok +#pod +#pod Exported only by request, these two functions run a given block of code, and +#pod provide TAP output indicating if it did, or did not throw an exception. +#pod These provide an easy upgrade path for replacing existing unit tests based on +#pod C<Test::Exception>. +#pod +#pod RJBS does not suggest using this except as a convenience while porting tests to +#pod use Test::Fatal's C<exception> routine. +#pod +#pod use Test::More tests => 2; +#pod use Test::Fatal qw(dies_ok lives_ok); +#pod +#pod dies_ok { die "I failed" } 'code that fails'; +#pod +#pod lives_ok { return "I'm still alive" } 'code that does not fail'; +#pod +#pod =cut + +my $Tester; + +# Signature should match that of Test::Exception +sub dies_ok (&;$) { + my $code = shift; + my $name = shift; + + require Test::Builder; + $Tester ||= Test::Builder->new; + + my $ok = $Tester->ok( exception( \&$code ), $name ); + $ok or $Tester->diag( "expected an exception but none was raised" ); + return $ok; +} + +sub lives_ok (&;$) { + my $code = shift; + my $name = shift; + + require Test::Builder; + $Tester ||= Test::Builder->new; + + my $ok = $Tester->ok( !exception( \&$code ), $name ); + $ok or $Tester->diag( "expected return but an exception was raised" ); + return $ok; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test::Fatal - incredibly simple helpers for testing code with exceptions + +=head1 VERSION + +version 0.014 + +=head1 SYNOPSIS + + use Test::More; + use Test::Fatal; + + use System::Under::Test qw(might_die); + + is( + exception { might_die; }, + undef, + "the code lived", + ); + + like( + exception { might_die; }, + qr/turns out it died/, + "the code died as expected", + ); + + isa_ok( + exception { might_die; }, + 'Exception::Whatever', + 'the thrown exception', + ); + +=head1 DESCRIPTION + +Test::Fatal is an alternative to the popular L<Test::Exception>. It does much +less, but should allow greater flexibility in testing exception-throwing code +with about the same amount of typing. + +It exports one routine by default: C<exception>. + +=head1 FUNCTIONS + +=head2 exception + + my $exception = exception { ... }; + +C<exception> takes a bare block of code and returns the exception thrown by +that block. If no exception was thrown, it returns undef. + +B<Achtung!> If the block results in a I<false> exception, such as 0 or the +empty string, Test::Fatal itself will die. Since either of these cases +indicates a serious problem with the system under testing, this behavior is +considered a I<feature>. If you must test for these conditions, you should use +L<Try::Tiny>'s try/catch mechanism. (Try::Tiny is the underlying exception +handling system of Test::Fatal.) + +Note that there is no TAP assert being performed. In other words, no "ok" or +"not ok" line is emitted. It's up to you to use the rest of C<exception> in an +existing test like C<ok>, C<isa_ok>, C<is>, et cetera. Or you may wish to use +the C<dies_ok> and C<lives_ok> wrappers, which do provide TAP output. + +C<exception> does I<not> alter the stack presented to the called block, meaning +that if the exception returned has a stack trace, it will include some frames +between the code calling C<exception> and the thing throwing the exception. +This is considered a I<feature> because it avoids the occasionally twitchy +C<Sub::Uplevel> mechanism. + +B<Achtung!> This is not a great idea: + + sub exception_like(&$;$) { + my ($code, $pattern, $name) = @_; + like( &exception($code), $pattern, $name ); + } + + exception_like(sub { }, qr/foo/, 'foo appears in the exception'); + +If the code in the C<...> is going to throw a stack trace with the arguments to +each subroutine in its call stack (for example via C<Carp::confess>, +the test name, "foo appears in the exception" will itself be matched by the +regex. Instead, write this: + + like( exception { ... }, qr/foo/, 'foo appears in the exception' ); + +B<Achtung>: One final bad idea: + + isnt( exception { ... }, undef, "my code died!"); + +It's true that this tests that your code died, but you should really test that +it died I<for the right reason>. For example, if you make an unrelated mistake +in the block, like using the wrong dereference, your test will pass even though +the code to be tested isn't really run at all. If you're expecting an +inspectable exception with an identifier or class, test that. If you're +expecting a string exception, consider using C<like>. + +=head2 success + + try { + should_live; + } catch { + fail("boo, we died"); + } success { + pass("hooray, we lived"); + }; + +C<success>, exported only by request, is a L<Try::Tiny> helper with semantics +identical to L<C<finally>|Try::Tiny/finally>, but the body of the block will +only be run if the C<try> block ran without error. + +Although almost any needed exception tests can be performed with C<exception>, +success blocks may sometimes help organize complex testing. + +=head2 dies_ok + +=head2 lives_ok + +Exported only by request, these two functions run a given block of code, and +provide TAP output indicating if it did, or did not throw an exception. +These provide an easy upgrade path for replacing existing unit tests based on +C<Test::Exception>. + +RJBS does not suggest using this except as a convenience while porting tests to +use Test::Fatal's C<exception> routine. + + use Test::More tests => 2; + use Test::Fatal qw(dies_ok lives_ok); + + dies_ok { die "I failed" } 'code that fails'; + + lives_ok { return "I'm still alive" } 'code that does not fail'; + +=head1 AUTHOR + +Ricardo Signes <rjbs@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2010 by Ricardo Signes. + +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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Needs.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Needs.pm new file mode 100644 index 0000000000..f3db264d31 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Needs.pm @@ -0,0 +1,315 @@ +package Test::Needs; +use strict; +use warnings; +no warnings 'once'; +our $VERSION = '0.002005'; +$VERSION =~ tr/_//d; + +BEGIN { + *_WORK_AROUND_HINT_LEAKAGE + = "$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001) + ? sub(){1} : sub(){0}; + *_WORK_AROUND_BROKEN_MODULE_STATE + = "$]" < 5.009 + ? sub(){1} : sub(){0}; +} + +sub _try_require { + local %^H + if _WORK_AROUND_HINT_LEAKAGE; + my ($module) = @_; + (my $file = "$module.pm") =~ s{::|'}{/}g; + my $err; + { + local $@; + eval { require $file } + or $err = $@; + } + if (defined $err) { + delete $INC{$file} + if _WORK_AROUND_BROKEN_MODULE_STATE; + die $err + unless $err =~ /\ACan't locate \Q$file\E/; + return !1; + } + !0; +} + +sub _find_missing { + my @bad = map { + my ($module, $version) = @$_; + if ($module eq 'perl') { + $version + = !$version ? 0 + : $version =~ /^[0-9]+\.[0-9]+$/ ? sprintf('%.6f', $version) + : $version =~ /^v?([0-9]+(?:\.[0-9]+)+)$/ ? do { + my @p = split /\./, $1; + push @p, 0 + until @p >= 3; + sprintf '%d.%03d%03d', @p; + } + : $version =~ /^\x05..?$/s ? do { + my @p = map ord, split //, $version; + push @p, 0 + until @p >= 3; + sprintf '%d.%03d%03d', @p; + } + : do { + use warnings FATAL => 'numeric'; + no warnings 'void'; + eval { 0 + $version; 1 } ? $version + : die sprintf qq{version "%s" for perl does not look like a number at %s line %s.\n}, + $version, (caller( 1 + ($Test::Builder::Level||0) ))[1,2]; + }; + if ("$]" < $version) { + sprintf "perl %s (have %.6f)", $version, $]; + } + else { + (); + } + } + elsif ($module =~ /^\d|[^\w:]|:::|[^:]:[^:]|^:|:$/) { + die sprintf qq{"%s" does not look like a module name at %s line %s.\n}, + $module, (caller( 1 + ($Test::Builder::Level||0) ))[1,2]; + die + } + elsif (_try_require($module)) { + local $@; + if (defined $version && !eval { $module->VERSION($version); 1 }) { + "$module $version (have ".$module->VERSION.')'; + } + else { + (); + } + } + else { + $version ? "$module $version" : $module; + } + } + map { + if (ref eq 'HASH') { + my $arg = $_; + map [ $_ => $arg->{$_} ], sort keys %$arg; + } + elsif (ref eq 'ARRAY') { + my $arg = $_; + map [ @{$arg}[$_*2,$_*2+1] ], 0 .. int($#$arg / 2); + } + else { + [ $_ => undef ]; + } + } @_; + @bad ? "Need " . join(', ', @bad) : undef; +} + +sub import { + my $class = shift; + my $target = caller; + if (@_) { + local $Test::Builder::Level = ($Test::Builder::Level||0) + 1; + test_needs(@_); + } + no strict 'refs'; + *{"${target}::test_needs"} = \&test_needs; +} + +sub test_needs { + my $missing = _find_missing(@_); + local $Test::Builder::Level = ($Test::Builder::Level||0) + 1; + _fail_or_skip($missing, $ENV{RELEASE_TESTING}) + if $missing; +} + +sub _skip { _fail_or_skip($_[0], 0) } +sub _fail { _fail_or_skip($_[0], 1) } + +sub _fail_or_skip { + my ($message, $fail) = @_; + if ($INC{'Test2/API.pm'}) { + my $ctx = Test2::API::context(); + my $hub = $ctx->hub; + if ($fail) { + $ctx->ok(0, "Test::Needs modules available", [$message]); + } + else { + my $plan = $hub->plan; + my $tests = $hub->count; + if ($plan || $tests) { + my $skips + = $plan && $plan ne 'NO PLAN' ? $plan - $tests : 1; + $ctx->skip("Test::Needs modules not available") for 1 .. $skips; + $ctx->note($message); + } + else { + $ctx->plan(0, 'SKIP', $message); + } + } + $ctx->done_testing; + $ctx->release if $Test2::API::VERSION < 1.302053; + $ctx->send_event('+'._t2_terminate_event()); + } + elsif ($INC{'Test/Builder.pm'}) { + my $tb = Test::Builder->new; + my $has_plan = Test::Builder->can('has_plan') ? 'has_plan' + : sub { $_[0]->expected_tests || eval { $_[0]->current_test($_[0]->current_test); 'no_plan' } }; + if ($fail) { + $tb->plan(tests => 1) + unless $tb->$has_plan; + $tb->ok(0, "Test::Needs modules available"); + $tb->diag($message); + } + else { + my $plan = $tb->$has_plan; + my $tests = $tb->current_test; + if ($plan || $tests) { + my $skips + = $plan && $plan ne 'no_plan' ? $plan - $tests : 1; + $tb->skip("Test::Needs modules not available") + for 1 .. $skips; + Test::Builer->can('note') ? $tb->note($message) : print "# $message\n"; + } + else { + $tb->skip_all($message); + } + } + $tb->done_testing + if Test::Builder->can('done_testing'); + die bless {} => 'Test::Builder::Exception' + if Test::Builder->can('parent') && $tb->parent; + } + else { + if ($fail) { + print "1..1\n"; + print "not ok 1 - Test::Needs modules available\n"; + print STDERR "# $message\n"; + exit 1; + } + else { + print "1..0 # SKIP $message\n"; + } + } + exit 0; +} + +my $terminate_event; +sub _t2_terminate_event () { + local $@; + $terminate_event ||= eval q{ + $INC{'Test/Needs/Event/Terminate.pm'} = $INC{'Test/Needs.pm'}; + package # hide + Test::Needs::Event::Terminate; + use Test2::Event (); + our @ISA = qw(Test2::Event); + sub no_display { 1 } + sub terminate { 0 } + __PACKAGE__; + } or die "$@"; +} + +1; +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Test::Needs - Skip tests when modules not available + +=head1 SYNOPSIS + + # need one module + use Test::Needs 'Some::Module'; + + # need multiple modules + use Test::Needs 'Some::Module', 'Some::Other::Module'; + + # need a given version of a module + use Test::Needs { + 'Some::Module' => '1.005', + }; + + # check later + use Test::Needs; + test_needs 'Some::Module'; + + # skips remainder of subtest + use Test::More; + use Test::Needs; + subtest 'my subtest' => sub { + test_needs 'Some::Module'; + ... + }; + + # check perl version + use Test::Needs { perl => 5.020 }; + +=head1 DESCRIPTION + +Skip test scripts if modules are not available. The requested modules will be +loaded, and optionally have their versions checked. If the module is missing, +the test script will be skipped. Modules that are found but fail to compile +will exit with an error rather than skip. + +If used in a subtest, the remainder of the subtest will be skipped. + +Skipping will work even if some tests have already been run, or if a plan has +been declared. + +Versions are checked via a C<< $module->VERSION($wanted_version) >> call. +Versions must be provided in a format that will be accepted. No extra +processing is done on them. + +If C<perl> is used as a module, the version is checked against the running perl +version (L<$]|perlvar/$]>). The version can be specified as a number, +dotted-decimal string, v-string, or version object. + +If the C<RELEASE_TESTING> environment variable is set, the tests will fail +rather than skip. Subtests will be aborted, but the test script will continue +running after that point. + +=head1 EXPORTS + +=head2 test_needs + +Has the same interface as when using Test::Needs in a C<use>. + +=head1 SEE ALSO + +=over 4 + +=item L<Test::Requires> + +A similar module, with some important differences. L<Test::Requires> will act +as a C<use> statement (despite its name), calling the import sub. Under +C<RELEASE_TESTING>, it will BAIL_OUT if a module fails to load rather than +using a normal test fail. It also doesn't distinguish between missing modules +and broken modules. + +=item L<Test2::Require::Module> + +Part of the L<Test2> ecosystem. Only supports running as a C<use> command to +skip an entire plan. + +=back + +=head1 AUTHOR + +haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org> + +=head1 CONTRIBUTORS + +None so far. + +=head1 COPYRIGHT + +Copyright (c) 2016 the Test::Needs L</AUTHOR> and L</CONTRIBUTORS> +as listed above. + +=head1 LICENSE + +This library is free software and may be distributed under the same terms +as perl itself. See L<http://dev.perl.org/licenses/>. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm new file mode 100644 index 0000000000..e78ca0bc6d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm @@ -0,0 +1,131 @@ +use strict; +use warnings; +package Test::RequiresInternet; +$Test::RequiresInternet::VERSION = '0.05'; +# ABSTRACT: Easily test network connectivity + + +use Socket; + +sub import { + skip_all("NO_NETWORK_TESTING") if env("NO_NETWORK_TESTING"); + + my $namespace = shift; + + my $argc = scalar @_; + if ( $argc == 0 ) { + push @_, 'www.google.com', 80; + } + elsif ( $argc % 2 != 0 ) { + die "Must supply server and a port pairs. You supplied " . (join ", ", @_) . "\n"; + } + + while ( @_ ) { + my $host = shift; + my $port = shift; + + local $@; + + eval {make_socket($host, $port)}; + + if ( $@ ) { + skip_all("$@"); + } + } +} + +sub make_socket { + my ($host, $port) = @_; + + my $portnum; + if ($port =~ /\D/) { + $portnum = getservbyname($port, "tcp"); + } + else { + $portnum = $port; + } + + die "Could not find a port number for $port\n" if not $portnum; + + my $iaddr = inet_aton($host) or die "no host: $host\n"; + + my $paddr = sockaddr_in($portnum, $iaddr); + my $proto = getprotobyname("tcp"); + + socket(my $sock, PF_INET, SOCK_STREAM, $proto) or die "socket: $!\n"; + connect($sock, $paddr) or die "connect: $!\n"; + close ($sock) or die "close: $!\n"; + + 1; +} + +sub env { + exists $ENV{$_[0]} && $ENV{$_[0]} eq '1' +} + +sub skip_all { + my $reason = shift; + print "1..0 # Skipped: $reason"; + exit 0; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test::RequiresInternet - Easily test network connectivity + +=head1 VERSION + +version 0.05 + +=head1 SYNOPSIS + + use Test::More; + use Test::RequiresInternet ('www.example.com' => 80, 'foobar.io' => 25); + + # if you reach here, sockets successfully connected to hosts/ports above + plan tests => 1; + + ok(do_that_internet_thing()); + +=head1 OVERVIEW + +This module is intended to easily test network connectivity before functional +tests begin to non-local Internet resources. It does not require any modules +beyond those supplied in core Perl. + +If you do not specify a host/port pair, then the module defaults to using +C<www.google.com> on port C<80>. + +You may optionally specify the port by its name, as in C<http> or C<ldap>. +If you do this, the test module will attempt to look up the port number +using C<getservbyname>. + +If you do specify a host and port, they must be specified in B<pairs>. It is a +fatal error to omit one or the other. + +If the environment variable C<NO_NETWORK_TESTING> is set, then the tests +will be skipped without attempting any socket connections. + +If the sockets cannot connect to the specified hosts and ports, the exception +is caught, reported and the tests skipped. + +=head1 AUTHOR + +Mark Allen <mrallen1@yahoo.com> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2014 by Mark Allen. + +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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Tie/Registry.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Tie/Registry.pm new file mode 100644 index 0000000000..2ded338d34 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Tie/Registry.pm @@ -0,0 +1,45 @@ +package Tie::Registry; + +# Tie/Registry.pm -- Provides backward compatibility for Win32::TieRegistry +# that was called Tie::Registry prior to version 0.20. +# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/. + +use strict; +use Carp; + +use vars qw( $VERSION @ISA ); +BEGIN { + require Win32::TieRegistry; + $VERSION = '0.15'; + @ISA = qw{Win32::TieRegistry}; +} + +sub import { + my $pkg = shift; + Win32::TieRegistry->import( ExportLevel => 1, SplitMultis => 0, @_ ); +} + +1; + +__END__ + +=pod + +=head1 NAME + +Tie::Registry - Legacy interface to Win32::TieRegistry (DEPRECATED) + +=head1 DESCRIPTION + +This module provides backward compatibility for L<Win32::TieRegistry> +that was called Tie::Registry prior to version 0.20. + +=head1 AUTHOR + +Tye McQueen E<lt>tye@metronet.comE<gt> + +=head1 COPYRIGHT + +Copyright 1999 Tye McQueen. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Time/Zone.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Time/Zone.pm new file mode 100644 index 0000000000..8a40f9158c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Time/Zone.pm @@ -0,0 +1,291 @@ + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Try/Tiny.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Try/Tiny.pm new file mode 100644 index 0000000000..14f5b09317 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Try/Tiny.pm @@ -0,0 +1,813 @@ +package Try::Tiny; # git description: v0.29-2-g3b23a06 +use 5.006; +# ABSTRACT: Minimal try/catch with proper preservation of $@ + +our $VERSION = '0.30'; + +use strict; +use warnings; + +use Exporter 5.57 'import'; +our @EXPORT = our @EXPORT_OK = qw(try catch finally); + +use Carp; +$Carp::Internal{+__PACKAGE__}++; + +BEGIN { + my $su = $INC{'Sub/Util.pm'} && defined &Sub::Util::set_subname; + my $sn = $INC{'Sub/Name.pm'} && eval { Sub::Name->VERSION(0.08) }; + unless ($su || $sn) { + $su = eval { require Sub::Util; } && defined &Sub::Util::set_subname; + unless ($su) { + $sn = eval { require Sub::Name; Sub::Name->VERSION(0.08) }; + } + } + + *_subname = $su ? \&Sub::Util::set_subname + : $sn ? \&Sub::Name::subname + : sub { $_[1] }; + *_HAS_SUBNAME = ($su || $sn) ? sub(){1} : sub(){0}; +} + +my %_finally_guards; + +# Need to prototype as @ not $$ because of the way Perl evaluates the prototype. +# Keeping it at $$ means you only ever get 1 sub because we need to eval in a list +# context & not a scalar one + +sub try (&;@) { + my ( $try, @code_refs ) = @_; + + # we need to save this here, the eval block will be in scalar context due + # to $failed + my $wantarray = wantarray; + + # work around perl bug by explicitly initializing these, due to the likelyhood + # this will be used in global destruction (perl rt#119311) + my ( $catch, @finally ) = (); + + # find labeled blocks in the argument list. + # catch and finally tag the blocks by blessing a scalar reference to them. + foreach my $code_ref (@code_refs) { + + if ( ref($code_ref) eq 'Try::Tiny::Catch' ) { + croak 'A try() may not be followed by multiple catch() blocks' + if $catch; + $catch = ${$code_ref}; + } elsif ( ref($code_ref) eq 'Try::Tiny::Finally' ) { + push @finally, ${$code_ref}; + } else { + croak( + 'try() encountered an unexpected argument (' + . ( defined $code_ref ? $code_ref : 'undef' ) + . ') - perhaps a missing semi-colon before or' + ); + } + } + + # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's + # not perfect, but we could provide a list of additional errors for + # $catch->(); + + # name the blocks if we have Sub::Name installed + _subname(caller().'::try {...} ' => $try) + if _HAS_SUBNAME; + + # set up scope guards to invoke the finally blocks at the end. + # this should really be a function scope lexical variable instead of + # file scope + local but that causes issues with perls < 5.20 due to + # perl rt#119311 + local $_finally_guards{guards} = [ + map { Try::Tiny::ScopeGuard->_new($_) } + @finally + ]; + + # save the value of $@ so we can set $@ back to it in the beginning of the eval + # and restore $@ after the eval finishes + my $prev_error = $@; + + my ( @ret, $error ); + + # failed will be true if the eval dies, because 1 will not be returned + # from the eval body + my $failed = not eval { + $@ = $prev_error; + + # evaluate the try block in the correct context + if ( $wantarray ) { + @ret = $try->(); + } elsif ( defined $wantarray ) { + $ret[0] = $try->(); + } else { + $try->(); + }; + + return 1; # properly set $failed to false + }; + + # preserve the current error and reset the original value of $@ + $error = $@; + $@ = $prev_error; + + # at this point $failed contains a true value if the eval died, even if some + # destructor overwrote $@ as the eval was unwinding. + if ( $failed ) { + # pass $error to the finally blocks + push @$_, $error for @{$_finally_guards{guards}}; + + # if we got an error, invoke the catch block. + if ( $catch ) { + # This works like given($error), but is backwards compatible and + # sets $_ in the dynamic scope for the body of C<$catch> + for ($error) { + return $catch->($error); + } + + # in case when() was used without an explicit return, the C<for> + # loop will be aborted and there's no useful return value + } + + return; + } else { + # no failure, $@ is back to what it was, everything is fine + return $wantarray ? @ret : $ret[0]; + } +} + +sub catch (&;@) { + my ( $block, @rest ) = @_; + + croak 'Useless bare catch()' unless wantarray; + + _subname(caller().'::catch {...} ' => $block) + if _HAS_SUBNAME; + return ( + bless(\$block, 'Try::Tiny::Catch'), + @rest, + ); +} + +sub finally (&;@) { + my ( $block, @rest ) = @_; + + croak 'Useless bare finally()' unless wantarray; + + _subname(caller().'::finally {...} ' => $block) + if _HAS_SUBNAME; + return ( + bless(\$block, 'Try::Tiny::Finally'), + @rest, + ); +} + +{ + package # hide from PAUSE + Try::Tiny::ScopeGuard; + + use constant UNSTABLE_DOLLARAT => ("$]" < '5.013002') ? 1 : 0; + + sub _new { + shift; + bless [ @_ ]; + } + + sub DESTROY { + my ($code, @args) = @{ $_[0] }; + + local $@ if UNSTABLE_DOLLARAT; + eval { + $code->(@args); + 1; + } or do { + warn + "Execution of finally() block $code resulted in an exception, which " + . '*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. ' + . 'Your program will continue as if this event never took place. ' + . "Original exception text follows:\n\n" + . (defined $@ ? $@ : '$@ left undefined...') + . "\n" + ; + } + } +} + +__PACKAGE__ + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Try::Tiny - Minimal try/catch with proper preservation of $@ + +=head1 VERSION + +version 0.30 + +=head1 SYNOPSIS + +You can use Try::Tiny's C<try> and C<catch> to expect and handle exceptional +conditions, avoiding quirks in Perl and common mistakes: + + # handle errors with a catch handler + try { + die "foo"; + } catch { + warn "caught error: $_"; # not $@ + }; + +You can also use it like a standalone C<eval> to catch and ignore any error +conditions. Obviously, this is an extreme measure not to be undertaken +lightly: + + # just silence errors + try { + die "foo"; + }; + +=head1 DESCRIPTION + +This module provides bare bones C<try>/C<catch>/C<finally> statements that are designed to +minimize common mistakes with eval blocks, and NOTHING else. + +This is unlike L<TryCatch> which provides a nice syntax and avoids adding +another call stack layer, and supports calling C<return> from the C<try> block to +return from the parent subroutine. These extra features come at a cost of a few +dependencies, namely L<Devel::Declare> and L<Scope::Upper> which are +occasionally problematic, and the additional catch filtering uses L<Moose> +type constraints which may not be desirable either. + +The main focus of this module is to provide simple and reliable error handling +for those having a hard time installing L<TryCatch>, but who still want to +write correct C<eval> blocks without 5 lines of boilerplate each time. + +It's designed to work as correctly as possible in light of the various +pathological edge cases (see L</BACKGROUND>) and to be compatible with any style +of error values (simple strings, references, objects, overloaded objects, etc). + +If the C<try> block dies, it returns the value of the last statement executed in +the C<catch> block, if there is one. Otherwise, it returns C<undef> in scalar +context or the empty list in list context. The following examples all +assign C<"bar"> to C<$x>: + + my $x = try { die "foo" } catch { "bar" }; + my $x = try { die "foo" } || "bar"; + my $x = (try { die "foo" }) // "bar"; + + my $x = eval { die "foo" } || "bar"; + +You can add C<finally> blocks, yielding the following: + + my $x; + try { die 'foo' } finally { $x = 'bar' }; + try { die 'foo' } catch { warn "Got a die: $_" } finally { $x = 'bar' }; + +C<finally> blocks are always executed making them suitable for cleanup code +which cannot be handled using local. You can add as many C<finally> blocks to a +given C<try> block as you like. + +Note that adding a C<finally> block without a preceding C<catch> block +suppresses any errors. This behaviour is consistent with using a standalone +C<eval>, but it is not consistent with C<try>/C<finally> patterns found in +other programming languages, such as Java, Python, Javascript or C#. If you +learnt the C<try>/C<finally> pattern from one of these languages, watch out for +this. + +=head1 EXPORTS + +All functions are exported by default using L<Exporter>. + +If you need to rename the C<try>, C<catch> or C<finally> keyword consider using +L<Sub::Import> to get L<Sub::Exporter>'s flexibility. + +=over 4 + +=item try (&;@) + +Takes one mandatory C<try> subroutine, an optional C<catch> subroutine and C<finally> +subroutine. + +The mandatory subroutine is evaluated in the context of an C<eval> block. + +If no error occurred the value from the first block is returned, preserving +list/scalar context. + +If there was an error and the second subroutine was given it will be invoked +with the error in C<$_> (localized) and as that block's first and only +argument. + +C<$@> does B<not> contain the error. Inside the C<catch> block it has the same +value it had before the C<try> block was executed. + +Note that the error may be false, but if that happens the C<catch> block will +still be invoked. + +Once all execution is finished then the C<finally> block, if given, will execute. + +=item catch (&;@) + +Intended to be used in the second argument position of C<try>. + +Returns a reference to the subroutine it was given but blessed as +C<Try::Tiny::Catch> which allows try to decode correctly what to do +with this code reference. + + catch { ... } + +Inside the C<catch> block the caught error is stored in C<$_>, while previous +value of C<$@> is still available for use. This value may or may not be +meaningful depending on what happened before the C<try>, but it might be a good +idea to preserve it in an error stack. + +For code that captures C<$@> when throwing new errors (i.e. +L<Class::Throwable>), you'll need to do: + + local $@ = $_; + +=item finally (&;@) + + try { ... } + catch { ... } + finally { ... }; + +Or + + try { ... } + finally { ... }; + +Or even + + try { ... } + finally { ... } + catch { ... }; + +Intended to be the second or third element of C<try>. C<finally> blocks are always +executed in the event of a successful C<try> or if C<catch> is run. This allows +you to locate cleanup code which cannot be done via C<local()> e.g. closing a file +handle. + +When invoked, the C<finally> block is passed the error that was caught. If no +error was caught, it is passed nothing. (Note that the C<finally> block does not +localize C<$_> with the error, since unlike in a C<catch> block, there is no way +to know if C<$_ == undef> implies that there were no errors.) In other words, +the following code does just what you would expect: + + try { + die_sometimes(); + } catch { + # ...code run in case of error + } finally { + if (@_) { + print "The try block died with: @_\n"; + } else { + print "The try block ran without error.\n"; + } + }; + +B<You must always do your own error handling in the C<finally> block>. C<Try::Tiny> will +not do anything about handling possible errors coming from code located in these +blocks. + +Furthermore B<exceptions in C<finally> blocks are not trappable and are unable +to influence the execution of your program>. This is due to limitation of +C<DESTROY>-based scope guards, which C<finally> is implemented on top of. This +may change in a future version of Try::Tiny. + +In the same way C<catch()> blesses the code reference this subroutine does the same +except it bless them as C<Try::Tiny::Finally>. + +=back + +=head1 BACKGROUND + +There are a number of issues with C<eval>. + +=head2 Clobbering $@ + +When you run an C<eval> block and it succeeds, C<$@> will be cleared, potentially +clobbering an error that is currently being caught. + +This causes action at a distance, clearing previous errors your caller may have +not yet handled. + +C<$@> must be properly localized before invoking C<eval> in order to avoid this +issue. + +More specifically, +L<before Perl version 5.14.0|perl5140delta/"Exception Handling"> +C<$@> was clobbered at the beginning of the C<eval>, which +also made it impossible to capture the previous error before you die (for +instance when making exception objects with error stacks). + +For this reason C<try> will actually set C<$@> to its previous value (the one +available before entering the C<try> block) in the beginning of the C<eval> +block. + +=head2 Localizing $@ silently masks errors + +Inside an C<eval> block, C<die> behaves sort of like: + + sub die { + $@ = $_[0]; + return_undef_from_eval(); + } + +This means that if you were polite and localized C<$@> you can't die in that +scope, or your error will be discarded (printing "Something's wrong" instead). + +The workaround is very ugly: + + my $error = do { + local $@; + eval { ... }; + $@; + }; + + ... + die $error; + +=head2 $@ might not be a true value + +This code is wrong: + + if ( $@ ) { + ... + } + +because due to the previous caveats it may have been unset. + +C<$@> could also be an overloaded error object that evaluates to false, but +that's asking for trouble anyway. + +The classic failure mode (fixed in L<Perl 5.14.0|perl5140delta/"Exception Handling">) is: + + sub Object::DESTROY { + eval { ... } + } + + eval { + my $obj = Object->new; + + die "foo"; + }; + + if ( $@ ) { + + } + +In this case since C<Object::DESTROY> is not localizing C<$@> but still uses +C<eval>, it will set C<$@> to C<"">. + +The destructor is called when the stack is unwound, after C<die> sets C<$@> to +C<"foo at Foo.pm line 42\n">, so by the time C<if ( $@ )> is evaluated it has +been cleared by C<eval> in the destructor. + +The workaround for this is even uglier than the previous ones. Even though we +can't save the value of C<$@> from code that doesn't localize, we can at least +be sure the C<eval> was aborted due to an error: + + my $failed = not eval { + ... + + return 1; + }; + +This is because an C<eval> that caught a C<die> will always return a false +value. + +=head1 ALTERNATE SYNTAX + +Using Perl 5.10 you can use L<perlsyn/"Switch statements"> (but please don't, +because that syntax has since been deprecated because there was too much +unexpected magical behaviour). + +=for stopwords topicalizer + +The C<catch> block is invoked in a topicalizer context (like a C<given> block), +but note that you can't return a useful value from C<catch> using the C<when> +blocks without an explicit C<return>. + +This is somewhat similar to Perl 6's C<CATCH> blocks. You can use it to +concisely match errors: + + try { + require Foo; + } catch { + when (/^Can't locate .*?\.pm in \@INC/) { } # ignore + default { die $_ } + }; + +=head1 CAVEATS + +=over 4 + +=item * + +C<@_> is not available within the C<try> block, so you need to copy your +argument list. In case you want to work with argument values directly via C<@_> +aliasing (i.e. allow C<$_[1] = "foo">), you need to pass C<@_> by reference: + + sub foo { + my ( $self, @args ) = @_; + try { $self->bar(@args) } + } + +or + + sub bar_in_place { + my $self = shift; + my $args = \@_; + try { $_ = $self->bar($_) for @$args } + } + +=item * + +C<return> returns from the C<try> block, not from the parent sub (note that +this is also how C<eval> works, but not how L<TryCatch> works): + + sub parent_sub { + try { + die; + } + catch { + return; + }; + + say "this text WILL be displayed, even though an exception is thrown"; + } + +Instead, you should capture the return value: + + sub parent_sub { + my $success = try { + die; + 1; + }; + return unless $success; + + say "This text WILL NEVER appear!"; + } + # OR + sub parent_sub_with_catch { + my $success = try { + die; + 1; + } + catch { + # do something with $_ + return undef; #see note + }; + return unless $success; + + say "This text WILL NEVER appear!"; + } + +Note that if you have a C<catch> block, it must return C<undef> for this to work, +since if a C<catch> block exists, its return value is returned in place of C<undef> +when an exception is thrown. + +=item * + +C<try> introduces another caller stack frame. L<Sub::Uplevel> is not used. L<Carp> +will not report this when using full stack traces, though, because +C<%Carp::Internal> is used. This lack of magic is considered a feature. + +=for stopwords unhygienically + +=item * + +The value of C<$_> in the C<catch> block is not guaranteed to be the value of +the exception thrown (C<$@>) in the C<try> block. There is no safe way to +ensure this, since C<eval> may be used unhygienically in destructors. The only +guarantee is that the C<catch> will be called if an exception is thrown. + +=item * + +The return value of the C<catch> block is not ignored, so if testing the result +of the expression for truth on success, be sure to return a false value from +the C<catch> block: + + my $obj = try { + MightFail->new; + } catch { + ... + + return; # avoid returning a true value; + }; + + return unless $obj; + +=item * + +C<$SIG{__DIE__}> is still in effect. + +Though it can be argued that C<$SIG{__DIE__}> should be disabled inside of +C<eval> blocks, since it isn't people have grown to rely on it. Therefore in +the interests of compatibility, C<try> does not disable C<$SIG{__DIE__}> for +the scope of the error throwing code. + +=item * + +Lexical C<$_> may override the one set by C<catch>. + +For example Perl 5.10's C<given> form uses a lexical C<$_>, creating some +confusing behavior: + + given ($foo) { + when (...) { + try { + ... + } catch { + warn $_; # will print $foo, not the error + warn $_[0]; # instead, get the error like this + } + } + } + +Note that this behavior was changed once again in +L<Perl5 version 18|https://metacpan.org/module/perldelta#given-now-aliases-the-global-_>. +However, since the entirety of lexical C<$_> is now L<considered experimental +|https://metacpan.org/module/perldelta#Lexical-_-is-now-experimental>, it +is unclear whether the new version 18 behavior is final. + +=back + +=head1 SEE ALSO + +=over 4 + +=item L<TryCatch> + +Much more feature complete, more convenient semantics, but at the cost of +implementation complexity. + +=item L<autodie> + +Automatic error throwing for builtin functions and more. Also designed to +work well with C<given>/C<when>. + +=item L<Throwable> + +A lightweight role for rolling your own exception classes. + +=item L<Error> + +Exception object implementation with a C<try> statement. Does not localize +C<$@>. + +=item L<Exception::Class::TryCatch> + +Provides a C<catch> statement, but properly calling C<eval> is your +responsibility. + +The C<try> keyword pushes C<$@> onto an error stack, avoiding some of the +issues with C<$@>, but you still need to localize to prevent clobbering. + +=back + +=head1 LIGHTNING TALK + +I gave a lightning talk about this module, you can see the slides (Firefox +only): + +L<http://web.archive.org/web/20100628040134/http://nothingmuch.woobling.org/talks/takahashi.xul> + +Or read the source: + +L<http://web.archive.org/web/20100305133605/http://nothingmuch.woobling.org/talks/yapc_asia_2009/try_tiny.yml> + +=head1 SUPPORT + +Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Try-Tiny> +(or L<bug-Try-Tiny@rt.cpan.org|mailto:bug-Try-Tiny@rt.cpan.org>). + +=head1 AUTHORS + +=over 4 + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=back + +=head1 CONTRIBUTORS + +=for stopwords Karen Etheridge Peter Rabbitson Ricardo Signes Mark Fowler Graham Knop Lukas Mai Aristotle Pagaltzis Dagfinn Ilmari MannsÃ¥ker Paul Howarth Rudolf Leermakers anaxagoras awalker chromatic Alex cm-perl Andrew Yates David Lowe Glenn Hans Dieter Pearcey Jens Berthold Jonathan Yu Marc Mims Stosberg Pali + +=over 4 + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Peter Rabbitson <ribasushi@cpan.org> + +=item * + +Ricardo Signes <rjbs@cpan.org> + +=item * + +Mark Fowler <mark@twoshortplanks.com> + +=item * + +Graham Knop <haarg@haarg.org> + +=item * + +Lukas Mai <l.mai@web.de> + +=item * + +Aristotle Pagaltzis <pagaltzis@gmx.de> + +=item * + +Dagfinn Ilmari MannsÃ¥ker <ilmari@ilmari.org> + +=item * + +Paul Howarth <paul@city-fan.org> + +=item * + +Rudolf Leermakers <rudolf@hatsuseno.org> + +=item * + +anaxagoras <walkeraj@gmail.com> + +=item * + +awalker <awalker@sourcefire.com> + +=item * + +chromatic <chromatic@wgz.org> + +=item * + +Alex <alex@koban.(none)> + +=item * + +cm-perl <cm-perl@users.noreply.github.com> + +=item * + +Andrew Yates <ayates@haddock.local> + +=item * + +David Lowe <davidl@lokku.com> + +=item * + +Glenn Fowler <cebjyre@cpan.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Jens Berthold <jens@jebecs.de> + +=item * + +Jonathan Yu <JAWNSY@cpan.org> + +=item * + +Marc Mims <marc@questright.com> + +=item * + +Mark Stosberg <mark@stosberg.com> + +=item * + +Pali <pali@cpan.org> + +=back + +=head1 COPYRIGHT AND LICENCE + +This software is Copyright (c) 2009 by יובל קוג'מן (Yuval Kogman). + +This is free software, licensed under: + + The MIT (X11) License + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI.pm new file mode 100644 index 0000000000..7d259c734a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI.pm @@ -0,0 +1,1162 @@ +package URI; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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.perl.com"); + $u2 = URI->new("foo", "http"); + $u3 = $u2->abs($u1); + $u4 = $u3->clone; + $u5 = URI->new("HTTP://WWW.perl.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.perl.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. + +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<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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/Escape.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/Escape.pm new file mode 100644 index 0000000000..f9392d446f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/Escape.pm @@ -0,0 +1,221 @@ +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 = "3.31"; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/Heuristic.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/Heuristic.pm new file mode 100644 index 0000000000..d4ace34379 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/Heuristic.pm @@ -0,0 +1,253 @@ +package URI::Heuristic; + +=head1 NAME + +URI::Heuristic - Expand URI using heuristics + +=head1 SYNOPSIS + + use URI::Heuristic qw(uf_uristr); + $u = uf_uristr("perl"); # http://www.perl.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 = "4.20"; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/IRI.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/IRI.pm new file mode 100644 index 0000000000..edb10450f7 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/IRI.pm @@ -0,0 +1,47 @@ +package URI::IRI; + +# Experimental + +use strict; +use warnings; +use URI (); + +use overload '""' => sub { shift->as_string }; + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/QueryParam.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/QueryParam.pm new file mode 100644 index 0000000000..16eed9823d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/QueryParam.pm @@ -0,0 +1,207 @@ +package URI::QueryParam; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/Split.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/Split.pm new file mode 100644 index 0000000000..39b5bcf7f2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/Split.pm @@ -0,0 +1,97 @@ +package URI::Split; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/URL.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/URL.pm new file mode 100644 index 0000000000..ba05ecaeba --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/URL.pm @@ -0,0 +1,303 @@ +package URI::URL; + +use strict; +use warnings; + +use parent 'URI::WithBase'; + +our $VERSION = "5.04"; + +# 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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/WithBase.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/WithBase.pm new file mode 100644 index 0000000000..943b7b533a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/WithBase.pm @@ -0,0 +1,174 @@ +package URI::WithBase; + +use strict; +use warnings; + +use URI; +use Scalar::Util 'blessed'; + +our $VERSION = "2.20"; + +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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_foreign.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_foreign.pm new file mode 100644 index 0000000000..d556c853e6 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_foreign.pm @@ -0,0 +1,10 @@ +package URI::_foreign; + +use strict; +use warnings; + +use parent 'URI::_generic'; + +our $VERSION = '1.76'; + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_generic.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_generic.pm new file mode 100644 index 0000000000..0da8f72998 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_generic.pm @@ -0,0 +1,256 @@ +package URI::_generic; + +use strict; +use warnings; + +use parent qw(URI URI::_query); + +use URI::Escape qw(uri_unescape); +use Carp (); + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_idna.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_idna.pm new file mode 100644 index 0000000000..8392e107d9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_idna.pm @@ -0,0 +1,91 @@ +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(encode_punycode decode_punycode); +use Carp qw(croak); + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_ldap.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_ldap.pm new file mode 100644 index 0000000000..5057c37cb3 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_ldap.pm @@ -0,0 +1,140 @@ +# 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 = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_login.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_login.pm new file mode 100644 index 0000000000..7c3e5a1b83 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_login.pm @@ -0,0 +1,13 @@ +package URI::_login; + +use strict; +use warnings; + +use parent qw(URI::_server URI::_userpass); + +our $VERSION = '1.76'; + +# Generic terminal logins. This is used as a base class for 'telnet', +# 'tn3270', and 'rlogin' URL schemes. + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_punycode.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_punycode.pm new file mode 100644 index 0000000000..405acc2de1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_punycode.pm @@ -0,0 +1,217 @@ +package URI::_punycode; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_query.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_query.pm new file mode 100644 index 0000000000..d9dde133e3 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_query.pm @@ -0,0 +1,97 @@ +package URI::_query; + +use strict; +use warnings; + +use URI (); +use URI::Escape qw(uri_unescape); + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_segment.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_segment.pm new file mode 100644 index 0000000000..01f207feb1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_segment.pm @@ -0,0 +1,24 @@ +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 = '1.76'; + +sub new +{ + my $class = shift; + my @segment = split(';', shift, -1); + $segment[0] = uri_unescape($segment[0]); + bless \@segment, $class; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_server.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_server.pm new file mode 100644 index 0000000000..5c32400d17 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_server.pm @@ -0,0 +1,166 @@ +package URI::_server; + +use strict; +use warnings; + +use parent 'URI::_generic'; + +use URI::Escape qw(uri_unescape); + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_userpass.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_userpass.pm new file mode 100644 index 0000000000..b57fb2a502 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/_userpass.pm @@ -0,0 +1,55 @@ +package URI::_userpass; + +use strict; +use warnings; + +use URI::Escape qw(uri_unescape); + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/data.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/data.pm new file mode 100644 index 0000000000..b21b5a31a0 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/data.pm @@ -0,0 +1,142 @@ +package URI::data; # RFC 2397 + +use strict; +use warnings; + +use parent 'URI'; + +our $VERSION = '1.76'; + +use MIME::Base64 qw(encode_base64 decode_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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file.pm new file mode 100644 index 0000000000..d76ddf2b5e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file.pm @@ -0,0 +1,327 @@ +package URI::file; + +use strict; +use warnings; + +use parent 'URI::_generic'; +our $VERSION = "4.21"; + +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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Base.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Base.pm new file mode 100644 index 0000000000..bddd78a44f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Base.pm @@ -0,0 +1,84 @@ +package URI::file::Base; + +use strict; +use warnings; + +use URI::Escape qw(); + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/FAT.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/FAT.pm new file mode 100644 index 0000000000..78ed78002e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/FAT.pm @@ -0,0 +1,27 @@ +package URI::file::FAT; + +use strict; +use warnings; + +use parent 'URI::file::Win32'; + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Mac.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Mac.pm new file mode 100644 index 0000000000..155d618b42 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Mac.pm @@ -0,0 +1,121 @@ +package URI::file::Mac; + +use strict; +use warnings; + +use parent 'URI::file::Base'; + +use URI::Escape qw(uri_unescape); + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/OS2.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/OS2.pm new file mode 100644 index 0000000000..a3cbf980b3 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/OS2.pm @@ -0,0 +1,32 @@ +package URI::file::OS2; + +use strict; +use warnings; + +use parent 'URI::file::Win32'; + +our $VERSION = '1.76'; + +# 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/QNX.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/QNX.pm new file mode 100644 index 0000000000..995fd632e2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/QNX.pm @@ -0,0 +1,20 @@ +package URI::file::QNX; + +use strict; +use warnings; + +use parent 'URI::file::Unix'; + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Unix.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Unix.pm new file mode 100644 index 0000000000..869e8991a7 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Unix.pm @@ -0,0 +1,58 @@ +package URI::file::Unix; + +use strict; +use warnings; + +use parent 'URI::file::Base'; + +use URI::Escape qw(uri_unescape); + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Win32.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Win32.pm new file mode 100644 index 0000000000..d4f1ecfe56 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/file/Win32.pm @@ -0,0 +1,87 @@ +package URI::file::Win32; + +use strict; +use warnings; + +use parent 'URI::file::Base'; + +use URI::Escape qw(uri_unescape); + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ftp.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ftp.pm new file mode 100644 index 0000000000..e2d195026d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ftp.pm @@ -0,0 +1,46 @@ +package URI::ftp; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/gopher.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/gopher.pm new file mode 100644 index 0000000000..00bc363a9e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/gopher.pm @@ -0,0 +1,97 @@ +package URI::gopher; # <draft-murali-url-gopher>, Dec 4, 1996 + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/http.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/http.pm new file mode 100644 index 0000000000..1b02cac9aa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/http.pm @@ -0,0 +1,27 @@ +package URI::http; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/https.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/https.pm new file mode 100644 index 0000000000..f40636bb94 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/https.pm @@ -0,0 +1,14 @@ +package URI::https; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::http'; + +sub default_port { 443 } + +sub secure { 1 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ldap.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ldap.pm new file mode 100644 index 0000000000..813bff9ea2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ldap.pm @@ -0,0 +1,120 @@ +# 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 = '1.76'; + +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 diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ldapi.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ldapi.pm new file mode 100644 index 0000000000..b138c8849c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ldapi.pm @@ -0,0 +1,29 @@ +package URI::ldapi; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent qw(URI::_ldap URI::_generic); + +require 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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ldaps.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ldaps.pm new file mode 100644 index 0000000000..02ad5115fb --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ldaps.pm @@ -0,0 +1,14 @@ +package URI::ldaps; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::ldap'; + +sub default_port { 636 } + +sub secure { 1 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/mailto.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/mailto.pm new file mode 100644 index 0000000000..300386ef44 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/mailto.pm @@ -0,0 +1,73 @@ +package URI::mailto; # RFC 2368 + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/mms.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/mms.pm new file mode 100644 index 0000000000..3c0e44f054 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/mms.pm @@ -0,0 +1,12 @@ +package URI::mms; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::http'; + +sub default_port { 1755 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/news.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/news.pm new file mode 100644 index 0000000000..55dcf71556 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/news.pm @@ -0,0 +1,71 @@ +package URI::news; # draft-gilman-news-url-01 + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/nntp.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/nntp.pm new file mode 100644 index 0000000000..80bd9429f9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/nntp.pm @@ -0,0 +1,10 @@ +package URI::nntp; # draft-gilman-news-url-01 + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::news'; + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/pop.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/pop.pm new file mode 100644 index 0000000000..ba824c01b0 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/pop.pm @@ -0,0 +1,71 @@ +package URI::pop; # RFC 2384 + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rlogin.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rlogin.pm new file mode 100644 index 0000000000..9dd5667486 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rlogin.pm @@ -0,0 +1,12 @@ +package URI::rlogin; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::_login'; + +sub default_port { 513 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rsync.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rsync.pm new file mode 100644 index 0000000000..fb6fc132f4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rsync.pm @@ -0,0 +1,14 @@ +package URI::rsync; # http://rsync.samba.org/ + +# rsync://[USER@]HOST[:PORT]/SRC + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent qw(URI::_server URI::_userpass); + +sub default_port { 873 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rtsp.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rtsp.pm new file mode 100644 index 0000000000..b06193ad3b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rtsp.pm @@ -0,0 +1,12 @@ +package URI::rtsp; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::http'; + +sub default_port { 554 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rtspu.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rtspu.pm new file mode 100644 index 0000000000..8ed9707da4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/rtspu.pm @@ -0,0 +1,12 @@ +package URI::rtspu; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::rtsp'; + +sub default_port { 554 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/sftp.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/sftp.pm new file mode 100644 index 0000000000..93ff152ed1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/sftp.pm @@ -0,0 +1,10 @@ +package URI::sftp; + +use strict; +use warnings; + +use parent 'URI::ssh'; + +our $VERSION = '1.76'; + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/sip.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/sip.pm new file mode 100644 index 0000000000..d793a3f57a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/sip.pm @@ -0,0 +1,85 @@ +# +# 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 qw(uri_unescape); + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/sips.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/sips.pm new file mode 100644 index 0000000000..4d5553b531 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/sips.pm @@ -0,0 +1,14 @@ +package URI::sips; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::sip'; + +sub default_port { 5061 } + +sub secure { 1 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/snews.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/snews.pm new file mode 100644 index 0000000000..9911046396 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/snews.pm @@ -0,0 +1,14 @@ +package URI::snews; # draft-gilman-news-url-01 + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::news'; + +sub default_port { 563 } + +sub secure { 1 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ssh.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ssh.pm new file mode 100644 index 0000000000..c4848f02f8 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/ssh.pm @@ -0,0 +1,16 @@ +package URI::ssh; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::_login'; + +# ssh://[USER@]HOST[:PORT]/SRC + +sub default_port { 22 } + +sub secure { 1 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/telnet.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/telnet.pm new file mode 100644 index 0000000000..4d95a6200c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/telnet.pm @@ -0,0 +1,12 @@ +package URI::telnet; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::_login'; + +sub default_port { 23 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/tn3270.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/tn3270.pm new file mode 100644 index 0000000000..cdcabbde85 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/tn3270.pm @@ -0,0 +1,12 @@ +package URI::tn3270; + +use strict; +use warnings; + +our $VERSION = '1.76'; + +use parent 'URI::_login'; + +sub default_port { 23 } + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/urn.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/urn.pm new file mode 100644 index 0000000000..bca02cb788 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/urn.pm @@ -0,0 +1,105 @@ +package URI::urn; # RFC 2141 + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/urn/isbn.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/urn/isbn.pm new file mode 100644 index 0000000000..9246345944 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/urn/isbn.pm @@ -0,0 +1,105 @@ +package URI::urn::isbn; # RFC 3187 + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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 2\n" + if Business::ISBN->VERSION < 2; + } + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/urn/oid.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/urn/oid.pm new file mode 100644 index 0000000000..2a4a0f9dcd --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/URI/urn/oid.pm @@ -0,0 +1,20 @@ +package URI::urn::oid; # RFC 2061 + +use strict; +use warnings; + +our $VERSION = '1.76'; + +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; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/WWW/RobotRules.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/WWW/RobotRules.pm new file mode 100644 index 0000000000..5dfc453934 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/WWW/RobotRules.pm @@ -0,0 +1,453 @@ +package WWW::RobotRules; + +$VERSION = "6.02"; +sub Version { $VERSION; } + +use strict; +use URI (); + + + +sub new { + my($class, $ua) = @_; + + # This ugly hack is needed to ensure backwards compatibility. + # The "WWW::RobotRules" class is now really abstract. + $class = "WWW::RobotRules::InCore" if $class eq "WWW::RobotRules"; + + my $self = bless { }, $class; + $self->agent($ua); + $self; +} + + +sub parse { + my($self, $robot_txt_uri, $txt, $fresh_until) = @_; + $robot_txt_uri = URI->new("$robot_txt_uri"); + my $netloc = $robot_txt_uri->host . ":" . $robot_txt_uri->port; + + $self->clear_rules($netloc); + $self->fresh_until($netloc, $fresh_until || (time + 365*24*3600)); + + my $ua; + my $is_me = 0; # 1 iff this record is for me + my $is_anon = 0; # 1 iff this record is for * + my $seen_disallow = 0; # watch for missing record separators + my @me_disallowed = (); # rules disallowed for me + my @anon_disallowed = (); # rules disallowed for * + + # blank lines are significant, so turn CRLF into LF to avoid generating + # false ones + $txt =~ s/\015\012/\012/g; + + # split at \012 (LF) or \015 (CR) (Mac text files have just CR for EOL) + for(split(/[\012\015]/, $txt)) { + + # Lines containing only a comment are discarded completely, and + # therefore do not indicate a record boundary. + next if /^\s*\#/; + + s/\s*\#.*//; # remove comments at end-of-line + + if (/^\s*$/) { # blank line + last if $is_me; # That was our record. No need to read the rest. + $is_anon = 0; + $seen_disallow = 0; + } + elsif (/^\s*User-Agent\s*:\s*(.*)/i) { + $ua = $1; + $ua =~ s/\s+$//; + + if ($seen_disallow) { + # treat as start of a new record + $seen_disallow = 0; + last if $is_me; # That was our record. No need to read the rest. + $is_anon = 0; + } + + if ($is_me) { + # This record already had a User-agent that + # we matched, so just continue. + } + elsif ($ua eq '*') { + $is_anon = 1; + } + elsif($self->is_me($ua)) { + $is_me = 1; + } + } + elsif (/^\s*Disallow\s*:\s*(.*)/i) { + unless (defined $ua) { + warn "RobotRules <$robot_txt_uri>: Disallow without preceding User-agent\n" if $^W; + $is_anon = 1; # assume that User-agent: * was intended + } + my $disallow = $1; + $disallow =~ s/\s+$//; + $seen_disallow = 1; + if (length $disallow) { + my $ignore; + eval { + my $u = URI->new_abs($disallow, $robot_txt_uri); + $ignore++ if $u->scheme ne $robot_txt_uri->scheme; + $ignore++ if lc($u->host) ne lc($robot_txt_uri->host); + $ignore++ if $u->port ne $robot_txt_uri->port; + $disallow = $u->path_query; + $disallow = "/" unless length $disallow; + }; + next if $@; + next if $ignore; + } + + if ($is_me) { + push(@me_disallowed, $disallow); + } + elsif ($is_anon) { + push(@anon_disallowed, $disallow); + } + } + elsif (/\S\s*:/) { + # ignore + } + else { + warn "RobotRules <$robot_txt_uri>: Malformed record: <$_>\n" if $^W; + } + } + + if ($is_me) { + $self->push_rules($netloc, @me_disallowed); + } + else { + $self->push_rules($netloc, @anon_disallowed); + } +} + + +# +# Returns TRUE if the given name matches the +# name of this robot +# +sub is_me { + my($self, $ua_line) = @_; + my $me = $self->agent; + + # See whether my short-name is a substring of the + # "User-Agent: ..." line that we were passed: + + if(index(lc($me), lc($ua_line)) >= 0) { + return 1; + } + else { + return ''; + } +} + + +sub allowed { + my($self, $uri) = @_; + $uri = URI->new("$uri"); + + return 1 unless $uri->scheme eq 'http' or $uri->scheme eq 'https'; + # Robots.txt applies to only those schemes. + + my $netloc = $uri->host . ":" . $uri->port; + + my $fresh_until = $self->fresh_until($netloc); + return -1 if !defined($fresh_until) || $fresh_until < time; + + my $str = $uri->path_query; + my $rule; + for $rule ($self->rules($netloc)) { + return 1 unless length $rule; + return 0 if index($str, $rule) == 0; + } + return 1; +} + + +# The following methods must be provided by the subclass. +sub agent; +sub visit; +sub no_visits; +sub last_visits; +sub fresh_until; +sub push_rules; +sub clear_rules; +sub rules; +sub dump; + + + +package WWW::RobotRules::InCore; + +use vars qw(@ISA); +@ISA = qw(WWW::RobotRules); + + + +sub agent { + my ($self, $name) = @_; + my $old = $self->{'ua'}; + if ($name) { + # Strip it so that it's just the short name. + # I.e., "FooBot" => "FooBot" + # "FooBot/1.2" => "FooBot" + # "FooBot/1.2 [http://foobot.int; foo@bot.int]" => "FooBot" + + $name = $1 if $name =~ m/(\S+)/; # get first word + $name =~ s!/.*!!; # get rid of version + unless ($old && $old eq $name) { + delete $self->{'loc'}; # all old info is now stale + $self->{'ua'} = $name; + } + } + $old; +} + + +sub visit { + my($self, $netloc, $time) = @_; + return unless $netloc; + $time ||= time; + $self->{'loc'}{$netloc}{'last'} = $time; + my $count = \$self->{'loc'}{$netloc}{'count'}; + if (!defined $$count) { + $$count = 1; + } + else { + $$count++; + } +} + + +sub no_visits { + my ($self, $netloc) = @_; + $self->{'loc'}{$netloc}{'count'}; +} + + +sub last_visit { + my ($self, $netloc) = @_; + $self->{'loc'}{$netloc}{'last'}; +} + + +sub fresh_until { + my ($self, $netloc, $fresh_until) = @_; + my $old = $self->{'loc'}{$netloc}{'fresh'}; + if (defined $fresh_until) { + $self->{'loc'}{$netloc}{'fresh'} = $fresh_until; + } + $old; +} + + +sub push_rules { + my($self, $netloc, @rules) = @_; + push (@{$self->{'loc'}{$netloc}{'rules'}}, @rules); +} + + +sub clear_rules { + my($self, $netloc) = @_; + delete $self->{'loc'}{$netloc}{'rules'}; +} + + +sub rules { + my($self, $netloc) = @_; + if (defined $self->{'loc'}{$netloc}{'rules'}) { + return @{$self->{'loc'}{$netloc}{'rules'}}; + } + else { + return (); + } +} + + +sub dump +{ + my $self = shift; + for (keys %$self) { + next if $_ eq 'loc'; + print "$_ = $self->{$_}\n"; + } + for (keys %{$self->{'loc'}}) { + my @rules = $self->rules($_); + print "$_: ", join("; ", @rules), "\n"; + } +} + + +1; + +__END__ + + +# Bender: "Well, I don't have anything else +# planned for today. Let's get drunk!" + +=head1 NAME + +WWW::RobotRules - database of robots.txt-derived permissions + +=head1 SYNOPSIS + + use WWW::RobotRules; + my $rules = WWW::RobotRules->new('MOMspider/1.0'); + + use LWP::Simple qw(get); + + { + my $url = "http://some.place/robots.txt"; + my $robots_txt = get $url; + $rules->parse($url, $robots_txt) if defined $robots_txt; + } + + { + my $url = "http://some.other.place/robots.txt"; + my $robots_txt = get $url; + $rules->parse($url, $robots_txt) if defined $robots_txt; + } + + # Now we can check if a URL is valid for those servers + # whose "robots.txt" files we've gotten and parsed: + if($rules->allowed($url)) { + $c = get $url; + ... + } + +=head1 DESCRIPTION + +This module parses F</robots.txt> files as specified in +"A Standard for Robot Exclusion", at +<http://www.robotstxt.org/wc/norobots.html> +Webmasters can use the F</robots.txt> file to forbid conforming +robots from accessing parts of their web site. + +The parsed files are kept in a WWW::RobotRules object, and this object +provides methods to check if access to a given URL is prohibited. The +same WWW::RobotRules object can be used for one or more parsed +F</robots.txt> files on any number of hosts. + +The following methods are provided: + +=over 4 + +=item $rules = WWW::RobotRules->new($robot_name) + +This is the constructor for WWW::RobotRules objects. The first +argument given to new() is the name of the robot. + +=item $rules->parse($robot_txt_url, $content, $fresh_until) + +The parse() method takes as arguments the URL that was used to +retrieve the F</robots.txt> file, and the contents of the file. + +=item $rules->allowed($uri) + +Returns TRUE if this robot is allowed to retrieve this URL. + +=item $rules->agent([$name]) + +Get/set the agent name. NOTE: Changing the agent name will clear the robots.txt +rules and expire times out of the cache. + +=back + +=head1 ROBOTS.TXT + +The format and semantics of the "/robots.txt" file are as follows +(this is an edited abstract of +<http://www.robotstxt.org/wc/norobots.html>): + +The file consists of one or more records separated by one or more +blank lines. Each record contains lines of the form + + <field-name>: <value> + +The field name is case insensitive. Text after the '#' character on a +line is ignored during parsing. This is used for comments. The +following <field-names> can be used: + +=over 3 + +=item User-Agent + +The value of this field is the name of the robot the record is +describing access policy for. If more than one I<User-Agent> field is +present the record describes an identical access policy for more than +one robot. At least one field needs to be present per record. If the +value is '*', the record describes the default access policy for any +robot that has not not matched any of the other records. + +The I<User-Agent> fields must occur before the I<Disallow> fields. If a +record contains a I<User-Agent> field after a I<Disallow> field, that +constitutes a malformed record. This parser will assume that a blank +line should have been placed before that I<User-Agent> field, and will +break the record into two. All the fields before the I<User-Agent> field +will constitute a record, and the I<User-Agent> field will be the first +field in a new record. + +=item Disallow + +The value of this field specifies a partial URL that is not to be +visited. This can be a full path, or a partial path; any URL that +starts with this value will not be retrieved + +=back + +Unrecognized records are ignored. + +=head1 ROBOTS.TXT EXAMPLES + +The following example "/robots.txt" file specifies that no robots +should visit any URL starting with "/cyberworld/map/" or "/tmp/": + + User-agent: * + Disallow: /cyberworld/map/ # This is an infinite virtual URL space + Disallow: /tmp/ # these will soon disappear + +This example "/robots.txt" file specifies that no robots should visit +any URL starting with "/cyberworld/map/", except the robot called +"cybermapper": + + User-agent: * + Disallow: /cyberworld/map/ # This is an infinite virtual URL space + + # Cybermapper knows where to go. + User-agent: cybermapper + Disallow: + +This example indicates that no robots should visit this site further: + + # go away + User-agent: * + Disallow: / + +This is an example of a malformed robots.txt file. + + # robots.txt for ancientcastle.example.com + # I've locked myself away. + User-agent: * + Disallow: / + # The castle is your home now, so you can go anywhere you like. + User-agent: Belle + Disallow: /west-wing/ # except the west wing! + # It's good to be the Prince... + User-agent: Beast + Disallow: + +This file is missing the required blank lines between records. +However, the intention is clear. + +=head1 SEE ALSO + +L<LWP::RobotUA>, L<WWW::RobotRules::AnyDBM_File> + +=head1 COPYRIGHT + + Copyright 1995-2009, Gisle Aas + Copyright 1995, Martijn Koster + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/WWW/RobotRules/AnyDBM_File.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/WWW/RobotRules/AnyDBM_File.pm new file mode 100644 index 0000000000..8daa68870f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/WWW/RobotRules/AnyDBM_File.pm @@ -0,0 +1,170 @@ +package WWW::RobotRules::AnyDBM_File; + +require WWW::RobotRules; +@ISA = qw(WWW::RobotRules); +$VERSION = "6.00"; + +use Carp (); +use AnyDBM_File; +use Fcntl; +use strict; + +=head1 NAME + +WWW::RobotRules::AnyDBM_File - Persistent RobotRules + +=head1 SYNOPSIS + + require WWW::RobotRules::AnyDBM_File; + require LWP::RobotUA; + + # Create a robot useragent that uses a diskcaching RobotRules + my $rules = WWW::RobotRules::AnyDBM_File->new( 'my-robot/1.0', 'cachefile' ); + my $ua = WWW::RobotUA->new( 'my-robot/1.0', 'me@foo.com', $rules ); + + # Then just use $ua as usual + $res = $ua->request($req); + +=head1 DESCRIPTION + +This is a subclass of I<WWW::RobotRules> that uses the AnyDBM_File +package to implement persistent diskcaching of F<robots.txt> and host +visit information. + +The constructor (the new() method) takes an extra argument specifying +the name of the DBM file to use. If the DBM file already exists, then +you can specify undef as agent name as the name can be obtained from +the DBM database. + +=cut + +sub new +{ + my ($class, $ua, $file) = @_; + Carp::croak('WWW::RobotRules::AnyDBM_File filename required') unless $file; + + my $self = bless { }, $class; + $self->{'filename'} = $file; + tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_CREAT|O_RDWR, 0640 + or Carp::croak("Can't open $file: $!"); + + if ($ua) { + $self->agent($ua); + } + else { + # Try to obtain name from DBM file + $ua = $self->{'dbm'}{"|ua-name|"}; + Carp::croak("No agent name specified") unless $ua; + } + + $self; +} + +sub agent { + my($self, $newname) = @_; + my $old = $self->{'dbm'}{"|ua-name|"}; + if (defined $newname) { + $newname =~ s!/?\s*\d+.\d+\s*$!!; # loose version + unless ($old && $old eq $newname) { + # Old info is now stale. + my $file = $self->{'filename'}; + untie %{$self->{'dbm'}}; + tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_TRUNC|O_RDWR, 0640; + %{$self->{'dbm'}} = (); + $self->{'dbm'}{"|ua-name|"} = $newname; + } + } + $old; +} + +sub no_visits { + my ($self, $netloc) = @_; + my $t = $self->{'dbm'}{"$netloc|vis"}; + return 0 unless $t; + (split(/;\s*/, $t))[0]; +} + +sub last_visit { + my ($self, $netloc) = @_; + my $t = $self->{'dbm'}{"$netloc|vis"}; + return undef unless $t; + (split(/;\s*/, $t))[1]; +} + +sub fresh_until { + my ($self, $netloc, $fresh) = @_; + my $old = $self->{'dbm'}{"$netloc|exp"}; + if ($old) { + $old =~ s/;.*//; # remove cleartext + } + if (defined $fresh) { + $fresh .= "; " . localtime($fresh); + $self->{'dbm'}{"$netloc|exp"} = $fresh; + } + $old; +} + +sub visit { + my($self, $netloc, $time) = @_; + $time ||= time; + + my $count = 0; + my $old = $self->{'dbm'}{"$netloc|vis"}; + if ($old) { + my $last; + ($count,$last) = split(/;\s*/, $old); + $time = $last if $last > $time; + } + $count++; + $self->{'dbm'}{"$netloc|vis"} = "$count; $time; " . localtime($time); +} + +sub push_rules { + my($self, $netloc, @rules) = @_; + my $cnt = 1; + $cnt++ while $self->{'dbm'}{"$netloc|r$cnt"}; + + foreach (@rules) { + $self->{'dbm'}{"$netloc|r$cnt"} = $_; + $cnt++; + } +} + +sub clear_rules { + my($self, $netloc) = @_; + my $cnt = 1; + while ($self->{'dbm'}{"$netloc|r$cnt"}) { + delete $self->{'dbm'}{"$netloc|r$cnt"}; + $cnt++; + } +} + +sub rules { + my($self, $netloc) = @_; + my @rules = (); + my $cnt = 1; + while (1) { + my $rule = $self->{'dbm'}{"$netloc|r$cnt"}; + last unless $rule; + push(@rules, $rule); + $cnt++; + } + @rules; +} + +sub dump +{ +} + +1; + +=head1 SEE ALSO + +L<WWW::RobotRules>, L<LWP::RobotUA> + +=head1 AUTHORS + +Hakan Ardo E<lt>hakan@munin.ub2.lu.se>, Gisle Aas E<lt>aas@sn.no> + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API.pm new file mode 100644 index 0000000000..e353e2eb32 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API.pm @@ -0,0 +1,1474 @@ +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API - Perl Win32 API Import Facility +# +# Author: Aldo Calpini <dada@perl.it> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# +# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu> +# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at> +# +####################################################################### + +package Win32::API; + use strict; + use warnings; +BEGIN { + require Exporter; # to export the constants to the main:: space + + sub ISCYG (); + if($^O eq 'cygwin') { + BEGIN{warnings->unimport('uninitialized')} + die "Win32::API on Cygwin requires the cygpath tool on PATH" + if index(`cygpath --help`,'Usage: cygpath') == -1; + require File::Basename; + eval "sub ISCYG () { 1 }"; + } else { + eval "sub ISCYG () { 0 }"; + } + + + use vars qw( $DEBUG $sentinal @ISA @EXPORT_OK $VERSION ); + + @ISA = qw( Exporter ); + @EXPORT_OK = qw( ReadMemory IsBadReadPtr MoveMemory + WriteMemory SafeReadWideCString ); # symbols to export on request + + use Scalar::Util qw( looks_like_number weaken); + + sub ERROR_NOACCESS () { 998 } + sub ERROR_NOT_ENOUGH_MEMORY () { 8 } + sub ERROR_INVALID_PARAMETER () { 87 } + sub APICONTROL_CC_STD () { 0 } + sub APICONTROL_CC_C () { 1 } + sub APICONTROL_CC_mask () { 0x7 } + sub APICONTROL_UseMI64 () { 0x8 } + sub APICONTROL_is_more () { 0x10 } + sub APICONTROL_has_proto() { 0x20 } + eval ' *Win32::API::Type::PTRSIZE = *Win32::API::More::PTRSIZE = *PTRSIZE = sub () { '.length(pack('p', undef)).' };'. + #Win64 added in 5.7.3 + ' *Win32::API::Type::IVSIZE = *Win32::API::More::IVSIZE = *IVSIZE = sub () { '.length(pack($] >= 5.007003 ? 'J' : 'I' ,0)).' };'. + ' *Win32::API::Type::DEBUGCONST = *Win32::API::Struct::DEBUGCONST = *DEBUGCONST = sub () { '.(!!$DEBUG+0).' };' +} + +sub DEBUG { + #checking flag redundant now, but keep in case of an accidental unprotected call + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } + else { + return 0; + } +} + +use Win32::API::Type (); +use Win32::API::Struct (); + +####################################################################### +# STATIC OBJECT PROPERTIES +# +#### some package-global hash to +#### keep track of the imported +#### libraries and procedures +my %Libraries = (); +my %Procedures = (); + + +####################################################################### +# dynamically load in the API extension module. +# BEGIN required for constant subs in BOOT: +BEGIN { + $VERSION = '0.84'; + require XSLoader; + XSLoader::load 'Win32::API', $VERSION; +} + +####################################################################### +# PUBLIC METHODS +# +sub new { + die "Win32::API/More::new/Import is a class method that takes 2 to 6 parameters, see POD" + if @_ < 3 || @_ > 7; + my ($class, $dll, $hproc, $ccnum, $outnum) = (shift, shift); + if(! defined $dll){ + $hproc = shift; + } + my ($proc, $in, $out, $callconvention) = @_; + my ($hdll, $freedll, $proto, $stackunwind) = (0, 0, 0, 0); + my $self = {}; + if(! defined $hproc){ + if (ISCYG() and $dll ne File::Basename::basename($dll)) { + + # need to convert $dll to win32 path + # isn't there an API for this? + my $newdll = `cygpath -w "$dll"`; + chomp $newdll; + DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n" if DEBUGCONST; + $dll = $newdll; + } + + #### avoid loading a library more than once + if (exists($Libraries{$dll})) { + DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n" if DEBUGCONST; + $hdll = $Libraries{$dll}; + } + else { + DEBUG "Win32::API::new: Loading library '$dll'\n" if DEBUGCONST; + $hdll = Win32::API::LoadLibrary($dll); + $freedll = 1; + # $Libraries{$dll} = $hdll; + } + + #### if the dll can't be loaded, set $! to Win32's GetLastError() + if (!$hdll) { + $! = Win32::GetLastError(); + DEBUG "FAILED Loading library '$dll': $^E\n" if DEBUGCONST; + return undef; + } + } + else{ + if(!looks_like_number($hproc) || IsBadReadPtr($hproc, 4)){ + Win32::SetLastError(ERROR_NOACCESS); + DEBUG "FAILED Function pointer '$hproc' is not a valid memory location\n" if DEBUGCONST; + return undef; + } + } + #### determine if we have a prototype or not, outtype is for future use in XS + if ((not defined $in) and (not defined $out)) { + ($proc, $self->{in}, $self->{intypes}, $outnum, $self->{outtype}, + $ccnum) = parse_prototype($class, $proc); + if( ! $proc ){ + Win32::API::FreeLibrary($hdll) if $freedll; + Win32::SetLastError(ERROR_INVALID_PARAMETER); + return undef; + } + $proto = 1; + } + else { + $self->{in} = []; + my $self_in = $self->{in}; #avoid hash derefing + if (ref($in) eq 'ARRAY') { + foreach (@$in) { + push(@{$self_in}, $class->type_to_num($_)); + } + } + else { + my @in = split '', $in; + foreach (@in) { + push(@{$self_in}, $class->type_to_num($_)); + } + }#'V' must be one and ONLY letter for "in" + foreach(@{$self_in}){ + if($_ == 0){ + if(@{$self_in} != 1){ + Win32::API::FreeLibrary($hdll) if $freedll; + die "Win32::API 'V' for in prototype must be the only parameter"; + } else {undef(@{$self_in});} #empty arr, as if in param was "" + } + } + $outnum = $class->type_to_num($out, 1); + $ccnum = calltype_to_num($callconvention); + } + + if(!$hproc){ #if not non DLL func + #### first try to import the function of given name... + $hproc = Win32::API::GetProcAddress($hdll, $proc); + + #### ...then try appending either A or W (for ASCII or Unicode) + if (!$hproc) { + my $tproc = $proc; + $tproc .= (IsUnicode() ? "W" : "A"); + + # print "Win32::API::new: procedure not found, trying '$tproc'...\n"; + $hproc = Win32::API::GetProcAddress($hdll, $tproc); + } + + #### ...if all that fails, give up, $! setting is back compat, $! is deprecated + if (!$hproc) { + my $err = $! = Win32::GetLastError(); + DEBUG "FAILED GetProcAddress for Proc '$proc': $^E\n" if DEBUGCONST; + Win32::API::FreeLibrary($hdll) if $freedll; + Win32::SetLastError($err); + return undef; + } + DEBUG "GetProcAddress('$proc') = '$hproc'\n" if DEBUGCONST; + } + else { + DEBUG "Using non-DLL function pointer '$hproc' for '$proc'\n" if DEBUGCONST; + } + if(PTRSIZE == 4 && $ccnum == APICONTROL_CC_C) {#fold out on WIN64 + #calculate add to ESP amount, in units of 4, will be *4ed later + $stackunwind += $_ == T_QUAD || $_ == T_DOUBLE ? 2 : 1 for(@{$self->{in}}); + if($stackunwind > 0xFFFF) { + goto too_many_in_params; + } + } + # if a prototype has 8 byte types on 32bit, $stackunwind will be higher than + # length of {in} letter array, so 2 different checks need to be done + if($#{$self->{in}} > 0xFFFF) { + too_many_in_params: + DEBUG "FAILED This function has too many parameters (> ~65535) \n" if DEBUGCONST; + Win32::API::FreeLibrary($hdll) if $freedll; + Win32::SetLastError(ERROR_NOT_ENOUGH_MEMORY); + return undef; + } + #### ok, let's stuff the object + $self->{procname} = $proc; + $self->{dll} = $hdll; + $self->{dllname} = $dll; + + $outnum &= ~T_FLAG_NUMERIC; + my $control; + $self->{weakapi} = \$control; + weaken($self->{weakapi}); + $control = pack( 'L' + .'L' + .(PTRSIZE == 8 ? 'Q' : 'L') + .(PTRSIZE == 8 ? 'Q' : 'L') + .(PTRSIZE == 8 ? 'Q' : 'L') + .(PTRSIZE == 8 ? '' : 'L') + ,($class eq "Win32::API::More" ? APICONTROL_is_more : 0) + | ($proto ? APICONTROL_has_proto : 0) + | $ccnum + | (PTRSIZE == 8 ? 0 : $stackunwind << 8) + | $outnum << 24 + , scalar(@{$self->{in}}) * PTRSIZE #in param count, in SV * units + , $hproc + , \($self->{weakapi})+0 #weak api obj ref + , (exists $self->{intypes} ? ($self->{intypes})+0 : 0) + , 0); #padding to align to 8 bytes on 32 bit only + #align to 16 bytes + $control .= "\x00" x ((((length($control)+ 15) >> 4) << 4)-length($control)); + #make a APIPARAM template array + my ($i, $arr_end) = (0, scalar(@{$self->{in}})); + for(; $i< $arr_end; $i++) { + my $tin = $self->{in}[$i]; + #unsigned meaningless no sign vs zero extends are done bc uv/iv is + #the biggest native integer on the cpu, big to small is truncation + #numeric is implemented as T_NUMCHAR for in, keeps asm jumptable clean + $tin &= ~(T_FLAG_UNSIGNED|T_FLAG_NUMERIC); + $tin--; #T_VOID doesn't exist as in param in XS + #put index of param array slice in unused space for croaks, why not? + $control .= "\x00" x 8 . pack('CCSSS', $tin, 0, 0, $i, $i+1); + } + _Align($control, 16); #align the whole PVX to 16 bytes for SSE moves + + #### keep track of the imported function + if(defined $dll){ + $Libraries{$dll} = $hdll; + $Procedures{$dll}++; + } + DEBUG "Object blessed!\n" if DEBUGCONST; + + my $ref = bless(\$control, $class); + SetMagicSV($ref, $self); + return $ref; +} + +sub Import { + my $closure = shift->new(@_) + or return undef; + my $procname = ${Win32::API::GetMagicSV($closure)}{procname}; + #dont allow "sub main:: {0;}" + Win32::SetLastError(ERROR_INVALID_PARAMETER), return undef if $procname eq ''; + _ImportXS($closure, (caller)[0].'::'.$procname); + return $closure; +} + +####################################################################### +# PRIVATE METHODS +# +sub DESTROY { + my ($self) = GetMagicSV($_[0]); + + return if ! defined $self->{dllname}; + #### decrease this library's procedures reference count + $Procedures{$self->{dllname}}--; + + #### once it reaches 0, free it + if ($Procedures{$self->{dllname}} == 0) { + DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n" if DEBUGCONST; + Win32::API::FreeLibrary($Libraries{$self->{dllname}}); + delete($Libraries{$self->{dllname}}); + } +} + +# Convert calling convention string (_cdecl|__stdcall) +# to a C const. Unknown counts as __stdcall +# +sub calltype_to_num { + my $type = shift; + + if (!$type || $type eq "__stdcall" || $type eq "WINAPI" || $type eq "NTAPI" + || $type eq "CALLBACK" ) { + return APICONTROL_CC_STD; + } + elsif ($type eq "_cdecl" || $type eq "__cdecl" || $type eq "WINAPIV") { + return APICONTROL_CC_C; + } + else { + warn "unknown calling convention: '$type'"; + return APICONTROL_CC_STD; + } +} + + +sub type_to_num { + die "wrong class" if shift ne "Win32::API"; + my $type = shift; + my $out = shift; + my ($num, $numeric); + if(index($type, 'num', 0) == 0){ + substr($type, 0, length('num'), ''); + $numeric = 1; + } + else{ + $numeric = 0; + } + + if ( $type eq 'N' + or $type eq 'n' + or $type eq 'l' + or $type eq 'L' + or ( PTRSIZE == 8 and $type eq 'Q' || $type eq 'q')) + { + $num = T_NUMBER; + } + elsif ($type eq 'P' + or $type eq 'p') + { + $num = T_POINTER; + } + elsif ($type eq 'I' + or $type eq 'i') + { + $num = T_INTEGER; + } + elsif ($type eq 'f' + or $type eq 'F') + { + $num = T_FLOAT; + } + elsif ($type eq 'D' + or $type eq 'd') + { + $num = T_DOUBLE; + } + elsif ($type eq 'c' + or $type eq 'C') + { + $num = $numeric ? T_NUMCHAR : T_CHAR; + } + elsif (PTRSIZE == 4 and $type eq 'q' || $type eq 'Q') + { + $num = T_QUAD; + } + elsif($type eq '>'){ + die "Win32::API does not support pass by copy structs as function arguments"; + } + else { + $num = T_VOID; #'V' takes this branch, which is T_VOID in C + }#not valid return types of the C func + if(defined $out) {#b/B remains private/undocumented + die "Win32::API invalid return type, structs and ". + "callbacks as return types not supported" + if($type =~ m/^s|S|t|T|b|B|k|K$/); + } + else {#in type + if ($type eq 's' or $type eq 'S' or $type eq 't' or $type eq 'T') + { + $num = T_STRUCTURE; + } + elsif ($type eq 'b' + or $type eq 'B') + { + $num = T_POINTERPOINTER; + } + elsif ($type eq 'k' + or $type eq 'K') + { + $num = T_CODE; + } + } + $num |= T_FLAG_NUMERIC if $numeric; + return $num; +} + +package Win32::API::More; + +use vars qw( @ISA ); +@ISA = qw ( Win32::API ); +sub type_to_num { + die "wrong class" if shift ne "Win32::API::More"; + my $type = shift; + my $out = shift; + my ($num, $numeric); + if(index($type, 'num', 0) == 0){ + substr($type, 0, length('num'), ''); + $numeric = 1; + } + else{ + $numeric = 0; + } + + if ( $type eq 'N' + or $type eq 'n' + or $type eq 'l' + or $type eq 'L' + or ( PTRSIZE == 8 and $type eq 'Q' || $type eq 'q') + or (! $out and # in XS short 'in's are interger/numbers code + $type eq 'S' + || $type eq 's')) + { + $num = Win32::API::T_NUMBER; + if(defined $out && ($type eq 'N' || $type eq 'L' + || $type eq 'S' || $type eq 'Q')){ + $num |= Win32::API::T_FLAG_UNSIGNED; + } + } + elsif ($type eq 'P' + or $type eq 'p') + { + $num = Win32::API::T_POINTER; + } + elsif ($type eq 'I' + or $type eq 'i') + { + $num = Win32::API::T_INTEGER; + if(defined $out && $type eq 'I'){ + $num |= Win32::API::T_FLAG_UNSIGNED; + } + } + elsif ($type eq 'f' + or $type eq 'F') + { + $num = Win32::API::T_FLOAT; + } + elsif ($type eq 'D' + or $type eq 'd') + { + $num = Win32::API::T_DOUBLE; + } + elsif ($type eq 'c' + or $type eq 'C') + { + $num = $numeric ? Win32::API::T_NUMCHAR : Win32::API::T_CHAR; + if(defined $out && $type eq 'C'){ + $num |= Win32::API::T_FLAG_UNSIGNED; + } + } + elsif (PTRSIZE == 4 and $type eq 'q' || $type eq 'Q') + { + $num = Win32::API::T_QUAD; + if(defined $out && $type eq 'Q'){ + $num |= Win32::API::T_FLAG_UNSIGNED; + } + } + elsif ($type eq 's') #4 is only used for out params + { + $num = Win32::API::T_SHORT; + } + elsif ($type eq 'S') + { + $num = Win32::API::T_SHORT | Win32::API::T_FLAG_UNSIGNED; + } + elsif($type eq '>'){ + die "Win32::API does not support pass by copy structs as function arguments"; + } + else { + $num = Win32::API::T_VOID; #'V' takes this branch, which is T_VOID in C + } #not valid return types of the C func + if(defined $out) {#b/B remains private/undocumented + die "Win32::API invalid return type, structs and ". + "callbacks as return types not supported" + if($type =~ m/^t|T|b|B|k|K$/); + } + else {#in type + if ( $type eq 't' + or $type eq 'T') + { + $num = Win32::API::T_STRUCTURE; + } + elsif ($type eq 'b' + or $type eq 'B') + { + $num = Win32::API::T_POINTERPOINTER; + } + elsif ($type eq 'k' + or $type eq 'K') + { + $num = Win32::API::T_CODE; + } + } + $num |= Win32::API::T_FLAG_NUMERIC if $numeric; + return $num; +} +package Win32::API; + +sub parse_prototype { + my ($class, $proto) = @_; + + my @in_params = (); + my @in_types = (); #one day create a BNF-ish formal grammer parser here + if ($proto =~ /^\s*((?:(?:un|)signed\s+|) #optional signedness + \S+)(?:\s*(\*)\s*|\s+) #type and maybe a * + (?:(\w+)\s+)? # maybe a calling convention + (\S+)\s* #func name + \(([^\)]*)\) #param list + /x) { + my $ret = $1.(defined($2)?$2:''); + my $callconvention = $3; + my $proc = $4; + my $params = $5; + + $params =~ s/^\s+//; + $params =~ s/\s+$//; + + DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc if DEBUGCONST; + DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params if DEBUGCONST; + + foreach my $param (split(/\s*,\s*/, $params)) { + my ($type, $name); + #match "in_t* _var" "in_t * _var" "in_t *_var" "in_t _var" "in_t*_var" supported + #unsigned or signed or nothing as prefix supported + # "in_t ** _var" and "const in_t* var" not supported + if ($param =~ /((?:(?:un|)signed\s+|)\w+)(?:\s*(\*)\s*|\s+)(\w+)/) { + ($type, $name) = ($1.(defined($2)? $2:''), $3); + } + { + BEGIN{warnings->unimport('uninitialized')} + if($type eq '') {goto BADPROTO;} #something very wrong, bail out + } + my $packing = Win32::API::Type::packing($type); + if (defined $packing && $packing ne '>') { + if (Win32::API::Type::is_pointer($type)) { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, + $packing, + $class->type_to_num('P') if DEBUGCONST; + push(@in_params, $class->type_to_num('P')); + } + else { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, + $packing, + $class->type_to_num(Win32::API::Type->packing($type, undef, 1)) if DEBUGCONST; + push(@in_params, $class->type_to_num(Win32::API::Type->packing($type, undef, 1))); + } + } + elsif (Win32::API::Struct::is_known($type)) { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, 'T', Win32::API::More->type_to_num('T') if DEBUGCONST; + push(@in_params, Win32::API::More->type_to_num('T')); + } + else { + warn + "Win32::API::parse_prototype: WARNING unknown parameter type '$type'"; + push(@in_params, $class->type_to_num('I')); + } + push(@in_types, $type); + + } + DEBUG "parse_prototype: IN=[ @in_params ]\n" if DEBUGCONST; + + + if (Win32::API::Type::is_known($ret)) { + if (Win32::API::Type::is_pointer($ret)) { + DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", + $ret, + Win32::API::Type->packing($ret), + $class->type_to_num('P') if DEBUGCONST; + return ($proc, \@in_params, \@in_types, $class->type_to_num('P', 1), + $ret, calltype_to_num($callconvention)); + } + else { + DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", + $ret, + Win32::API::Type->packing($ret), + $class->type_to_num(Win32::API::Type->packing($ret, undef, 1), 1) if DEBUGCONST; + return ( + $proc, \@in_params, \@in_types, + $class->type_to_num(Win32::API::Type->packing($ret, undef, 1), 1), + $ret, calltype_to_num($callconvention) + ); + } + } + else { + warn + "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'"; + return ($proc, \@in_params, \@in_types, $class->type_to_num('I', 1), + $ret, calltype_to_num($callconvention)); + } + + } + else { + BADPROTO: + warn "Win32::API::parse_prototype: bad prototype '$proto'"; + return undef; + } +} + +# +# XXX hack, see the proper implementation in TODO +# The point here is don't let fork children free the parent's DLLs. +# CLONE runs on ::API and ::More, that's bad and causes a DLL leak, make sure +# CLONE dups the DLL handles only once per CLONE +# GetModuleHandleEx was not used since that is a WinXP and newer function, not Win2K. +# GetModuleFileName was used to get full DLL pathname incase SxS/multiple DLLs +# with same file name exist in the process. Even if the dll was loaded as a +# relative path initially, later SxS can load a DLL with a different full path +# yet same file name, and then LoadLibrary'ing the original relative path +# might increase the refcount on the wrong DLL or return a different HMODULE +sub CLONE { + return if $_[0] ne "Win32::API"; + + _my_cxt_clone(); + foreach( keys %Libraries){ + if($Libraries{$_} != Win32::API::LoadLibrary(Win32::API::GetModuleFileName($Libraries{$_}))){ + die "Win32::API::CLONE unable to clone DLL \"$Libraries{$_}\" Unicode Problem??"; + } + } +} + +1; + +__END__ + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API - Perl Win32 API Import Facility + +=head1 SYNOPSIS + + #### Method 1: with prototype + + use Win32::API; + $function = Win32::API::More->new( + 'mydll', 'int sum_integers(int a, int b)' + ); + #### $^E is non-Cygwin only + die "Error: $^E" if ! $function; + #### or on Cygwin and non-Cygwin + die "Error: ".(Win32::FormatMessage(Win32::GetLastError())) if ! $function; + #### + $return = $function->Call(3, 2); + + #### Method 2: with prototype and your function pointer + + use Win32::API; + $function = Win32::API::More->new( + undef, 38123456, 'int name_ignored(int a, int b)' + ); + die "Error: $^E" if ! $function; #$^E is non-Cygwin only + $return = $function->Call(3, 2); + + #### Method 3: with parameter list + + use Win32::API; + $function = Win32::API::More->new( + 'mydll', 'sum_integers', 'II', 'I' + ); + die "Error: $^E" if ! $function; #$^E is non-Cygwin only + $return = $function->Call(3, 2); + + #### Method 4: with parameter list and your function pointer + + use Win32::API; + $function = Win32::API::More->new( + undef, 38123456, 'name_ignored', 'II', 'I' + ); + die "Error: $^E" if ! $function; #$^E is non-Cygwin only + $return = $function->Call(3, 2); + + #### Method 5: with Import (slightly faster than ->Call) + + use Win32::API; + $function = Win32::API::More->Import( + 'mydll', 'int sum_integers(int a, int b)' + ); + die "Error: $^E" if ! $function; #$^E is non-Cygwin only + $return = sum_integers(3, 2); + + +=for LATER-UNIMPLEMENTED + #### or + use Win32::API mydll => 'int sum_integers(int a, int b)'; + $return = sum_integers(3, 2); + + +=head1 ABSTRACT + +With this module you can import and call arbitrary functions +from Win32's Dynamic Link Libraries (DLL) or arbitrary functions for +which you have a pointer (MS COM, etc), without having +to write an XS extension. Note, however, that this module +can't do everything. In fact, parameters input and output is +limited to simpler cases. + +A regular B<XS> extension is always safer and faster anyway. + +The current version of Win32::API is always available at your +nearest CPAN mirror: + + http://search.cpan.org/dist/Win32-API/ + +A short example of how you can use this module (it just gets the PID of +the current process, eg. same as Perl's internal C<$$>): + + use Win32::API; + Win32::API::More->Import("kernel32", "int GetCurrentProcessId()"); + $PID = GetCurrentProcessId(); + +Starting with 0.69. Win32::API initiated objects are deprecated due to numerous +bugs and improvements, use Win32::API::More now. The use statement remains +as C<use Win32::API;>. + +The possibilities are nearly infinite (but not all are good :-). +Enjoy it. + +=head1 DESCRIPTION + +To use this module put the following line at the beginning of your script: + + use Win32::API; + +You can now use the C<new()> function of the Win32::API module to create a +new Win32::API::More object (see L<IMPORTING A FUNCTION>) and then invoke the +C<Call()> method on this object to perform a call to the imported API +(see L<CALLING AN IMPORTED FUNCTION>). + +Starting from version 0.40, you can also avoid creating a Win32::API::More object +and instead automatically define a Perl sub with the same name of the API +function you're importing. This 2nd way using C<Import> to create a sub instead +of an object is slightly faster than doing C<-E<gt>Call()>. The details of the +API definitions are the same, just the method name is different: + + my $GetCurrentProcessId = Win32::API::More->new( + "kernel32", "int GetCurrentProcessId()" + ); + die "Failed to import GetCurrentProcessId" if !$GetCurrentProcessId; + $GetCurrentProcessId->UseMI64(1); + my $PID = $GetCurrentProcessId->Call(); + + #### vs. + + my $UnusedGCPI = Win32::API::More->Import("kernel32", "int GetCurrentProcessId()"); + die "Failed to import GetCurrentProcessId" if !$UnusedGCPI; + $UnusedGCPI->UseMI64(1); + $PID = GetCurrentProcessId(); + +Note that C<Import> returns the Win32::API obj on success and false on failure +(in which case you can check the content of C<$^E>). This allows some settings +to be set through method calls that can't be specified as a parameter to Import, +yet still have the convience of not writing C<-E<gt>Call()>. The Win32::API obj +does not need to be assigned to a scalar. C<unless(Win32::API::More-E<gt>Import> +is fine. Prior to v0.76_02, C<Import> returned returned 1 on success and 0 on +failure. + +=head2 IMPORTING A FUNCTION + +You can import a function from a 32 bit Dynamic Link Library (DLL) file with +the C<new()> function or, starting in 0.69, supply your own function pointer. +This will create a Perl object that contains the reference to that function, +which you can later C<Call()>. + +What you need to know is the prototype of the function you're going to import +(eg. the definition of the function expressed in C syntax). + +Starting from version 0.40, there are 2 different approaches for this step: +(the preferred) one uses the prototype directly, while the other (now deprecated) +one uses Win32::API's internal representation for parameters. + +=head2 IMPORTING A FUNCTION BY PROTOTYPE + +You need to pass 2 or 3 parameters: + +=over 4 + +=item 1. + +The name of the library from which you want to import the function. If the +name is undef, you are requesting a object created from a function pointer, +and must supply item 2. + +=item 2. + +This parameter is optional, most people should skip it, skip does not mean +supplying undef. Supply a function pointer in the format of number 1234, not +string "\x01\x02\x03\x04". Undef will be returned if the pointer is not +readable, L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E"> +will be C<ERROR_NOACCESS>. + +=item 3. + +The C prototype of the function. If you are using a function pointer, the name +of the function should be something "friendly" to you and no attempt is made +to retrieve such a name from any DLL's export table. This name for a function +pointer is also used for Import(). + +=back + +When calling a function imported with a prototype, if you pass an +undefined Perl scalar to one of its arguments, it will be +automatically turned into a C C<NULL> value. + +See L<Win32::API::Type> for a list of the known parameter types and +L<Win32::API::Struct> for information on how to define a structure. + +If a prototype type is exactly C<signed char> or C<unsigned char> for an +"in" parameter or the return parameter, and for "in" parameters only +C<signed char *> or C<unsigned char *> the parameters will be treated as a +number, C<0x01>, not C<"\x01">. "UCHAR" is not "unsigned char". Change the +C prototype if you want numeric handling for your chars. + +=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST + +You need to pass at minimum 4 parameters. + +=over 4 + +=item 1. +The name of the library from which you want to import the function. + +=item 2. +This parameter is optional, most people should skip it, skip does not mean +supplying undef. Supply a function pointer in the format of number C<1234>, +not string C<"\x01\x02\x03\x04">. Undef will be returned if the pointer is not +readable, L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E"> +will be C<ERROR_NOACCESS>. + +=item 3. +The name of the function (as exported by the library) or for function pointers +a name that is "friendly" to you. This name for a function pointer is also used +for Import(). No attempt is made to retrieve such a name from any DLL's export +table in the 2nd case. + +=item 4. +The number and types of the arguments the function expects as input. + +=item 5. +The type of the value returned by the function. + +=item 6. +And optionally you can specify the calling convention, this defaults to +'__stdcall', alternatively you can specify '_cdecl' or '__cdecl' (API > v0.68) +or (API > v0.70_02) 'WINAPI', 'NTAPI', 'CALLBACK' (__stdcall), 'WINAPIV' (__cdecl) . +False is __stdcall. Vararg functions are always cdecl. MS DLLs are typically +stdcall. Non-MS DLLs are typically cdecl. If API > v0.75, mixing up the calling +convention on 32 bits is detected and Perl will C<croak> an error message and +C<die>. + +=back + +To better explain their meaning, let's suppose that we +want to import and call the Win32 API C<GetTempPath()>. +This function is defined in C as: + + DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer ); + +This is documented in the B<Win32 SDK Reference>; you can look +for it on the Microsoft's WWW site, or in your C compiler's +documentation, if you own one. + +=over 4 + +=item B<1.> + +The first parameter is the name of the library file that +exports this function; our function resides in the F<KERNEL32.DLL> +system file. + +When specifying this name as parameter, the F<.DLL> extension +is implicit, and if no path is given, the file is searched through +a couple of directories, including: + +=over 4 + +=item 1. The directory from which the application loaded. + +=item 2. The current directory. + +=item 3. The Windows system directory (eg. c:\windows\system or system32). + +=item 4. The Windows directory (eg. c:\windows). + +=item 5. The directories that are listed in the PATH environment variable. + +=back + +You may, but don't have to write F<C:\windows\system\kernel32.dll>; or +F<kernel32.dll>, only F<kernel32> is enough: + + $GetTempPath = new Win32::API::More('kernel32', ... + +=item B<2.> + +Since this function is from a DLL, skip the 2nd parameter. Skip does not +mean supplying undef. + +=item B<3.> + +Now for the real second parameter: the name of the function. +It must be written exactly as it is exported +by the library (case is significant here). +If you are using Windows 95 or NT 4.0, you can use the B<Quick View> +command on the DLL file to see the function it exports. +Remember that you can only import functions from 32 or 64 bit DLLs: +in Quick View, the file's characteristics should report +somewhere "32 bit word machine"; as a rule of thumb, +when you see that all the exported functions are in upper case, +the DLL is a 16 bit one and you can't use it. You also can not load a 32 bit +DLL into a 64 bit Perl, or vice versa. If you try, C<new>/C<Import> will fail +and C<$^E> will be C<ERROR_BAD_EXE_FORMAT>. +If their capitalization looks correct, then it's probably a 32 bit +DLL. If you have Platform SDK or Visual Studio, you can use the Dumpbin +tool. Call it as C<dumpbin /exports name_of_dll.dll> on the command line. +If you have Mingw GCC, use objdump as +C<objdump -x name_of_dll.dll E<gt> dlldump.txt> and search for the word exports +in the very long output. + +Also note that many Win32 APIs are exported twice, with the addition of +a final B<A> or B<W> to their name, for - respectively - the ASCII +and the Unicode version. +When a function name is not found, Win32::API will actually append +an B<A> to the name and try again; if the extension is built on a +Unicode system, then it will try with the B<W> instead. +So our function name will be: + + $GetTempPath = new Win32::API::More('kernel32', 'GetTempPath', ... + +In our case C<GetTempPath> is really loaded as C<GetTempPathA>. + +=item B<4.> + +The third parameter, the input parameter list, specifies how many +arguments the function wants, and their types. It can be passed as +a single string, in which each character represents one parameter, +or as a list reference. The following forms are valid: + + "abcd" + [a, b, c, d] + \@LIST + +But those are not: + + (a, b, c, d) + @LIST + +The number of characters, or elements in the list, specifies the number +of parameters, and each character or element specifies the type of an +argument; allowed types are: + +=over 4 + +=item C<I>: +value is an unsigned integer (unsigned int) + +=item C<i>: +value is an signed integer (signed int or int) + +=item C<N>: +value is a unsigned pointer sized number (unsigned long) + +=item C<n>: +value is a signed pointer sized number (signed long or long) + +=item C<Q>: +value is a unsigned 64 bit integer number (unsigned long long, unsigned __int64) +See next item for details. + +=item C<q>: +value is a signed 64 bit integer number (long long, __int64) +If your perl has 'Q'/'q' quads support for L<perlfunc/pack> then Win32::API's 'q' +is a normal perl numeric scalar. All 64 bit Perls have quad support. Almost no +32 bit Perls have quad support. On 32 bit Perls, without quad support, +Win32::API's 'q'/'Q' letter is a packed 8 byte string. So C<0x8000000050000000> +from a perl with native Quad support would be written as +C<"\x00\x00\x00\x50\x00\x00\x00\x80"> on a 32 bit Perl without Quad support. +To improve the use of 64 bit integers with Win32::API on a 32 bit Perl without +Quad support, there is a per Win32::API::* object setting called L</UseMI64> +that causes all quads to be accepted as, and returned as L<Math::Int64> objects. +For "in" params in Win32::API and Win32::API::More and "out" in +Win32::API::Callback only, if the argument is a reference, it will automatically +be treated as a Math::Int64 object without having to previously call +L</UseMI64>. + +=item C<F>: +value is a single precision (4 bytes) floating point number (float) + +=item C<D>: +value is a double precision (8 bytes) floating point number (double) + +=item C<S>: +value is a unsigned short (unsigned short) + +=item C<s>: +value is a signed short (signed short or short) + +=item C<C>: +value is a char (char), pass as C<"a">, not C<97>, C<"abc"> will truncate to C<"a"> + +=item C<P>: +value is a pointer (to a string, structure, etc...) +padding out the buffer string is required, buffer overflow detection is +performed. Pack and unpack the data yourself. If P is a return type, only +null terminated strings or NULL pointer are supported. If P is an in type, NULL +is integer C<0>. C<undef>, C<"0">, and C<""+0> are not integer C<0>, C<"0"+0> is +integer C<0>. + +It is suggested to +not use P as a return type and instead use N and read the memory yourself, and +free the pointer if applicable. This pointer is effectively undefined after the +C function returns control to Perl. The C function may not hold onto it after +the C function returns control. There are exceptions where the pointer will +remain valid after the C function returns control, but tread at your own risk, +and at your knowledge of Perl interpreter's C internals. + +=item C<T>: +value is a Win32::API::Struct object, in parameter only, pass by reference +(pointer) only, pass by copy not implemented, see other sections for more + +=item C<K>: +value is a Win32::API::Callback object, in parameter only, (see L<Win32::API::Callback>) + +=item C<V>: +no value, no parameters, stands for C<void>, may not be combined with any other +letters, equivalent to a "" + +=back + +For beginners, just skip this paragraph. +Note, all parameter types are little endian. This is probably what you want +unless the documentation for the C function you are calling explicitly says +the parameters must be big endian. If there is no documentation for your C +function or no mention of endianess in the documentation, this doesn't apply +to you and skip the rest of this paragraph. There is no inherent support +for big endian parameters. Perl's scalar numbers model is that numeric +scalars are effectively opaque and their machine representation is +irrelevant. On Windows Perl, scalar numbers are little endian +internally. So C<$number = 5; print "$number";> will put 5 on the screen. +C<$number> given to Win32::API will pass little endian integer 5 to the C +function call. This is almost surly what you want. If you really must pass +a big endian integer, do C<$number = unpack('L', pack('N', 5));>, then +C<print "$number";> will put 83886080 on the screen, but this is big endian 5, +and passing 83886080 to C<-E<gt>Call()> will make sure that +the C function is getting big endian 5. See L<perlpacktut> for more. + +Our function needs two parameters: a number (C<DWORD>) and a pointer to a +string (C<LPSTR>): + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ... + +=item B<4.> + +The fourth is the type of the value returned by the +function. It can be one of the types seen above, plus another type named B<V> +(for C<void>), used for functions that do not return a value. +In our example the value returned by GetTempPath() is a C<DWORD>, which is a +typedef for unsigned long, so our return type will be B<N>: + + $GetTempPath = new Win32::API::More('kernel32', 'GetTempPath', 'NP', 'N'); + +Now the line is complete, and the GetTempPath() API is ready to be used +in Perl. Before calling it, you should test that $GetTempPath is +L<perlfunc/defined>, otherwise errors such as the function or the library could +not be loaded or the C prototype was unparsable happened, and no object was +created. If the return value is undefined, to get detailed error status, use +L<perlvar/"$^E"> or L<Win32::GetLastError|Win32/Win32::GetLastError()>. C<$^E> +is slower than C<Win32::GetLastError> and useless on Cygwin, but C<$^E> in +string context provides a readable description of the error. In numeric context, +C<$^E> is equivelent to C<Win32::GetLastError>. C<Win32::GetLastError> always +returns an integer error code. You may use +L<Win32::FormatMessage|Win32/Win32::FormatMessage()> to convert an integer error +code to a readable description on Cygwin and Native builds of Perl. + +Our definition, with error checking added, should then look like this: + + $GetTempPath = new Win32::API::More('kernel32', 'GetTempPath', 'NP', 'N'); + if(not defined $GetTempPath) { + die "Can't import API GetTempPath: $^E\n"; + } + +=back + +=head2 CALLING AN IMPORTED FUNCTION + +To effectively make a call to an imported function you must use the +Call() method on the Win32::API object you created. +Continuing with the example from the previous paragraph, +the GetTempPath() API can be called using the method: + + $GetTempPath->Call(... + +Of course, parameters have to be passed as defined in the import phase. +In particular, if the number of parameters does not match (in the example, +if GetTempPath() is called with more or less than two parameters), +Perl will C<croak> an error message and C<die>. + +The two parameters needed here are the length of the buffer +that will hold the returned temporary path, and a pointer to the +buffer itself. +For numerical parameters except for char, you can use either a constant expression +or a variable, it will be numified similar to the expression C<($var+0)>. +For pointers, also note that B<memory must be allocated before calling the function>, +just like in C. +For example, to pass a buffer of 80 characters to GetTempPath(), +it must be initialized before with: + + $lpBuffer = " " x 80; + +This allocates a string of 80 characters. If you don't do so, you'll +probably get a fatal buffer overflow error starting in 0.69. +The call should therefore include: + + $lpBuffer = " " x 80; + $GetTempPath->Call(80, $lpBuffer); + +And the result will be stored in the $lpBuffer variable. +Note that you never need to pass a reference to the variable +(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set +by the function. + +A little problem here is that Perl does not trim the variable, +so $lpBuffer will still contain 80 characters in return; the exceeding +characters will be spaces, because we said C<" " x 80>. + +In this case we're lucky enough, because the value returned by +the GetTempPath() function is the length of the string, so to get +the actual temporary path we can write: + + $lpBuffer = " " x 80; + $return = $GetTempPath->Call(80, $lpBuffer); + $TempPath = substr($lpBuffer, 0, $return); + +If you don't know the length of the string, you can usually +cut it at the C<\0> (ASCII zero) character, which is the string +delimiter in C: + + $TempPath = ((split(/\0/, $lpBuffer))[0]; + # or + $lpBuffer =~ s/\0.*$//; + +=head2 USING STRUCTURES + +Starting from version 0.40, Win32::API comes with a support package +named Win32::API::Struct. The package is loaded automatically with +Win32::API, so you don't need to use it explicitly. + +With this module you can conveniently define structures and use +them as parameters to Win32::API functions. A short example follows: + + + # the 'POINT' structure is defined in C as: + # typedef struct { + # LONG x; + # LONG y; + # } POINT; + + + #### define the structure + Win32::API::Struct->typedef( POINT => qw{ + LONG x; + LONG y; + }); + + #### import an API that uses this structure + Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)'); + + #### create a 'POINT' object + my $pt = Win32::API::Struct->new('POINT'); + + #### call the function passing our structure object + GetCursorPos($pt); + + #### and now, access its members + print "The cursor is at: $pt->{x}, $pt->{y}\n"; + +Note that this works only when the function wants a +B<pointer to a structure>, not a "pass by copy" structure. As you can see, our +structure is named 'POINT', but the API used 'LPPOINT'. Some heuristics are +done to validate the argument's type vs the parameter's type if the function +has a C prototype definition (not letter definition). First, if the parameter +type starts with the LP prefix, the LP prefix is stripped, then compared to +the argument's type. If that fails, the Win32::API::Type database +(see L<Win32::API::Type/typedef>) +will be used to convert the parameter type to the base type. If that fails, +the parameter type will be stripped of a trailing whitespace then a '*', and +then checked against the base type. L<Dies|perlfunc/die> if the parameter and +argument types do not match after 3 attempts. + +For more information, see also L<Win32::API::Struct>. + +If you don't want (or can't) use the C<Win32::API::Struct> facility, +you can still use the low-level approach to use structures: + +=over 4 + +=item 1. + +you have to L<pack()|perlfunc/pack> the required elements in a variable: + + $lpPoint = pack('ll', 0, 0); # store two LONGs + +=item 2. + +to access the values stored in a structure, L<unpack()|perlfunc/unpack> it as required: + + ($x, $y) = unpack(';;', $lpPoint); # get the actual values + +=back + +The rest is left as an exercise to the reader... + +=head2 EXPORTED FUNCTIONS + +=head3 ReadMemory + + $copy_of_memblock = ReadMemory($SourcePtr, $length); + +Reads the source pointer for C<$length> number of bytes. Returns a copy of +the memory block in a scalar. No readability checking is done on C<$SourcePtr>. +C<$SourcePtr>'s format is 123456, not C<"\x01\x02\x03\x04">. + +=head3 WriteMemory + + WriteMemory($DestPtr, $sourceScalar, $length); + +Copies the string contents of the C<$sourceScalar> scalar to C<$DestPtr> for +C<$length> bytes. $length must be less than or equal to the length of +C<$sourceScalar>, otherwise the function croaks. No readability checking is +done on C<$DestPtr>. C<$DestPtr>'s format is 123456, not +C<"\x01\x02\x03\x04">. Returns nothing. + +=head3 MoveMemory + + MoveMemory($destPtr, $sourcePtr, $length); + +Copies a block of memory from one location to another. The source and +destination blocks may overlap. All pointers are in the format of 123456, +not C<"\x01\x02\x03\x04">. No readability checking is done. Returns nothing. + +=head3 IsBadReadPtr + + if(IsBadReadPtr($ptr, $length)) {die "bad ptr";} + +Probes a memory block for C<$length> bytes for readability. Returns true if +access violation occurs, otherwise false is returned. This function is useful +to avoid dereferencing pointers which will crash the perl process. This function +has many limitations, including not detecting uninitialized memory, not +detecting freed memory, and not detecting gibberish. It can not tell whether a +function pointer is valid x86 machine code. Ideally, you should never use it, +or remove it once your code is stable. C<$ptr> is in the format of 123456, +not C<"\x01\x02\x03\x04">. See MS's documentation for a lot more +on this function of the same name. + +=head3 SafeReadWideCString + + $source = Encode::encode("UTF-16LE","Just another perl h\x{00E2}cker\x00"); + $string = SafeReadWideCString(unpack('J',pack('p', $source))); + die "impossible" if $source ne "Just another perl h\x{00E2}cker"; + +Safely (SEH aware) reads a utf-16 wide null terminated string (the first and +only parameter), into a scalar. Returns undef, if an access violation happens +or null pointer (same thing). The string pointer is in the format of 123456, +not C<"\x01\x02\x03\x04">. The returned scalar will be UTF8 marked if the string +can not be represented in the system's ANSI codepage. Conversion is done with +WideCharToMultiByte. Returns a 0 length scalar string if WideCharToMultiByte fails. +This function was created because L<pack's|perlfunc/pack> p letter won't read UTF16 +and L</ReadMemory> and L</IsBadReadPtr> require an explicit length. + +=head2 CONSTRUCTORS + +=head3 new + + $obj = Win32::API::More->new([$dllname | (undef , $funcptr)], [$c_proto | ($in, $out [, $calling_convention])]); + +See L</DESCRIPTION>. + +=head3 Import + $obj = Win32::API::More->Import([$dllname | (undef , $funcptr)], [$c_proto | ($in, $out [, $calling_convention])]); + +See L</DESCRIPTION>. + +=head2 METHODS + +=head3 Call + +The main method of a Win32::API object. Documented elsewhere in this document. + +=head3 UseMI64 + + $bool = $APIObj->UseMI64(); + $oldbool = $APIObj->UseMI64($newbool); + +Turns on Quads as L<Math::Int64> objects support for a particular object +instance. You must call L<perlfunc/use>/L<perlfunc/require> on Math::Int64 +before calling UseMI64. Win32::API does not C<use> Math::Int64 for you. +Works on Win32::API and Win32::API::Callback objects. This method +does not exist if your Perl natively supports Quads (64 bit Perl for example). +Takes 1 optional parameter, which is a true or false value to use or don't use +Math::Int64, returns the old setting, which is a true or false value. If called +without any parameters, returns current setting, which is a true or false value, +without setting the option. As discussed in L</q>, if you are not using +Math::Int64 you must supply/will receive 8 byte scalar strings for quads. +For "in" params in Win32::API and Win32::API::More and "out" in +Win32::API::Callback only, if the argument is a reference, it will automatically +be treated as a Math::Int64 object without having to previously call this +function. + +=head2 VERBOSE DEBUGGING + +If using C<Win32::GetLastError> and C<$^E> does not reveal the problem with your +use of Win32::API, you may turn on Win32::API's very verbose debugging mode as +follows + + BEGIN { + $Win32::API::DEBUG = 1; + } + use Win32::API; + $function = Win32::API::More->new( + 'mydll', 'int sum_integers(int a, int b)' + ); + +=head1 HISTORY + +=over 4 + +=item UseMI64 API change + +Starting in 0.71, UseMI64 on a set returns old value, not previously +new value. + +=item fork safe + +Starting in 0.71, a Win32::API object can go through a fork and work +correctly in the child and parent psuedo-processes. Previously when either +psuedo-processes exited, the DLL would be unloaded and the other +psuedo-processes would crash if a Call() was done on the object. + +=item return value signedness + +Prior to 0.69, for numeric integer types, the return scalar was always signed. +Unsigned-ness was ignored. + +=item shorts + +Prior to 0.69, shorts were not supported. 'S' meant a sturct. To fix this +Win32::API::More class was created for 0.69. 'S'/'s' now means short, per pack's +letters. Struct has been moved to letter 'T'. Win32::API will continue to exist +for legacy code. + +=item float return types + +Prior to 0.69, if a function had a return type of float, it was silently +not called. + +=item buffer overflow protection + +Introduced in 0.69. If disabling is required, which is highly +B<not recommended>, set an environmental variable called +WIN32_API_SORRY_I_WAS_AN_IDIOT to 1. + +=item automatic un/pack + +Starting with 0.69, when using Win32::API::More, there is automatic un/packing +of pointers to numbers-ish things for in parameters when using the C +prototype interface. + +=item Quads on 32 bit + +Added in 0.70. + +=item __stdcall vs __cdecl checking on 32 bits + +Added in 0.76_01 + +=item Import returns an api obj on success, undef on failure, instead of 1 or 0 + +Added in 0.76_02 + +=item checking C<$!> for C<new>/C<Import> failure is broken and deprecated + +Starting in 0.76_06, due to many bugs with C<new> and C<Import> not setting +L<perlvar/$!> or Win32 and C error codes overlapping and Win32 error codes being +stringified as different C error codes, checking C<$!> is deprecated and the +existing, partial setting of C<$!>, maybe removed in the future. Only check +C<Win32::GetLastError()> or C<$^E> to find out why the call failed. + +=back + +See the C<Changes> file for more details, many of which not mentioned here. + +=head1 BUGS AND LIMITATIONS + +=over 4 + +=item E<nbsp> Unicode DLL paths + +Untested. + +=item E<nbsp> ithreads + +Minimally tested. + +=item E<nbsp> C functions getting utf8 scalars vs byte scalars + +Untested and undefined. + +=back + +=head1 SEE ALSO + +L<Math::Int64> + +L<Win32::API::Struct> + +L<Win32::API::Type> + +L<Win32::API::Callback> + +L<Win32::API::Callback::IATPatch> + +L<http://homepage.ntlworld.com/jonathan.deboynepollard/FGA/function-calling-conventions.html> + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ) + +=head1 MAJOR CONTRIBUTOR + +Daniel Dragan ( I<bulkdd@cpan.org> ) + +=head1 LICENSE + +To finally clarify this, C<Win32::API> is OSI-approved free software; +you can redistribute it and/or modify it under the same terms as Perl +itself. + +See L<http://dev.perl.org/licenses/artistic.html> + +=head1 CREDITS + +All the credits go to Andrea Frosini for the neat assembler trick +that makes this thing work. I've also used some work by Dave Roth +for the prototyping stuff. A big thank you also to Gurusamy Sarathy +for his invaluable help in XS development, and to all the Perl +community for being what it is. + +Cosimo also wants to personally thank everyone that contributed +to Win32::API with complaints, emails, patches, RT bug reports +and so on. + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback.pm new file mode 100644 index 0000000000..1731a637fb --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback.pm @@ -0,0 +1,575 @@ +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Callback - Perl Win32 API Import Facility +# +# Author: Aldo Calpini <dada@perl.it> +# Author: Daniel Dragan <bulkdd@cpan.org> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# +####################################################################### + +package Win32::API::Callback; +use strict; +use warnings; +use vars qw( $VERSION $Stage2FuncPtrPkd ); + +$VERSION = '0.84'; + +#require XSLoader; # to dynuhlode the module. #already loaded by Win32::API +#use Data::Dumper; + +use Win32::API qw ( WriteMemory ) ; + +BEGIN { + #there is supposed to be 64 bit IVs on 32 bit perl compatibility here + #but it is untested + *IVSIZE = *Win32::API::IVSIZE; + #what kind of stack processing/calling convention/machine code we needed + eval "sub ISX64 () { ".(Win32::API::PTRSIZE() == 8 ? 1 : 0)." }"; + eval 'sub OPV () {'.$].'}'; + sub OPV(); + sub CONTEXT_XMM0(); + sub CONTEXT_RAX(); + *IsBadStringPtr = *Win32::API::IsBadStringPtr; + sub PTRSIZE (); + *PTRSIZE = *Win32::API::PTRSIZE; + sub PTRLET (); + *PTRLET = *Win32::API::Type::pointer_pack_type; + if(OPV <= 5.008000){ #don't have unpackstring in C + eval('sub _CallUnpack {return unpack($_[0], $_[1]);}'); + } + *DEBUGCONST = *Win32::API::DEBUGCONST; + *DEBUG = *Win32::API::DEBUG; +} +####################################################################### +# dynamically load in the API extension module. +# +XSLoader::load 'Win32::API::Callback', $VERSION; + +####################################################################### +# PUBLIC METHODS +# +sub new { + my ($class, $proc, $in, $out, $callconvention) = @_; + my $self = bless {}, $class; #about croak/die safety, can safely bless here, + #a ::Callback has no DESTROY, it has no resources to release, there is a HeapBlock obj + #stored in the ::Callback hash, but the HeapBlock destroys on its own + # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out; + + $self->{intypes} = []; #XS requires this, do not remove + if (ref($in) eq 'ARRAY') { + foreach (@$in) { + push(@{$self->{intypes}}, $_); + } + } + else { + my @in = split '', $in; + foreach (@in) { + push(@{$self->{intypes}}, $_); + } + } + $self->{inbytes} = 0; + foreach(@{$self->{intypes}}){ #calc how long the c stack is + if($_ eq 'Q' or $_ eq 'q' or $_ eq 'D' or $_ eq 'd'){ + $self->{inbytes} += 8; #always 8 + } + else{ + $self->{inbytes} += PTRSIZE; #4 or 8 + } + } + $self->{outtype} = $out; + $self->{out} = Win32::API->type_to_num($out); + $self->{sub} = $proc; + $self->{cdecl} = Win32::API::calltype_to_num($callconvention); + + DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n" if DEBUGCONST; + my $hproc = MakeCB($self); + + DEBUG "(PM)Callback::new: hproc=$hproc\n" if DEBUGCONST; + + $self->{code} = $hproc; + + #### cast the spell + return $self; +} + +sub MakeStruct { + my ($self, $n, $addr) = @_; + DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n" if DEBUGCONST; + my $struct = Win32::API::Struct->new($self->{intypes}->[$n]); + $struct->FromMemory($addr); + return $struct; +} + +#this was rewritten in XS, and is broken b/c it doesn't work on 32bit Perl with Quads +#sub MakeParamArr { #on x64, never do "$i++; $packedparam .= $arr->[$i];" +# #on x86, structs and over word size params appears on the stack, +# #on x64 anything over the size of a "word" is passed by pointer +# #nothing takes more than 8 bytes per parameter on x64 +# #there is no way to formally specify a pass by copy struct in ::Callback +# #this only matters on x86, a work around is a bunch of N/I parameters, +# #repack them as Js, then concat them, and you have the original pass by copy +# #x86 struct +# my ($self, $arr) = @_; +# my ($i, @pass_arr) = (0); +# for(@{$self->{intypes}}){ #elements of intypes are not 1 to 1 with stack params +# my ($typeletter, $packedparam, $finalParam, $unpackletter) = ($_, $arr->[$i]); +# +# #structs don't work, this is broken code from old version +# #$self->{intypes} is letters types not C prototype params +# #C prototype support would have to exist for MakeStruct to work +# if( $typeletter eq 'S' || $typeletter eq 's'){ +# die "Win32::API::Callback::MakeParamArr type letter \"S\" and struct support not implemented"; +# #push(@pass_arr, MakeStruct($self, $i, $packedparam)); +# }elsif($typeletter eq 'I'){ +# $unpackletter = 'I', goto UNPACK; +# }elsif($typeletter eq 'i'){ +# $unpackletter = 'i', goto UNPACK; +# }elsif($typeletter eq 'f' || $typeletter eq 'F'){ +# $unpackletter = 'f', goto UNPACK; +# } +# elsif($typeletter eq 'd' || $typeletter eq 'D'){ +# if(IVSIZE == 4){ #need more data, 32 bit machine +# $packedparam .= $arr->[++$i]; +# } +# $unpackletter = 'd', goto UNPACK; +# } +# elsif($typeletter eq 'N' || $typeletter eq 'L' #on x64, J is 8 bytes +# || (IVSIZE == 8 ? $typeletter eq 'Q': 0)){ +# $unpackletter = 'J', goto UNPACK; +# }elsif($typeletter eq 'n' || $typeletter eq 'l' +# || (IVSIZE == 8 ? $typeletter eq 'q': 0)){ +# $unpackletter = 'j', goto UNPACK; +# }elsif(IVSIZE == 4 && ($typeletter eq 'q' || $typeletter eq 'Q')){ +# #need more data, 32 bit machine +# $finalParam = $packedparam . $arr->[++$i]; +# }elsif($typeletter eq 'p' || $typeletter eq 'P'){ +# if(!IsBadStringPtr($arr->[$i], ~0)){ #P letter is terrible design +# $unpackletter = 'p', goto UNPACK; +# }#else undef +# } +# else{ die "Win32::API::Callback::MakeParamArr unknown in type letter $typeletter";} +# goto GOTPARAM; +# UNPACK: +# $finalParam = unpack($unpackletter, $packedparam); +# GOTPARAM: +# $i++; +# push(@pass_arr, $finalParam); +# } +# return \@pass_arr; +#} + +#on x64 +#void RunCB($self, $EBP_ESP, $retval) +#on x86 +#void RunCB($self, $EBP_ESP, $retval, $unwindcount, $F_or_D) +if(! ISX64 ) { +*RunCB = sub {#32 bits + my $self = $_[0]; + my (@pass_arr, $return, $typeletter, $inbytes, @arr); + $inbytes = $self->{inbytes}; + #first is ebp copy then ret address + $inbytes += PTRSIZE * 2; + my $paramcount = $inbytes / PTRSIZE ; + my $stackstr = unpack('P'.$inbytes, pack(PTRLET, $_[1])); + #pack () were added in 5.7.2 + if (OPV > 5.007002) { + @arr = unpack("(a[".PTRLET."])[$paramcount]",$stackstr); + } else { + #letter can not be used for size, must be numeric on 5.6 + @arr = unpack(("a4") x $paramcount,$stackstr); + } + shift @arr, shift @arr; #remove ebp copy and ret address + $paramcount -= 2; + $return = &{$self->{sub}}(@{MakeParamArr($self, \@arr)}); + + #now the return type + $typeletter = $self->{outtype}; + #float_or_double flag, its always used + #float is default for faster copy of probably unused value + $_[4] = 0; + #its all the same in memory + if($typeletter eq 'n' || $typeletter eq 'N' + || $typeletter eq 'l' || $typeletter eq 'L' + || $typeletter eq 'i' || $typeletter eq 'I'){ + $_[2] = pack(PTRLET, $return); + }elsif($typeletter eq 'q' || $typeletter eq 'Q'){ + if(IVSIZE == 4){ + if($self->{'UseMI64'} || ref($return)){ #un/signed meaningless + $_[2] = Math::Int64::int64_to_native($return); + } + else{ + warn("Win32::API::Callback::RunCB return value for return type Q is under 8 bytes long") + if length($return) < 8; + $_[2] = $return.''; #$return should be a 8 byte string + #will be garbage padded in XS if < 8, but must be a string, not a IV or under + } + } + else{ + $_[2] = pack($typeletter, $return); + } + }elsif($typeletter eq 'f' || $typeletter eq 'F' ){ + $_[2] = pack('f', $return); + }elsif($typeletter eq 'd' || $typeletter eq 'D' ){ + $_[2] = pack('d', $return); + $_[4] = 1; #use double + }else { #return null + $_[2] = "\x00" x 8; + } + + if(! $self->{cdecl}){ + $_[3] = PTRSIZE * $paramcount; #stack rewind amount in bytes + } + else{$_[3] = 0;} +}; +} +else{ #64 bits +*RunCB = sub { + my $self = $_[0]; + my (@pass_arr, $return, $typeletter); + my $paramcount = $self->{inbytes} / IVSIZE; + my $stack_ptr = unpack('P[J]', pack('J', ($_[1]+CONTEXT_RAX()))); + my $stack_str = unpack('P['.$self->{inbytes}.']', $stack_ptr); + my @stack_arr = unpack("(a[J])[$paramcount]",$stack_str); + #not very efficient, todo search for f/F/d/D in new() not here + my $XMMStr = unpack('P['.(4 * 16).']', pack('J', ($_[1]+CONTEXT_XMM0()))); + #print Dumper([unpack('(H[32])[4]', $XMMStr)]); + my @XMM = unpack('(a[16])[4]', $XMMStr); + #assume registers are copied to shadow stack space already + #because of ... prototype, so only XMM registers need to be fetched. + #Limitation, vararg funcs on x64 get floating points in normal registers + #not XMMs, so a vararg function taking floats and doubles in the first 4 + #parameters isn't supported + if($paramcount){ + for(0..($paramcount > 4 ? 4 : $paramcount)-1){ + my $typeletter = ${$self->{intypes}}[$_]; + if($typeletter eq 'f' || $typeletter eq 'F' || $typeletter eq 'd' + || $typeletter eq 'D'){ + #x64 calling convention does not use the high 64 bits of a XMM register + #although right here the high 64 bits are in @XMM elements + #J on x64 is 8 bytes, a double will not corrupt, this is unreachable on x86 + #note we are copying 16 bytes elements to @stack_arr, @stack_arr is + #normally 8 byte elements, unpack ignores the excess bytes later + $stack_arr[$_] = $XMM[$_]; + } + } + } + #print Dumper(\@stack_arr); + #print Dumper(\@XMM); + $return = &{$self->{sub}}(@{MakeParamArr($self, \@stack_arr)}); + + #now the return type + $typeletter = $self->{outtype}; + #its all the same in memory + if($typeletter eq 'n' || $typeletter eq 'N' + || $typeletter eq 'l' || $typeletter eq 'L' + || $typeletter eq 'i' || $typeletter eq 'I' + || $typeletter eq 'q' || $typeletter eq 'Q'){ + $_[2] = pack('J', $return); + } + elsif($typeletter eq 'f' || $typeletter eq 'F' ){ + $_[2] = pack('f', $return); + } + elsif($typeletter eq 'd' || $typeletter eq 'D' ){ + $_[2] = pack('d', $return); + } + else { #return null + $_[2] = pack('J', 0); + } +}; +} + +sub MakeCB{ + + my $self = $_[0]; + #this x86 function does not corrupt the callstack in a debugger since it + #uses ebp and saves ebp on the stack, the function won't have a pretty + #name though + my $code = (!ISX64) ? ('' #parenthesis required to constant fold + ."\x55" # push ebp + ."\x8B\xEC" # mov ebp, esp + ."\x83\xEC\x0C"# sub esp, 0Ch + ."\x8D\x45\xFC" # lea eax, [ebp+FuncRtnCxtVar] + ."\x50"# push eax + ."\x8D\x45\xF4"# lea eax, [ebp+retval] + ."\x50"# push eax + ."\x8B\xC5"# mov eax,ebp + ."\x50"# push eax + ."\xB8").PackedRVTarget($self)#B8 mov imm32 to eax, a HV * winds up here + .("\x50"# push eax + ."\xB8").$Stage2FuncPtrPkd # mov eax, 0C0DE0001h + .("\xFF\xD0"# call eax + #since ST(0) is volatile, we don't care if we fill it with garbage + ."\x80\x7D\xFE\x00"#cmp [ebp+FuncRtnCxtVar.F_Or_D], 0 + ."\xDD\xD8"# fstp st(0) pop a FP reg to make space on FPU stack + ."\x74\x05"# jz 5 bytes + ."\xDD\x45\xF4"# fld qword ptr [ebp+retval] (double) + ."\xEB\x03"# jmp 3 bytes + ."\xD9\x45\xF4"# fld dword ptr [ebp+retval] (float) + #rewind sp to entry sp, no pop push after this point + ."\x83\xC4\x24"# add esp, 24h + ."\x8B\x45\xF4"# mov eax, dword ptr [ebp+retval] + #edx might be garbage, we don't care, caller only looks at volatile + #registers that the caller's prototype says the caller does + ."\x8B\x55\xF8"# mov edx, dword ptr [ebp+retval+4] + #can't use retn op, it requires a immediate count, our count is in a register + #only one register available now, this will be complicated + ."\x0F\xB7\x4D\xFC"#movzx ecx, word ptr [ebp+FuncRtnCxtVar.unwind_len] + ."\x01\xCC"# add esp, ecx , might be zero or more + ."\x8B\x4D\x04"# mov ecx, dword ptr [ebp+4] ret address + ."\x8B\x6D\x00"# mov ebp, dword ptr [ebp+0] restore BP + ."\xFF\xE1")# jmp ecx + + + #begin x64 part + #these packs don't constant fold in < 5.17 :-( + #they are here for readability + :(''.pack('C', 0b01000000 #REX base + | 0b00001000 #REX.W + | 0b00000001 #REX.B + ).pack('C', 0xB8+2) #mov to r10 register + .PackedRVTarget($self) + .pack('C', 0b01000000 #REX base + | 0b00001000 #REX.W + ).pack('C', 0xB8) #mov to rax register + .$Stage2FuncPtrPkd + ."\xFF\xE0");# jmp rax +#making a full function in Perl in x64 was removed because RtlAddFunctionTable +#has no effect on VS 2008 debugger, it is a bug in VS 2008, in WinDbg the C callstack +#is correct with RtlAddFunctionTable, and broken without RtlAddFunctionTable +#in VS 2008, the C callstack was always broken since WinDbg and VS 2008 both +#*only* use Unwind Tables on x64 to calculate C callstacks, they do not, I think, +#use 32 bit style EBP/RBP walking, x64 VC almost never uses BP addressing anyway. +#The easiest fix was to not have dynamic machine code in the callstack at all, +#which is what I did. Having good C callstacks in a debugger with ::API and +#::Callback are a good goal. +# +##--- c:\documents and settings\administrator\desktop\w32api\callback\callback.c - +# $code .= "\x4C\x8B\xDC";# mov r11,rsp +# $code .= "\x49\x89\x4B\x08";# mov qword ptr [r11+8],rcx +# $code .= "\x49\x89\x53\x10";# mov qword ptr [r11+10h],rdx +# $code .= "\x4D\x89\x43\x18";# mov qword ptr [r11+18h],r8 +# $code .= "\x4D\x89\x4B\x20";# mov qword ptr [r11+20h],r9 +# $code .= "\x48\x83\xEC\x78";# sub rsp,78h +# #void (*LPerlCallback)(SV *, void *, unsigned __int64 *, void *) = +# #( void (*)(SV *, void *, unsigned __int64 *, void *)) 0xC0DE00FFFF000001; +# #__m128 arr [4]; +# #__m128 retval; +## arr[0].m128_u64[0] = 0xFFFF00000000FF10; +##00000000022D1017 48 B8 10 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF10h +##arr[0].m128_u64[1] = 0xFFFF00000000FF11; +## arr[1].m128_u64[0] = 0xFFFF00000000FF20; +## arr[1].m128_u64[1] = 0xFFFF00000000FF21; +## arr[2].m128_u64[0] = 0xFFFF00000000FF30; +## arr[2].m128_u64[1] = 0xFFFF00000000FF31; +## arr[3].m128_u64[0] = 0xFFFF00000000FF40; +## arr[3].m128_u64[1] = 0xFFFF00000000FF41; +# +## LPerlCallback((SV *)0xC0DE00FFFF000002, (void*) arr, (unsigned __int64 *)&retval, +## (DWORD_PTR)&a); +##00000000022D1021 4D 8D 4B 08 lea r9,[r11+8] #no 4th param +# $code .= "\x4D\x8D\x43\xA8";# lea r8,[r11-58h] #&retval param +##00000000022D1029 49 89 43 B8 mov qword ptr [r11-48h],rax +##00000000022D102D 48 B8 11 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF11h +# $code .= "\x49\x8D\x53\xB8";# lea rdx,[r11-48h] #arr param +##00000000022D103B 49 89 43 C0 mov qword ptr [r11-40h],rax +##00000000022D103F 48 B8 20 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF20h +##00000000022D1049 48 B9 02 00 00 FF FF 00 DE C0 mov rcx,0C0DE00FFFF000002h +# $code .= "\x48\xB9".PackedRVTarget($self);# mov rcx, the HV * +##00000000022D1053 49 89 43 C8 mov qword ptr [r11-38h],rax +##00000000022D1057 48 B8 21 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF21h +##00000000022D1061 49 89 43 D0 mov qword ptr [r11-30h],rax +##00000000022D1065 48 B8 30 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF30h +##00000000022D106F 49 89 43 D8 mov qword ptr [r11-28h],rax +##00000000022D1073 48 B8 31 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF31h +##00000000022D107D 49 89 43 E0 mov qword ptr [r11-20h],rax +##00000000022D1081 48 B8 40 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF40h +##00000000022D108B 49 89 43 E8 mov qword ptr [r11-18h],rax +##00000000022D108F 48 B8 41 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF41h +##00000000022D1099 49 89 43 F0 mov qword ptr [r11-10h],rax +##00000000022D109D 48 B8 01 00 00 FF FF 00 DE C0 mov rax,0C0DE00FFFF000001h +# $code .= "\x48\xB8".$Stage2FuncPtrPkd; # mov rax,0C0DE00FFFF000001h +# $code .= "\xFF\xD0";# call rax +## return *(void **)&retval; +# $code .= "\x48\x8B\x44\x24\x20";# mov rax,qword ptr [retval] +##} +# $code .= "\x48\x83\xC4\x78";# add rsp,78h +# $code .= "\xC3";# ret + +#$self->{codestr} = $code; #save memory +#32 bit perl doesn't use DEP in my testing, but use executable heap to be safe +#a Win32::API::Callback::HeapBlock is a ref to scalar, that scalar has the void * +my $ptr = ${($self->{codeExecAlloc} = Win32::API::Callback::HeapBlock->new(length($code)))}; +WriteMemory($ptr, $code, length($code)); +return $ptr; +} + + +1; + +__END__ + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Callback - Callback support for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + use Win32::API::Callback; + + my $callback = Win32::API::Callback->new( + sub { my($a, $b) = @_; return $a+$b; }, + "NN", "N", + ); + + Win32::API->Import( + 'mydll', 'two_integers_cb', 'KNN', 'N', + ); + + $sum = two_integers_cb( $callback, 3, 2 ); + + +=head1 FOREWORDS + +=over 4 + +=item * +Support for this module is B<highly experimental> at this point. + +=item * +I won't be surprised if it doesn't work for you. + +=item * +Feedback is very appreciated. + +=item * +Documentation is in the work. Either see the SYNOPSIS above +or the samples in the F<samples> or the tests in the F<t> directory. + +=back + +=head1 USAGE + +Win32::API::Callback uses a subset of the type letters of Win32::API. C Prototype +interface isn't supported. Not all the type letters of Win32::API are supported +in Win32::API::Callback. + +=over 4 + +=item C<I>: +value is an unsigned integer (unsigned int) + +=item C<i>: +value is an signed integer (signed int or int) + +=item C<N>: +value is a unsigned pointer sized number (unsigned long) + +=item C<n>: +value is a signed pointer sized number (signed long or long) + +=item C<Q>: +value is a unsigned 64 bit integer number (unsigned long long, unsigned __int64) +See next item for details. + +=item C<q>: +value is a signed 64 bit integer number (long long, __int64) +If your perl has 'Q'/'q' quads support for L<pack> then Win32::API's 'q' +is a normal perl numeric scalar. All 64 bit Perls have quad support. Almost no +32 bit Perls have quad support. On 32 bit Perls, without quad support, +Win32::API::Callback's 'q'/'Q' letter is a packed 8 byte string. +So C<0x8000000050000000> from a perl with native Quad support +would be written as C<"\x00\x00\x00\x50\x00\x00\x00\x80"> on a 32 bit +Perl without Quad support. To improve the use of 64 bit integers with +Win32::API::Callback on a 32 bit Perl without Quad support, there is +a per Win32::API::Callback object setting called L<Win32::API/UseMI64> +that causes all quads to be accepted as, and returned as L<Math::Int64> +objects. 4 to 8 byte long pass by copy/return type C aggregate types +are very rare in Windows, but they are supported as "in" and return +types by using 'q'/'Q' on 32 and 64 bits. Converting between the C aggregate +and its representation as a quad is up to the reader. For "out" in +Win32::API::Callback (not "in"), if the argument is a reference, it will +automatically be treated as a Math::Int64 object without having to +previously call this function. + +=item C<F>: +value is a floating point number (float) + +=item C<D>: +value is a double precision number (double) + +=item C<Unimplemented types>: +Unimplemented in Win32::API::Callback types such as shorts, chars, and +smaller than "machine word size" (32/64bit) numbers can be processed +by specifying N, then masking off the high bytes. +For example, to get a char, specify N, then do C<$numeric_char = $_[2] & 0xFF;> +in your Perl callback sub. To get a short, specify N, then do +C<$numeric_char = $_[2] & 0xFFFF;> in your Perl callback sub. + +=back + +=head2 FUNCTIONS + +=head3 new + + $CallbackObj = Win32::API::Callback->new( sub { print "hello world";}, + 'NDF', 'Q', '__cdecl'); + $CallbackObj = Win32::API::Callback->new( sub { print "hello world";}, + $in, $out); + +Creates and returns a new Win32::API::Callback object. Calling convention +parameter is optional. Calling convention parameter has same behaviour as +Win32::API's calling convention parameter. C prototype parsing of Win32::API +is not available with Win32::API::Callback. If the C caller assumes the +callback has vararg parameters, and the platform is 64 bits/x64, in the first 4 +parameters, if they are floats or doubles they will be garbage. Note there is +no way to create a Win32::API::Callback callback with a vararg prototype. +A workaround is to put "enough" Ns as the in types, and stop looking at the @_ +slices in your Perl sub callback after a certain count. Usually the first +parameter will somehow indicate how many additional stack parameters you are +receiving. The Ns in @_ will eventually become garbage, technically they are +the return address, saved registers, and C stack allocated variables of the +caller. They are effectivly garbage for your vararg callback. All vararg +callbacks on 32 bits must supply a calling convention, and it must be '__cdecl' +or 'WINAPIV'. + +=head2 METHODS + +=head3 UseMI64 + +See L<Win32::API/UseMI64>. + +=head1 KNOWN ISSUES + +=over 4 + +=item * + +Callback is safe across a Win32 psuedo-fork. Callback is not safe across a +Cygwin fork. On Cygwin, in the child process of the fork, a Segmentation Fault +will happen if the Win32::API::Callback callback is is called. + +=back + +=head1 SEE ALSO + +L<Win32::API::Callback::IATPatch> + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). +Daniel Dragan ( I<bulkdd@cpan.org> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ). + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod new file mode 100644 index 0000000000..27eb1af2fb --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod @@ -0,0 +1,181 @@ +=head1 NAME + +Win32::API::Callback::IATPatch - Hooking and Patching a DLL's Imported C Functions + +=head1 SYNOPSIS + + use Win32::API; + use Win32::API::Callback; + warn "usually fatally errors on Cygwin" if $^O eq 'cygwin'; + # do not do a "use" or "require" on Win32::API::Callback::IATPatch + # IATPatch comes with Win32::API::Callback + my $LoadLibraryExA; + my $callback = Win32::API::Callback->new( + sub { + my $libname = unpack('p', pack('J', $_[0])); + print "got $libname\n"; + return $LoadLibraryExA->Call($libname, $_[1], $_[2]); + }, + 'NNI', + 'N' + ); + my $patch = Win32::API::Callback::IATPatch->new( + $callback, "perl518.dll", 'kernel32.dll', 'LoadLibraryExA'); + die "failed to create IATPatch Obj $^E" if ! defined $patch; + $LoadLibraryExA = Win32::API::More->new( undef, $patch->GetOriginalFunctionPtr(), ' + HMODULE + WINAPI + LoadLibraryExA( + LPCSTR lpLibFileName, + HANDLE hFile, + DWORD dwFlags + ); + '); + die "failed to make old function object" if ! defined $LoadLibraryExA; + require Encode; + #console will get a print of the dll filename now + +=head1 DESCRIPTION + +Win32::API::Callback::IATPatch allows you to hook a compile time dynamic linked +function call from any DLL (or EXE, from now on all examples are from a DLL to +another DLL, but from a EXE to a DLL is implied) in the Perl process, to a +different DLL in the same Perl process, by placing a Win32::API::Callback object +in between. This module does B<not> hook B<GetProcAddress> function calls. It +also will not hook a function call from a DLL to another function in the same +DLL. The function you want to hook B<must> appear in the B<import table> of the +DLL you want to use the hook. Functions from delay loaded DLL have their own +import table, it is different import table from the normal one IATPatch supports. +IATPatch will not find a delay loaded function and will not patch it. The hook +occurs at the caller DLL, not the callee DLL. This means your callback will be +called from all the calls to a one function in different DLL from the one +particular DLL the IATPatch object patched. The caller DLL is modified at +runtime, in the Perl process where the IATPatch was created, not on disk, +not globally among all processes. The callee or exporting DLL is NOT modified, +so your hook callback will be called from the 1 DLL that you choose to hook with +1 IATPatch object. You can create multiple IATPatch objects, one for each DLL in +the Perl process that you want to call your callback and not the original +destination function. If a new DLL is loaded into the process during runtime, +you must create a new IATPatch object specifically targeting it. There may be a +period from when the new DLL is loaded into the process, and when your Perl +script creates IATPatch object, where calls from that new DLL goto the real +destination function without hooking. If a DLL is unloaded, then reloaded into +the process, you must call C<Unpatch(0)> method on the old IATPatch object, then +create a new IATPatch object. IATPatch has no notification feature that a DLL +is being loaded or unloaded from the process. Unless you completely control, and +have the source code of the caller DLL, and understand all of the source code of +that DLL, there is a high chance that you will B<NOT> hook all calls from that +DLL to the destination function. If a call to the destination function is +dangerous or unacceptable, do not use IATPatch. IATPatch is not Microsoft +Detours or the like in any sense. Detours and its brethern will rewrite the +machine code in the beginning of the destination function call, hooking all +calls to that function call process wide, without exception. + +Why this module was created? So I could mock kernel32 functions to +unit test Perl's C function calls to Kernel32. + +=head2 CONSTRUCTORS + +=head3 new + + my $patch = Win32::API::Callback::IATPatch->new( + $A_Win32_API_Callback_Obj, $EXE_or_DLL_hmodule_or_name_to_hook, + $import_DLL_name, $import_function_name_or_ordinal); + +Creates a new IATPatch object. The Win32::API::Callback will be called as long +as the IATPatch object exists. When an IATPatch object is DESTROYed, unless +C<-E<gt>Unpatch(0)> is called first, the patch is undone and the original +function is directly called from then on by that DLL. The DLL is not reference +count saved by an IATPatch object, so it may be unloaded at any time. If it is +unloaded you must call C<-E<gt>Unpatch(0)> before a DESTROY. Otherwise the DESTROY +will croak when it tries to unpatch the DLL. The DLL to hook must be a valid +PE file, while in memory. DLL and EXE "packers" can create invalid PE +files that do load successfully into memory, but they are not full PE files in +memory. On error, undef is returned and an error code is available through +L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E">. The error code may be from either +IATPatch directly, or from a Win32 call that IATPatch made. IATPatch objects +do not go through a L<perlfunc/"fork"> onto the child interp. IATPatch is fork safe. + +The hook dll name can be one of 3 things, if the dllname is multiple things +(a number and a string), the first format found in the following order is used. +A string C<"123"> (a very strange DLL name BTW), this DLL is converted to DLL +HMODULE with GetModuleHandle. If there are 2 DLLs with the same filename, +refer to GetModuleHandle's +L<MSDN documentation|http://msdn.microsoft.com/en-us/library/windows/desktop/ms683199%28v=vs.85%29.aspx> +on what happens. Then if the +DLL name is an integer C<123456>, it is interpreted as a HMODULE directly. +If DLL name undefined, the file used to create the calling process will be +patched (a .exe). Finally if the DLL name is defined, a fatal error croak occurs. +It is best to use an HMODULE, since things like SxS can create multiple DLLs with +the same name in the same process. How to get an HMODULE, you are on your own. + +C<$import_function_name_or_ordinal> can be one of 2 things. First it is checked if +it is a string, if so, it is used as the function name to hook. Else it is used +as an integer ordinal to hook. Importing by ordinal is obsolete in Windows, and +you shouldn't ever have to use it. The author of IATPatch was unable to test if +ordinal hooking works correctly in IATPatch. + +=head2 METHODS + +=head3 Unpatch + + die "failed to undo the patch error: $^E" if ! + $IATPatch->Unpatch(); #undo the patch + #or + die "failed to undo the patch error: $^E" if ! + $IATPatch->Unpatch(1); #undo the patch + #or + die "failed to undo the patch error: $^E" if ! + $IATPatch->Unpatch(0); #never undo the patch + #or + die "failed to undo the patch error: $^E" if ! + $IATPatch->Unpatch(undef); #never undo the patch + +Unpatches the DLL with the original destination function from the L<Win32::API::Callback::IATPatch/"new"> +call. Returns undef on failure with error number available through +L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E">. If Unpatch was called once already, +calling it again will fail, and error will be ERROR_NO_MORE_ITEMS. + +=head3 GetOriginalFunctionPtr + +Returns the original function pointer found in the import table in C<123456> +format. If the returned pointer is 0, L<Win32::API::Callback::IATPatch/"Unpatch"> +was called earlier. There are no error numbers associated with this method. +This value can be directly used to create a function pointer based Win32::API +object to call the original destination function from inside your Perl callback. +See L<Win32::API::Callback::IATPatch/"SYNOPSIS"> for a usage example. + +=head1 BUGS AND LIMITATIONS + +=over 4 + +=item E<nbsp>Cygwin not supported + +L<new()|Win32::API::Callback::IATPatch/"new"> usually fatally errors on Cygwin +with "IATPatch 3GB mode not supported" on Cygwins that allocate the heap at +0x80000000 or are "Large Address Aware" + +=back + +=head1 SEE ALSO + +L<Win32::API::Callback> + +L<Win32::API> + +L<http://msdn.microsoft.com/en-us/magazine/cc301808.aspx> + +=head1 AUTHOR + +Daniel Dragan ( I<bulkdd@cpan.org> ). + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2012 by Daniel Dragan + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.10.0 or, +at your option, any later version of Perl 5 you may have available. + + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Struct.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Struct.pm new file mode 100644 index 0000000000..85d1f7154d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Struct.pm @@ -0,0 +1,755 @@ +# +# Win32::API::Struct - Perl Win32 API struct Facility +# +# Author: Aldo Calpini <dada@perl.it> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# + +package Win32::API::Struct; +use strict; +use warnings; +use vars qw( $VERSION ); +$VERSION = '0.67'; + +my %Known = (); + +#import DEBUG sub +sub DEBUG; +*DEBUG = *Win32::API::DEBUG; + +#package main; +# +#sub userlazyapisub2{ +# userlazyapisub(); +#} +#sub userlazyapisub { +# Win32::API::Struct::lazyapisub(); +#} +# +#sub userapisub { +# Win32::API::Struct::apisub(); +#} +# +#package Win32::API::Struct; +# +#sub lazyapisub { +# lazycarp('bad'); +#} +#sub apisub { +# require Carp; +# Carp::carp('bad'); +#} +sub lazycarp { + require Carp; + Carp::carp(@_); +} + +sub lazycroak { + require Carp; + Carp::croak(@_); +} + +sub typedef { + my $class = shift; + my $struct = shift; + my ($type, $name, @recog_arr); + my $self = { + align => undef, + typedef => [], + }; + while (defined($type = shift)) { + #not compatible with "unsigned foo;" + $type .= ' '.shift if $type eq 'unsigned' || $type eq 'signed'; + $name = shift; + #"int foo [8];" instead of "int foo[8];" so tack on the array count + { + BEGIN{warnings->unimport('uninitialized')} + $name .= shift if substr($_[0],0,1) eq '['; + } + #typedef() takes a list, not a str, for backcompat, this can't be changed + #but, should typedef() keep shifting slices until it finds ";" or not? + #all the POD examples have ;s, but they are actually optional, should it + #be assumed that existing code was nice and used ;s or not? backcompat + #breaks if you say ;-less member defs should be allowed and aren't a user + #mistake + $name =~ s/;$//; + @recog_arr = recognize($type, $name); +#http://perlmonks.org/?node_id=978468, not catching the type not found here, +#will lead to a div 0 later + if(@recog_arr != 3){ + lazycarp "Win32::API::Struct::typedef: unknown member type=\"$type\", name=\"$name\""; + return undef; + } + push(@{$self->{typedef}}, [@recog_arr]); + } + + $Known{$struct} = $self; + $Win32::API::Type::Known{$struct} = '>'; + return 1; +} + + +#void ck_type($param, $proto, $param_num) +sub ck_type { + my ($param, $proto) = @_; + #legacy LP prefix check + return if substr($proto, 0, 2) eq 'LP' && substr($proto, 2) eq $param; + #check if proto can be converted to base struct name + return if exists $Win32::API::Struct::Pointer{$proto} && + $param eq $Win32::API::Struct::Pointer{$proto}; + #check if proto can have * chopped off to convert to base struct name + $proto =~ s/\s*\*$//; + return if $proto eq $param; + lazycroak("Win32::API::Call: supplied type (LP)\"". + $param."\"( *) doesn't match type \"". + $_[1]."\" for parameter ". + $_[2]." "); +} + +#$basename = to_base_struct($pointername) +sub to_base_struct { + return $Win32::API::Struct::Pointer{$_[0]} + if exists $Win32::API::Struct::Pointer{$_[0]}; + die "Win32::API::Struct::Unpack unknown type"; +} + +sub recognize { + my ($type, $name) = @_; + my ($size, $packing); + + if (exists $Known{$type}) { + $packing = '>'; + return ($name, $packing, $type); + } + else { + $packing = Win32::API::Type::packing($type); + return undef unless defined $packing; + if ($name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $packing . '*' . $size; + } + DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n" if DEBUGCONST; + return ($name, $packing, $type); + } +} + +sub new { + my $class = shift; + my ($type, $name, $packing); + my $self = {typedef => [],}; + if ($#_ == 0) { + if (is_known($_[0])) { + DEBUG "(PM)Struct::new: got '$_[0]'\n" if DEBUGCONST; + if( ! defined ($self->{typedef} = $Known{$_[0]}->{typedef})){ + lazycarp 'Win32::API::Struct::new: unknown type="'.$_[0].'"'; + return undef; + } + foreach my $member (@{$self->{typedef}}) { + ($name, $packing, $type) = @$member; + next unless defined $name; + if ($packing eq '>') { + $self->{$name} = Win32::API::Struct->new($type); + } + } + $self->{__typedef__} = $_[0]; + } + else { + lazycarp "Unknown Win32::API::Struct '$_[0]'"; + return undef; + } + } + else { + while (defined($type = shift)) { + $name = shift; + + # print "new: found member $name ($type)\n"; + if (not exists $Win32::API::Type::Known{$type}) { + lazycarp "Unknown Win32::API::Struct type '$type'"; + return undef; + } + else { + push(@{$self->{typedef}}, + [$name, $Win32::API::Type::Known{$type}, $type]); + } + } + } + return bless $self; +} + +sub members { + my $self = shift; + return map { $_->[0] } @{$self->{typedef}}; +} + +sub sizeof { + my $self = shift; + my $size = 0; + my $align = 0; + my $first = ''; + + for my $member (@{$self->{typedef}}) { + my ($name, $packing, $type) = @{$member}; + next unless defined $name; + if (ref $self->{$name} eq q{Win32::API::Struct}) { + + # If member is a struct, recursively calculate its size + # FIXME for subclasses + $size += $self->{$name}->sizeof(); + } + else { + + # Member is a simple type (LONG, DWORD, etc...) + if ($packing =~ /\w\*(\d+)/) { # Arrays (ex: 'c*260') + $size += Win32::API::Type::sizeof($type) * $1; + $first = Win32::API::Type::sizeof($type) * $1 unless defined $first; + DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = " . $size + . "\n" if DEBUGCONST; + } + else { # Simple types + my $type_size = Win32::API::Type::sizeof($type); + $align = $type_size if $type_size > $align; + my $type_align = (($size + $type_size) % $type_size); + $size += $type_size + $type_align; + $first = Win32::API::Type::sizeof($type) unless defined $first; + } + } + } + + my $struct_size = $size; + if (defined $align && $align > 0) { + $struct_size += ($size % $align); + } + DEBUG "(PM)Struct::sizeof first=$first totalsize=$struct_size\n" if DEBUGCONST; + return $struct_size; +} + +sub align { + my $self = shift; + my $align = shift; + + if (not defined $align) { + + if (!(defined $self->{align} && $self->{align} eq 'auto')) { + return $self->{align}; + } + + $align = 0; + + foreach my $member (@{$self->{typedef}}) { + my ($name, $packing, $type) = @$member; + + if (ref($self->{$name}) eq "Win32::API::Struct") { + #### ???? + } + else { + if ($packing =~ /\w\*(\d+)/) { + #### ???? + } + else { + $align = Win32::API::Type::sizeof($type) + if Win32::API::Type::sizeof($type) > $align; + } + } + } + return $align; + } + else { + $self->{align} = $align; + + } +} + +sub getPack { + my $self = shift; + my $packing = ""; + my $packed_size = 0; + my ($type, $name, $type_size, $type_align); + my @items = (); + my @recipients = (); + my @buffer_ptrs = (); #this contains the struct_ptrs that were placed in the + #the struct, its part of "C func changes the struct ptr to a private allocated + #struct" code, it is push/poped only for struct ptrs, it is NOT a 1 to + #1 mapping between all struct members, so don't access it with indexes + + my $align = $self->align(); + + foreach my $member (@{$self->{typedef}}) { + my ($name, $type, $orig) = @$member; + if ($type eq '>') { + my ($subpacking, $subitems, $subrecipients, $subpacksize, $subbuffersptrs) = + $self->{$name}->getPack(); + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n" if DEBUGCONST; + push(@items, @$subitems); + push(@recipients, @$subrecipients); + push(@buffer_ptrs, @$subbuffersptrs); + $packing .= $subpacking; + $packed_size += $subpacksize; + } + else { + my $repeat = 1; + $type_size = Win32::API::Type::sizeof($orig); + if ($type =~ /\w\*(\d+)/) { + $repeat = $1; + $type = 'a'.($repeat*$type_size); + } + + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n" if DEBUGCONST; + + if ($type eq 'p') { + $type = Win32::API::Type::pointer_pack_type(); + push(@items, Win32::API::PointerTo($self->{$name})); + } + elsif ($type eq 'T') { + $type = Win32::API::Type::pointer_pack_type(); + my $structptr; + if(ref($self->{$name})){ + $self->{$name}->Pack(); + $structptr = Win32::API::PointerTo($self->{$name}->{buffer}); + } + else{ + $structptr = 0; + } + push(@items, $structptr); + push(@buffer_ptrs, $structptr); + } + else { + push(@items, $self->{$name}); + } + push(@recipients, $self); + $type_align = (($packed_size + $type_size) % $type_size); + $packing .= "x" x $type_align . $type; + $packed_size += ( $type_size * $repeat ) + $type_align; + } + } + + DEBUG + "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, $packed_size)\n" if DEBUGCONST; + + return ($packing, [@items], [@recipients], $packed_size, \@buffer_ptrs); +} + +# void $struct->Pack([$priv_warnings_flag]); +sub Pack { + my $self = shift; + my ($packing, $items); + ($packing, $items, $self->{buffer_recipients}, + undef, $self->{buffer_ptrs}) = $self->getPack(); + + DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n" if DEBUGCONST; + + if($_[0]){ #Pack() on a new struct, without slice set, will cause lots of uninit + #warnings, sometimes its intentional to set up buffer recipients for a + #future UnPack() + BEGIN{warnings->unimport('uninitialized')} + $self->{buffer} = pack($packing, @$items); + } + else{ + $self->{buffer} = pack($packing, @$items); + } + if (DEBUGCONST) { + for my $i (0 .. $self->sizeof - 1) { + printf "#pack# %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1)); + } + } +} + +sub getUnpack { + my $self = shift; + my $packing = ""; + my $packed_size = 0; + my ($type, $name, $type_size, $type_align, $orig_type); + my (@items, @types, @type_names); + my $align = $self->align(); + foreach my $member (@{$self->{typedef}}) { + my ($name, $type, $orig) = @$member; + if ($type eq '>') { + my ($subpacking, $subpacksize, $subitems, $subtypes, $subtype_names) = $self->{$name}->getUnpack(); + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n" if DEBUGCONST; + $packing .= $subpacking; + $packed_size += $subpacksize; + push(@items, @$subitems); + push(@types, @$subtypes); + push(@type_names, @$subtype_names); + } + else { + if($type eq 'T') { + $orig_type = $type; + $type = Win32::API::Type::pointer_pack_type(); + } + $type_size = Win32::API::Type::sizeof($orig); + my $repeat = 1; + if ($type =~ /\w\*(\d+)/) { #some kind of array + $repeat = $1; + $type = + $type_size == 1 ? + 'Z'.$repeat #have pack truncate to NULL char + :'a'.($repeat*$type_size); #manually truncate to wide NULL char later + } + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n" if DEBUGCONST; + $type_align = (($packed_size + $type_size) % $type_size); + $packing .= "x" x $type_align . $type; + $packed_size += ( $type_size * $repeat ) + $type_align; + push(@items, $name); + if($orig_type){ + push(@types, $orig_type); + undef($orig_type); + } + else{ + push(@types, $type); + } + push(@type_names, $orig); + } + } + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n" if DEBUGCONST; + return ($packing, $packed_size, \@items, \@types, \@type_names); +} + +sub Unpack { + my $self = shift; + my ($packing, undef, $items, $types, $type_names) = $self->getUnpack(); + my @itemvalue = unpack($packing, $self->{buffer}); + DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n" if DEBUGCONST; + foreach my $i (0 .. $#$items) { + my $recipient = $self->{buffer_recipients}->[$i]; + my $item = $$items[$i]; + my $type = $$types[$i]; + DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n", + $recipient->{__typedef__}, + $item, + $itemvalue[$i], + $itemvalue[$i], + if DEBUGCONST; + if($type eq 'T'){ +my $oldstructptr = pop(@{$self->{buffer_ptrs}}); +my $newstructptr = $itemvalue[$i]; +my $SVMemberRef = \$recipient->{$item}; + +if(!$newstructptr){ #new ptr is null + if($oldstructptr != $newstructptr){ #old ptr was true + lazycarp "Win32::API::Struct::Unpack struct pointer". + " member \"".$item."\" was changed by C function,". + " possible resource leak"; + } + $$SVMemberRef = undef; +} +else{ #new ptr is true + if($oldstructptr != $newstructptr){#old ptr was true, or null, but has changed, leak warning + lazycarp "Win32::API::Struct::Unpack struct pointer". + " member \"".$item."\" was changed by C function,". + " possible resource leak"; + }#create a ::Struct if the slice is undef, user had the slice set to undef + + if (!ref($$SVMemberRef)){ + $$SVMemberRef = Win32::API::Struct->new(to_base_struct($type_names->[$i])); + $$SVMemberRef->Pack(1); #buffer_recipients must be generated, no uninit warnings + } +#must fix {buffer} with contents of the new struct, $structptr might be +#null or might be a SVPV from a ::Struct that was ignored, in any case, +#a foreign memory allocator is at work here + $$SVMemberRef->{buffer} = Win32::API::ReadMemory($newstructptr, $$SVMemberRef->sizeof) + if($oldstructptr != $newstructptr); +#always must be called, if new ptr is not null, at this point, C func, did +#one of 2 things, filled the old ::Struct's {buffer} PV, or gave a new struct * +#from its own allocator, there is no way to tell if the struct contents changed +#so Unpack() must be called + $$SVMemberRef->Unpack(); +} +} + else{ #not a struct ptr + my $itemvalueref = \$itemvalue[$i]; + Win32::API::_TruncateToWideNull($$itemvalueref) + if substr($type,0,1) eq 'a' && length($type) > 1; + $recipient->{$item} = $$itemvalueref; + + # DEBUG "(PM)Struct::Unpack: self.items[$i] = $self->{$$items[$i]}\n"; + } + } +} + +sub FromMemory { + my ($self, $addr) = @_; + DEBUG "(PM)Struct::FromMemory: doing Pack\n" if DEBUGCONST; + $self->Pack(); + DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof if DEBUGCONST; + $self->{buffer} = Win32::API::ReadMemory($addr, $self->sizeof); + $self->Unpack(); + if(DEBUGCONST) { + DEBUG "(PM)Struct::FromMemory: doing Unpack\n"; + DEBUG "(PM)Struct::FromMemory: structure is now:\n"; + $self->Dump(); + DEBUG "\n"; + } +} + +sub Dump { + my $self = shift; + my $prefix = shift; + foreach my $member (@{$self->{typedef}}) { + my ($name, $packing, $type) = @$member; + if (ref($self->{$name})) { + $self->{$name}->Dump($name); + } + else { + printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name}; + } + } +} + +#the LP logic should be moved to parse_prototype, since only +#::API::Call() ever understood the implied LP prefix, Struct::new never did +#is_known then can be inlined away and sub deleted, it is not public API +sub is_known { + my $name = shift; + if (exists $Known{$name}) { + return 1; + } + else { + my $nametest = $name; + if ($nametest =~ s/^LP//) { + return exists $Known{$nametest}; + } + $nametest = $name; + if($nametest =~ s/\*$//){ + return exists $Known{$nametest}; + } + return 0; + } +} + +sub TIEHASH { + return Win32::API::Struct::new(@_); +} + +sub EXISTS { + +} + +sub FETCH { + my $self = shift; + my $key = shift; + + if ($key eq 'sizeof') { + return $self->sizeof; + } + my @members = map { $_->[0] } @{$self->{typedef}}; + if (grep(/^\Q$key\E$/, @members)) { + return $self->{$key}; + } + else { + warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; + } +} + +sub STORE { + my $self = shift; + my ($key, $val) = @_; + my @members = map { $_->[0] } @{$self->{typedef}}; + if (grep(/^\Q$key\E$/, @members)) { + $self->{$key} = $val; + } + else { + warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; + } +} + +sub FIRSTKEY { + my $self = shift; + my @members = map { $_->[0] } @{$self->{typedef}}; + return $members[0]; +} + +sub NEXTKEY { + my $self = shift; + my $key = shift; + my @members = map { $_->[0] } @{$self->{typedef}}; + for my $i (0 .. $#members - 1) { + return $members[$i + 1] if $members[$i] eq $key; + } + return undef; +} + +1; + +__END__ + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Struct - C struct support package for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + + Win32::API::Struct->typedef( 'POINT', qw( + LONG x; + LONG y; + )); + + my $Point = Win32::API::Struct->new( 'POINT' ); + $Point->{x} = 1024; + $Point->{y} = 768; + + #### alternatively + + tie %Point, 'Win32::API::Struct', 'POINT'; + $Point{x} = 1024; + $Point{y} = 768; + + +=head1 ABSTRACT + +This module enables you to define C structs for use with +Win32::API. + +See L<Win32::API/USING STRUCTURES> for more info about its usage. + +=head1 DESCRIPTION + +This module is automatically imported by Win32::API, so you don't +need to 'use' it explicitly. The main methods are C<typedef> and +C<new>, which are documented below. + +=over 4 + +=item C<typedef NAME, TYPE, MEMBER, TYPE, MEMBER, ...> + +This method defines a structure named C<NAME>. The definition consists +of types and member names, just like in C. In fact, most of the +times you can cut the C definition for a structure and paste it +verbatim to your script, enclosing it in a C<qw()> block. The +function takes care of removing the semicolon after the member +name. Win32::API::Struct does B<NOT> support Enums, Unions, or Bitfields. +C<NAME> must not end in C<*>, typedef creates structs, not struct pointers. +See L<Win32::API::Type/"typedef"> +on how to create a struct pointer type. Returns true on success, and undef on error. +On error it L<warns|perlfunc/warn> with the specific reason. + +The synopsis example could be written like this: + + Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y'); + +But it could also be written like this (note the indirect object +syntax), which is pretty cool: + + typedef Win32::API::Struct POINT => qw{ + LONG x; + LONG y; + }; + +L<Win32::API/Call> automatically knows that an 'LPNAME' type, refers +to a 'NAME' type struct. Also see L<Win32::API::Type/"typedef"> on how to declare +pointers to struct types. + +Unlike in Win32::API, a single non-array char or CHAR struct member in a +struct is numeric, NOT the first character of a string. UTF16 strings pointers +will be garbage on read back (passing in works, returning doesn't) since +the NULL character will often be the 2nd byte of the UTF16 string. + +=item C<new NAME> + +This creates a structure (a Win32::API::Struct object) of the +type C<NAME> (it must have been defined with C<typedef>). In Perl, +when you create a structure, all the members are undefined. But +when you use that structure in C (eg. a Win32::API call), you +can safely assume that they will be treated as zero (or NULL). + +=item C<sizeof> + +This returns the size, in bytes, of the structure. Acts just like +the C function of the same name. It is particularly useful for +structures that need a member to be initialized to the structure's +own size. + +=item C<align [SIZE]> + +Sets or returns the structure alignment (eg. how the structure is +stored in memory). This is a very advanced option, and you normally +don't need to mess with it. +All structures in the Win32 Platform SDK should work without it. +But if you define your own structure, you may need to give it an +explicit alignment. In most cases, passing a C<SIZE> of 'auto' +should keep the world happy. + +=back + +=head2 THE C<tie> INTERFACE + +Instead of creating an object with the C<new> method, you can +tie a hash, which will hold the desired structure, using the +C<tie> builtin function: + + tie %structure, Win32::API::Struct => 'NAME'; + +The differences between the tied and non-tied approaches are: + +=over 4 + +=item * +with tied structures, you can access members directly as +hash lookups, eg. + + # tied # non-tied + $Point{x} vs. $Point->{x} + +=item * +with tied structures, when you try to fetch or store a +member that is not part of the structure, it will result +in a warning, eg. + + print $Point{z}; + # this will warn: 'z' is not a member of Win32::API::Struct POINT + +=item * +when you pass a tied structure as a Win32::API parameter, +remember to backslash it, eg. + + # tied # non-tied + GetCursorPos( \%Point ) vs. GetCursorPos( $Point ) + +=back + +=head2 FOREIGN MEMORY ALLOCATORS + +Using Win32::API::Struct is not recommended in situations where a C function +will return results to you by putting a pointer to a string or a pointer to +another struct into your supplied struct. Win32::API::Struct will do its best +to detect that a new pointer appeared and to read it contents into Perl, but +that pointer will be tossed away after being read. If this pointer is +something you must explicitly free, you have leaked it by using +Win32::API::Struct to decode it. If this pointer is something you must pass back to +the C API you are using, you lost/leaked it. If you pass NULL, or a ::Struct +pointer in a ::Struct to C API, after the C API call, ::Struct will detect the +pointer changed, it will read the new struct from the new pointer into +Perl, and a new child ::Struct will appear in the hash slice +of the parent ::Struct, if you pass this new child ::Struct into the C API +it will be a B<COPY> of the struct the C API from Perl's allocation placed +in the parent ::Struct. For C++-like APIs, this will be unacceptable and lead to +crashes as the C Functions tries to free a memory block that didn't come from the +allocator of the C Function. Windows has many memory allocators, each CRT +(VS 2, 3, 4, 5, NT/6, 7.0, 7.1, 8, 9, 10) malloc, LocalAlloc, GlobalAlloc, +HeapAlloc, (each version of C++ Runtime Library) "new", CoGetMalloc, CoTaskMemAlloc, +NetApiBufferAllocate, VirtualAlloc, CryptMemAlloc, AllocADsMem, SHAlloc, +SnmpUtilMemAlloc. None of these allocators' pointers are compatible with Perl's +allocator. Some C APIs give you static global buffers which never are freed or freed +automatically in the next call to a function from to that DLL. + +With foreign allocators, its best to treat to write a pointer class, bless the +ref to scalar integer (holding the pointer) into that class to ensure that the +DESTROY method will free the pointer and you never leak it, and your write +method accessors using L<perlfunc/pack>, L<Win32::API/ReadMemory> and +L<Win32::API/WriteMemory> around the pointer. + + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ). + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Type.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Type.pm new file mode 100644 index 0000000000..3c4c4d5fea --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Type.pm @@ -0,0 +1,590 @@ +package Win32::API::Type; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Type - Perl Win32 API type definitions +# +# Author: Aldo Calpini <dada@perl.it> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# +####################################################################### + +use strict; +use warnings; +use vars qw( %Known %PackSize %Modifier %Pointer $VERSION ); + +$VERSION = '0.70'; + +#import DEBUG sub +sub DEBUG; +*DEBUG = *Win32::API::DEBUG; + +#const optimize +BEGIN { + eval ' sub pointer_pack_type () { \'' + .(PTRSIZE == 8 ? 'Q' : 'L'). + '\' }'; +} + +%Known = (); +%PackSize = (); +%Modifier = (); +%Pointer = (); + +# Initialize data structures at startup. +# Aldo wants to keep the <DATA> approach. +# +my $section = 'nothing'; +foreach (<DATA>) { + next if /^\s*(?:#|$)/; + chomp; + if (/\[(.+)\]/) { + $section = $1; + next; + } + if ($section eq 'TYPE') { + my ($name, $packing) = split(/\s+/); + + # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n"; + $packing = pointer_pack_type() + if ($packing eq '_P'); + $Known{$name} = $packing; + } + elsif ($section eq 'POINTER') { + my ($pointer, $pointto) = split(/\s+/); + + # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n"; + $Pointer{$pointer} = $pointto; + } + elsif ($section eq 'PACKSIZE') { + my ($packing, $size) = split(/\s+/); + + # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n"; + $size = PTRSIZE + if ($size eq '_P'); + $PackSize{$packing} = $size; + } + elsif ($section eq 'MODIFIER') { + my ($modifier, $mapto) = split(/\s+/, $_, 2); + my %maps = (); + foreach my $item (split(/\s+/, $mapto)) { + my ($k, $v) = split(/=/, $item); + $maps{$k} = $v; + } + + # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n"; + $Modifier{$modifier} = {%maps}; + } +} +close(DATA); + +sub new { + my $class = shift; + my ($type) = @_; + my $packing = packing($type); + my $size = sizeof($type); + my $self = { + type => $type, + packing => $packing, + size => $size, + }; + return bless $self; +} + +sub typedef { + my $class = shift; + my ($name, $type) = @_; + $type =~ m/^\s*(.*?)\s*$/; + $type =~ m/^(.+?)\s*(\*)$/; + $type = $1; + $type .= $2 if defined $2; + $name =~ m/^\s*(.*?)\s*$/; + $name =~ m/^(.+?)\s*(\*)$/; + $name = $1; + $name .= $2 if defined $2; + #FIXME BUG, unsigned __int64 * doesn't pase in typedef, it does in parse_prototype + my $packing = packing($type, $name); #FIXME BUG + if(! defined $packing){ + warn "Win32::API::Type::typedef: WARNING unknown type '$_[1]'"; + return undef; + } + #Win32::API::Struct logic + #limitation, this won't alias a new struct type to an existing struct type + #this only creates new struct type pointer types to an existing struct type + if($packing eq '>'){ + if(is_pointer($type)){ + $packing = 'T'; + $type =~ s/\s*\*$//; #chop off ' *' + $Win32::API::Struct::Pointer{$name} = $type; + } + else{ + warn "Win32::API::Type::typedef: aliasing struct \"".$_[0] + ."\" to struct \"".$_[1]."\" not supported"; + return undef; + } + } + DEBUG "(PM)Type::typedef: packing='$packing'\n" if DEBUGCONST; + if($packing eq 'p'){ + $Pointer{$name} = $Pointer{$type}; + }else{ + $Known{$name} = $packing; + } + return 1; +} + + +sub is_known { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if (ref($type) =~ /Win32::API::Type/) { + return 1; + } + else { + return defined packing($type); + } +} + +sub sizeof { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if (ref($type) =~ /Win32::API::Type/) { + return $self->{size}; + } + else { + my $packing = packing($type); + if ($packing =~ /(\w)\*(\d+)/) { + return $PackSize{$1} * $2; + } + else { + return $PackSize{$packing}; + } + } +} +# $packing_letter = packing( [$class = 'Win32::API::Type' ,] $type [, $pass_numeric]) +sub packing { + + # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n"; + my $self = shift; + my $is_pointer = 0; + if (ref($self) =~ /Win32::API::Type/) { + + # DEBUG "(PM)Type::packing: got an object\n"; + return $self->{packing}; + } + my $type = ($self eq 'Win32::API::Type') ? shift : $self; + my $name = shift; + my $pass_numeric = shift; + + # DEBUG "(PM)Type::packing: got '$type', '$name'\n"; + my ($modifier, $size, $packing); + if (exists $Pointer{$type}) { + + # DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n"; + $type = $Pointer{$type}; + $is_pointer = 1; + } + elsif ($type =~ /(\w+)\s+(\w+)/) { + $modifier = $1; + $type = $2; + + # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n"; + } + + $type =~ s/\s*\*$//; #kill whitespace "CHAR " isn't "CHAR" + + if (exists $Known{$type}) { + if (defined $name and $name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $Known{$type}[0] . "*" . $size; + + # DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n"; + } + else { + $packing = $Known{$type}; + if ($is_pointer and ($packing eq 'c' or $packing eq 'S')) { + $packing = "p"; + } + + # DEBUG "(PM)Type::packing: simple packing: '$packing'\n"; + } + if (defined $modifier and exists $Modifier{$modifier}->{$type}) { + +# DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n"; + $packing = $Modifier{$modifier}->{$type}; + if(!$pass_numeric) { #for older num unaware calls + substr($packing, 0, length("num"), ''); + } + } + return $packing; + } + else { + + # DEBUG "(PM)Type::packing: NOT FOUND\n"; + return undef; + } +} + + +sub is_pointer { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if (ref($type) =~ /Win32::API::Type/) { + return 1; + } + else { + if ($type =~ /\*$/) { + return 1; + } + else { + return exists $Pointer{$type}; + } + } +} + +sub Pack { + my $type = $_[1]; + + my $pack_type = packing($type); + #print "Pack: type $type pack_type $pack_type\n"; + if ($pack_type eq 'p') { #char or wide char pointer + #$pack_type = 'Z*'; + return; + } + elsif(IVSIZE() == 4 && ($pack_type eq 'q' || $pack_type eq 'Q')){ + if($_[0]->UseMI64() || ref($_[2])){ #un/signed meaningless + $_[2] = Math::Int64::int64_to_native($_[2]); + } + else{ + if(length($_[2]) < 8){ + warn("Win32::API::Call value for 64 bit integer is under 8 bytes long"); + $_[2] = pack('a8', $_[2]); + } + } + return; + } + $_[2] = pack($pack_type, $_[2]); + return; +} + +sub Unpack { + my $type = $_[1]; + + my $pack_type = packing($type); + + if ($pack_type eq 'p') { + DEBUG "(PM)Type::Unpack: got packing 'p': is a pointer\n" if DEBUGCONST; + #$pack_type = 'Z*'; + return; + } + elsif(IVSIZE() == 4){ + #todo debugging output + if($pack_type eq 'q'){ + if($_[0]->UseMI64() || ref($_[2])){ + $_[2] = Math::Int64::native_to_int64($_[2]); + DEBUG "(PM)Type::Unpack: returning signed Math::Int64 '".$_[2]."'\n" if DEBUGCONST; + } + return; + }elsif($pack_type eq 'Q'){ + if($_[0]->UseMI64() || ref($_[2])){ + $_[2] = Math::Int64::native_to_uint64($_[2]); + DEBUG "(PM)Type::Unpack: returning unsigned Math::Int64 '".$_[2]."'\n" if DEBUGCONST; + } + return; + } + } + DEBUG "(PM)Type::Unpack: unpacking '$pack_type' '$_[2]'\n" if DEBUGCONST; + $_[2] = unpack($pack_type, $_[2]); + DEBUG "(PM)Type::Unpack: returning '" . ($_[2] || '') . "'\n" if DEBUGCONST; +} + +1; + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Type - C type support package for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + + Win32::API::Type->typedef( 'my_number', 'LONG' ); + + +=head1 ABSTRACT + +This module is a support package for Win32::API that implements +C types for the import with prototype functionality. + +See L<Win32::API> for more info about its usage. + +=head1 DESCRIPTION + +This module is automatically imported by Win32::API, so you don't +need to 'use' it explicitly. These are the methods of this package: + +=over 4 + +=item C<typedef NAME, TYPE> + +This method defines a new type named C<NAME>. This actually just +creates an alias for the already-defined type C<TYPE>, which you +can use as a parameter in a Win32::API call. + +When C<TYPE> contains a Win32::API::Struct type declared with +L<Win32::API::Struct/typedef> with " *" postfixed to C<TYPE> parameter, +C<NAME> will be a alias for the pointer version of the struct type. Creating +an alias for a struct type is not supported, you have to call +L<Win32::API::Struct/typedef> again. Passing a struct type as C<TYPE> +without the " *" postfix is not supported. + +L<Warns|perlfunc/warn> and returns undef if C<TYPE> is unknown, else returns true. + +=item C<sizeof TYPE> + +This returns the size, in bytes, of C<TYPE>. Acts just like +the C function of the same name. + +=item C<is_known TYPE> + +Returns true if C<TYPE> is known by Win32::API::Type, false +otherwise. + +=back + +=head2 SUPPORTED TYPES + +This module recognizes many commonly used types defined in the Win32 Platform +SDK header files, but not all. Types less than 13 years old are very unlikely +to be the in built type database. + +Please see the source for this module, in the C<__DATA__> section, +for the full list of builtin supported types. + + +=head2 NOTES ON SELECT TYPES + +=over 4 + +=item LPVOID + +Due to poor design, currently LPVOID is a char *, a string, not a number. +It should really be a number. It is suggested to replace LPVOID in your +C prototypes passed to Win32::API with UINT_PTR which is a pointer +sized number. + +=item SOMETYPE ** + +Currently ** types do not parse. + +=item void ** + +Replace void ** in your C prototype that you pass to Win32::API::More with +LPHANDLE. + +=item unsigned char + +=item signed char + +These 2 types by name force numeric handling. C<97> not C<"a">. C<UCHAR> is +not a C<unsigned char> for numeric handling purposes. + +=back + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ). + +=cut + + +__DATA__ + +[TYPE] +ATOM s +BOOL L +BOOLEAN c +BYTE C +CHAR c +COLORREF L +DWORD L +DWORD32 L +DWORD64 Q +DWORD_PTR _P +FLOAT f +HACCEL _P +HANDLE _P +HBITMAP _P +HBRUSH _P +HCOLORSPACE _P +HCONV _P +HCONVLIST _P +HCURSOR _P +HDC _P +HDDEDATA _P +HDESK _P +HDROP _P +HDWP _P +HENHMETAFILE _P +HFILE _P +HFONT _P +HGDIOBJ _P +HGLOBAL _P +HHOOK _P +HICON _P +HIMC _P +HINSTANCE _P +HKEY _P +HKL _P +HLOCAL _P +HMENU _P +HMETAFILE _P +HMODULE _P +HPALETTE _P +HPEN _P +HRGN _P +HRSRC _P +HSZ _P +HWINSTA _P +HWND _P +INT i +INT32 i +INT64 q +LANGID s +LCID L +LCSCSTYPE L +LCSGAMUTMATCH L +LCTYPE L +LONG l +LONG32 l +LONG64 q +LONGLONG q +LPARAM _P +LRESULT _P +NTSTATUS l +REGSAM L +SC_HANDLE _P +SC_LOCK _P +SERVICE_STATUS_HANDLE _P +SHORT s +SIZE_T _P +SSIZE_T _P +TBYTE c +TCHAR C +UCHAR C +UINT I +UINT_PTR _P +UINT32 I +UINT64 Q +ULONG L +ULONG32 L +ULONG64 Q +ULONGLONG Q +USHORT S +WCHAR S +WORD S +WPARAM _P +VOID c + +int i +long l +float f +double d +char c +short s +void c +__int64 q + +#VOID is a 'c'? huh? +#making void be a 'c' too, ~bulk88 +#CRITICAL_SECTION 24 -- a structure +#LUID ? 8 -- a structure +#VOID 0 +#CONST 4 +#FILE_SEGMENT_ELEMENT 8 -- a structure + +[PACKSIZE] +c 1 +C 1 +d 8 +f 4 +i 4 +I 4 +l 4 +L 4 +q 8 +Q 8 +s 2 +S 2 +p _P +T _P +t _P + +[MODIFIER] +unsigned int=numI long=numL short=numS char=numC +signed int=numi long=numl short=nums char=numc + +[POINTER] +INT_PTR INT +LPBOOL BOOL +LPBYTE BYTE +LPCOLORREF COLORREF +LPCSTR CHAR +#LPCTSTR CHAR or WCHAR +LPCTSTR CHAR +LPCVOID any +LPCWSTR WCHAR +LPDOUBLE double +LPDWORD DWORD +LPHANDLE HANDLE +LPINT INT +LPLONG LONG +LPSTR CHAR +#LPTSTR CHAR or WCHAR +LPTSTR CHAR +LPVOID VOID +LPWORD WORD +LPWSTR WCHAR + +PBOOL BOOL +PBOOLEAN BOOL +PBYTE BYTE +PCHAR CHAR +PCSTR CSTR +PCWCH CWCH +PCWSTR CWSTR +PDWORD DWORD +PFLOAT FLOAT +PHANDLE HANDLE +PHKEY HKEY +PINT INT +PLCID LCID +PLONG LONG +PSHORT SHORT +PSTR CHAR +#PTBYTE TBYTE -- +#PTCHAR TCHAR -- +#PTSTR CHAR or WCHAR +PTSTR CHAR +PUCHAR UCHAR +PUINT UINT +PULONG ULONG +PUSHORT USHORT +PVOID VOID +PWCHAR WCHAR +PWORD WORD +PWSTR WCHAR +char* CHAR diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Console.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Console.pm new file mode 100644 index 0000000000..2e41c2a83d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Console.pm @@ -0,0 +1,1463 @@ +####################################################################### +# +# Win32::Console - Win32 Console and Character Mode Functions +# +####################################################################### + +package Win32::Console; + +require Exporter; +require DynaLoader; + +$VERSION = "0.10"; + +@ISA= qw( Exporter DynaLoader ); +@EXPORT = qw( + BACKGROUND_BLUE + BACKGROUND_GREEN + BACKGROUND_INTENSITY + BACKGROUND_RED + CAPSLOCK_ON + CONSOLE_TEXTMODE_BUFFER + CTRL_BREAK_EVENT + CTRL_C_EVENT + ENABLE_ECHO_INPUT + ENABLE_LINE_INPUT + ENABLE_MOUSE_INPUT + ENABLE_PROCESSED_INPUT + ENABLE_PROCESSED_OUTPUT + ENABLE_WINDOW_INPUT + ENABLE_WRAP_AT_EOL_OUTPUT + ENHANCED_KEY + FILE_SHARE_READ + FILE_SHARE_WRITE + FOREGROUND_BLUE + FOREGROUND_GREEN + FOREGROUND_INTENSITY + FOREGROUND_RED + LEFT_ALT_PRESSED + LEFT_CTRL_PRESSED + NUMLOCK_ON + GENERIC_READ + GENERIC_WRITE + RIGHT_ALT_PRESSED + RIGHT_CTRL_PRESSED + SCROLLLOCK_ON + SHIFT_PRESSED + STD_INPUT_HANDLE + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + $FG_BLACK + $FG_GRAY + $FG_BLUE + $FG_LIGHTBLUE + $FG_RED + $FG_LIGHTRED + $FG_GREEN + $FG_LIGHTGREEN + $FG_MAGENTA + $FG_LIGHTMAGENTA + $FG_CYAN + $FG_LIGHTCYAN + $FG_BROWN + $FG_YELLOW + $FG_LIGHTGRAY + $FG_WHITE + $BG_BLACK + $BG_GRAY + $BG_BLUE + $BG_LIGHTBLUE + $BG_RED + $BG_LIGHTRED + $BG_GREEN + $BG_LIGHTGREEN + $BG_MAGENTA + $BG_LIGHTMAGENTA + $BG_CYAN + $BG_LIGHTCYAN + $BG_BROWN + $BG_YELLOW + $BG_LIGHTGRAY + $BG_WHITE + $ATTR_NORMAL + $ATTR_INVERSE + @CONSOLE_COLORS +); + + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. +# + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { +# if ($! =~ /Invalid/) { +# $AutoLoader::AUTOLOAD = $AUTOLOAD; +# goto &AutoLoader::AUTOLOAD; +# } else { + ($pack, $file, $line) = caller; undef $pack; + die "Symbol Win32::Console::$constname not defined, used at $file line $line."; +# } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +####################################################################### +# STATIC OBJECT PROPERTIES +# + +# %HandlerRoutineStack = (); +# $HandlerRoutineRegistered = 0; + +####################################################################### +# PUBLIC METHODS +# + +#======== +sub new { +#======== + my($class, $param1, $param2) = @_; + + my $self = {}; + + if (defined($param1) + and ($param1 == constant("STD_INPUT_HANDLE", 0) + or $param1 == constant("STD_OUTPUT_HANDLE", 0) + or $param1 == constant("STD_ERROR_HANDLE", 0))) + { + $self->{'handle'} = _GetStdHandle($param1); + } + else { + $param1 = constant("GENERIC_READ", 0) | constant("GENERIC_WRITE", 0) unless $param1; + $param2 = constant("FILE_SHARE_READ", 0) | constant("FILE_SHARE_WRITE", 0) unless $param2; + $self->{'handle'} = _CreateConsoleScreenBuffer($param1, $param2, + constant("CONSOLE_TEXTMODE_BUFFER", 0)); + } + bless $self, $class; + return $self; +} + +#============ +sub Display { +#============ + my($self) = @_; + return undef unless ref($self); + return _SetConsoleActiveScreenBuffer($self->{'handle'}); +} + +#=========== +sub Select { +#=========== + my($self, $type) = @_; + return undef unless ref($self); + return _SetStdHandle($type, $self->{'handle'}); +} + +#=========== +sub SetIcon { +#=========== + my($self, $icon) = @_; + $icon = $self unless ref($self); + return _SetConsoleIcon($icon); +} + +#========== +sub Title { +#========== + my($self, $title) = @_; + $title = $self unless ref($self); + + if (defined($title)) { + return _SetConsoleTitle($title); + } + else { + return _GetConsoleTitle(); + } +} + +#============== +sub WriteChar { +#============== + my($self, $text, $col, $row) = @_; + return undef unless ref($self); + return _WriteConsoleOutputCharacter($self->{'handle'},$text,$col,$row); +} + +#============= +sub ReadChar { +#============= + my($self, $size, $col, $row) = @_; + return undef unless ref($self); + + my $buffer = (" " x $size); + if (_ReadConsoleOutputCharacter($self->{'handle'}, $buffer, $size, $col, $row)) { + return $buffer; + } + else { + return undef; + } +} + +#============== +sub WriteAttr { +#============== + my($self, $attr, $col, $row) = @_; + return undef unless ref($self); + return _WriteConsoleOutputAttribute($self->{'handle'}, $attr, $col, $row); +} + +#============= +sub ReadAttr { +#============= + my($self, $size, $col, $row) = @_; + return undef unless ref($self); + return _ReadConsoleOutputAttribute($self->{'handle'}, $size, $col, $row); +} + +#========== +sub Write { +#========== + my($self,$string) = @_; + return undef unless ref($self); + return _WriteConsole($self->{'handle'}, $string); +} + +#============= +sub ReadRect { +#============= + my($self, $left, $top, $right, $bottom) = @_; + return undef unless ref($self); + + my $col = $right - $left + 1; + my $row = $bottom - $top + 1; + + my $buffer = (" " x ($col*$row*4)); + if (_ReadConsoleOutput($self->{'handle'}, $buffer, + $col, $row, 0, 0, + $left, $top, $right, $bottom)) + { + return $buffer; + } + else { + return undef; + } +} + +#============== +sub WriteRect { +#============== + my($self, $buffer, $left, $top, $right, $bottom) = @_; + return undef unless ref($self); + + my $col = $right - $left + 1; + my $row = $bottom - $top + 1; + + return _WriteConsoleOutput($self->{'handle'}, $buffer, + $col, $row, 0, 0, + $left, $top, $right, $bottom); +} + +#=========== +sub Scroll { +#=========== + my($self, $left1, $top1, $right1, $bottom1, + $col, $row, $char, $attr, + $left2, $top2, $right2, $bottom2) = @_; + return undef unless ref($self); + + return _ScrollConsoleScreenBuffer($self->{'handle'}, + $left1, $top1, $right1, $bottom1, + $col, $row, $char, $attr, + $left2, $top2, $right2, $bottom2); +} + +#============== +sub MaxWindow { +#============== + my($self, $flag) = @_; + return undef unless ref($self); + + if (not defined($flag)) { + my @info = _GetConsoleScreenBufferInfo($self->{'handle'}); + return $info[9], $info[10]; + } + else { + return _GetLargestConsoleWindowSize($self->{'handle'}); + } +} + +#========= +sub Info { +#========= + my($self) = @_; + return undef unless ref($self); + return _GetConsoleScreenBufferInfo($self->{'handle'}); +} + +#=========== +sub Window { +#=========== + my($self, $flag, $left, $top, $right, $bottom) = @_; + return undef unless ref($self); + + if (not defined($flag)) { + my @info = _GetConsoleScreenBufferInfo($self->{'handle'}); + return $info[5], $info[6], $info[7], $info[8]; + } + else { + return _SetConsoleWindowInfo($self->{'handle'}, $flag, $left, $top, $right, $bottom); + } +} + +#============== +sub GetEvents { +#============== + my($self) = @_; + return undef unless ref($self); + return _GetNumberOfConsoleInputEvents($self->{'handle'}); +} + +#========== +sub Flush { +#========== + my($self) = @_; + return undef unless ref($self); + return _FlushConsoleInputBuffer($self->{'handle'}); +} + +#============== +sub InputChar { +#============== + my($self, $number) = @_; + return undef unless ref($self); + + $number = 1 unless defined($number); + + my $buffer = (" " x $number); + if (_ReadConsole($self->{'handle'}, $buffer, $number) == $number) { + return $buffer; + } + else { + return undef; + } +} + +#========== +sub Input { +#========== + my($self) = @_; + return undef unless ref($self); + return _ReadConsoleInput($self->{'handle'}); +} + +#============== +sub PeekInput { +#============== + my($self) = @_; + return undef unless ref($self); + return _PeekConsoleInput($self->{'handle'}); +} + +#=============== +sub WriteInput { +#=============== + my($self) = shift; + return undef unless ref($self); + return _WriteConsoleInput($self->{'handle'}, @_); +} + +#========= +sub Mode { +#========= + my($self, $mode) = @_; + return undef unless ref($self); + if (defined($mode)) { + return _SetConsoleMode($self->{'handle'}, $mode); + } + else { + return _GetConsoleMode($self->{'handle'}); + } +} + +#======== +sub Cls { +#======== + my($self, $attr) = @_; + return undef unless ref($self); + + $attr = $ATTR_NORMAL unless defined($attr); + + my ($x, $y) = $self->Size(); + my($left, $top, $right ,$bottom) = $self->Window(); + my $vx = $right - $left; + my $vy = $bottom - $top; + $self->FillChar(" ", $x*$y, 0, 0); + $self->FillAttr($attr, $x*$y, 0, 0); + $self->Cursor(0, 0); + $self->Window(1, 0, 0, $vx, $vy); +} + +#========= +sub Attr { +#========= + my($self, $attr) = @_; + return undef unless ref($self); + + if (not defined($attr)) { + return (_GetConsoleScreenBufferInfo($self->{'handle'}))[4]; + } + else { + return _SetConsoleTextAttribute($self->{'handle'}, $attr); + } +} + +#=========== +sub Cursor { +#=========== + my($self, $col, $row, $size, $visi) = @_; + return undef unless ref($self); + + my $curr_row = 0; + my $curr_col = 0; + my $curr_size = 0; + my $curr_visi = 0; + my $return = 0; + my $discard = 0; + + + if (defined($col)) { + $row = -1 if not defined($row); + if ($col == -1 or $row == -1) { + ($discard, $discard, $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + $col=$curr_col if $col==-1; + $row=$curr_row if $row==-1; + } + $return += _SetConsoleCursorPosition($self->{'handle'}, $col, $row); + if (defined($size) and defined($visi)) { + if ($size == -1 or $visi == -1) { + ($curr_size, $curr_visi) = _GetConsoleCursorInfo($self->{'handle'}); + $size = $curr_size if $size == -1; + $visi = $curr_visi if $visi == -1; + } + $size = 1 if $size < 1; + $size = 99 if $size > 99; + $return += _SetConsoleCursorInfo($self->{'handle'}, $size, $visi); + } + return $return; + } + else { + ($discard, $discard, $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + ($curr_size, $curr_visi) = _GetConsoleCursorInfo($self->{'handle'}); + return ($curr_col, $curr_row, $curr_size, $curr_visi); + } +} + +#========= +sub Size { +#========= + my($self, $col, $row) = @_; + return undef unless ref($self); + + if (not defined($col)) { + ($col, $row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + return ($col, $row); + } + else { + $row = -1 if not defined($row); + if ($col == -1 or $row == -1) { + ($curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + $col=$curr_col if $col==-1; + $row=$curr_row if $row==-1; + } + return _SetConsoleScreenBufferSize($self->{'handle'}, $col, $row); + } +} + +#============= +sub FillAttr { +#============= + my($self, $attr, $number, $col, $row) = @_; + return undef unless ref($self); + + $number = 1 unless $number; + + if (!defined($col) or !defined($row) or $col == -1 or $row == -1) { + ($discard, $discard, + $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + $col = $curr_col if !defined($col) or $col == -1; + $row = $curr_row if !defined($row) or $row == -1; + } + return _FillConsoleOutputAttribute($self->{'handle'}, $attr, $number, $col, $row); +} + +#============= +sub FillChar { +#============= + my($self, $char, $number, $col, $row) = @_; + return undef unless ref($self); + + if (!defined($col) or !defined($row) or $col == -1 or $row == -1) { + ($discard, $discard, + $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + $col = $curr_col if !defined($col) or $col == -1; + $row = $curr_row if !defined($row) or $row == -1; + } + return _FillConsoleOutputCharacter($self->{'handle'}, $char, $number, $col, $row); +} + +#============ +sub InputCP { +#============ + my($self, $codepage) = @_; + $codepage = $self if (defined($self) and ref($self) ne "Win32::Console"); + if (defined($codepage)) { + return _SetConsoleCP($codepage); + } + else { + return _GetConsoleCP(); + } +} + +#============= +sub OutputCP { +#============= + my($self, $codepage) = @_; + $codepage = $self if (defined($self) and ref($self) ne "Win32::Console"); + if (defined($codepage)) { + return _SetConsoleOutputCP($codepage); + } + else { + return _GetConsoleOutputCP(); + } +} + +#====================== +sub GenerateCtrlEvent { +#====================== + my($self, $type, $pid) = @_; + $type = constant("CTRL_C_EVENT", 0) unless defined($type); + $pid = 0 unless defined($pid); + return _GenerateConsoleCtrlEvent($type, $pid); +} + +#=================== +#sub SetCtrlHandler { +#=================== +# my($name, $add) = @_; +# $add = 1 unless defined($add); +# my @nor = keys(%HandlerRoutineStack); +# if ($add == 0) { +# foreach $key (@nor) { +# delete $HandlerRoutineStack{$key}, last if $HandlerRoutineStack{$key}==$name; +# } +# $HandlerRoutineRegistered--; +# } else { +# if ($#nor == -1) { +# my $r = _SetConsoleCtrlHandler(); +# if (!$r) { +# print "WARNING: SetConsoleCtrlHandler failed...\n"; +# } +# } +# $HandlerRoutineRegistered++; +# $HandlerRoutineStack{$HandlerRoutineRegistered} = $name; +# } +#} + +#=================== +sub get_Win32_IPC_HANDLE { # So Win32::IPC can wait on a console handle +#=================== + $_[0]->{'handle'}; +} + +######################################################################## +# PRIVATE METHODS +# + +#================ +#sub CtrlHandler { +#================ +# my($ctrltype) = @_; +# my $routine; +# my $result = 0; +# CALLEM: foreach $routine (sort { $b <=> $a } keys %HandlerRoutineStack) { +# #print "CtrlHandler: calling $HandlerRoutineStack{$routine}($ctrltype)\n"; +# $result = &{"main::".$HandlerRoutineStack{$routine}}($ctrltype); +# last CALLEM if $result; +# } +# return $result; +#} + +#============ +sub DESTROY { +#============ + my($self) = @_; + _CloseHandle($self->{'handle'}); +} + +####################################################################### +# dynamically load in the Console.pll module. +# + +bootstrap Win32::Console; + +####################################################################### +# ADDITIONAL CONSTANTS EXPORTED IN THE MAIN NAMESPACE +# + +$FG_BLACK = 0; +$FG_GRAY = constant("FOREGROUND_INTENSITY",0); +$FG_BLUE = constant("FOREGROUND_BLUE",0); +$FG_LIGHTBLUE = constant("FOREGROUND_BLUE",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_RED = constant("FOREGROUND_RED",0); +$FG_LIGHTRED = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_GREEN = constant("FOREGROUND_GREEN",0); +$FG_LIGHTGREEN = constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_MAGENTA = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_BLUE",0); +$FG_LIGHTMAGENTA = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_BLUE",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_CYAN = constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_BLUE",0); +$FG_LIGHTCYAN = constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_BLUE",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_BROWN = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_GREEN",0); +$FG_YELLOW = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_LIGHTGRAY = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_BLUE",0); +$FG_WHITE = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_BLUE",0)| + constant("FOREGROUND_INTENSITY",0); + +$BG_BLACK = 0; +$BG_GRAY = constant("BACKGROUND_INTENSITY",0); +$BG_BLUE = constant("BACKGROUND_BLUE",0); +$BG_LIGHTBLUE = constant("BACKGROUND_BLUE",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_RED = constant("BACKGROUND_RED",0); +$BG_LIGHTRED = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_GREEN = constant("BACKGROUND_GREEN",0); +$BG_LIGHTGREEN = constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_MAGENTA = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_BLUE",0); +$BG_LIGHTMAGENTA = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_BLUE",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_CYAN = constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_BLUE",0); +$BG_LIGHTCYAN = constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_BLUE",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_BROWN = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_GREEN",0); +$BG_YELLOW = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_LIGHTGRAY = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_BLUE",0); +$BG_WHITE = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_BLUE",0)| + constant("BACKGROUND_INTENSITY",0); + +$ATTR_NORMAL = $FG_LIGHTGRAY|$BG_BLACK; +$ATTR_INVERSE = $FG_BLACK|$BG_LIGHTGRAY; + +for my $fg ($FG_BLACK, $FG_GRAY, $FG_BLUE, $FG_GREEN, + $FG_CYAN, $FG_RED, $FG_MAGENTA, $FG_BROWN, + $FG_LIGHTBLUE, $FG_LIGHTGREEN, $FG_LIGHTCYAN, + $FG_LIGHTRED, $FG_LIGHTMAGENTA, $FG_YELLOW, + $FG_LIGHTGRAY, $FG_WHITE) +{ + for my $bg ($BG_BLACK, $BG_GRAY, $BG_BLUE, $BG_GREEN, + $BG_CYAN, $BG_RED, $BG_MAGENTA, $BG_BROWN, + $BG_LIGHTBLUE, $BG_LIGHTGREEN, $BG_LIGHTCYAN, + $BG_LIGHTRED, $BG_LIGHTMAGENTA, $BG_YELLOW, + $BG_LIGHTGRAY, $BG_WHITE) + { + push(@CONSOLE_COLORS, $fg|$bg); + } +} + +# Preloaded methods go here. + +#Currently Autoloading is not implemented in Perl for win32 +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; + +__END__ + +=head1 NAME + +Win32::Console - Win32 Console and Character Mode Functions + + +=head1 DESCRIPTION + +This module implements the Win32 console and character mode +functions. They give you full control on the console input and output, +including: support of off-screen console buffers (eg. multiple screen +pages) + +=over + +=item * + +reading and writing of characters, attributes and whole portions of +the screen + +=item * + +complete processing of keyboard and mouse events + +=item * + +some very funny additional features :) + +=back + +Those functions should also make possible a port of the Unix's curses +library; if there is anyone interested (and/or willing to contribute) +to this project, e-mail me. Thank you. + + +=head1 REFERENCE + + +=head2 Methods + +=over + +=item Alloc + +Allocates a new console for the process. Returns C<undef> on errors, a +nonzero value on success. A process cannot be associated with more +than one console, so this method will fail if there is already an +allocated console. Use Free to detach the process from the console, +and then call Alloc to create a new console. See also: C<Free> + +Example: + + $CONSOLE->Alloc(); + +=item Attr [attr] + +Gets or sets the current console attribute. This attribute is used by +the Write method. + +Example: + + $attr = $CONSOLE->Attr(); + $CONSOLE->Attr($FG_YELLOW | $BG_BLUE); + +=item Close + +Closes a shortcut object. Note that it is not "strictly" required to +close the objects you created, since the Win32::Shortcut objects are +automatically closed when the program ends (or when you somehow +destroy such an object). + +Example: + + $LINK->Close(); + +=item Cls [attr] + +Clear the console, with the specified I<attr> if given, or using +ATTR_NORMAL otherwise. + +Example: + + $CONSOLE->Cls(); + $CONSOLE->Cls($FG_WHITE | $BG_GREEN); + +=item Cursor [x, y, size, visible] + +Gets or sets cursor position and appearance. Returns C<undef> on +errors, or a 4-element list containing: I<x>, I<y>, I<size>, +I<visible>. I<x> and I<y> are the current cursor position; ... + +Example: + + ($x, $y, $size, $visible) = $CONSOLE->Cursor(); + + # Get position only + ($x, $y) = $CONSOLE->Cursor(); + + $CONSOLE->Cursor(40, 13, 50, 1); + + # Set position only + $CONSOLE->Cursor(40, 13); + + # Set size and visibility without affecting position + $CONSOLE->Cursor(-1, -1, 50, 1); + +=item Display + +Displays the specified console on the screen. Returns C<undef> on errors, +a nonzero value on success. + +Example: + + $CONSOLE->Display(); + +=item FillAttr [attribute, number, col, row] + +Fills the specified number of consecutive attributes, beginning at +I<col>, I<row>, with the value specified in I<attribute>. Returns the +number of attributes filled, or C<undef> on errors. See also: +C<FillChar>. + +Example: + + $CONSOLE->FillAttr($FG_BLACK | $BG_BLACK, 80*25, 0, 0); + +=item FillChar char, number, col, row + +Fills the specified number of consecutive characters, beginning at +I<col>, I<row>, with the character specified in I<char>. Returns the +number of characters filled, or C<undef> on errors. See also: +C<FillAttr>. + +Example: + + $CONSOLE->FillChar("X", 80*25, 0, 0); + +=item Flush + +Flushes the console input buffer. All the events in the buffer are +discarded. Returns C<undef> on errors, a nonzero value on success. + +Example: + + $CONSOLE->Flush(); + +=item Free + +Detaches the process from the console. Returns C<undef> on errors, a +nonzero value on success. See also: C<Alloc>. + +Example: + + $CONSOLE->Free(); + +=item GenerateCtrlEvent [type, processgroup] + +Sends a break signal of the specified I<type> to the specified +I<processgroup>. I<type> can be one of the following constants: + + CTRL_BREAK_EVENT + CTRL_C_EVENT + +they signal, respectively, the pressing of Control + Break and of +Control + C; if not specified, it defaults to CTRL_C_EVENT. +I<processgroup> is the pid of a process sharing the same console. If +omitted, it defaults to 0 (the current process), which is also the +only meaningful value that you can pass to this function. Returns +C<undef> on errors, a nonzero value on success. + +Example: + + # break this script now + $CONSOLE->GenerateCtrlEvent(); + +=item GetEvents + +Returns the number of unread input events in the console's input +buffer, or C<undef> on errors. See also: C<Input>, C<InputChar>, +C<PeekInput>, C<WriteInput>. + +Example: + + $events = $CONSOLE->GetEvents(); + +=item Info + +Returns an array of informations about the console (or C<undef> on +errors), which contains: + +=over + +=item * + +columns (X size) of the console buffer. + +=item * + +rows (Y size) of the console buffer. + +=item * + +current column (X position) of the cursor. + +=item * + +current row (Y position) of the cursor. + +=item * + +current attribute used for C<Write>. + +=item * + +left column (X of the starting point) of the current console window. + +=item * + +top row (Y of the starting point) of the current console window. + +=item * + +right column (X of the final point) of the current console window. + +=item * + +bottom row (Y of the final point) of the current console window. + +=item * + +maximum number of columns for the console window, given the current +buffer size, font and the screen size. + +=item * + +maximum number of rows for the console window, given the current +buffer size, font and the screen size. + +=back + +See also: C<Attr>, C<Cursor>, C<Size>, C<Window>, C<MaxWindow>. + +Example: + + @info = $CONSOLE->Info(); + print "Cursor at $info[3], $info[4].\n"; + +=item Input + +Reads an event from the input buffer. Returns a list of values, which +depending on the event's nature are: + +=over + +=item keyboard event + +The list will contain: + +=over + +=item * + +event type: 1 for keyboard + +=item * + +key down: TRUE if the key is being pressed, FALSE if the key is being released + +=item * + +repeat count: the number of times the key is being held down + +=item * + +virtual keycode: the virtual key code of the key + +=item * + +virtual scancode: the virtual scan code of the key + +=item * + +char: the ASCII code of the character (if the key is a character key, 0 otherwise) + +=item * + +control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.) + +=back + +=item mouse event + +The list will contain: + +=over + +=item * + +event type: 2 for mouse + +=item * + +mouse pos. X: X coordinate (column) of the mouse location + +=item * + +mouse pos. Y: Y coordinate (row) of the mouse location + +=item * + +button state: the mouse button(s) which are pressed + +=item * + +control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.) + +=item * + +event flags: the type of the mouse event + +=back + +=back + +This method will return C<undef> on errors. Note that the events +returned are depending on the input C<Mode> of the console; for example, +mouse events are not intercepted unless ENABLE_MOUSE_INPUT is +specified. See also: C<GetEvents>, C<InputChar>, C<Mode>, +C<PeekInput>, C<WriteInput>. + +Example: + + @event = $CONSOLE->Input(); + +=item InputChar number + +Reads and returns I<number> characters from the console input buffer, +or C<undef> on errors. See also: C<Input>, C<Mode>. + +Example: + + $key = $CONSOLE->InputChar(1); + +=item InputCP [codepage] + +Gets or sets the input code page used by the console. Note that this +doesn't apply to a console object, but to the standard input +console. This attribute is used by the Write method. See also: +C<OutputCP>. + +Example: + + $codepage = $CONSOLE->InputCP(); + $CONSOLE->InputCP(437); + + # you may want to use the non-instanciated form to avoid confuzion :) + $codepage = Win32::Console::InputCP(); + Win32::Console::InputCP(437); + +=item MaxWindow + +Returns the size of the largest possible console window, based on the +current font and the size of the display. The result is C<undef> on +errors, otherwise a 2-element list containing col, row. + +Example: + + ($maxCol, $maxRow) = $CONSOLE->MaxWindow(); + +=item Mode [flags] + +Gets or sets the input or output mode of a console. I<flags> can be a +combination of the following constants: + + ENABLE_LINE_INPUT + ENABLE_ECHO_INPUT + ENABLE_PROCESSED_INPUT + ENABLE_WINDOW_INPUT + ENABLE_MOUSE_INPUT + ENABLE_PROCESSED_OUTPUT + ENABLE_WRAP_AT_EOL_OUTPUT + +For more informations on the meaning of those flags, please refer to +the L<"Microsoft's Documentation">. + +Example: + + $mode = $CONSOLE->Mode(); + $CONSOLE->Mode(ENABLE_MOUSE_INPUT | ENABLE_PROCESSED_INPUT); + +=item MouseButtons + +Returns the number of the buttons on your mouse, or C<undef> on errors. + +Example: + + print "Your mouse has ", $CONSOLE->MouseButtons(), " buttons.\n"; + +=item new Win32::Console standard_handle + +=item new Win32::Console [accessmode, sharemode] + +Creates a new console object. The first form creates a handle to a +standard channel, I<standard_handle> can be one of the following: + + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + STD_INPUT_HANDLE + +The second form, instead, creates a console screen buffer in memory, +which you can access for reading and writing as a normal console, and +then redirect on the standard output (the screen) with C<Display>. In +this case, you can specify one or both of the following values for +I<accessmode>: + + GENERIC_READ + GENERIC_WRITE + +which are the permissions you will have on the created buffer, and one +or both of the following values for I<sharemode>: + + FILE_SHARE_READ + FILE_SHARE_WRITE + +which affect the way the console can be shared. If you don't specify +any of those parameters, all 4 flags will be used. + +Example: + + $STDOUT = new Win32::Console(STD_OUTPUT_HANDLE); + $STDERR = new Win32::Console(STD_ERROR_HANDLE); + $STDIN = new Win32::Console(STD_INPUT_HANDLE); + + $BUFFER = new Win32::Console(); + $BUFFER = new Win32::Console(GENERIC_READ | GENERIC_WRITE); + +=item OutputCP [codepage] + +Gets or sets the output code page used by the console. Note that this +doesn't apply to a console object, but to the standard output console. +See also: C<InputCP>. + +Example: + + $codepage = $CONSOLE->OutputCP(); + $CONSOLE->OutputCP(437); + + # you may want to use the non-instanciated form to avoid confuzion :) + $codepage = Win32::Console::OutputCP(); + Win32::Console::OutputCP(437); + +=item PeekInput + +Does exactly the same as C<Input>, except that the event read is not +removed from the input buffer. See also: C<GetEvents>, C<Input>, +C<InputChar>, C<Mode>, C<WriteInput>. + +Example: + + @event = $CONSOLE->PeekInput(); + +=item ReadAttr [number, col, row] + +Reads the specified I<number> of consecutive attributes, beginning at +I<col>, I<row>, from the console. Returns the attributes read (a +variable containing one character for each attribute), or C<undef> on +errors. You can then pass the returned variable to C<WriteAttr> to +restore the saved attributes on screen. See also: C<ReadChar>, +C<ReadRect>. + +Example: + + $colors = $CONSOLE->ReadAttr(80*25, 0, 0); + +=item ReadChar [number, col, row] + +Reads the specified I<number> of consecutive characters, beginning at +I<col>, I<row>, from the console. Returns a string containing the +characters read, or C<undef> on errors. You can then pass the +returned variable to C<WriteChar> to restore the saved characters on +screen. See also: C<ReadAttr>, C<ReadRect>. + +Example: + + $chars = $CONSOLE->ReadChar(80*25, 0, 0); + +=item ReadRect left, top, right, bottom + +Reads the content (characters and attributes) of the rectangle +specified by I<left>, I<top>, I<right>, I<bottom> from the console. +Returns a string containing the rectangle read, or C<undef> on errors. +You can then pass the returned variable to C<WriteRect> to restore the +saved rectangle on screen (or on another console). See also: +C<ReadAttr>, C<ReadChar>. + +Example: + + $rect = $CONSOLE->ReadRect(0, 0, 80, 25); + +=item Scroll left, top, right, bottom, col, row, char, attr, + [cleft, ctop, cright, cbottom] + +Moves a block of data in a console buffer; the block is identified by +I<left>, I<top>, I<right>, I<bottom>, while I<row>, I<col> identify +the new location of the block. The cells left empty as a result of +the move are filled with the character I<char> and attribute I<attr>. +Optionally you can specify a clipping region with I<cleft>, I<ctop>, +I<cright>, I<cbottom>, so that the content of the console outside this +rectangle are unchanged. Returns C<undef> on errors, a nonzero value +on success. + +Example: + + # scrolls the screen 10 lines down, filling with black spaces + $CONSOLE->Scroll(0, 0, 80, 25, 0, 10, " ", $FG_BLACK | $BG_BLACK); + +=item Select standard_handle + +Redirects a standard handle to the specified console. +I<standard_handle> can have one of the following values: + + STD_INPUT_HANDLE + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + +Returns C<undef> on errors, a nonzero value on success. + +Example: + + $CONSOLE->Select(STD_OUTPUT_HANDLE); + +=item SetIcon icon_file + +Sets the icon in the title bar of the current console window. + +Example: + + $CONSOLE->SetIcon("C:/My/Path/To/Custom.ico"); + +=item Size [col, row] + +Gets or sets the console buffer size. + +Example: + + ($x, $y) = $CONSOLE->Size(); + $CONSOLE->Size(80, 25); + +=item Title [title] + +Gets or sets the title of the current console window. + +Example: + + $title = $CONSOLE->Title(); + $CONSOLE->Title("This is a title"); + +=item Window [flag, left, top, right, bottom] + +Gets or sets the current console window size. If called without +arguments, returns a 4-element list containing the current window +coordinates in the form of I<left>, I<top>, I<right>, I<bottom>. To +set the window size, you have to specify an additional I<flag> +parameter: if it is 0 (zero), coordinates are considered relative to +the current coordinates; if it is non-zero, coordinates are absolute. + +Example: + + ($left, $top, $right, $bottom) = $CONSOLE->Window(); + $CONSOLE->Window(1, 0, 0, 80, 50); + +=item Write string + +Writes I<string> on the console, using the current attribute, that you +can set with C<Attr>, and advancing the cursor as needed. This isn't +so different from Perl's "print" statement. Returns the number of +characters written or C<undef> on errors. See also: C<WriteAttr>, +C<WriteChar>, C<WriteRect>. + +Example: + + $CONSOLE->Write("Hello, world!"); + +=item WriteAttr attrs, col, row + +Writes the attributes in the string I<attrs>, beginning at I<col>, +I<row>, without affecting the characters that are on screen. The +string attrs can be the result of a C<ReadAttr> function, or you can +build your own attribute string; in this case, keep in mind that every +attribute is treated as a character, not a number (see example). +Returns the number of attributes written or C<undef> on errors. See +also: C<Write>, C<WriteChar>, C<WriteRect>. + +Example: + + $CONSOLE->WriteAttr($attrs, 0, 0); + + # note the use of chr()... + $attrs = chr($FG_BLACK | $BG_WHITE) x 80; + $CONSOLE->WriteAttr($attrs, 0, 0); + +=item WriteChar chars, col, row + +Writes the characters in the string I<attr>, beginning at I<col>, I<row>, +without affecting the attributes that are on screen. The string I<chars> +can be the result of a C<ReadChar> function, or a normal string. Returns +the number of characters written or C<undef> on errors. See also: +C<Write>, C<WriteAttr>, C<WriteRect>. + +Example: + + $CONSOLE->WriteChar("Hello, worlds!", 0, 0); + +=item WriteInput (event) + +Pushes data in the console input buffer. I<(event)> is a list of values, +for more information see C<Input>. The string chars can be the result of +a C<ReadChar> function, or a normal string. Returns the number of +characters written or C<undef> on errors. See also: C<Write>, +C<WriteAttr>, C<WriteRect>. + +Example: + + $CONSOLE->WriteInput(@event); + +=item WriteRect rect, left, top, right, bottom + +Writes a rectangle of characters and attributes (contained in I<rect>) +on the console at the coordinates specified by I<left>, I<top>, +I<right>, I<bottom>. I<rect> can be the result of a C<ReadRect> +function. Returns C<undef> on errors, otherwise a 4-element list +containing the coordinates of the affected rectangle, in the format +I<left>, I<top>, I<right>, I<bottom>. See also: C<Write>, +C<WriteAttr>, C<WriteChar>. + +Example: + + $CONSOLE->WriteRect($rect, 0, 0, 80, 25); + +=back + + +=head2 Constants + +The following constants are exported in the main namespace of your +script using Win32::Console: + + BACKGROUND_BLUE + BACKGROUND_GREEN + BACKGROUND_INTENSITY + BACKGROUND_RED + CAPSLOCK_ON + CONSOLE_TEXTMODE_BUFFER + ENABLE_ECHO_INPUT + ENABLE_LINE_INPUT + ENABLE_MOUSE_INPUT + ENABLE_PROCESSED_INPUT + ENABLE_PROCESSED_OUTPUT + ENABLE_WINDOW_INPUT + ENABLE_WRAP_AT_EOL_OUTPUT + ENHANCED_KEY + FILE_SHARE_READ + FILE_SHARE_WRITE + FOREGROUND_BLUE + FOREGROUND_GREEN + FOREGROUND_INTENSITY + FOREGROUND_RED + LEFT_ALT_PRESSED + LEFT_CTRL_PRESSED + NUMLOCK_ON + GENERIC_READ + GENERIC_WRITE + RIGHT_ALT_PRESSED + RIGHT_CTRL_PRESSED + SCROLLLOCK_ON + SHIFT_PRESSED + STD_INPUT_HANDLE + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + +Additionally, the following variables can be used: + + $FG_BLACK + $FG_GRAY + $FG_BLUE + $FG_LIGHTBLUE + $FG_RED + $FG_LIGHTRED + $FG_GREEN + $FG_LIGHTGREEN + $FG_MAGENTA + $FG_LIGHTMAGENTA + $FG_CYAN + $FG_LIGHTCYAN + $FG_BROWN + $FG_YELLOW + $FG_LIGHTGRAY + $FG_WHITE + + $BG_BLACK + $BG_GRAY + $BG_BLUE + $BG_LIGHTBLUE + $BG_RED + $BG_LIGHTRED + $BG_GREEN + $BG_LIGHTGREEN + $BG_MAGENTA + $BG_LIGHTMAGENTA + $BG_CYAN + $BG_LIGHTCYAN + $BG_BROWN + $BG_YELLOW + $BG_LIGHTGRAY + $BG_WHITE + + $ATTR_NORMAL + $ATTR_INVERSE + +ATTR_NORMAL is set to gray foreground on black background (DOS's +standard colors). + + +=head2 Microsoft's Documentation + +Documentation for the Win32 Console and Character mode Functions can +be found on Microsoft's site at this URL: + +http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar.htm + +A reference of the available functions is at: + +http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar_34.htm + + +=head1 AUTHOR + +Aldo Calpini <a.calpini@romagiubileo.it> + +=head1 CREDITS + +Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the +Perl-Win32-Users community. + +=head1 DISCLAIMER + +This program is FREE; you can redistribute, modify, disassemble, or +even reverse engineer this software at your will. Keep in mind, +however, that NOTHING IS GUARANTEED to work and everything you do is +AT YOUR OWN RISK - I will not take responsibility for any damage, loss +of money and/or health that may arise from the use of this program! + +This is distributed under the terms of Larry Wall's Artistic License. diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE.pm new file mode 100644 index 0000000000..ece534b15f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE.pm @@ -0,0 +1,968 @@ +# The documentation is at the __END__ + +package Win32::OLE; + +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK @EXPORT_FAIL $AUTOLOAD + $CP $LCID $Warn $LastError $_NewEnum $_Unique); + +$VERSION = '0.1712'; + +use Carp; +use Exporter; +use DynaLoader; +@ISA = qw(Exporter DynaLoader); + +@EXPORT = qw(); +@EXPORT_OK = qw(in valof with HRESULT EVENTS OVERLOAD + CP_ACP CP_OEMCP CP_MACCP CP_UTF7 CP_UTF8 + DISPATCH_METHOD DISPATCH_PROPERTYGET + DISPATCH_PROPERTYPUT DISPATCH_PROPERTYPUTREF); +@EXPORT_FAIL = qw(EVENTS OVERLOAD); + +sub export_fail { + shift; + my @unknown; + while (@_) { + my $symbol = shift; + if ($symbol eq 'OVERLOAD') { + eval <<'OVERLOAD'; + use overload '""' => \&valof, + '0+' => \&valof, + fallback => 1; +OVERLOAD + } + elsif ($symbol eq 'EVENTS') { + Win32::OLE->Initialize(Win32::OLE::COINIT_OLEINITIALIZE()); + } + else { + push @unknown, $symbol; + } + } + return @unknown; +} + +unless (defined &Dispatch) { + # Use regular DynaLoader if XS part is not yet initialized + bootstrap Win32::OLE; + require Win32::OLE::Lite; +} + +1; + +######################################################################## + +__END__ + +=head1 NAME + +Win32::OLE - OLE Automation extensions + +=head1 SYNOPSIS + + $ex = Win32::OLE->new('Excel.Application') or die "oops\n"; + $ex->Amethod("arg")->Bmethod->{'Property'} = "foo"; + $ex->Cmethod(undef,undef,$Arg3); + $ex->Dmethod($RequiredArg1, {NamedArg1 => $Value1, NamedArg2 => $Value2}); + + $wd = Win32::OLE->GetObject("D:\\Data\\Message.doc"); + $xl = Win32::OLE->GetActiveObject("Excel.Application"); + +=head1 DESCRIPTION + +This module provides an interface to OLE Automation from Perl. +OLE Automation brings VisualBasic like scripting capabilities and +offers powerful extensibility and the ability to control many Win32 +applications from Perl scripts. + +The Win32::OLE module uses the IDispatch interface exclusively. It is +not possible to access a custom OLE interface. OLE events and OCX's are +currently not supported. + +Actually, that's no longer strictly true. This module now contains +B<ALPHA> level support for OLE events. This is largely untested and the +specific interface might still change in the future. + +=head2 Methods + +=over 8 + +=item Win32::OLE->new(PROGID[, DESTRUCTOR]) + +The new() class method starts a new instance of an OLE Automation object. +It returns a reference to this object or C<undef> if the creation failed. + +The PROGID argument must be either the OLE I<program id> or the I<class id> +of the required application. The optional DESTRUCTOR specifies a DESTROY-like +method. This can be either a CODE reference or a string containing an OLE +method name. It can be used to cleanly terminate OLE applications in case the +Perl program dies. + +To create an object via DCOM on a remote server you can use an array +reference in place of PROGID. The referenced array must contain the +machine name and the I<program id> or I<class id>. For example: + + my $obj = Win32::OLE->new(['my.machine.com', 'Program.Id']); + +If the PROGID is a I<program id> then Win32::OLE will try to resolve the +corresponding I<class id> locally. If the I<program id> is not registered +locally then the remote registry is queried. This will only succeed if +the local process has read access to the remote registry. The safest +(and fastest) method is to specify the C<class id> directly. + +=item Win32::OLE->EnumAllObjects([CALLBACK]) + +This class method returns the number Win32::OLE objects currently in +existence. It will call the optional CALLBACK function for each of +these objects: + + $Count = Win32::OLE->EnumAllObjects(sub { + my $Object = shift; + my $Class = Win32::OLE->QueryObjectType($Object); + printf "# Object=%s Class=%s\n", $Object, $Class; + }); + +The EnumAllObjects() method is primarily a debugging tool. It can be +used e.g. in an END block to check if all external connections have +been properly destroyed. + +=item Win32::OLE->FreeUnusedLibraries() + +The FreeUnusedLibraries() class method unloads all unused OLE +resources. These are the libraries of those classes of which all +existing objects have been destroyed. The unloading of object +libraries is really only important for long running processes that +might instantiate a huge number of B<different> objects over time. + +Be aware that objects implemented in Visual Basic have a buggy +implementation of this functionality: They pretend to be unloadable +while they are actually still running their cleanup code. Unloading +the DLL at that moment typically produces an access violation. The +probability for this problem can be reduced by calling the +SpinMessageLoop() method and sleep()ing for a few seconds. + +=item Win32::OLE->GetActiveObject(CLASS[, DESTRUCTOR]) + +The GetActiveObject() class method returns an OLE reference to a +running instance of the specified OLE automation server. It returns +C<undef> if the server is not currently active. It will croak if +the class is not even registered. The optional DESTRUCTOR method takes +either a method name or a code reference. It is executed when the last +reference to this object goes away. It is generally considered rude +to stop applications that you did not start yourself. + +=item Win32::OLE->GetObject(MONIKER[, DESTRUCTOR]) + +The GetObject() class method returns an OLE reference to the specified +object. The object is specified by a pathname optionally followed by +additional item subcomponent separated by exclamation marks '!'. The +optional DESTRUCTOR argument has the same semantics as the DESTRUCTOR in +new() or GetActiveObject(). + +=item Win32::OLE->Initialize([COINIT]) + +The Initialize() class method can be used to specify an alternative +apartment model for the Perl thread. It must be called B<before> the +first OLE object is created. If the C<Win32::OLE::Const> module is +used then the call to the Initialize() method must be made from a BEGIN +block before the first C<use> statement for the C<Win32::OLE::Const> +module. + +Valid values for COINIT are: + + Win32::OLE::COINIT_APARTMENTTHREADED - single threaded + Win32::OLE::COINIT_MULTITHREADED - the default + Win32::OLE::COINIT_OLEINITIALIZE - single threaded, additional OLE stuff + +COINIT_OLEINITIALIZE is sometimes needed when an OLE object uses +additional OLE compound document technologies not available from the +normal COM subsystem (for example MAPI.Session seems to require it). +Both COINIT_OLEINITIALIZE and COINIT_APARTMENTTHREADED create a hidden +top level window and a message queue for the Perl process. This may +create problems with other application, because Perl normally doesn't +process its message queue. This means programs using synchronous +communication between applications (such as DDE initiation), may hang +until Perl makes another OLE method call/property access or terminates. +This applies to InstallShield setups and many things started to shell +associations. Please try to utilize the C<Win32::OLE-E<gt>SpinMessageLoop> +and C<Win32::OLE-E<gt>Uninitialize> methods if you can not use the default +COINIT_MULTITHREADED model. + +=item OBJECT->Invoke(METHOD[, ARGS]) + +The Invoke() object method is an alternate way to invoke OLE +methods. It is normally equivalent to C<$OBJECT-E<gt>METHOD(@ARGS)>. This +function must be used if the METHOD name contains characters not valid +in a Perl variable name (like foreign language characters). It can +also be used to invoke the default method of an object even if the +default method has not been given a name in the type library. In this +case use <undef> or C<''> as the method name. To invoke an OLE objects +native Invoke() method (if such a thing exists), please use: + + $Object->Invoke('Invoke', @Args); + +=item Win32::OLE->LastError() + +The LastError() class method returns the last recorded OLE +error. This is a dual value like the C<$!> variable: in a numeric +context it returns the error number and in a string context it returns +the error message. The error number is a signed HRESULT value. Please +use the L<HRESULT(ERROR)> function to convert an unsigned hexadecimal +constant to a signed HRESULT. + +The last OLE error is automatically reset by a successful OLE +call. The numeric value can also explicitly be set by a call (which will +discard the string value): + + Win32::OLE->LastError(0); + +=item OBJECT->LetProperty(NAME,ARGS,VALUE) + +In Win32::OLE property assignment using the hash syntax is equivalent +to the Visual Basic C<Set> syntax (I<by reference> assignment): + + $Object->{Property} = $OtherObject; + +corresponds to this Visual Basic statement: + + Set Object.Property = OtherObject + +To get the I<by value> treatment of the Visual Basic C<Let> statement + + Object.Property = OtherObject + +you have to use the LetProperty() object method in Perl: + + $Object->LetProperty($Property, $OtherObject); + +LetProperty() also supports optional arguments for the property assignment. +See L<OBJECT->SetProperty(NAME,ARGS,VALUE)> for details. + +=item Win32::OLE->MessageLoop() + +The MessageLoop() class method will run a standard Windows message +loop, dispatching messages until the QuitMessageLoop() class method is +called. It is used to wait for OLE events. + +=item Win32::OLE->Option(OPTION) + +The Option() class method can be used to inspect and modify +L<Module Options>. The single argument form retrieves the value of +an option: + + my $CP = Win32::OLE->Option('CP'); + +A single call can be used to set multiple options simultaneously: + + Win32::OLE->Option(CP => CP_ACP, Warn => 3); + +=item Win32::OLE->QueryObjectType(OBJECT) + +The QueryObjectType() class method returns a list of the type library +name and the objects class name. In a scalar context it returns the +class name only. It returns C<undef> when the type information is not +available. + +=item Win32::OLE->QuitMessageLoop() + +The QuitMessageLoop() class method posts a (user-level) "Quit" message +to the current threads message loop. QuitMessageLoop() is typically +called from an event handler. The MessageLoop() class method will +return when it receives this "Quit" method. + +=item OBJECT->SetProperty(NAME,ARGS,VALUE) + +The SetProperty() method allows to modify properties with arguments, +which is not supported by the hash syntax. The hash form + + $Object->{Property} = $Value; + +is equivalent to + + $Object->SetProperty('Property', $Value); + +Arguments must be specified between the property name and the new value: + + $Object->SetProperty('Property', @Args, $Value); + +It is not possible to use "named argument" syntax with this function +because the new value must be the last argument to SetProperty(). + +This method hides any native OLE object method called SetProperty(). +The native method will still be available through the Invoke() method: + + $Object->Invoke('SetProperty', @Args); + +=item Win32::OLE->SpinMessageLoop + +This class method retrieves all pending messages from the message queue +and dispatches them to their respective window procedures. Calling this +method is only necessary when not using the COINIT_MULTITHREADED model. +All OLE method calls and property accesses automatically process the +message queue. + +=item Win32::OLE->Uninitialize + +The Uninitialize() class method uninitializes the OLE subsystem. It +also destroys the hidden top level window created by OLE for single +threaded apartments. All OLE objects will become invalid after this call! +It is possible to call the Initialize() class method again with a different +apartment model after shutting down OLE with Uninitialize(). + +=item Win32::OLE->WithEvents(OBJECT[, HANDLER[, INTERFACE]]) + +This class method enables and disables the firing of events by the +specified OBJECT. If no HANDLER is specified, then events are +disconnected. For some objects Win32::OLE is not able to +automatically determine the correct event interface. In this case the +INTERFACE argument must contain either the COCLASS name of the OBJECT +or the name of the event DISPATCH interface. Please read the L<Events> +section below for detailed explanation of the Win32::OLE event +support. + +=back + +Whenever Perl does not find a method name in the Win32::OLE package it +is automatically used as the name of an OLE method and this method call +is dispatched to the OLE server. + +There is one special hack built into the module: If a method or property +name could not be resolved with the OLE object, then the default method +of the object is called with the method name as its first parameter. So + + my $Sheet = $Worksheets->Table1; +or + my $Sheet = $Worksheets->{Table1}; + +is resolved as + + my $Sheet = $Worksheet->Item('Table1'); + +provided that the $Worksheets object does not have a C<Table1> method +or property. This hack has been introduced to call the default method +of collections which did not name the method in their type library. The +recommended way to call the "unnamed" default method is: + + my $Sheet = $Worksheets->Invoke('', 'Table1'); + +This special hack is disabled under C<use strict 'subs';>. + +=head2 Object methods and properties + +The object returned by the new() method can be used to invoke +methods or retrieve properties in the same fashion as described +in the documentation for the particular OLE class (eg. Microsoft +Excel documentation describes the object hierarchy along with the +properties and methods exposed for OLE access). + +Optional parameters on method calls can be omitted by using C<undef> +as a placeholder. A better way is to use named arguments, as the +order of optional parameters may change in later versions of the OLE +server application. Named parameters can be specified in a reference +to a hash as the last parameter to a method call. + +Properties can be retrieved or set using hash syntax, while methods +can be invoked with the usual perl method call syntax. The C<keys> +and C<each> functions can be used to enumerate an object's properties. +Beware that a property is not always writable or even readable (sometimes +raising exceptions when read while being undefined). + +If a method or property returns an embedded OLE object, method +and property access can be chained as shown in the examples below. + +=head2 Functions + +The following functions are not exported by default. + +=over 8 + +=item HRESULT(ERROR) + +The HRESULT() function converts an unsigned number into a signed HRESULT +error value as used by OLE internally. This is necessary because Perl +treats all hexadecimal constants as unsigned. To check if the last OLE +function returned "Member not found" (0x80020003) you can write: + + if (Win32::OLE->LastError == HRESULT(0x80020003)) { + # your error recovery here + } + +=item in(COLLECTION) + +If COLLECTION is an OLE collection object then C<in $COLLECTION> +returns a list of all members of the collection. This is a shortcut +for C<Win32::OLE::Enum-E<gt>All($COLLECTION)>. It is most commonly used in +a C<foreach> loop: + + foreach my $value (in $collection) { + # do something with $value here + } + +=item valof(OBJECT) + +Normal assignment of Perl OLE objects creates just another reference +to the OLE object. The valof() function explictly dereferences the +object (through the default method) and returns the value of the object. + + my $RefOf = $Object; + my $ValOf = valof $Object; + $Object->{Value} = $NewValue; + +Now $ValOf still contains the old value whereas $RefOf would +resolve to the $NewValue because it is still a reference to +$Object. + +The valof() function can also be used to convert Win32::OLE::Variant +objects to Perl values. + +=item with(OBJECT, PROPERTYNAME => VALUE, ...) + +This function provides a concise way to set the values of multiple +properties of an object. It iterates over its arguments doing +C<$OBJECT-E<gt>{PROPERTYNAME} = $VALUE> on each trailing pair. + +=back + +=head2 Overloading + +The Win32::OLE objects can be overloaded to automatically convert to +their values whenever they are used in a bool, numeric or string +context. This is not enabled by default. You have to request it +through the OVERLOAD pseudoexport: + + use Win32::OLE qw(in valof with OVERLOAD); + +You can still get the original string representation of an object +(C<Win32::OLE=0xDEADBEEF>), e.g. for debugging, by using the +C<overload::StrVal()> method: + + print overload::StrVal($object), "\n"; + +Please note that C<OVERLOAD> is a global setting. If any module enables +Win32::OLE overloading then it's active everywhere. + +=head2 Events + +The Win32::OLE module now contains B<ALPHA> level event support. This +support is only available when Perl is running in a single threaded +apartment. This can most easily be assured by using the C<EVENTS> +pseudo-import: + + use Win32::OLE qw(EVENTS); + +which implicitly does something like: + + use Win32::OLE; + Win32::OLE->Initialize(Win32::OLE::COINIT_OLEINITIALIZE); + +The current interface to OLE events should be considered experimental +and is subject to change. It works as expected for normal OLE +applications, but OLE control events often don't seem to work yet. + +Events must be enabled explicitly for an OLE object through the +Win32::OLE->WithEvents() class method. The Win32::OLE module uses the +IProvideClassInfo2 interface to determine the default event source of +the object. If this interface is not supported, then the user must +specify the name of the event source explicitly in the WithEvents() +method call. It is also possible to specify the class name of the +object as the third parameter. In this case Win32::OLE will try to +look up the default source interface for this COCLASS. + +The HANDLER argument to Win32::OLE->WithEvents() can either be a CODE +reference or a package name. In the first case, all events will invoke +this particular function. The first two arguments to this function will +be the OBJECT itself and the name of the event. The remaining arguments +will be event specific. + + sub Event { + my ($Obj,$Event,@Args) = @_; + print "Event triggered: '$Event'\n"; + } + Win32::OLE->WithEvents($Obj, \&Event); + +Alternatively the HANDLER argument can specify a package name. When the +OBJECT fires an event, Win32::OLE will try to find a function of the same +name as the event in this package. This function will be called with the +OBJECT as the first argument followed again by the event specific parameters: + + package MyEvents; + sub EventName1 { + my ($Obj,@Args) = @_; + print "EventName1 event triggered\n"; + } + + package main; + Win32::OLE->WithEvents($Obj, 'MyEvents', 'IEventInterface'); + +If Win32::OLE doesn't find a function with the name of the event then nothing +happens. + +Event parameters passed I<by reference> are handled specially. They are not +converted to the corresponding Perl datatype but passed as Win32::OLE::Variant +objects. You can assign a new value to these objects with the help of the +Put() method. This value will be passed back to the object when the event +function returns: + + package MyEvents; + sub BeforeClose { + my ($self,$Cancel) = @_; + $Cancel->Put(1) unless $MayClose; + } + +Direct assignment to $Cancel would have no effect on the original value and +would therefore not command the object to abort the closing action. + +=head2 Module Options + +The following module options can be accessed and modified with the +C<Win32::OLE-E<gt>Option> class method. In earlier versions of the Win32::OLE +module these options were manipulated directly as class variables. This +practice is now deprecated. + +=over 8 + +=item CP + +This variable is used to determine the codepage used by all +translations between Perl strings and Unicode strings used by the OLE +interface. The default value is CP_ACP, which is the default ANSI +codepage. Other possible values are CP_OEMCP, CP_MACCP, CP_UTF7 and +CP_UTF8. These constants are not exported by default. + +=item LCID + +This variable controls the locale identifier used for all OLE calls. +It is set to LOCALE_NEUTRAL by default. Please check the +L<Win32::OLE::NLS> module for other locale related information. + +=item Variant + +This options controls how method calls and property accessors return +values of type VT_CY and VT_DECIMAL are being returned. By default +VT_CY values are turned into strings and VT_DECIMAL values into +floating point numbers. If the C<Variant> option is enabled, these +values are returned as Win32::OLE::Variant objects, just like VT_DATE +and VT_ERROR values. If the Win32::OLE::Variant module is also +loaded, then all values should still behave as before in string and in +numeric context. + +The only reason that the C<Variant> behavior is not the default is that +this is an incompatible change that might break existing programs. + +=item Warn + +This variable determines the behavior of the Win32::OLE module when +an error happens. Valid values are: + + 0 Ignore error, return undef + 1 Carp::carp if $^W is set (-w option) + 2 always Carp::carp + 3 Carp::croak + +The error number and message (without Carp line/module info) are +available through the C<Win32::OLE-E<gt>LastError> class method. + +Alternatively the Warn option can be set to a CODE reference. E.g. + + Win32::OLE->Option(Warn => 3); + +is equivalent to + + Win32::OLE->Option(Warn => \&Carp::croak); + +This can even be used to emulate the VisualBasic C<On Error Goto +Label> construct: + + Win32::OLE->Option(Warn => sub {goto CheckError}); + # ... your normal OLE code here ... + + CheckError: + # ... your error handling code here ... + +=item _NewEnum + +This option enables additional enumeration support for collection +objects. When the C<_NewEnum> option is set, all collections will +receive one additional property: C<_NewEnum>. The value of this +property will be a reference to an array containing all the elements +of the collection. This option can be useful when used in conjunction +with an automatic tree traversal program, like C<Data::Dumper> or an +object tree browser. The value of this option should be either 1 +(enabled) or 0 (disabled, default). + + Win32::OLE->Option(_NewEnum => 1); + # ... + my @sheets = @{$Excel->Worksheets->{_NewEnum}}; + +In normal application code, this would be better written as: + + use Win32::OLE qw(in); + # ... + my @sheets = in $Excel->Worksheets; + +=item _Unique + +The C<_Unique> options guarantees that Win32::OLE will maintain a +one-to-one mapping between Win32::OLE objects and the native COM/OLE +objects. Without this option, you can query the same property twice +and get two different Win32::OLE objects for the same underlying COM +object. + +Using a unique proxy makes life easier for tree traversal algorithms +to recognize they already visited a particular node. This option +comes at a price: Win32::OLE has to maintain a global hash of all +outstanding objects and their corresponding proxies. Identity checks +on COM objects can also be expensive if the objects reside +out-of-process or even on a different computer. Therefore this option +is off by default unless the program is being run in the debugger. + +Unfortunately, this option doesn't always help. Some programs will +return new COM objects for even the same property when asked for it +multiple times (especially for collections). In this case, there is +nothing Win32::OLE can do to detect that these objects are in fact +identical (because they aren't at the COM level). + +The C<_Unique> option can be set to either 1 (enabled) or 0 (disabled, +default). + +=back + +=head1 EXAMPLES + +Here is a simple Microsoft Excel application. + + use Win32::OLE; + + # use existing instance if Excel is already running + eval {$ex = Win32::OLE->GetActiveObject('Excel.Application')}; + die "Excel not installed" if $@; + unless (defined $ex) { + $ex = Win32::OLE->new('Excel.Application', sub {$_[0]->Quit;}) + or die "Oops, cannot start Excel"; + } + + # get a new workbook + $book = $ex->Workbooks->Add; + + # write to a particular cell + $sheet = $book->Worksheets(1); + $sheet->Cells(1,1)->{Value} = "foo"; + + # write a 2 rows by 3 columns range + $sheet->Range("A8:C9")->{Value} = [[ undef, 'Xyzzy', 'Plugh' ], + [ 42, 'Perl', 3.1415 ]]; + + # print "XyzzyPerl" + $array = $sheet->Range("A8:C9")->{Value}; + for (@$array) { + for (@$_) { + print defined($_) ? "$_|" : "<undef>|"; + } + print "\n"; + } + + # save and exit + $book->SaveAs( 'test.xls' ); + undef $book; + undef $ex; + +Please note the destructor specified on the Win32::OLE->new method. It ensures +that Excel will shutdown properly even if the Perl program dies. Otherwise +there could be a process leak if your application dies after having opened +an OLE instance of Excel. It is the responsibility of the module user to +make sure that all OLE objects are cleaned up properly! + +Here is an example of using Variant data types. + + use Win32::OLE; + use Win32::OLE::Variant; + $ex = Win32::OLE->new('Excel.Application', \&OleQuit) or die "oops\n"; + $ex->{Visible} = 1; + $ex->Workbooks->Add; + # should generate a warning under -w + $ovR8 = Variant(VT_R8, "3 is a good number"); + $ex->Range("A1")->{Value} = $ovR8; + $ex->Range("A2")->{Value} = Variant(VT_DATE, 'Jan 1,1970'); + + sub OleQuit { + my $self = shift; + $self->Quit; + } + +The above will put value "3" in cell A1 rather than the string +"3 is a good number". Cell A2 will contain the date. + +Similarly, to invoke a method with some binary data, you can +do the following: + + $obj->Method( Variant(VT_UI1, "foo\000b\001a\002r") ); + +Here is a wrapper class that basically delegates everything but +new() and DESTROY(). The wrapper class shown here is another way to +properly shut down connections if your application is liable to die +without proper cleanup. Your own wrappers will probably do something +more specific to the particular OLE object you may be dealing with, +like overriding the methods that you may wish to enhance with your +own. + + package Excel; + use Win32::OLE; + + sub new { + my $s = {}; + if ($s->{Ex} = Win32::OLE->new('Excel.Application')) { + return bless $s, shift; + } + return undef; + } + + sub DESTROY { + my $s = shift; + if (exists $s->{Ex}) { + print "# closing connection\n"; + $s->{Ex}->Quit; + return undef; + } + } + + sub AUTOLOAD { + my $s = shift; + $AUTOLOAD =~ s/^.*:://; + $s->{Ex}->$AUTOLOAD(@_); + } + + 1; + +The above module can be used just like Win32::OLE, except that +it takes care of closing connections in case of abnormal exits. +Note that the effect of this specific example can be easier accomplished +using the optional destructor argument of Win32::OLE::new: + + my $Excel = Win32::OLE->new('Excel.Application', sub {$_[0]->Quit;}); + +Note that the delegation shown in the earlier example is not the same as +true subclassing with respect to further inheritance of method calls in your +specialized object. See L<perlobj>, L<perltoot> and L<perlbot> for details. +True subclassing (available by setting C<@ISA>) is also feasible, +as the following example demonstrates: + + # + # Add error reporting to Win32::OLE + # + + package Win32::OLE::Strict; + use Carp; + use Win32::OLE; + + use strict qw(vars); + use vars qw($AUTOLOAD @ISA); + @ISA = qw(Win32::OLE); + + sub AUTOLOAD { + my $obj = shift; + $AUTOLOAD =~ s/^.*:://; + my $meth = $AUTOLOAD; + $AUTOLOAD = "SUPER::" . $AUTOLOAD; + my $retval = $obj->$AUTOLOAD(@_); + unless (defined($retval) || $AUTOLOAD eq 'DESTROY') { + my $err = Win32::OLE::LastError(); + croak(sprintf("$meth returned OLE error 0x%08x",$err)) + if $err; + } + return $retval; + } + + 1; + +This package inherits the constructor new() from the Win32::OLE +package. It is important to note that you cannot later rebless a +Win32::OLE object as some information about the package is cached by +the object. Always invoke the new() constructor through the right +package! + +Here's how the above class will be used: + + use Win32::OLE::Strict; + my $Excel = Win32::OLE::Strict->new('Excel.Application', 'Quit'); + my $Books = $Excel->Workbooks; + $Books->UnknownMethod(42); + +In the sample above the call to UnknownMethod() will be caught with + + UnknownMethod returned OLE error 0x80020009 at test.pl line 5 + +because the Workbooks object inherits the class C<Win32::OLE::Strict> from the +C<$Excel> object. + +=head1 NOTES + +=head2 Hints for Microsoft Office automation + +=over 8 + +=item Documentation + +The object model for the Office applications is defined in the Visual Basic +reference guides for the various applications. These are typically not +installed by default during the standard installation. They can be added +later by rerunning the setup program with the custom install option. + +=item Class, Method and Property names + +The names have been changed between different versions of Office. For +example C<Application> was a method in Office 95 and is a property in +Office97. Therefore it will not show up in the list of property names +C<keys %$object> when querying an Office 95 object. + +The class names are not always identical to the method/property names +producing the object. E.g. the C<Workbook> method returns an object of +type C<Workbook> in Office 95 and C<_Workbook> in Office 97. + +=item Moniker (GetObject support) + +Office applications seem to implement file monikers only. For example +it seems to be impossible to retrieve a specific worksheet object through +C<GetObject("File.XLS!Sheet")>. Furthermore, in Excel 95 the moniker starts +a Worksheet object and in Excel 97 it returns a Workbook object. You can use +either the Win32::OLE::QueryObjectType class method or the $object->{Version} +property to write portable code. + +=item Enumeration of collection objects + +Enumerations seem to be incompletely implemented. Office 95 application don't +seem to support neither the Reset() nor the Clone() methods. The Clone() +method is still unimplemented in Office 97. A single walk through the +collection similar to Visual Basics C<for each> construct does work however. + +=item Localization + +Starting with Office 97 Microsoft has changed the localized class, method and +property names back into English. Note that string, date and currency +arguments are still subject to locale specific interpretation. Perl uses the +system default locale for all OLE transaction whereas Visual Basic uses a +type library specific locale. A Visual Basic script would use "R1C1" in string +arguments to specify relative references. A Perl script running on a German +language Windows would have to use "Z1S1". Set the LCID module option +to an English locale to write portable scripts. This variable should +not be changed after creating the OLE objects; some methods seem to randomly +fail if the locale is changed on the fly. + +=item SaveAs method in Word 97 doesn't work + +This is an known bug in Word 97. Search the MS knowledge base for Word / +Foxpro incompatibility. That problem applies to the Perl OLE interface as +well. A workaround is to use the WordBasic compatibility object. It doesn't +support all the options of the native method though. + + $Word->WordBasic->FileSaveAs($file); + +The problem seems to be fixed by applying the Office 97 Service Release 1. + +=item Randomly failing method calls + +It seems like modifying objects that are not selected/activated is sometimes +fragile. Most of these problems go away if the chart/sheet/document is +selected or activated before being manipulated (just like an interactive +user would automatically do it). + +=back + +=head2 Incompatibilities + +There are some incompatibilities with the version distributed by Activeware +(as of build 306). + +=over 8 + +=item 1 + +The package name has changed from "OLE" to "Win32::OLE". + +=item 2 + +All functions of the form "Win32::OLEFoo" are now "Win32::OLE::Foo", +though the old names are temporarily accommodated. Win32::OLECreateObject() +was changed to Win32::OLE::CreateObject(), and is now called +Win32::OLE::new() bowing to established convention for naming constructors. +The old names should be considered deprecated, and will be removed in the +next version. + +=item 3 + +Package "OLE::Variant" is now "Win32::OLE::Variant". + +=item 4 + +The Variant function is new, and is exported by default. So are +all the VT_XXX type constants. + +=item 5 + +The support for collection objects has been moved into the package +Win32::OLE::Enum. The C<keys %$object> method is now used to enumerate +the properties of the object. + +=back + +=head2 Bugs and Limitations + +=over 8 + +=item * + +To invoke a native OLE method with the same name as one of the +Win32::OLE methods (C<Dispatch>, C<Invoke>, C<SetProperty>, C<DESTROY>, +etc.), you have to use the C<Invoke> method: + + $Object->Invoke('Dispatch', @AdditionalArgs); + +The same is true for names exported by the Exporter or the Dynaloader +modules, e.g.: C<export>, C<export_to_level>, C<import>, +C<_push_tags>, C<export_tags>, C<export_ok_tags>, C<export_fail>, +C<require_version>, C<dl_load_flags>, +C<croak>, C<bootstrap>, C<dl_findfile>, C<dl_expandspec>, +C<dl_find_symbol_anywhere>, C<dl_load_file>, C<dl_find_symbol>, +C<dl_undef_symbols>, C<dl_install_xsub> and C<dl_error>. + +=back + +=head1 SEE ALSO + +The documentation for L<Win32::OLE::Const>, L<Win32::OLE::Enum>, +L<Win32::OLE::NLS> and L<Win32::OLE::Variant> contains additional +information about OLE support for Perl on Win32. + +=head1 AUTHORS + +Originally put together by the kind people at Hip and Activeware. + +Gurusamy Sarathy <gsar@cpan.org> subsequently fixed several +major bugs, memory leaks, and reliability problems, along with some +redesign of the code. + +Jan Dubois <jand@activestate.com> pitched in with yet more massive redesign, +added support for named parameters, and other significant enhancements. +He's been hacking on it ever since. + +Please send questions about problems with this module to the +Perl-Win32-Users mailinglist at ActiveState.com. The mailinglist charter +requests that you put an [OLE] tag somewhere on the subject line (for OLE +related questions only, of course). + +=head1 COPYRIGHT + + (c) 1995 Microsoft Corporation. All rights reserved. + Developed by ActiveWare Internet Corp., now known as + ActiveState Tool Corp., http://www.ActiveState.com + + Other modifications Copyright (c) 1997-2006 by Gurusamy Sarathy + <gsar@cpan.org> and Jan Dubois <jand@activestate.com> + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the README file. + +=head1 VERSION + +Version 0.1712 14 May 2014 + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Const.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Const.pm new file mode 100644 index 0000000000..d0fe00b9ea --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Const.pm @@ -0,0 +1,201 @@ +# The documentation is at the __END__ + +package Win32::OLE::Const; + +use strict; +use Carp; +use Win32::OLE; + +my $Typelibs; +sub _Typelib { + my ($clsid,$title,$version,$langid,$filename) = @_; + # Filenames might have a resource index appended to it. + $filename = $1 if $filename =~ /^(.*\.(?:dll|exe))(\\\d+)$/i; + # Ignore if it looks like a file but doesn't exist. + # We don't verify existence of monikers or filenames + # without a full pathname. + return if $filename =~ /^\w:\\.*\.(exe|dll)$/ && !-f $filename; + push @$Typelibs, \@_; +} +unless (__PACKAGE__->_Typelibs("TypeLib")) { + warn("Cannot access HKEY_CLASSES_ROOT\\Typelib"); +} +# Enumerate 32bit type libraries on Win64 +__PACKAGE__->_Typelibs("Wow6432Node\\TypeLib"); + +sub import { + my ($self,$name,$major,$minor,$language,$codepage) = @_; + return unless defined($name) && $name !~ /^\s*$/; + $self->Load($name,$major,$minor,$language,$codepage,scalar caller); +} + +sub EnumTypeLibs { + my ($self,$callback) = @_; + foreach (@$Typelibs) { &$callback(@$_) } + return; +} + +sub Load { + my ($self,$name,$major,$minor,$language,$codepage,$caller) = @_; + + if (UNIVERSAL::isa($name,'Win32::OLE')) { + my $typelib = $name->GetTypeInfo->GetContainingTypeLib; + return _Constants($typelib, undef); + } + + undef $minor unless defined $major; + my $typelib = $self->LoadRegTypeLib($name,$major,$minor, + $language,$codepage); + return _Constants($typelib, $caller); +} + +sub LoadRegTypeLib { + my ($self,$name,$major,$minor,$language,$codepage) = @_; + undef $minor unless defined $major; + + unless (defined($name) && $name !~ /^\s*$/) { + carp "Win32::OLE::Const->Load: No or invalid type library name"; + return; + } + + my @found; + foreach my $Typelib (@$Typelibs) { + my ($clsid,$title,$version,$langid,$filename) = @$Typelib; + next unless $title =~ /^$name/; + next unless $version =~ /^([0-9a-fA-F]+)\.([0-9a-fA-F]+)$/; + my ($maj,$min) = (hex($1), hex($2)); + next if defined($major) && $maj != $major; + next if defined($minor) && $min < $minor; + next if defined($language) && $language != $langid; + push @found, [$clsid,$maj,$min,$langid,$filename]; + } + + unless (@found) { + carp "No type library matching \"$name\" found"; + return; + } + + @found = sort { + # Prefer greater version number + my $res = $b->[1] <=> $a->[1]; + $res = $b->[2] <=> $a->[2] if $res == 0; + # Prefer default language for equal version numbers + $res = -1 if $res == 0 && $a->[3] == 0; + $res = 1 if $res == 0 && $b->[3] == 0; + $res; + } @found; + + #printf "Loading %s\n", join(' ', @{$found[0]}); + return _LoadRegTypeLib(@{$found[0]},$codepage); +} + +1; + +__END__ + +=head1 NAME + +Win32::OLE::Const - Extract constant definitions from TypeLib + +=head1 SYNOPSIS + + use Win32::OLE::Const 'Microsoft Excel'; + printf "xlMarkerStyleDot = %d\n", xlMarkerStyleDot; + + my $wd = Win32::OLE::Const->Load("Microsoft Word 8\\.0 Object Library"); + foreach my $key (keys %$wd) { + printf "$key = %s\n", $wd->{$key}; + } + +=head1 DESCRIPTION + +This modules makes all constants from a registered OLE type library +available to the Perl program. The constant definitions can be +imported as functions, providing compile time name checking. +Alternatively the constants can be returned in a hash reference +which avoids defining lots of functions of unknown names. + +=head2 Functions/Methods + +=over 4 + +=item use Win32::OLE::Const + +The C<use> statement can be used to directly import the constant names +and values into the users namespace. + + use Win32::OLE::Const (TYPELIB,MAJOR,MINOR,LANGUAGE); + +The TYPELIB argument specifies a regular expression for searching +through the registry for the type library. Note that this argument is +implicitly prefixed with C<^> to speed up matches in the most common +cases. Use a typelib name like ".*Excel" to match anywhere within the +description. TYPELIB is the only required argument. + +The MAJOR and MINOR arguments specify the requested version of +the type specification. If the MAJOR argument is used then only +typelibs with exactly this major version number will be matched. The +MINOR argument however specifies the minimum acceptable minor version. +MINOR is ignored if MAJOR is undefined. + +If the LANGUAGE argument is used then only typelibs with exactly this +language id will be matched. + +The module will select the typelib with the highest version number +satisfying the request. If no language id is specified then a the default +language (0) will be preferred over the others. + +Note that only constants with valid Perl variable names will be exported, +i.e. names matching this regexp: C</^[a-zA-Z_][a-zA-Z0-9_]*$/>. + +=item Win32::OLE::Const->Load + +The Win32::OLE::Const->Load method returns a reference to a hash of +constant definitions. + + my $const = Win32::OLE::Const->Load(TYPELIB,MAJOR,MINOR,LANGUAGE); + +The parameters are the same as for the C<use> case. + +This method is generally preferable when the typelib uses a non-english +language and the constant names contain locale specific characters not +allowed in Perl variable names. + +Another advantage is that all available constants can now be enumerated. + +The load method also accepts an OLE object as a parameter. In this case +the OLE object is queried about its containing type library and no registry +search is done at all. Interestingly this seems to be slower. + +=back + +=head1 EXAMPLES + +The first example imports all Excel constants names into the main namespace +and prints the value of xlMarkerStyleDot (-4118). + + use Win32::OLE::Const ('Microsoft Excel 8.0 Object Library'); + print "xlMarkerStyleDot = %d\n", xlMarkerStyleDot; + +The second example returns all Word constants in a hash ref. + + use Win32::OLE::Const; + my $wd = Win32::OLE::Const->Load("Microsoft Word 8.0 Object Library"); + foreach my $key (keys %$wd) { + printf "$key = %s\n", $wd->{$key}; + } + printf "wdGreen = %s\n", $wd->{wdGreen}; + +The last example uses an OLE object to specify the type library: + + use Win32::OLE; + use Win32::OLE::Const; + my $Excel = Win32::OLE->new('Excel.Application', 'Quit'); + my $xl = Win32::OLE::Const->Load($Excel); + + +=head1 AUTHORS/COPYRIGHT + +This module is part of the Win32::OLE distribution. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Enum.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Enum.pm new file mode 100644 index 0000000000..6047d2c827 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Enum.pm @@ -0,0 +1,95 @@ +# The documentation is at the __END__ + +package Win32::OLE::Enum; +1; + +# everything is pure XS in Win32::OLE::Enum +# - new +# - DESTROY +# +# - All +# - Clone +# - Next +# - Reset +# - Skip + +__END__ + +=head1 NAME + +Win32::OLE::Enum - OLE Automation Collection Objects + +=head1 SYNOPSIS + + my $Sheets = $Excel->Workbooks(1)->Worksheets; + my $Enum = Win32::OLE::Enum->new($Sheets); + my @Sheets = $Enum->All; + + while (defined(my $Sheet = $Enum->Next)) { ... } + +=head1 DESCRIPTION + +This module provides an interface to OLE collection objects from +Perl. It defines an enumerator object closely mirroring the +functionality of the IEnumVARIANT interface. + +Please note that the Reset() method is not available in all implementations +of OLE collections (like Excel 7). In that case the Enum object is good +only for a single walk through of the collection. + +=head2 Functions/Methods + +=over 8 + +=item Win32::OLE::Enum->new($object) + +Creates an enumerator for $object, which must be a valid OLE collection +object. Note that correctly implemented collection objects must support +the C<Count> and C<Item> methods, so creating an enumerator is not always +necessary. + +=item $Enum->All() + +Returns a list of all objects in the collection. You have to call +$Enum->Reset() before the enumerator can be used again. The previous +position in the collection is lost. + +This method can also be called as a class method: + + my @list = Win32::OLE::Enum->All($Collection); + +=item $Enum->Clone() + +Returns a clone of the enumerator maintaining the current position within +the collection (if possible). Note that the C<Clone> method is often not +implemented. Use $Enum->Clone() in an eval block to avoid dying if you +are not sure that Clone is supported. + +=item $Enum->Next( [$count] ) + +Returns the next element of the collection. In a list context the optional +$count argument specifies the number of objects to be returned. In a scalar +context only the last of at most $count retrieved objects is returned. The +default for $count is 1. + +=item $Enum->Reset() + +Resets the enumeration sequence to the beginning. There is no guarantee that +the exact same set of objects will be enumerated again (e.g. when enumerating +files in a directory). The methods return value indicates the success of the +operation. (Note that the Reset() method seems to be unimplemented in some +applications like Excel 7. Use it in an eval block to avoid dying.) + +=item $Enum->Skip( [$count] ) + +Skip the next $count elements of the enumeration. The default for $count is 1. +The functions returns TRUE if at least $count elements could be skipped. It +returns FALSE if not enough elements were left. + +=back + +=head1 AUTHORS/COPYRIGHT + +This module is part of the Win32::OLE distribution. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm new file mode 100644 index 0000000000..66b5e50ac0 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm @@ -0,0 +1,224 @@ +package Win32::OLE; + +sub _croak { require Carp; Carp::croak(@_) } + +unless (defined &Dispatch) { + DynaLoader::boot_DynaLoader('DynaLoader') + unless defined(&DynaLoader::dl_load_file); + my $file; + foreach my $dir (@INC) { + my $try = "$dir/auto/Win32/OLE/OLE.dll"; + last if $file = (-f $try && $try); + } + _croak("Can't locate loadable object for module Win32::OLE". + " in \@INC (\@INC contains: @INC)") + unless $file; # wording similar to error from 'require' + + my $libref = DynaLoader::dl_load_file($file, 0) or + _croak("Can't load '$file' for module Win32::OLE: ". + DynaLoader::dl_error()."\n"); + + my $boot_symbol_ref = DynaLoader::dl_find_symbol($libref, "boot_Win32__OLE") + or _croak("Can't find 'boot_Win32__OLE' symbol in $file\n"); + + my $xs = DynaLoader::dl_install_xsub("Win32::OLE::bootstrap", + $boot_symbol_ref, $file); + &$xs('Win32::OLE'); +} + +if (defined &DB::sub && !defined $_Unique) { + warn "Win32::OLE operating in debugging mode: _Unique => 1\n"; + $_Unique = 1; +} + +$Warn = 1; + +sub CP_ACP {0;} # ANSI codepage +sub CP_OEMCP {1;} # OEM codepage +sub CP_MACCP {2;} +sub CP_UTF7 {65000;} +sub CP_UTF8 {65001;} + +sub DISPATCH_METHOD {1;} +sub DISPATCH_PROPERTYGET {2;} +sub DISPATCH_PROPERTYPUT {4;} +sub DISPATCH_PROPERTYPUTREF {8;} + +sub COINIT_MULTITHREADED {0;} # Default +sub COINIT_APARTMENTTHREADED {2;} # Use single threaded apartment model + +# Bogus COINIT_* values to indicate special cases: +sub COINIT_OLEINITIALIZE {-1;} # Use OleInitialize instead of CoInitializeEx +sub COINIT_NO_INITIALIZE {-2;} # We are already initialized, just believe me + +sub HRESULT { + my $hr = shift; + $hr -= 2**32 if $hr & 0x80000000; + return $hr; +} + +# CreateObject is defined here only because it is documented in the +# "Learning Perl on Win32 Systems" Gecko book. Please use Win32::OLE->new(). +sub CreateObject { + if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) { + $AUTOLOAD = ref($_[0]) . '::CreateObject'; + goto &AUTOLOAD; + } + + # Hack to allow C<$obj = CreateObject Win32::OLE 'My.App';>. Although this + # is contrary to the Gecko, we just make it work since it doesn't hurt. + return Win32::OLE->new($_[1]) if $_[0] eq 'Win32::OLE'; + + # Gecko form: C<$success = Win32::OLE::CreateObject('My.App',$obj);> + $_[1] = Win32::OLE->new($_[0]); + return defined $_[1]; +} + +sub LastError { + unless (defined $_[0]) { + # Win32::OLE::LastError() will always return $Win32::OLE::LastError + return $LastError; + } + + if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) { + $AUTOLOAD = ref($_[0]) . '::LastError'; + goto &AUTOLOAD; + } + + #no strict 'refs'; + my $LastError = "$_[0]::LastError"; + $$LastError = $_[1] if defined $_[1]; + return $$LastError; +} + +my $Options = "^(?:CP|LCID|Warn|Variant|_NewEnum|_Unique)\$"; + +sub Option { + if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) { + $AUTOLOAD = ref($_[0]) . '::Option'; + goto &AUTOLOAD; + } + + my $class = shift; + + if (@_ == 1) { + my $option = shift; + return ${"${class}::$option"} if $option =~ /$Options/o; + _croak("Invalid $class option: $option"); + } + + while (@_) { + my ($option,$value) = splice @_, 0, 2; + _croak("Invalid $class option: $option") if $option !~ /$Options/o; + ${"${class}::$option"} = $value; + $class->_Unique() if $option eq "_Unique"; + } +} + +sub Invoke { + my ($self,$method,@args) = @_; + $self->Dispatch($method, my $retval, @args); + return $retval; +} + +sub LetProperty { + my ($self,$method,@args) = @_; + $self->Dispatch([DISPATCH_PROPERTYPUT, $method], my $retval, @args); + return $retval; +} + +sub SetProperty { + my ($self,$method,@args) = @_; + my $wFlags = DISPATCH_PROPERTYPUT; + if (@args) { + # If the value is an object then it will be set by reference! + my $value = $args[-1]; + if (UNIVERSAL::isa($value, 'Win32::OLE')) { + $wFlags = DISPATCH_PROPERTYPUTREF; + } + elsif (UNIVERSAL::isa($value,'Win32::OLE::Variant')) { + my $type = $value->Type & ~0xfff; # VT_TYPEMASK + # VT_DISPATCH and VT_UNKNOWN represent COM objects + $wFlags = DISPATCH_PROPERTYPUTREF if $type == 9 || $type == 13; + } + } + $self->Dispatch([$wFlags, $method], my $retval, @args); + return $retval; +} + +sub AUTOLOAD { + my $self = shift; + my $autoload = substr $AUTOLOAD, rindex($AUTOLOAD, ':')+1; + _croak("Cannot autoload class method \"$autoload\"") + unless ref($self) && UNIVERSAL::isa($self, 'Win32::OLE'); + my $success = $self->Dispatch($autoload, my $retval, @_); + unless (defined $success || ($^H & 0x200) != 0) { + # Retry default method if C<no strict 'subs';> + $self->Dispatch(undef, $retval, $autoload, @_); + } + return $retval; +} + +sub in { + my @res; + while (@_) { + my $this = shift; + if (UNIVERSAL::isa($this, 'Win32::OLE')) { + push @res, Win32::OLE::Enum->All($this); + } + elsif (ref($this) eq 'ARRAY') { + push @res, @$this; + } + else { + push @res, $this; + } + } + return @res; +} + +sub valof { + my $arg = shift; + if (UNIVERSAL::isa($arg, 'Win32::OLE')) { + require Win32::OLE::Variant; + my ($class) = overload::StrVal($arg) =~ /^([^=]+)=/; + #no strict 'refs'; + local $Win32::OLE::CP = ${"${class}::CP"}; + local $Win32::OLE::LCID = ${"${class}::LCID"}; + #use strict 'refs'; + # VT_EMPTY variant for return code + my $variant = Win32::OLE::Variant->new; + $arg->Dispatch(undef, $variant); + return $variant->Value; + } + $arg = $arg->Value if UNIVERSAL::can($arg, 'Value'); + return $arg; +} + +sub with { + my $object = shift; + while (@_) { + my $property = shift; + $object->{$property} = shift; + } +} + +######################################################################## + +package Win32::OLE::Tie; + +# Only retry default method under C<no strict 'subs';> +sub FETCH { + my ($self,$key) = @_; + if ($key eq "_NewEnum") { + (my $class = ref $self) =~ s/::Tie$//; + return [Win32::OLE::Enum->All($self)] if ${"${class}::_NewEnum"}; + } + $self->Fetch($key, !$Win32::OLE::Strict); +} + +sub STORE { + my ($self,$key,$value) = @_; + $self->Store($key, $value, !$Win32::OLE::Strict); +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NEWS.pod b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NEWS.pod new file mode 100644 index 0000000000..217fe4a6fc --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NEWS.pod @@ -0,0 +1,380 @@ +=pod + +=head1 NAME + +Win32::OLE::NEWS - What's new in Win32::OLE + +This file contains a history of user visible changes to the +Win32::OLE::* modules. Only new features and major bug fixes that +might affect backwards compatibility are included. + +=head1 Version 0.18 + +=head2 VT_CY and VT_DECIMAL return values handled differently + +The new C<Variant> option enables values of VT_CY or VT_DECIMAL type +to be returned as Win32::OLE::Variant objects instead of being +converted into strings and numbers respectively. This is similar to +the change in Win32::OLE version 0.12 to VT_DATE and VT_ERROR values. +The Win32::OLE::Variant module must be included to make sure that +VT_CY and VT_DECIMAL values behave as before in numeric or string +contexts. + +Because the new behavior is potentially incompatible, it must be +explicitly enabled: + + Win32::OLE->Option(Variant => 1); + + +=head1 Version 0.17 + +=head2 New nullstring() function in Win32::OLE::Variant + +The nullstring() function returns a VT_BSTR variant containing a NULL +string pointer. Note that this is not the same as a VT_BSTR variant +containing the empty string "". + +The nullstring() return value is equivalent to the Visual Basic +C<vbNullString> constant. + + +=head1 Version 0.16 + +=head2 Improved Unicode support + +Passing Unicode strings to methods and properties as well as returning +Unicode strings back to Perl works now with both Perl 5.6 and 5.8. +Note that the Unicode support in 5.8 is much more complete than in 5.6 +or 5.6.1. + +C<Unicode::String> objects can now be passed to methods or assigned to +properties. + +You must enable Unicode support by switching Win32::OLE to the UTF8 +codepage: + + Win32::OLE->Option(CP => Win32::OLE::CP_UTF8()); + + +=head1 Version 0.13 + +=head2 New nothing() function in Win32::OLE::Variant + +The nothing() function returns an empty VT_DISPATCH variant. It can be +used to clear an object reference stored in a property + + use Win32::OLE::Variant qw(:DEFAULT nothing); + # ... + $object->{Property} = nothing; + +This has the same effect as the Visual Basic statement + + Set object.Property = Nothing + +=head2 New _NewEnum and _Unique options + +There are two new options available for the Win32::OLE->Option class +method: C<_NewEnum> provides the elements of a collection object +directly as the value of a C<_NewEnum> property. The C<_Unique> +option guarantees that Win32::OLE will not create multiple proxy +objects for the same underlying COM/OLE object. + +Both options are only really useful to tree traversal programs or +during debugging. + + +=head1 Version 0.12 + +=head2 Additional error handling functionality + +The Warn option can now be set to a CODE reference too. For example, + + Win32::OLE->Option(Warn => 3); + +could now be written as + + Win32::OLE->Option(Warn => \&Carp::croak); + +This can even be used to emulate the VisualBasic C<On Error Goto +Label> construct: + + Win32::OLE->Option(Warn => sub {goto CheckError}); + # ... your normal OLE code here ... + + CheckError: + # ... your error handling code here ... + +=head2 Builtin event loop + +Processing OLE events required a polling loop before, e.g. + + my $Quit; + #... + until ($Quit) { + Win32::OLE->SpinMessageLoop; + Win32::Sleep(100); + } + package BrowserEvents; + sub OnQuit { $Quit = 1 } + +This is inefficient and a bit odd. This version of Win32::OLE now +supports a standard messageloop: + + Win32::OLE->MessageLoop(); + + package BrowserEvents; + sub OnQuit { Win32::OLE->QuitMessageLoop } + +=head2 Free unused OLE libraries + +Previous versions of Win32::OLE would call the CoFreeUnusedLibraries() +API whenever an OLE object was destroyed. This made sure that OLE +libraries would be unloaded as soon as they were no longer needed. +Unfortunately, objects implemented in Visual Basic tend to crash +during this call, as they pretend to be ready for unloading, when in +fact, they aren't. + +The unloading of object libraries is really only important for long +running processes that might instantiate a huge number of B<different> +objects over time. Therefore this API is no longer called +automatically. The functionality is now available explicitly to those +who want or need it by calling a Win32::OLE class method: + + Win32::OLE->FreeUnusedLibraries(); + +=head2 The "Win32::OLE" article from "The Perl Journal #10" + +The article is Copyright 1998 by I<The Perl +Journal>. http://www.tpj.com + +It originally appeared in I<The Perl Journal> # 10 and appears here +courtesy of Jon Orwant and I<The Perl Journal>. The sample code from +the article is in the F<eg/tpj.pl> file. + +=head2 VARIANT->Put() bug fixes + +The Put() method didn't work correctly for arrays of type VT_BSTR, +VT_DISPATH or VT_UNKNOWN. This has been fixed. + +=head2 Error message fixes + +Previous versions of Win32::OLE gave a wrong argument index for some +OLE error messages (the number was too large by 1). This should be +fixed now. + +=head2 VT_DATE and VT_ERROR return values handled differently + +Method calls and property accesses returning a VT_DATE or VT_ERROR +value would previously translate the value to string or integer +format. This has been changed to return a Win32::OLE::Variant object. +The return values will behave as before if the Win32::OLE::Variant +module is being used. This module overloads the conversion of +the objects to strings and numbers. + + +=head1 Version 0.11 (changes since 0.1008) + +=head2 new DHTML typelib browser + +The Win32::OLE distribution now contains a type library browser. It +is written in PerlScript, generating dynamic HTML. It requires +Internet Explorer 4.0 or later. You'll find it in +F<browser/Browser.html>. It should be available in the ActivePerl +HTML help under Win32::OLE::Browser. + +After selecting a library, type or member you can press F1 to call up +the corresponding help file at the appropriate location. + +=head2 VT_DECIMAL support + +The Win32::OLE::Variant module now supports VT_DECIMAL variants too. +They are not "officially" allowed in OLE Automation calls, but even +Microsoft's "ActiveX Data Objects" sometimes returns VT_DECIMAL +values. + +VT_DECIMAL variables are stored as 96-bit integers scaled by a +variable power of 10. The power of 10 scaling factor specifies the +number of digits to the right of the decimal point, and ranges from 0 +to 28. With a scale of 0 (no decimal places), the largest possible +value is +/-79,228,162,514,264,337,593,543,950,335. With a 28 decimal +places, the largest value is +/-7.9228162514264337593543950335 and the +smallest, non-zero value is +/-0.0000000000000000000000000001. + +=head1 Version 0.1008 + +=head2 new LetProperty() object method + +In Win32::OLE property assignment using the hash syntax is equivalent +to the Visual Basic C<Set> syntax (I<by reference> assignment): + + $Object->{Property} = $OtherObject; + +corresponds to this Visual Basic statement: + + Set Object.Property = OtherObject + +To get the I<by value> treatment of the Visual Basic C<Let> statement + + Object.Property = OtherObject + +you have to use the LetProperty() object method in Perl: + + $Object->LetProperty($Property, $OtherObject); + +=head2 new HRESULT() function + +The HRESULT() function converts an unsigned number into a signed HRESULT +error value as used by OLE internally. This is necessary because Perl +treats all hexadecimal constants as unsigned. To check if the last OLE +function returned "Member not found" (0x80020003) you can write: + + if (Win32::OLE->LastError == HRESULT(0x80020003)) { + # your error recovery here + } + +=head1 Version 0.1007 (changes since 0.1005) + +=head2 OLE Event support + +This version of Win32::OLE contains B<ALPHA> level support for OLE events. The +user interface is still subject to change. There are ActiveX objects / controls +that don't fire events under the current implementation. + +Events are enabled for a specific object with the Win32::OLE->WithEvents() +class method: + + Win32::OLE->WithEvents(OBJECT, HANDLER, INTERFACE) + +Please read further documentation in Win32::OLE. + +=head2 GetObject() and GetActiveObject() now support optional DESTRUCTOR argument + +It is now possible to specify a DESTRUCTOR argument to the GetObject() and +GetActiveObject() class methods. They work identical to the new() DESTRUCTOR +argument. + +=head2 Remote object instantiation via DCOM + +This has actually been in Win32::OLE since 0.0608, but somehow never got +documented. You can provide an array reference in place of the usual PROGID +parameter to Win32::OLE->new(): + + OBJ = Win32::OLE->new([MACHINE, PRODID]); + +The array must contain two elements: the name of the MACHINE and the PROGID. +This will try to create the object on the remote MACHINE. + +=head2 Enumerate all Win32::OLE objects + +This class method returns the number Win32::OLE objects currently in +existence. It will call the optional CALLBACK function for each of +these objects: + + $Count = Win32::OLE->EnumAllObjects(sub { + my $Object = shift; + my $Class = Win32::OLE->QueryObjectType($Object); + printf "# Object=%s Class=%s\n", $Object, $Class; + }); + +The EnumAllObjects() method is primarily a debugging tool. It can be +used e.g. in an END block to check if all external connections have +been properly destroyed. + +=head2 The VARIANT->Put() method now returns the VARIANT object itself + +This allows chaining of Put() method calls to set multiple values in an +array variant: + + $Array->Put(0,0,$First_value)->Put(0,1,$Another_value); + +=head2 The VARIANT->Put(ARRAYREF) form allows assignment to a complete SAFEARRAY + +This allows automatic conversion from a list of lists to a SAFEARRAY. +You can now write: + + my $Array = Variant(VT_ARRAY|VT_R8, [1,2], 2); + $Array->Put([[1,2], [3,4]]); + +instead of the tedious: + + $Array->Put(1,0,1); + $Array->Put(1,1,2); + $Array->Put(2,0,3); + $Array->Put(2,1,4); + +=head2 New Variant formatting methods + +There are four new methods for formatting variant values: Currency(), Date(), +Number() and Time(). For example: + + my $v = Variant(VT_DATE, "April 1 99"); + print $v->Date(DATE_LONGDATE), "\n"; + print $v->Date("ddd',' MMM dd yy"), "\n"; + +will print: + + Thursday, April 01, 1999 + Thu, Apr 01 99 + +=head2 new Win32::OLE::NLS methods: SendSettingChange() and SetLocaleInfo() + +SendSettingChange() sends a WM_SETTINGCHANGE message to all top level windows. + +SetLocaleInfo() allows changing elements in the user override section of the +locale database. Unfortunately these changes are not automatically available +to further Variant formatting; you have to call SendSettingChange() first. + +=head2 Win32::OLE::Const now correctly treats version numbers as hex + +The minor and major version numbers of type libraries have been treated as +decimal. This was wrong. They are now correctly decoded as hex. + +=head2 more robust global destruction of Win32::OLE objects + +The final destruction of Win32::OLE objects has always been somewhat fragile. +The reason for this is that Perl doesn't honour reference counts during global +destruction but destroys objects in seemingly random order. This can lead +to leaked database connections or unterminated external objects. The only +solution was to make all objects lexical and hope that no object would be +trapped in a closure. Alternatively all objects could be explicitly set to +C<undef>, which doesn't work very well with exception handling. + +With version 0.1007 of Win32::OLE this problem should be gone: The module +keeps a list of active Win32::OLE objects. It uses an END block to destroy +all objects at program termination I<before> the Perl's global destruction +starts. Objects still existing at program termination are now destroyed in +reverse order of creation. The effect is similar to explicitly calling +Win32::OLE->Uninitialize() just prior to termination. + +=head1 Version 0.1005 (changes since 0.1003) + +Win32::OLE 0.1005 has been release with ActivePerl build 509. It is also +included in the I<Perl Resource Kit for Win32> Update. + +=head2 optional DESTRUCTOR for GetActiveObject() GetObject() class methods + +The GetActiveObject() and GetObject() class method now also support an +optional DESTRUCTOR parameter just like Win32::OLE->new(). The DESTRUCTOR +is executed when the last reference to this object goes away. It is +generally considered C<impolite> to stop applications that you did not +start yourself. + +=head2 new Variant object method: $object->Copy() + +See L<Win32::OLE::Variant/Copy([DIM])>. + +=head2 new Win32::OLE->Option() class method + +The Option() class method can be used to inspect and modify +L<Win32::OLE/Module Options>. The single argument form retrieves +the value of an option: + + my $CP = Win32::OLE->Option('CP'); + +A single call can be used to set multiple options simultaneously: + + Win32::OLE->Option(CP => CP_ACP, Warn => 3); + +Currently the following options exist: CP, LCID and C<Warn>. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NLS.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NLS.pm new file mode 100644 index 0000000000..84ea0c7724 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NLS.pm @@ -0,0 +1,968 @@ +# The documentation is at the __END__ + +package Win32::OLE::NLS; +require Win32::OLE; # Make sure the XS bootstrap has been called + +use strict; +use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA); + +use Exporter; +@ISA = qw(Exporter); + +@EXPORT = qw( + CompareString + LCMapString + GetLocaleInfo + GetStringType + GetSystemDefaultLangID + GetSystemDefaultLCID + GetUserDefaultLangID + GetUserDefaultLCID + + MAKELANGID + PRIMARYLANGID + SUBLANGID + LANG_SYSTEM_DEFAULT + LANG_USER_DEFAULT + MAKELCID + LANGIDFROMLCID + LOCALE_SYSTEM_DEFAULT + LOCALE_USER_DEFAULT + ); + +@EXPORT_OK = qw(SetLocaleInfo SendSettingChange); + +%EXPORT_TAGS = +( + CT => [qw(CT_CTYPE1 CT_CTYPE2 CT_CTYPE3)], + C1 => [qw(C1_UPPER C1_LOWER C1_DIGIT C1_SPACE C1_PUNCT + C1_CNTRL C1_BLANK C1_XDIGIT C1_ALPHA)], + C2 => [qw(C2_LEFTTORIGHT C2_RIGHTTOLEFT C2_EUROPENUMBER + C2_EUROPESEPARATOR C2_EUROPETERMINATOR C2_ARABICNUMBER + C2_COMMONSEPARATOR C2_BLOCKSEPARATOR C2_SEGMENTSEPARATOR + C2_WHITESPACE C2_OTHERNEUTRAL C2_NOTAPPLICABLE)], + C3 => [qw(C3_NONSPACING C3_DIACRITIC C3_VOWELMARK C3_SYMBOL C3_KATAKANA + C3_HIRAGANA C3_HALFWIDTH C3_FULLWIDTH C3_IDEOGRAPH C3_KASHIDA + C3_ALPHA C3_NOTAPPLICABLE)], + NORM => [qw(NORM_IGNORECASE NORM_IGNORENONSPACE NORM_IGNORESYMBOLS + NORM_IGNOREWIDTH NORM_IGNOREKANATYPE NORM_IGNOREKASHIDA)], + LCMAP => [qw(LCMAP_LOWERCASE LCMAP_UPPERCASE LCMAP_SORTKEY LCMAP_HALFWIDTH + LCMAP_FULLWIDTH LCMAP_HIRAGANA LCMAP_KATAKANA)], + LANG => [qw(LANG_NEUTRAL LANG_ALBANIAN LANG_ARABIC LANG_BAHASA + LANG_BULGARIAN LANG_CATALAN LANG_CHINESE LANG_CZECH LANG_DANISH + LANG_DUTCH LANG_ENGLISH LANG_FINNISH LANG_FRENCH LANG_GERMAN + LANG_GREEK LANG_HEBREW LANG_HUNGARIAN LANG_ICELANDIC + LANG_ITALIAN LANG_JAPANESE LANG_KOREAN LANG_NORWEGIAN + LANG_POLISH LANG_PORTUGUESE LANG_RHAETO_ROMAN LANG_ROMANIAN + LANG_RUSSIAN LANG_SERBO_CROATIAN LANG_SLOVAK LANG_SPANISH + LANG_SWEDISH LANG_THAI LANG_TURKISH LANG_URDU)], + SUBLANG => [qw(SUBLANG_NEUTRAL SUBLANG_DEFAULT SUBLANG_SYS_DEFAULT + SUBLANG_CHINESE_SIMPLIFIED SUBLANG_CHINESE_TRADITIONAL + SUBLANG_DUTCH SUBLANG_DUTCH_BELGIAN SUBLANG_ENGLISH_US + SUBLANG_ENGLISH_UK SUBLANG_ENGLISH_AUS SUBLANG_ENGLISH_CAN + SUBLANG_ENGLISH_NZ SUBLANG_ENGLISH_EIRE SUBLANG_FRENCH + SUBLANG_FRENCH_BELGIAN SUBLANG_FRENCH_CANADIAN + SUBLANG_FRENCH_SWISS SUBLANG_GERMAN SUBLANG_GERMAN_SWISS + SUBLANG_GERMAN_AUSTRIAN SUBLANG_ITALIAN SUBLANG_ITALIAN_SWISS + SUBLANG_NORWEGIAN_BOKMAL SUBLANG_NORWEGIAN_NYNORSK + SUBLANG_PORTUGUESE SUBLANG_PORTUGUESE_BRAZILIAN + SUBLANG_SERBO_CROATIAN_CYRILLIC SUBLANG_SERBO_CROATIAN_LATIN + SUBLANG_SPANISH SUBLANG_SPANISH_MEXICAN + SUBLANG_SPANISH_MODERN)], + CTRY => [qw(CTRY_DEFAULT CTRY_AUSTRALIA CTRY_AUSTRIA CTRY_BELGIUM + CTRY_BRAZIL CTRY_CANADA CTRY_DENMARK CTRY_FINLAND CTRY_FRANCE + CTRY_GERMANY CTRY_ICELAND CTRY_IRELAND CTRY_ITALY CTRY_JAPAN + CTRY_MEXICO CTRY_NETHERLANDS CTRY_NEW_ZEALAND CTRY_NORWAY + CTRY_PORTUGAL CTRY_PRCHINA CTRY_SOUTH_KOREA CTRY_SPAIN + CTRY_SWEDEN CTRY_SWITZERLAND CTRY_TAIWAN CTRY_UNITED_KINGDOM + CTRY_UNITED_STATES)], + LOCALE => [qw(LOCALE_NOUSEROVERRIDE LOCALE_ILANGUAGE LOCALE_SLANGUAGE + LOCALE_SENGLANGUAGE LOCALE_SABBREVLANGNAME + LOCALE_SNATIVELANGNAME LOCALE_ICOUNTRY LOCALE_SCOUNTRY + LOCALE_SENGCOUNTRY LOCALE_SABBREVCTRYNAME LOCALE_SNATIVECTRYNAME + LOCALE_IDEFAULTLANGUAGE LOCALE_IDEFAULTCOUNTRY + LOCALE_IDEFAULTCODEPAGE LOCALE_IDEFAULTANSICODEPAGE LOCALE_SLIST + LOCALE_IMEASURE LOCALE_SDECIMAL LOCALE_STHOUSAND + LOCALE_SGROUPING LOCALE_IDIGITS LOCALE_ILZERO LOCALE_INEGNUMBER + LOCALE_SNATIVEDIGITS LOCALE_SCURRENCY LOCALE_SINTLSYMBOL + LOCALE_SMONDECIMALSEP LOCALE_SMONTHOUSANDSEP LOCALE_SMONGROUPING + LOCALE_ICURRDIGITS LOCALE_IINTLCURRDIGITS LOCALE_ICURRENCY + LOCALE_INEGCURR LOCALE_SDATE LOCALE_STIME LOCALE_SSHORTDATE + LOCALE_SLONGDATE LOCALE_STIMEFORMAT LOCALE_IDATE LOCALE_ILDATE + LOCALE_ITIME LOCALE_ITIMEMARKPOSN LOCALE_ICENTURY LOCALE_ITLZERO + LOCALE_IDAYLZERO LOCALE_IMONLZERO LOCALE_S1159 LOCALE_S2359 + LOCALE_ICALENDARTYPE LOCALE_IOPTIONALCALENDAR + LOCALE_IFIRSTDAYOFWEEK LOCALE_IFIRSTWEEKOFYEAR LOCALE_SDAYNAME1 + LOCALE_SDAYNAME2 LOCALE_SDAYNAME3 LOCALE_SDAYNAME4 + LOCALE_SDAYNAME5 LOCALE_SDAYNAME6 LOCALE_SDAYNAME7 + LOCALE_SABBREVDAYNAME1 LOCALE_SABBREVDAYNAME2 + LOCALE_SABBREVDAYNAME3 LOCALE_SABBREVDAYNAME4 + LOCALE_SABBREVDAYNAME5 LOCALE_SABBREVDAYNAME6 + LOCALE_SABBREVDAYNAME7 LOCALE_SMONTHNAME1 LOCALE_SMONTHNAME2 + LOCALE_SMONTHNAME3 LOCALE_SMONTHNAME4 LOCALE_SMONTHNAME5 + LOCALE_SMONTHNAME6 LOCALE_SMONTHNAME7 LOCALE_SMONTHNAME8 + LOCALE_SMONTHNAME9 LOCALE_SMONTHNAME10 LOCALE_SMONTHNAME11 + LOCALE_SMONTHNAME12 LOCALE_SMONTHNAME13 LOCALE_SABBREVMONTHNAME1 + LOCALE_SABBREVMONTHNAME2 LOCALE_SABBREVMONTHNAME3 + LOCALE_SABBREVMONTHNAME4 LOCALE_SABBREVMONTHNAME5 + LOCALE_SABBREVMONTHNAME6 LOCALE_SABBREVMONTHNAME7 + LOCALE_SABBREVMONTHNAME8 LOCALE_SABBREVMONTHNAME9 + LOCALE_SABBREVMONTHNAME10 LOCALE_SABBREVMONTHNAME11 + LOCALE_SABBREVMONTHNAME12 LOCALE_SABBREVMONTHNAME13 + LOCALE_SPOSITIVESIGN LOCALE_SNEGATIVESIGN LOCALE_IPOSSIGNPOSN + LOCALE_INEGSIGNPOSN LOCALE_IPOSSYMPRECEDES LOCALE_IPOSSEPBYSPACE + LOCALE_INEGSYMPRECEDES LOCALE_INEGSEPBYSPACE)], + TIME => [qw(TIME_NOMINUTESORSECONDS TIME_NOSECONDS TIME_NOTIMEMARKER + TIME_FORCE24HOURFORMAT)], + DATE => [qw(DATE_SHORTDATE DATE_LONGDATE DATE_USE_ALT_CALENDAR + DATE_YEARMONTH DATE_LTRREADING DATE_RTLREADING)], +); + +foreach my $tag (keys %EXPORT_TAGS) { + push @EXPORT_OK, @{$EXPORT_TAGS{$tag}}; +} + +# Character Type Flags +sub CT_CTYPE1 { 0x0001 } +sub CT_CTYPE2 { 0x0002 } +sub CT_CTYPE3 { 0x0004 } + +# Character Type 1 Bits +sub C1_UPPER { 0x0001 } +sub C1_LOWER { 0x0002 } +sub C1_DIGIT { 0x0004 } +sub C1_SPACE { 0x0008 } +sub C1_PUNCT { 0x0010 } +sub C1_CNTRL { 0x0020 } +sub C1_BLANK { 0x0040 } +sub C1_XDIGIT { 0x0080 } +sub C1_ALPHA { 0x0100 } + +# Character Type 2 Bits +sub C2_LEFTTORIGHT { 0x1 } +sub C2_RIGHTTOLEFT { 0x2 } +sub C2_EUROPENUMBER { 0x3 } +sub C2_EUROPESEPARATOR { 0x4 } +sub C2_EUROPETERMINATOR { 0x5 } +sub C2_ARABICNUMBER { 0x6 } +sub C2_COMMONSEPARATOR { 0x7 } +sub C2_BLOCKSEPARATOR { 0x8 } +sub C2_SEGMENTSEPARATOR { 0x9 } +sub C2_WHITESPACE { 0xA } +sub C2_OTHERNEUTRAL { 0xB } +sub C2_NOTAPPLICABLE { 0x0 } + +# Character Type 3 Bits +sub C3_NONSPACING { 0x0001 } +sub C3_DIACRITIC { 0x0002 } +sub C3_VOWELMARK { 0x0004 } +sub C3_SYMBOL { 0x0008 } +sub C3_KATAKANA { 0x0010 } +sub C3_HIRAGANA { 0x0020 } +sub C3_HALFWIDTH { 0x0040 } +sub C3_FULLWIDTH { 0x0080 } +sub C3_IDEOGRAPH { 0x0100 } +sub C3_KASHIDA { 0x0200 } +sub C3_ALPHA { 0x8000 } +sub C3_NOTAPPLICABLE { 0x0 } + +# String Flags +sub NORM_IGNORECASE { 0x0001 } +sub NORM_IGNORENONSPACE { 0x0002 } +sub NORM_IGNORESYMBOLS { 0x0004 } +sub NORM_IGNOREWIDTH { 0x0008 } +sub NORM_IGNOREKANATYPE { 0x0040 } +sub NORM_IGNOREKASHIDA { 0x40000} + +# Locale Dependent Mapping Flags +sub LCMAP_LOWERCASE { 0x0100 } +sub LCMAP_UPPERCASE { 0x0200 } +sub LCMAP_SORTKEY { 0x0400 } +sub LCMAP_HALFWIDTH { 0x0800 } +sub LCMAP_FULLWIDTH { 0x1000 } +sub LCMAP_HIRAGANA { 0x2000 } +sub LCMAP_KATAKANA { 0x4000 } + +# Primary Language Identifier +sub LANG_NEUTRAL { 0x00 } +sub LANG_ALBANIAN { 0x1c } +sub LANG_ARABIC { 0x01 } +sub LANG_BAHASA { 0x21 } +sub LANG_BULGARIAN { 0x02 } +sub LANG_CATALAN { 0x03 } +sub LANG_CHINESE { 0x04 } +sub LANG_CZECH { 0x05 } +sub LANG_DANISH { 0x06 } +sub LANG_DUTCH { 0x13 } +sub LANG_ENGLISH { 0x09 } +sub LANG_FINNISH { 0x0b } +sub LANG_FRENCH { 0x0c } +sub LANG_GERMAN { 0x07 } +sub LANG_GREEK { 0x08 } +sub LANG_HEBREW { 0x0d } +sub LANG_HUNGARIAN { 0x0e } +sub LANG_ICELANDIC { 0x0f } +sub LANG_ITALIAN { 0x10 } +sub LANG_JAPANESE { 0x11 } +sub LANG_KOREAN { 0x12 } +sub LANG_NORWEGIAN { 0x14 } +sub LANG_POLISH { 0x15 } +sub LANG_PORTUGUESE { 0x16 } +sub LANG_RHAETO_ROMAN { 0x17 } +sub LANG_ROMANIAN { 0x18 } +sub LANG_RUSSIAN { 0x19 } +sub LANG_SERBO_CROATIAN { 0x1a } +sub LANG_SLOVAK { 0x1b } +sub LANG_SPANISH { 0x0a } +sub LANG_SWEDISH { 0x1d } +sub LANG_THAI { 0x1e } +sub LANG_TURKISH { 0x1f } +sub LANG_URDU { 0x20 } + +# Sublanguage Identifier +sub SUBLANG_NEUTRAL { 0x00 } +sub SUBLANG_DEFAULT { 0x01 } +sub SUBLANG_SYS_DEFAULT { 0x02 } +sub SUBLANG_CHINESE_SIMPLIFIED { 0x02 } +sub SUBLANG_CHINESE_TRADITIONAL { 0x01 } +sub SUBLANG_DUTCH { 0x01 } +sub SUBLANG_DUTCH_BELGIAN { 0x02 } +sub SUBLANG_ENGLISH_US { 0x01 } +sub SUBLANG_ENGLISH_UK { 0x02 } +sub SUBLANG_ENGLISH_AUS { 0x03 } +sub SUBLANG_ENGLISH_CAN { 0x04 } +sub SUBLANG_ENGLISH_NZ { 0x05 } +sub SUBLANG_ENGLISH_EIRE { 0x06 } +sub SUBLANG_FRENCH { 0x01 } +sub SUBLANG_FRENCH_BELGIAN { 0x02 } +sub SUBLANG_FRENCH_CANADIAN { 0x03 } +sub SUBLANG_FRENCH_SWISS { 0x04 } +sub SUBLANG_GERMAN { 0x01 } +sub SUBLANG_GERMAN_SWISS { 0x02 } +sub SUBLANG_GERMAN_AUSTRIAN { 0x03 } +sub SUBLANG_ITALIAN { 0x01 } +sub SUBLANG_ITALIAN_SWISS { 0x02 } +sub SUBLANG_NORWEGIAN_BOKMAL { 0x01 } +sub SUBLANG_NORWEGIAN_NYNORSK { 0x02 } +sub SUBLANG_PORTUGUESE { 0x02 } +sub SUBLANG_PORTUGUESE_BRAZILIAN { 0x01 } +sub SUBLANG_SERBO_CROATIAN_CYRILLIC { 0x02 } +sub SUBLANG_SERBO_CROATIAN_LATIN { 0x01 } +sub SUBLANG_SPANISH { 0x01 } +sub SUBLANG_SPANISH_MEXICAN { 0x02 } +sub SUBLANG_SPANISH_MODERN { 0x03 } + +# Country codes +sub CTRY_DEFAULT { 0 } +sub CTRY_AUSTRALIA { 61 } +sub CTRY_AUSTRIA { 43 } +sub CTRY_BELGIUM { 32 } +sub CTRY_BRAZIL { 55 } +sub CTRY_CANADA { 2 } +sub CTRY_DENMARK { 45 } +sub CTRY_FINLAND { 358 } +sub CTRY_FRANCE { 33 } +sub CTRY_GERMANY { 49 } +sub CTRY_ICELAND { 354 } +sub CTRY_IRELAND { 353 } +sub CTRY_ITALY { 39 } +sub CTRY_JAPAN { 81 } +sub CTRY_MEXICO { 52 } +sub CTRY_NETHERLANDS { 31 } +sub CTRY_NEW_ZEALAND { 64 } +sub CTRY_NORWAY { 47 } +sub CTRY_PORTUGAL { 351 } +sub CTRY_PRCHINA { 86 } +sub CTRY_SOUTH_KOREA { 82 } +sub CTRY_SPAIN { 34 } +sub CTRY_SWEDEN { 46 } +sub CTRY_SWITZERLAND { 41 } +sub CTRY_TAIWAN { 886 } +sub CTRY_UNITED_KINGDOM { 44 } +sub CTRY_UNITED_STATES { 1 } + +# Locale Types +sub LOCALE_NOUSEROVERRIDE { 0x80000000 } +sub LOCALE_ILANGUAGE { 0x0001 } +sub LOCALE_SLANGUAGE { 0x0002 } +sub LOCALE_SENGLANGUAGE { 0x1001 } +sub LOCALE_SABBREVLANGNAME { 0x0003 } +sub LOCALE_SNATIVELANGNAME { 0x0004 } +sub LOCALE_ICOUNTRY { 0x0005 } +sub LOCALE_SCOUNTRY { 0x0006 } +sub LOCALE_SENGCOUNTRY { 0x1002 } +sub LOCALE_SABBREVCTRYNAME { 0x0007 } +sub LOCALE_SNATIVECTRYNAME { 0x0008 } +sub LOCALE_IDEFAULTLANGUAGE { 0x0009 } +sub LOCALE_IDEFAULTCOUNTRY { 0x000A } +sub LOCALE_IDEFAULTCODEPAGE { 0x000B } +sub LOCALE_IDEFAULTANSICODEPAGE { 0x1004 } +sub LOCALE_SLIST { 0x000C } +sub LOCALE_IMEASURE { 0x000D } +sub LOCALE_SDECIMAL { 0x000E } +sub LOCALE_STHOUSAND { 0x000F } +sub LOCALE_SGROUPING { 0x0010 } +sub LOCALE_IDIGITS { 0x0011 } +sub LOCALE_ILZERO { 0x0012 } +sub LOCALE_INEGNUMBER { 0x1010 } +sub LOCALE_SNATIVEDIGITS { 0x0013 } +sub LOCALE_SCURRENCY { 0x0014 } +sub LOCALE_SINTLSYMBOL { 0x0015 } +sub LOCALE_SMONDECIMALSEP { 0x0016 } +sub LOCALE_SMONTHOUSANDSEP { 0x0017 } +sub LOCALE_SMONGROUPING { 0x0018 } +sub LOCALE_ICURRDIGITS { 0x0019 } +sub LOCALE_IINTLCURRDIGITS { 0x001A } +sub LOCALE_ICURRENCY { 0x001B } +sub LOCALE_INEGCURR { 0x001C } +sub LOCALE_SDATE { 0x001D } +sub LOCALE_STIME { 0x001E } +sub LOCALE_SSHORTDATE { 0x001F } +sub LOCALE_SLONGDATE { 0x0020 } +sub LOCALE_STIMEFORMAT { 0x1003 } +sub LOCALE_IDATE { 0x0021 } +sub LOCALE_ILDATE { 0x0022 } +sub LOCALE_ITIME { 0x0023 } +sub LOCALE_ITIMEMARKPOSN { 0x1005 } +sub LOCALE_ICENTURY { 0x0024 } +sub LOCALE_ITLZERO { 0x0025 } +sub LOCALE_IDAYLZERO { 0x0026 } +sub LOCALE_IMONLZERO { 0x0027 } +sub LOCALE_S1159 { 0x0028 } +sub LOCALE_S2359 { 0x0029 } +sub LOCALE_ICALENDARTYPE { 0x1009 } +sub LOCALE_IOPTIONALCALENDAR { 0x100B } +sub LOCALE_IFIRSTDAYOFWEEK { 0x100C } +sub LOCALE_IFIRSTWEEKOFYEAR { 0x100D } +sub LOCALE_SDAYNAME1 { 0x002A } +sub LOCALE_SDAYNAME2 { 0x002B } +sub LOCALE_SDAYNAME3 { 0x002C } +sub LOCALE_SDAYNAME4 { 0x002D } +sub LOCALE_SDAYNAME5 { 0x002E } +sub LOCALE_SDAYNAME6 { 0x002F } +sub LOCALE_SDAYNAME7 { 0x0030 } +sub LOCALE_SABBREVDAYNAME1 { 0x0031 } +sub LOCALE_SABBREVDAYNAME2 { 0x0032 } +sub LOCALE_SABBREVDAYNAME3 { 0x0033 } +sub LOCALE_SABBREVDAYNAME4 { 0x0034 } +sub LOCALE_SABBREVDAYNAME5 { 0x0035 } +sub LOCALE_SABBREVDAYNAME6 { 0x0036 } +sub LOCALE_SABBREVDAYNAME7 { 0x0037 } +sub LOCALE_SMONTHNAME1 { 0x0038 } +sub LOCALE_SMONTHNAME2 { 0x0039 } +sub LOCALE_SMONTHNAME3 { 0x003A } +sub LOCALE_SMONTHNAME4 { 0x003B } +sub LOCALE_SMONTHNAME5 { 0x003C } +sub LOCALE_SMONTHNAME6 { 0x003D } +sub LOCALE_SMONTHNAME7 { 0x003E } +sub LOCALE_SMONTHNAME8 { 0x003F } +sub LOCALE_SMONTHNAME9 { 0x0040 } +sub LOCALE_SMONTHNAME10 { 0x0041 } +sub LOCALE_SMONTHNAME11 { 0x0042 } +sub LOCALE_SMONTHNAME12 { 0x0043 } +sub LOCALE_SMONTHNAME13 { 0x100E } +sub LOCALE_SABBREVMONTHNAME1 { 0x0044 } +sub LOCALE_SABBREVMONTHNAME2 { 0x0045 } +sub LOCALE_SABBREVMONTHNAME3 { 0x0046 } +sub LOCALE_SABBREVMONTHNAME4 { 0x0047 } +sub LOCALE_SABBREVMONTHNAME5 { 0x0048 } +sub LOCALE_SABBREVMONTHNAME6 { 0x0049 } +sub LOCALE_SABBREVMONTHNAME7 { 0x004A } +sub LOCALE_SABBREVMONTHNAME8 { 0x004B } +sub LOCALE_SABBREVMONTHNAME9 { 0x004C } +sub LOCALE_SABBREVMONTHNAME10 { 0x004D } +sub LOCALE_SABBREVMONTHNAME11 { 0x004E } +sub LOCALE_SABBREVMONTHNAME12 { 0x004F } +sub LOCALE_SABBREVMONTHNAME13 { 0x100F } +sub LOCALE_SPOSITIVESIGN { 0x0050 } +sub LOCALE_SNEGATIVESIGN { 0x0051 } +sub LOCALE_IPOSSIGNPOSN { 0x0052 } +sub LOCALE_INEGSIGNPOSN { 0x0053 } +sub LOCALE_IPOSSYMPRECEDES { 0x0054 } +sub LOCALE_IPOSSEPBYSPACE { 0x0055 } +sub LOCALE_INEGSYMPRECEDES { 0x0056 } +sub LOCALE_INEGSEPBYSPACE { 0x0057 } + +# GetTimeFormat Flags +sub TIME_NOMINUTESORSECONDS { 0x0001 } +sub TIME_NOSECONDS { 0x0002 } +sub TIME_NOTIMEMARKER { 0x0004 } +sub TIME_FORCE24HOURFORMAT { 0x0008 } + +# GetDateFormat Flags +sub DATE_SHORTDATE { 0x0001 } +sub DATE_LONGDATE { 0x0002 } +sub DATE_USE_ALT_CALENDAR { 0x0004 } +sub DATE_YEARMONTH { 0x0008 } +sub DATE_LTRREADING { 0x0010 } +sub DATE_RTLREADING { 0x0020 } + +# Language Identifier Functions +sub MAKELANGID { my ($p,$s) = @_; (($s & 0xffff) << 10) | ($p & 0xffff); } +sub PRIMARYLANGID { my $lgid = shift; $lgid & 0x3ff; } +sub SUBLANGID { my $lgid = shift; ($lgid >> 10) & 0x3f; } + +sub LANG_SYSTEM_DEFAULT { MAKELANGID(LANG_NEUTRAL, SUBLANG_SYS_DEFAULT); } +sub LANG_USER_DEFAULT { MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT); } + +# Locale Identifier Functions +sub MAKELCID { my $lgid = shift; $lgid & 0xffff; } +sub LANGIDFROMLCID { my $lcid = shift; $lcid & 0xffff; } + +sub LOCALE_SYSTEM_DEFAULT { MAKELCID(LANG_SYSTEM_DEFAULT); } +sub LOCALE_USER_DEFAULT { MAKELCID(LANG_USER_DEFAULT); } + +1; + +__END__ + +=head1 NAME + +Win32::OLE::NLS - OLE National Language Support + +=head1 SYNOPSIS + + missing + +=head1 DESCRIPTION + +This module provides access to the national language support features +in the F<OLENLS.DLL>. + +=head2 Functions + +=over 8 + +=item CompareString(LCID,FLAGS,STR1,STR2) + +Compare STR1 and STR2 in the LCID locale. FLAGS indicate the character +traits to be used or ignored when comparing the two strings. + + NORM_IGNORECASE Ignore case + NORM_IGNOREKANATYPE Ignore hiragana/katakana character differences + NORM_IGNORENONSPACE Ignore accents, diacritics, and vowel marks + NORM_IGNORESYMBOLS Ignore symbols + NORM_IGNOREWIDTH Ignore character width + +Possible return values are: + + 0 Function failed + 1 STR1 is less than STR2 + 2 STR1 is equal to STR2 + 3 STR1 is greater than STR2 + +Note that you can subtract 2 from the return code to get values +comparable to the C<cmp> operator. + +=item LCMapString(LCID,FLAGS,STR) + +LCMapString translates STR using LCID dependent translation. +Flags contains a combination of the following options: + + LCMAP_LOWERCASE Lowercase + LCMAP_UPPERCASE Uppercase + LCMAP_HALFWIDTH Narrow characters + LCMAP_FULLWIDTH Wide characters + LCMAP_HIRAGANA Hiragana + LCMAP_KATAKANA Katakana + LCMAP_SORTKEY Character sort key + +The following normalization options can be combined with C<LCMAP_SORTKEY>: + + NORM_IGNORECASE Ignore case + NORM_IGNOREKANATYPE Ignore hiragana/katakana character differences + NORM_IGNORENONSPACE Ignore accents, diacritics, and vowel marks + NORM_IGNORESYMBOLS Ignore symbols + NORM_IGNOREWIDTH Ignore character width + +The return value is the translated string. + +=item GetLocaleInfo(LCID,LCTYPE) + +Retrieve locale setting LCTYPE from the locale specified by LCID. Use +LOCALE_NOUSEROVERRIDE | LCTYPE to always query the locale database. +Otherwise user changes to C<win.ini> through the windows control panel +take precedence when retrieving values for the system default locale. +See the documentation below for a list of valid LCTYPE values. + +The return value is the contents of the requested locale setting. + +=item GetStringType(LCID,TYPE,STR) + +Retrieve type information from locale LCID about each character in STR. +The requested TYPE can be one of the following 3 levels: + + CT_CTYPE1 ANSI C and POSIX type information + CT_CTYPE2 Text layout type information + CT_CTYPE3 Text processing type information + +The return value is a list of values, each of wich is a bitwise OR of +the applicable type bits from the corresponding table below: + + @ct = GetStringType(LOCALE_SYSTEM_DEFAULT, CT_CTYPE1, "String"); + +ANSI C and POSIX character type information: + + C1_UPPER Uppercase + C1_LOWER Lowercase + C1_DIGIT Decimal digits + C1_SPACE Space characters + C1_PUNCT Punctuation + C1_CNTRL Control characters + C1_BLANK Blank characters + C1_XDIGIT Hexadecimal digits + C1_ALPHA Any letter + +Text layout type information: + + C2_LEFTTORIGHT Left to right + C2_RIGHTTOLEFT Right to left + C2_EUROPENUMBER European number, European digit + C2_EUROPESEPARATOR European numeric separator + C2_EUROPETERMINATOR European numeric terminator + C2_ARABICNUMBER Arabic number + C2_COMMONSEPARATOR Common numeric separator + C2_BLOCKSEPARATOR Block separator + C2_SEGMENTSEPARATOR Segment separator + C2_WHITESPACE White space + C2_OTHERNEUTRAL Other neutrals + C2_NOTAPPLICABLE No implicit direction (e.g. ctrl codes) + +Text precessing type information: + + C3_NONSPACING Nonspacing mark + C3_DIACRITIC Diacritic nonspacing mark + C3_VOWELMARK Vowel nonspacing mark + C3_SYMBOL Symbol + C3_KATAKANA Katakana character + C3_HIRAGANA Hiragana character + C3_HALFWIDTH Narrow character + C3_FULLWIDTH Wide character + C3_IDEOGRAPH Ideograph + C3_ALPHA Any letter + C3_NOTAPPLICABLE Not applicable + + +=item GetSystemDefaultLangID() + +Returns the system default language identifier. + +=item GetSystemDefaultLCID() + +Returns the system default locale identifier. + +=item GetUserDefaultLangID() + +Returns the user default language identifier. + +=item GetUserDefaultLCID() + +Returns the user default locale identifier. + +=item SendSettingChange() + +Sends a WM_SETTINGCHANGE message to all top level windows. + +=item SetLocaleInfo(LCID, LCTYPE, LCDATA) + +Changes an item in the user override part of the locale setting LCID. +It doesn't change the system default database. The following LCTYPEs are +changeable: + + LOCALE_ICALENDARTYPE LOCALE_SDATE + LOCALE_ICURRDIGITS LOCALE_SDECIMAL + LOCALE_ICURRENCY LOCALE_SGROUPING + LOCALE_IDIGITS LOCALE_SLIST + LOCALE_IFIRSTDAYOFWEEK LOCALE_SLONGDATE + LOCALE_IFIRSTWEEKOFYEAR LOCALE_SMONDECIMALSEP + LOCALE_ILZERO LOCALE_SMONGROUPING + LOCALE_IMEASURE LOCALE_SMONTHOUSANDSEP + LOCALE_INEGCURR LOCALE_SNEGATIVESIGN + LOCALE_INEGNUMBER LOCALE_SPOSITIVESIGN + LOCALE_IPAPERSIZE LOCALE_SSHORTDATE + LOCALE_ITIME LOCALE_STHOUSAND + LOCALE_S1159 LOCALE_STIME + LOCALE_S2359 LOCALE_STIMEFORMAT + LOCALE_SCURRENCY LOCALE_SYEARMONTH + +You have to call SendSettingChange() to activate these changes for +subsequent Win32::OLE::Variant object formatting because the OLE +subsystem seems to cache locale information. + +=item MAKELANGID(LANG,SUBLANG) + +Creates a language identifier from a primary language and a sublanguage. + +=item PRIMARYLANGID(LANGID) + +Retrieves the primary language from a language identifier. + +=item SUBLANGID(LANGID) + +Retrieves the sublanguage from a language identifier. + +=item MAKELCID(LANGID) + +Creates a locale identifies from a language identifier. + +=item LANGIDFROMLCID(LCID) + +Retrieves a language identifier from a locale identifier. + +=back + +=head2 Locale Types + +=over 8 + +=item LOCALE_ILANGUAGE + +The language identifier (in hex). + +=item LOCALE_SLANGUAGE + +The localized name of the language. + +=item LOCALE_SENGLANGUAGE + +The ISO Standard 639 English name of the language. + +=item LOCALE_SABBREVLANGNAME + +The three-letter abbreviated name of the language. The first two +letters are from the ISO Standard 639 language name abbreviation. The +third letter indicates the sublanguage type. + +=item LOCALE_SNATIVELANGNAME + +The native name of the language. + +=item LOCALE_ICOUNTRY + +The country code, which is based on international phone codes. + +=item LOCALE_SCOUNTRY + +The localized name of the country. + +=item LOCALE_SENGCOUNTRY + +The English name of the country. + +=item LOCALE_SABBREVCTRYNAME + +The ISO Standard 3166 abbreviated name of the country. + +=item LOCALE_SNATIVECTRYNAME + +The native name of the country. + +=item LOCALE_IDEFAULTLANGUAGE + +Language identifier for the principal language spoken in this +locale. + +=item LOCALE_IDEFAULTCOUNTRY + +Country code for the principal country in this locale. + +=item LOCALE_IDEFAULTANSICODEPAGE + +The ANSI code page associated with this locale. Format: 4 Unicode +decimal digits plus a Unicode null terminator. + +XXX This should be translated by GetLocaleInfo. XXX + +=item LOCALE_IDEFAULTCODEPAGE + +The OEM code page associated with the country. + +=item LOCALE_SLIST + +Characters used to separate list items (often a comma). + +=item LOCALE_IMEASURE + +Default measurement system: + + 0 metric system (S.I.) + 1 U.S. system + +=item LOCALE_SDECIMAL + +Characters used for the decimal separator (often a dot). + +=item LOCALE_STHOUSAND + +Characters used as the separator between groups of digits left of the decimal. + +=item LOCALE_SGROUPING + +Sizes for each group of digits to the left of the decimal. An explicit +size is required for each group. Sizes are separated by semicolons. If +the last value is 0, the preceding value is repeated. To group +thousands, specify 3;0. + +=item LOCALE_IDIGITS + +The number of fractional digits. + +=item LOCALE_ILZERO + +Whether to use leading zeros in decimal fields. A setting of 0 +means use no leading zeros; 1 means use leading zeros. + +=item LOCALE_SNATIVEDIGITS + +The ten characters that are the native equivalent of the ASCII 0-9. + +=item LOCALE_INEGNUMBER + +Negative number mode. + + 0 (1.1) + 1 -1.1 + 2 -1.1 + 3 1.1 + 4 1.1 + +=item LOCALE_SCURRENCY + +The string used as the local monetary symbol. + +=item LOCALE_SINTLSYMBOL + +Three characters of the International monetary symbol specified in ISO +4217, Codes for the Representation of Currencies and Funds, followed +by the character separating this string from the amount. + +=item LOCALE_SMONDECIMALSEP + +Characters used for the monetary decimal separators. + +=item LOCALE_SMONTHOUSANDSEP + +Characters used as monetary separator between groups of digits left of +the decimal. + +=item LOCALE_SMONGROUPING + +Sizes for each group of monetary digits to the left of the decimal. An +explicit size is needed for each group. Sizes are separated by +semicolons. If the last value is 0, the preceding value is +repeated. To group thousands, specify 3;0. + +=item LOCALE_ICURRDIGITS + +Number of fractional digits for the local monetary format. + +=item LOCALE_IINTLCURRDIGITS + +Number of fractional digits for the international monetary format. + +=item LOCALE_ICURRENCY + +Positive currency mode. + + 0 Prefix, no separation. + 1 Suffix, no separation. + 2 Prefix, 1-character separation. + 3 Suffix, 1-character separation. + +=item LOCALE_INEGCURR + +Negative currency mode. + + 0 ($1.1) + 1 -$1.1 + 2 $-1.1 + 3 $1.1- + 4 $(1.1$) + 5 -1.1$ + 6 1.1-$ + 7 1.1$- + 8 -1.1 $ (space before $) + 9 -$ 1.1 (space after $) + 10 1.1 $- (space before $) + +=item LOCALE_ICALENDARTYPE + +The type of calendar currently in use. + + 1 Gregorian (as in U.S.) + 2 Gregorian (always English strings) + 3 Era: Year of the Emperor (Japan) + 4 Era: Year of the Republic of China + 5 Tangun Era (Korea) + +=item LOCALE_IOPTIONALCALENDAR + +The additional calendar types available for this LCID. Can be a +null-separated list of all valid optional calendars. Value is +0 for "None available" or any of the LOCALE_ICALENDARTYPE settings. + +XXX null separated list should be translated by GetLocaleInfo XXX + +=item LOCALE_SDATE + +Characters used for the date separator. + +=item LOCALE_STIME + +Characters used for the time separator. + +=item LOCALE_STIMEFORMAT + +Time-formatting string. + +=item LOCALE_SSHORTDATE + +Short Date_Time formatting strings for this locale. + +=item LOCALE_SLONGDATE + +Long Date_Time formatting strings for this locale. + +=item LOCALE_IDATE + +Short Date format-ordering specifier. + + 0 Month - Day - Year + 1 Day - Month - Year + 2 Year - Month - Day + +=item LOCALE_ILDATE + +Long Date format ordering specifier. Value can be any of the valid +LOCALE_IDATE settings. + +=item LOCALE_ITIME + +Time format specifier. + + 0 AM/PM 12-hour format. + 1 24-hour format. + +=item LOCALE_ITIMEMARKPOSN + +Whether the time marker string (AM|PM) precedes or follows the time +string. + 0 Suffix (9:15 AM). + 1 Prefix (AM 9:15). + +=item LOCALE_ICENTURY + +Whether to use full 4-digit century. + + 0 Two digit. + 1 Full century. + +=item LOCALE_ITLZERO + +Whether to use leading zeros in time fields. + + 0 No leading zeros. + 1 Leading zeros for hours. + +=item LOCALE_IDAYLZERO + +Whether to use leading zeros in day fields. Values as for +LOCALE_ITLZERO. + +=item LOCALE_IMONLZERO + +Whether to use leading zeros in month fields. Values as for +LOCALE_ITLZERO. + +=item LOCALE_S1159 + +String for the AM designator. + +=item LOCALE_S2359 + +String for the PM designator. + +=item LOCALE_IFIRSTWEEKOFYEAR + +Specifies which week of the year is considered first. + + 0 Week containing 1/1 is the first week of the year. + 1 First full week following 1/1is the first week of the year. + 2 First week with at least 4 days is the first week of the year. + +=item LOCALE_IFIRSTDAYOFWEEK + +Specifies the day considered first in the week. Value "0" means +SDAYNAME1 and value "6" means SDAYNAME7. + +=item LOCALE_SDAYNAME1 .. LOCALE_SDAYNAME7 + +Long name for Monday .. Sunday. + +=item LOCALE_SABBREVDAYNAME1 .. LOCALE_SABBREVDAYNAME7 + +Abbreviated name for Monday .. Sunday. + +=item LOCALE_SMONTHNAME1 .. LOCALE_SMONTHNAME12 + +Long name for January .. December. + +=item LOCALE_SMONTHNAME13 + +Native name for 13th month, if it exists. + +=item LOCALE_SABBREVMONTHNAME1 .. LOCALE_SABBREVMONTHNAME12 + +Abbreviated name for January .. December. + +=item LOCALE_SABBREVMONTHNAME13 + +Native abbreviated name for 13th month, if it exists. + +=item LOCALE_SPOSITIVESIGN + +String value for the positive sign. + +=item LOCALE_SNEGATIVESIGN + +String value for the negative sign. + +=item LOCALE_IPOSSIGNPOSN + +Formatting index for positive values. + + 0 Parentheses surround the amount and the monetary symbol. + 1 The sign string precedes the amount and the monetary symbol. + 2 The sign string precedes the amount and the monetary symbol. + 3 The sign string precedes the amount and the monetary symbol. + 4 The sign string precedes the amount and the monetary symbol. + +=item LOCALE_INEGSIGNPOSN + +Formatting index for negative values. Values as for LOCALE_IPOSSIGNPOSN. + +=item LOCALE_IPOSSYMPRECEDES + +If the monetary symbol precedes, 1. If it succeeds a positive amount, 0. + +=item LOCALE_IPOSSEPBYSPACE + +If the monetary symbol is separated by a space from a positive amount, +1. Otherwise, 0. + +=item LOCALE_INEGSYMPRECEDES + +If the monetary symbol precedes, 1. If it succeeds a negative amount, 0. + +=item LOCALE_INEGSEPBYSPACE + +If the monetary symbol is separated by a space from a negative amount, +1. Otherwise, 0. + +=back + +=head1 AUTHORS/COPYRIGHT + +This module is part of the Win32::OLE distribution. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TPJ.pod b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TPJ.pod new file mode 100644 index 0000000000..e45770baa4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TPJ.pod @@ -0,0 +1,798 @@ +=pod + +=head1 NAME + +The Perl Journal #10 - Win32::OLE by Jan Dubois + +=head1 INTRODUCTION + +Suppose you're composing a document with Microsoft Word. You want to +include an Excel spreadsheet. You could save the spreadsheet in some +image format that Word can understand, and import it into your +document. But if the spreadsheet changes, your document will be out of +date. + +Microsoft's OLE (Object Linking and Embedding, pronounced "olay") lets +one program use objects from another. In the above scenario, the +spreadsheet is the object. As long as Excel makes that spreadsheet +available as an OLE object, and Word knows to treat it like one, your +document will always be current. + +You can control OLE objects from Perl with the Win32::OLE module, and +that's what this article is about. First, I'll show you how to "think +OLE," which mostly involves a lot of jargon. Next, I'll show you the +mechanics involved in using Win32::OLE. Then we'll go through a Perl +program that uses OLE to manipulate Microsoft Excel, Microsoft Access, +and Lotus Notes. Finally, I'll talk about Variants, an internal OLE +data type. + + +=head1 THE OLE MINDSET + +When an application makes an OLE object available for other +applications to use, that's called OLE I<automation>. The program +using the object is called the I<controller>, and the application +providing the object is called the I<server>. OLE automation is guided +by the OLE Component Object Model (COM) which specifies how those +objects must behave if they are to be used by other processes and +machines. + +There are two different types of OLE automation servers. I<In-process> +servers are implemented as dynamic link libraries (DLLs) and run in +the same process space as the controller. I<Out-of-process> servers +are more interesting; they are standalone executables that exist as +separate processes - possibly on a different computer. + +The Win32::OLE module lets your Perl program act as an OLE +controller. It allows Perl to be used in place of other languages like +Visual Basic or Java to control OLE objects. This makes all OLE +automation servers immediately available as Perl modules. + +Don't confuse ActiveState OLE with Win32::OLE. ActiveState OLE is +completely different, although future builds of ActiveState Perl (500 +and up) will work with Win32::OLE. + +Objects can expose OLE methods, properties, and events to the outside +world. Methods are functions that the controller can call to make the +object do something; properties describe the state of the object; and +events let the controller know about external events affecting the +object, such as the user clicking on a button. Since events involve +asynchronous communication with their objects, they require either +threads or an event loop. They are not yet supported by the Win32::OLE +module, and for the same reason ActiveX controls (OCXs) are currently +unsupported as well. + +=head1 WORKING WITH WIN32::OLE + +The Win32::OLE module doesn't let your Perl program create OLE +objects. What it does do is let your Perl program act like a remote +control for other applications-it lets your program be an OLE +controller. You can take an OLE object from another application +(Access, Notes, Excel, or anything else that speaks OLE) and invoke +its methods or manipulate its properties. + +=head2 THE FIRST STEP: CREATING AN OLE SERVER OBJECT + +First, we need to create a Perl object to represent the OLE +server. This is a weird idea; what it amounts to is that if we want to +control OLE objects produced by, say, Excel, we have to create a Perl +object that represents Excel. So even though our program is an OLE +controller, it'll contain objects that represent OLE servers. + +You can create a new OLE I<server object> with C<< Win32::OLE->new >>. +This takes a program ID (a human readable string like +C<'Speech.VoiceText'>) and returns a server object: + + my $server = Win32::OLE->new('Excel.Application', 'Quit'); + +Some server objects (particularly those for Microsoft Office +applications) don't automatically terminate when your program no +longer needs them. They need some kind of Quit method, and that's just +what our second argument is. It can be either a code reference or a +method name to be invoked when the object is destroyed. This lets you +ensure that objects will be properly cleaned up even when the Perl +program dies abnormally. + +To access a server object on a different computer, replace the first +argument with a reference to a list of the server name and program ID: + + my $server = Win32::OLE->new(['foo.bar.com', + 'Excel.Application']); + +(To get the requisite permissions, you'll need to configure your +security settings with F<DCOMCNFG.EXE>.) + +You can also directly attach your program to an already running OLE +server: + + my $server = Win32::OLE->GetActiveObject('Excel.Application'); + +This fails (returning C<undef>) if no server exists, or if the server +refuses the connection for some reason. It is also possible to use a +persistent object moniker (usually a filename) to start the associated +server and load the object into memory: + + my $doc = Win32::OLE->GetObject("MyDocument.Doc"); + +=head2 METHOD CALLS + +Once you've created one of these server objects, you need to call its +methods to make the OLE objects sing and dance. OLE methods are +invoked just like normal Perl object methods: + + $server->Foo(@Arguments); + +This is a Perl method call - but it also triggers an OLE method call +in the object. After your program executes this statement, the +C<$server> object will execute its Foo() method. The available methods +are typically documented in the application's I<object model>. + +B<Parameters.> By default, all parameters are positional +(e.g. C<foo($first, $second, $third)>) rather than named (e.g. +C<< foo(-name => "Yogi", -title => "Coach") >>). The required parameters +come first, followed by the optional parameters; if you need to +provide a dummy value for an optional parameter, use undef. + +Positional parameters get cumbersome if a method takes a lot of +them. You can use named arguments instead if you go to a little extra +trouble - when the last argument is a reference to a hash, the +key/value pairs of the hash are treated as named parameters: + + $server->Foo($Pos1, $Pos2, {Name1 => $Value1, + Name2 => $Value2}); + +B<Foreign Languages and Default Methods.> Sometimes OLE servers use +method and property names that are specific to a non-English +locale. That means they might have non-ASCII characters, which aren't +allowed in Perl variable names. In German, you might see C<Öffnen> used +instead of C<Open>. In these cases, you can use the Invoke() method: + + $server->Invoke('Öffnen', @Arguments); + +This is necessary because C<< $Server->Öffnen(@Arguments) >> is a syntax +error in current versions of Perl. + +=head2 PROPERTIES + +As I said earlier, objects can expose three things to the outside +world: methods, properties, and events. We've covered methods, and +Win32::OLE can't handle events. That leaves properties. But as it +turns out, properties and events are largely interchangeable. Most +methods have corresponding properties, and vice versa. + +An object's properties can be accessed with a hash reference: + + $server->{Bar} = $value; + $value = $server->{Bar}; + +This example sets and queries the value of the property named +C<Bar>. You could also have called the object's Bar() method to +achieve the same effect: + + $value = $server->Bar; + +However, you can't write the first line as C<< $server->Bar = $value >>, +because you can't assign to the return value of a method call. In +Visual Basic, OLE automation distinguishes between assigning the name +of an object and assigning its value: + + Set Object = OtherObject + + Let Value = Object + +The C<Set> statement shown here makes C<Object> refer to the same object as +C<OtherObject>. The C<Let> statement copies the value instead. (The value of +an OLE object is what you get when you call the object's default +method. + +In Perl, saying C<< $server1 = $server2 >> always creates another reference, +just like the C<Set> in Visual Basic. If you want to assign the value +instead, use the valof() function: + + my $value = valof $server; + +This is equivalent to + + my $value = $server->Invoke(''); + +=head2 SAMPLE APPLICATION + +Let's look at how all of this might be used. In Listing: 1 you'll see +F<T-Bond.pl>, a program that uses Win32::OLE for an almost-real world +application. + +The developer of this application, Mary Lynch, is a financial futures +broker. Every afternoon, she connects to the Chicago Board of Trade +(CBoT) web site at http://www.cbot.com and collects the time and sales +information for U.S. T-bond futures. She wants her program to create a +chart that depicts the data in 15-minute intervals, and then she wants +to record the data in a database for later analysis. Then she wants +her program to send mail to her clients. + +Mary's program will use Microsoft Access as a database, Microsoft +Excel to produce the chart, and Lotus Notes to send the mail. It will +all be controlled from a single Perl program using OLE automation. In +this section, we'll go through T-Bond. pl step by step so you can see +how Win32::OLE lets you control these applications. + +=head2 DOWNLOADING A WEB PAGE WITH LWP + +However, Mary first needs to amass the raw T-bond data by having her +Perl program automatically download and parse a web page. That's the +perfect job for LWP, the libwww-perl bundle available on the CPAN. LWP +has nothing to do with OLE. But this is a real-world application, and +it's just what Mary needs to download her data from the Chicago Board +of Trade. + + use LWP::Simple; + my $URL = 'http://www.cbot.com/mplex/quotes/tsfut'; + my $text = get("$URL/tsf$Contract.htm"); + +She could also have used the Win32::Internet module: + + use Win32::Internet; + my $URL = 'http://www.cbot.com/mplex/quotes/tsfut'; + my $text = $Win32::Internet->new->FetchURL("$URL/tsf$Contract.htm"); + +Mary wants to condense the ticker data into 15 minute bars. She's +interested only in lines that look like this: + + 03/12/1998 US 98Mar 12116 15:28:34 Open + +A regular expression can be used to determine whether a line looks +like this. If it does, the regex can split it up into individual +fields. The price quoted above, C<12116>, really means 121 16/32, and +needs to be converted to 121.5. The data is then condensed into 15 +minute intervals and only the first, last, highest, and lowest price +during each interval are kept. The time series is stored in the array +C<@Bars>. Each entry in C<@Bars> is a reference to a list of 5 elements: +Time, Open, High, Low, and Close. + + foreach (split "\n", $text) { + # 03/12/1998 US 98Mar 12116 15:28:34 Open + my ($Date,$Price,$Hour,$Min,$Sec,$Ind) = + m|^\s*(\d+/\d+/\d+) # " 03/12/1998" + \s+US\s+\S+\s+(\d+) # " US 98Mar 12116" + \s+(\d+):(\d+):(\d+) # " 12:42:40" + \s*(.*)$|x; # " Ask" + next unless defined $Date; + $Day = $Date; + + # Convert from fractional to decimal format + $Price = int($Price/100) + ($Price%100)/32; + + # Round up time to next multiple of 15 minutes + my $NewTime = int(($Sec+$Min*60+$Hour*3600)/900+1)*900; + unless (defined $Time && $NewTime == $Time) { + push @Bars, [$hhmm, $Open, $High, $Low, $Close] + if defined $Time; + $Open = $High = $Low = $Close = undef; + $Time = $NewTime; + my $Hour = int($Time/3600); + $hhmm = sprintf "%02d:%02d", $Hour, $Time/60-$Hour*60; + } + + # Update 15 minute bar values + $Close = $Price; + $Open = $Price unless defined $Open; + $High = $Price unless defined $High && $High > $Price; + $Low = $Price unless defined $Low && $Low > $Price; + } + + die "No data found" unless defined $Time; + push @Bars, [$hhmm, $Open, $High, $Low, $Close]; + +=head2 MICROSOFT ACCESS + +Now that Mary has her T-bond quotes, she's ready to use Win32::OLE to +store them into a Microsoft Access database. This has the advantage +that she can copy the database to her lap-top and work with it on her +long New York commute. She's able to create an Access database as +follows: + + use Win32::ODBC; + use Win32::OLE; + + # Include the constants for the Microsoft Access + # "Data Access Object". + + use Win32::OLE::Const 'Microsoft DAO'; + + my $DSN = 'T-Bonds'; + my $Driver = 'Microsoft Access Driver (*.mdb)'; + my $Desc = 'US T-Bond Quotes'; + my $Dir = 'i:\tmp\tpj'; + my $File = 'T-Bonds.mdb'; + my $Fullname = "$Dir\\$File"; + + # Remove old database and dataset name + unlink $Fullname if -f $Fullname; + Win32::ODBC::ConfigDSN(ODBC_REMOVE_DSN, $Driver, "DSN=$DSN") + if Win32::ODBC::DataSources($DSN); + + # Create new database + my $Access = Win32::OLE->new('Access.Application', 'Quit'); + my $Workspace = $Access->DBEngine->CreateWorkspace('', 'Admin', ''); + my $Database = $Workspace->CreateDatabase($Fullname, dbLangGeneral); + + # Add new database name + Win32::ODBC::ConfigDSN(ODBC_ADD_DSN, $Driver, + "DSN=$DSN", "Description=$Desc", "DBQ=$Fullname", + "DEFAULTDIR=$Dir", "UID=", "PWD="); + +This uses Win32::ODBC (described in TPJ #9) to remove and create +F<T-Bonds.mdb>. This lets Mary use the same script on her workstation +and on her laptop even when the database is stored in different +locations on each. The program also uses Win32::OLE to make Microsoft +Access create an empty database. + +Every OLE server has some constants that your Perl program will need +to use, made accessible by the Win32::OLE::Const module. For instance, +to grab the Excel constants, say C<use Win32::OLE::Const 'Microsoft +Excel'>. + +In the above example, we imported the Data Access Object con-stants +just so we could use C<dbLangGeneral>. + +=head2 MICROSOFT EXCEL + +Now Mary uses Win32::OLE a second time, to have Microsoft Excel create +the chart shown below. + + Figure 1: T-Bond data generated by MicroSoft Excel via Win32::OLE + + # Start Excel and create new workbook with a single sheet + use Win32::OLE qw(in valof with); + use Win32::OLE::Const 'Microsoft Excel'; + use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG); + + my $lgid = MAKELANGID(LANG_ENGLISH, SUBLANG_DEFAULT); + $Win32::OLE::LCID = MAKELCID($lgid); + + $Win32::OLE::Warn = 3; + +Here, Mary sets the locale to American English, which lets her do +things like use American date formats (e.g. C<"12-30-98"> rather than +C<"30-12-98">) in her program. It will continue to work even when she's +visiting one of her international customers and has to run this +program on their computers. + +The value of C<$Win32::OLE::Warn> determines what happens when an OLE +error occurs. If it's 0, the error is ignored. If it's 2, or if it's 1 +and the script is running under C<-w>, the Win32::OLE module invokes +C<Carp::carp()>. If C<$Win32::OLE::Warn> is set to 3, C<Carp::croak()> +is invoked and the program dies immediately. + +Now the data can be put into an Excel spreadsheet to produce the +chart. The following section of the program launches Excel and creates +a new workbook with a single worksheet. It puts the column titles +('Time', 'Open', 'High', 'Low', and 'Close') in a bold font on the +first row of the sheet. The first column displays the timestamp in +I<hh:mm> format; the next four display prices. + + my $Excel = Win32::OLE->new('Excel.Application', 'Quit'); + $Excel->{SheetsInNewWorkbook} = 1; + my $Book = $Excel->Workbooks->Add; + my $Sheet = $Book->Worksheets(1); + $Sheet->{Name} = 'Candle'; + + # Insert column titles + my $Range = $Sheet->Range("A1:E1"); + $Range->{Value} = [qw(Time Open High Low Close)]; + $Range->Font->{Bold} = 1; + + $Sheet->Columns("A:A")->{NumberFormat} = "h:mm"; + # Open/High/Low/Close to be displayed in 32nds + $Sheet->Columns("B:E")->{NumberFormat} = "# ?/32"; + + # Add 15 minute data to spreadsheet + print "Add data\n"; + $Range = $Sheet->Range(sprintf "A2:E%d", 2+$#Bars); + $Range->{Value} = \@Bars; + +The last statement shows how to pass arrays to OLE objects. The +Win32::OLE module automatically translates each array reference to a +C<SAFEARRAY>, the internal OLE array data type. This translation first +determines the maximum nesting level used by the Perl array, and then +creates a C<SAFEARRAY> of the same dimension. The C<@Bars> array +already contains the data in the correct form for the spreadsheet: + + ([Time1, Open1, High1, Low1, Close1], + ... + [TimeN, OpenN, HighN, LowN, CloseN]) + +Now the table in the spreadsheet can be used to create a candle stick +chart from our bars. Excel automatically chooses the time axis labels +if they are selected before the chart is created: + + # Create candle stick chart as new object on worksheet + $Sheet->Range("A:E")->Select; + + my $Chart = $Book->Charts->Add; + $Chart->{ChartType} = xlStockOHLC; + $Chart->Location(xlLocationAsObject, $Sheet->{Name}); + # Excel bug: the old $Chart is now invalid! + $Chart = $Excel->ActiveChart; + +We can change the type of the chart from a separate sheet to a chart +object on the spreadsheet page with the C<< $Chart->Location >> +method. (This invalidates the chart object handle, which might be +considered a bug in Excel.) Fortunately, this new chart is still the +'active' chart, so an object handle to it can be reclaimed simply by +asking Excel. + +At this point, our chart still needs a title, the legend is +meaningless, and the axis has decimals instead of fractions. We can +fix those with the following code: + + # Add title, remove legend + with($Chart, HasLegend => 0, HasTitle => 1); + $Chart->ChartTitle->Characters->{Text} = "US T-Bond"; + + # Set up daily statistics + $Open = $Bars[0][1]; + $High = $Sheet->Evaluate("MAX(C:C)"); + $Low = $Sheet->Evaluate("MIN(D:D)"); + $Close = $Bars[$#Bars][4]; + +The with() function partially mimics the Visual Basic With statement, +but allows only property assignments. It's a convenient shortcut for +this: + + { # open new scope + my $Axis = $Chart->Axes(xlValue); + $Axis->{HasMajorGridlines} = 1; + $Axis->{HasMinorGridlines} = 1; + # etc ... + } + +The C<$High> and C<$Low> for the day are needed to determine the +minimum and maximum scaling levels. MIN and MAX are spreadsheet +functions, and aren't automatically available as methods. However, +Excel provides an Evaluate() method to calculate arbitrary spreadsheet +functions, so we can use that. + +We want the chart to show major gridlines at every fourth tick and +minor gridlines at every second tick. The minimum and maximum are +chosen to be whatever multiples of 1/16 we need to do that. + + # Change tickmark spacing from decimal to fractional + with($Chart->Axes(xlValue), + HasMajorGridlines => 1, + HasMinorGridlines => 1, + MajorUnit => 1/8, + MinorUnit => 1/16, + MinimumScale => int($Low*16)/16, + MaximumScale => int($High*16+1)/16 + ); + + # Fat candles with only 5% gaps + $Chart->ChartGroups(1)->{GapWidth} = 5; + + sub RGB { $_[0] | ($_[1] >> 8) | ($_[2] >> 16) } + + # White background with a solid border + + $Chart->PlotArea->Border->{LineStyle} = xlContinuous; + $Chart->PlotArea->Border->{Color} = RGB(0,0,0); + $Chart->PlotArea->Interior->{Color} = RGB(255,255,255); + + # Add 1 hour moving average of the Close series + my $MovAvg = $Chart->SeriesCollection(4)->Trendlines + ->Add({Type => xlMovingAvg, Period => 4}); + $MovAvg->Border->{Color} = RGB(255,0,0); + +Now the finished workbook can be saved to disk as +F<i:\tmp\tpj\data.xls>. That file most likely still exists from when the +program ran yesterday, so we'll remove it. (Otherwise, Excel would pop +up a dialog with a warning, because the SaveAs() method doesn't like +to overwrite files.) + + + # Save workbook to file my $Filename = 'i:\tmp\tpj\data.xls'; + unlink $Filename if -f $Filename; + $Book->SaveAs($Filename); + $Book->Close; + +=head2 ACTIVEX DATA OBJECTS + +Mary stores the daily prices in her T-bonds database, keeping the data +for the different contracts in separate tables. After creating an ADO +(ActiveX Data Object) connection to the database, she tries to connect +a record set to the table for the current contract. If this fails, she +assumes that the table doesn't exists yet and tries to create it: + + use Win32::OLE::Const 'Microsoft ActiveX Data Objects'; + + my $Connection = Win32::OLE->new('ADODB.Connection'); + my $Recordset = Win32::OLE->new('ADODB.Recordset'); + $Connection->Open('T-Bonds'); + + # Open a record set for the table of this contract + { + local $Win32::OLE::Warn = 0; + $Recordset->Open($Contract, $Connection, adOpenKeyset, + adLockOptimistic, adCmdTable); + } + + # Create table and index if it doesn't exist yet + if (Win32::OLE->LastError) { + $Connection->Execute(<<"SQL"); + CREATE TABLE $Contract + ( + Day DATETIME, + Open DOUBLE, High DOUBLE, Low DOUBLE, Close DOUBLE + ) + SQL + $Connection->Execute(<<"SQL"); + CREATE INDEX $Contract + ON $Contract (Day) WITH PRIMARY + SQL + $Recordset->Open($Contract, $Connection, adOpenKeyset, + adLockOptimistic, adCmdTable); + } + +C<$Win32::OLE::Warn> is temporarily set to zero, so that if +C<$Recordset->Open> fails, the failure will be recorded silently without +terminating the program. C<Win32::OLE->LastError> shows whether the Open +failed or not. C<LastError> returns the OLE error code in a numeric +context and the OLE error message in a string context, just like +Perl's C<$!> variable. + +Now Mary can add today's data: + + # Add new record to table + use Win32::OLE::Variant; + $Win32::OLE::Variant::LCID = $Win32::OLE::LCID; + + my $Fields = [qw(Day Open High Low Close)]; + my $Values = [Variant(VT_DATE, $Day), + $Open, $High, $Low, $Close]; + +Mary uses the Win32::OLE::Variant module to store C<$Day> as a date +instead of a mere string. She wants to make sure that it's stored as +an American-style date, so in the third line shown here she sets the +locale ID of the Win32::OLE::Variant module to match the Win32::OLE +module. (C<$Win32::OLE::LCID> had been set earlier to English, since +that's what the Chicago Board of Trade uses.) + + { + local $Win32::OLE::Warn = 0; + $Recordset->AddNew($Fields, $Values); + } + + # Replace existing record + if (Win32::OLE->LastError) { + $Recordset->CancelUpdate; + $Recordset->Close; + $Recordset->Open(<<"SQL", $Connection, adOpenDynamic); + SELECT * FROM $Contract + WHERE Day = #$Day# + SQL + $Recordset->Update($Fields, $Values); + } + + $Recordset->Close; + $Connection->Close; + +The program expects to be able to add a new record to the table. It +fails if a record for this date already exists, because the Day field +is the primary index and therefore must be unique. If an error occurs, +the update operation started by AddNew() must first be cancelled with +C<< $Recordset->CancelUpdate >>; otherwise the record set won't close. + +=head2 LOTUS NOTES + +Now Mary can use Lotus Notes to mail updates to all her customers +interested in the T-bond data. (Lotus Notes doesn't provide its +constants in the OLE type library, so Mary had to determine them by +playing around with LotusScript.) The actual task is quite simple: A +Notes session must be started, the mail database must be opened and +the mail message must be created. The body of the message is created +as a rich text field, which lets her mix formatted text with object +attachments. + +In her program, Mary extracts the email addresses from her customer +database and sends separate message to each. Here, we've simplified it +somewhat. + + sub EMBED_ATTACHMENT {1454;} # from LotusScript + + my $Notes = Win32::OLE->new('Notes.NotesSession'); + my $Database = $Notes->GetDatabase('', ''); + $Database->OpenMail; + my $Document = $Database->CreateDocument; + + $Document->{Form} = 'Memo'; + $Document->{SendTo} = ['Jon Orwant >orwant@tpj.com>', + 'Jan Dubois >jan.dubois@ibm.net>']; + $Document->{Subject} = "US T-Bonds Chart for $Day"; + + my $Body = $Document->CreateRichtextItem('Body'); + $Body->AppendText(<<"EOT"); + I\'ve attached the latest US T-Bond data and chart for $Day. + The daily statistics were: + + \tOpen\t$Open + \tHigh\t$High + \tLow\t$Low + \tClose\t$Close + + Kind regards, + + Mary + EOT + + $Body->EmbedObject(EMBED_ATTACHMENT, '', $Filename); + + $Document->Send(0); + +=head1 VARIANTS + +In this final section, I'll talk about Variants, which are the data +types that you use to talk to OLE objects. We talked about this line +earlier: + + my $Values = [Variant(VT_DATE, $Day), + $Open, $High, $Low, $Close]; + +Here, the Variant() function creates a Variant object, of type C<VT_DATE> +and with the value C<$Day>. Variants are similar in many ways to Perl +scalars. Arguments to OLE methods are transparently converted from +their internal Perl representation to Variants and back again by the +Win32::OLE module. + +OLE automation uses a generic C<VARIANT> data type to pass +parameters. This data type contains type information in addition to +the actual data value. Only the following data types are valid for OLE +automation: + + B<Data Type Meaning> + VT_EMPTY Not specified + VT_NULL Null + VT_I2 2 byte signed integer + VT_I4 4 byte signed integer + VT_R4 4 byte real + VT_R8 8 byte real + VT_CY Currency + VT_DATE Date + VT_BSTR Unicode string + VT_DISPATCH OLE automation interface + VT_ERROR Error + VT_BOOL Boolean + VT_VARIANT (only valid with VT_BYREF) + VT_UNKNOWN Generic COM interface + VT_UI1 Unsigned character + +The following two flags can also be used: + + VT_ARRAY Array of values + VT_BYREF Pass by reference (instead of by value) + +B<The Perl to Variant transformation.> The following conversions are +performed automatically whenever a Perl value must be translated into +a Variant: + + Perl value Variant + Integer values VT_I4 + Real values VT_R8 + Strings VT_BSTR + undef VT_ERROR (DISP_E_PARAMNOTFOUND) + Array reference VT_VARIANT | VT_ARRAY + Win32::OLE object VT_DISPATCH + Win32::OLE::Variant object Type of the Variant object + +What if your Perl value is a list of lists? Those can be irregularly +shaped in Perl; that is, the subsidiary lists needn't have the same +number of elements. In this case, the structure will be converted to a +"rectangular" C<SAFEARRAY> of Variants, with unused slots set to +C<VT_EMPTY>. Consider this Perl 2-D array: + + [ ["Perl" ], # one element + [1, 3.1215, undef] # three elements + ] + +This will be translated to a 2 by 3 C<SAFEARRAY> that looks like this: + + VT_BSTR("Perl") VT_EMPTY VT_EMPTY + VT_I4(1) VT_R8(3.1415) VT_ERROR(DISP_E_PARAMNOTFOUND) + +B<The Variant To Perl Transformation.> Automatic conversion from Variants +to Perl values happens as follows: + + Variant Perl value + VT_BOOL, VT_ERROR Integer + VT_UI1, VT_I2, VT_I4 Integer + VT_R4, VT_R8 Float value + VT_BSTR String + VT_DISPATCH Win32::OLE object + +B<The Win32::OLE::Variant module.> This module provides access to the +Variant data type, which gives you more control over how these +arguments to OLE methods are encoded. (This is rarely necessary if you +have a good grasp of the default conversion rules.) A Variant object +can be created with the C<< Win32::OLE::Variant->new >> method or the +equivalent Variant() function: + + use Win32::OLE::Variant; + my $var1 = Win32::OLE::Variant->new(VT_DATE, 'Jan 1,1970'); + my $var2 = Variant(VT_BSTR, 'This is an Unicode string'); + +Several methods let you inspect and manipulate Variant objects: The +Type() and Value() methods return the variant type and value; the As() +method returns the value after converting it to a different variant +type; ChangeType() coerces the Variant into a different type; and +Unicode() returns the value of a Variant object as an object of the +Unicode::String class. + +These conversions are more interesting if they can be applied directly +to the return value of an OLE method call without first mutilating the +value with default conversions. This is possible with the following +trick: + + my $RetVal = Variant(VT_EMPTY, undef); + $Object->Dispatch($Method, $RetVal, @Arguments); + +Normally, you wouldn't call Dispatch() directly; it's executed +implicitly by either AUTOLOAD() or Invoke(). If Dispatch() realizes +that the return value is already a Win32::OLE::Variant object, the +return value is not translated into a Perl representation but rather +copied verbatim into the Variant object. + +Whenever a Win32::OLE::Variant object is used in a numeric or string +context it is automatically converted into the corresponding format. + + printf "Number: %f and String: %s\n", + $Var, $Var; + +This is equivalent to: + + printf "Number: %f and String: %s\n", + $Var->As(VT_R8), $Var->As(VT_BSTR); + +For methods that modify their arguments, you need to use the C<VT_BYREF> +flag. This lets you create number and string Variants that can be +modified by OLE methods. Here, Corel's GetSize() method takes two +integers and stores the C<x> and C<y> dimensions in them: + + my $x = Variant( VT_I4 | VT_BYREF, 0); + my $y = Variant( VT_I4 | VT_BYREF, 0); + $Corel->GetSize($x, $y); + +C<VT_BYREF> support for other Variant types might appear in future +releases of Win32::OLE. + +=head1 FURTHER INFORMATION + +=head2 DOCUMENTATION AND EXAMPLE CODE + +More information about the OLE modules can be found in the +documentation bundled with Win32::OLE. The distribution also contains +other code samples. + +The object model for Microsoft Office applications can be found in the +Visual Basic Reference for Microsoft Access, Excel, Word, or +PowerPoint. These help files are not installed by default, but they +can be added later by rerunning F<setup.exe> and choosing I<custom +setup>. The object model for Microsoft Outlook can be found on the +Microsoft Office Developer Forum at: +http://www.microsoft.com/OutlookDev/. + +Information about the LotusScript object model can be found at: +http://www.lotus.com/products/lotusscript.nsf. + +=head2 OLE AUTOMATION ON OTHER PLATFORMS + +Microsoft also makes OLE technology available for the Mac. DCOM is +already included in Windows NT 4.0 and can be downloaded for Windows +95. MVS and some Unix systems can use EntireX to get OLE +functionality; see +http://www.softwareag.com/corporat/solutions/entirex/entirex.htm. + +=head1 COPYRIGHT + +Copyright 1998 I<The Perl Journal>. http://www.tpj.com + +This article originally appeared in I<The Perl Journal> #10. It +appears courtesy of Jon Orwant and I<The Perl Journal>. This document +may be distributed under the same terms as Perl itself. diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TypeInfo.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TypeInfo.pm new file mode 100644 index 0000000000..d95399c1e2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TypeInfo.pm @@ -0,0 +1,389 @@ +# This module is still experimental and intentionally undocumented. +# If you don't know why it is here, then you should probably not use it. + +package Win32::OLE::TypeInfo; + +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK); +use vars qw(@VT %TYPEFLAGS @TYPEKIND %IMPLTYPEFLAGS %PARAMFLAGS + %FUNCFLAGS @CALLCONV @FUNCKIND %INVOKEKIND %VARFLAGS + %LIBFLAGS @SYSKIND); + +use Exporter; +@ISA = qw(Exporter); + +@EXPORT = qw( + VT_EMPTY VT_NULL VT_I2 VT_I4 VT_R4 VT_R8 VT_CY VT_DATE + VT_BSTR VT_DISPATCH VT_ERROR VT_BOOL VT_VARIANT VT_UNKNOWN + VT_DECIMAL VT_I1 VT_UI1 VT_UI2 VT_UI4 VT_I8 VT_UI8 VT_INT + VT_UINT VT_VOID VT_HRESULT VT_PTR VT_SAFEARRAY VT_CARRAY + VT_USERDEFINED VT_LPSTR VT_LPWSTR VT_FILETIME VT_BLOB + VT_STREAM VT_STORAGE VT_STREAMED_OBJECT VT_STORED_OBJECT + VT_BLOB_OBJECT VT_CF VT_CLSID VT_VECTOR VT_ARRAY VT_BYREF + VT_RESERVED VT_ILLEGAL VT_ILLEGALMASKED VT_TYPEMASK + + TYPEFLAG_FAPPOBJECT TYPEFLAG_FCANCREATE TYPEFLAG_FLICENSED + TYPEFLAG_FPREDECLID TYPEFLAG_FHIDDEN TYPEFLAG_FCONTROL + TYPEFLAG_FDUAL TYPEFLAG_FNONEXTENSIBLE TYPEFLAG_FOLEAUTOMATION + TYPEFLAG_FRESTRICTED TYPEFLAG_FAGGREGATABLE TYPEFLAG_FREPLACEABLE + TYPEFLAG_FDISPATCHABLE TYPEFLAG_FREVERSEBIND + + TKIND_ENUM TKIND_RECORD TKIND_MODULE TKIND_INTERFACE TKIND_DISPATCH + TKIND_COCLASS TKIND_ALIAS TKIND_UNION TKIND_MAX + + IMPLTYPEFLAG_FDEFAULT IMPLTYPEFLAG_FSOURCE IMPLTYPEFLAG_FRESTRICTED + IMPLTYPEFLAG_FDEFAULTVTABLE + + PARAMFLAG_NONE PARAMFLAG_FIN PARAMFLAG_FOUT PARAMFLAG_FLCID + PARAMFLAG_FRETVAL PARAMFLAG_FOPT PARAMFLAG_FHASDEFAULT + + FUNCFLAG_FRESTRICTED FUNCFLAG_FSOURCE FUNCFLAG_FBINDABLE + FUNCFLAG_FREQUESTEDIT FUNCFLAG_FDISPLAYBIND FUNCFLAG_FDEFAULTBIND + FUNCFLAG_FHIDDEN FUNCFLAG_FUSESGETLASTERROR FUNCFLAG_FDEFAULTCOLLELEM + FUNCFLAG_FUIDEFAULT FUNCFLAG_FNONBROWSABLE FUNCFLAG_FREPLACEABLE + FUNCFLAG_FIMMEDIATEBIND + + CC_FASTCALL CC_CDECL CC_MSCPASCAL CC_PASCAL CC_MACPASCAL CC_STDCALL + CC_FPFASTCALL CC_SYSCALL CC_MPWCDECL CC_MPWPASCAL CC_MAX + + INVOKE_FUNC INVOKE_PROPERTYGET INVOKE_PROPERTYPUT INVOKE_PROPERTYPUTREF + + VARFLAG_FREADONLY VARFLAG_FSOURCE VARFLAG_FBINDABLE VARFLAG_FREQUESTEDIT + VARFLAG_FDISPLAYBIND VARFLAG_FDEFAULTBIND VARFLAG_FHIDDEN VARFLAG_FRESTRICTED + VARFLAG_FDEFAULTCOLLELEM VARFLAG_FUIDEFAULT VARFLAG_FNONBROWSABLE + VARFLAG_FREPLACEABLE VARFLAG_FIMMEDIATEBIND + + LIBFLAG_FRESTRICTED LIBFLAG_FCONTROL LIBFLAG_FHIDDEN + SYS_WIN16 SYS_WIN32 SYS_MAC + + FUNC_VIRTUAL FUNC_PUREVIRTUAL FUNC_NONVIRTUAL FUNC_STATIC FUNC_DISPATCH + + @VT %TYPEFLAGS @TYPEKIND %IMPLTYPEFLAGS %PARAMFLAGS + %FUNCFLAGS @CALLCONV @FUNCKIND %INVOKEKIND %VARFLAGS %LIBFLAGS @SYSKIND +); + +# Lib Flags +# --------- + +sub LIBFLAG_FRESTRICTED () { 0x01; } +sub LIBFLAG_FCONTROL () { 0x02; } +sub LIBFLAG_FHIDDEN () { 0x04; } + +$LIBFLAGS{LIBFLAG_FRESTRICTED()} = LIBFLAG_FRESTRICTED; +$LIBFLAGS{LIBFLAG_FCONTROL()} = LIBFLAG_FCONTROL; +$LIBFLAGS{LIBFLAG_FHIDDEN()} = LIBFLAG_FHIDDEN; + +# Sys Kind +# -------- + +sub SYS_WIN16 () { 0; } +sub SYS_WIN32 () { SYS_WIN16() + 1; } +sub SYS_MAC () { SYS_WIN32() + 1; } + +$SYSKIND[SYS_WIN16] = 'SYS_WIN16'; +$SYSKIND[SYS_WIN32] = 'SYS_WIN32'; +$SYSKIND[SYS_MAC] = 'SYS_MAC'; + +# Type Flags +# ---------- + +sub TYPEFLAG_FAPPOBJECT () { 0x1; } +sub TYPEFLAG_FCANCREATE () { 0x2; } +sub TYPEFLAG_FLICENSED () { 0x4; } +sub TYPEFLAG_FPREDECLID () { 0x8; } +sub TYPEFLAG_FHIDDEN () { 0x10; } +sub TYPEFLAG_FCONTROL () { 0x20; } +sub TYPEFLAG_FDUAL () { 0x40; } +sub TYPEFLAG_FNONEXTENSIBLE () { 0x80; } +sub TYPEFLAG_FOLEAUTOMATION () { 0x100; } +sub TYPEFLAG_FRESTRICTED () { 0x200; } +sub TYPEFLAG_FAGGREGATABLE () { 0x400; } +sub TYPEFLAG_FREPLACEABLE () { 0x800; } +sub TYPEFLAG_FDISPATCHABLE () { 0x1000; } +sub TYPEFLAG_FREVERSEBIND () { 0x2000; } + +$TYPEFLAGS{TYPEFLAG_FAPPOBJECT()} = TYPEFLAG_FAPPOBJECT; +$TYPEFLAGS{TYPEFLAG_FCANCREATE()} = TYPEFLAG_FCANCREATE; +$TYPEFLAGS{TYPEFLAG_FLICENSED()} = TYPEFLAG_FLICENSED; +$TYPEFLAGS{TYPEFLAG_FPREDECLID()} = TYPEFLAG_FPREDECLID; +$TYPEFLAGS{TYPEFLAG_FHIDDEN()} = TYPEFLAG_FHIDDEN; +$TYPEFLAGS{TYPEFLAG_FCONTROL()} = TYPEFLAG_FCONTROL; +$TYPEFLAGS{TYPEFLAG_FDUAL()} = TYPEFLAG_FDUAL; +$TYPEFLAGS{TYPEFLAG_FNONEXTENSIBLE()} = TYPEFLAG_FNONEXTENSIBLE; +$TYPEFLAGS{TYPEFLAG_FOLEAUTOMATION()} = TYPEFLAG_FOLEAUTOMATION; +$TYPEFLAGS{TYPEFLAG_FRESTRICTED()} = TYPEFLAG_FRESTRICTED; +$TYPEFLAGS{TYPEFLAG_FAGGREGATABLE()} = TYPEFLAG_FAGGREGATABLE; +$TYPEFLAGS{TYPEFLAG_FREPLACEABLE()} = TYPEFLAG_FREPLACEABLE; +$TYPEFLAGS{TYPEFLAG_FDISPATCHABLE()} = TYPEFLAG_FDISPATCHABLE; +$TYPEFLAGS{TYPEFLAG_FREVERSEBIND()} = TYPEFLAG_FREVERSEBIND; + +# Type Kind +# --------- + +sub TKIND_ENUM () { 0; } +sub TKIND_RECORD () { TKIND_ENUM() + 1; } +sub TKIND_MODULE () { TKIND_RECORD() + 1; } +sub TKIND_INTERFACE () { TKIND_MODULE() + 1; } +sub TKIND_DISPATCH () { TKIND_INTERFACE() + 1; } +sub TKIND_COCLASS () { TKIND_DISPATCH() + 1; } +sub TKIND_ALIAS () { TKIND_COCLASS() + 1; } +sub TKIND_UNION () { TKIND_ALIAS() + 1; } +sub TKIND_MAX () { TKIND_UNION() + 1; } + +$TYPEKIND[TKIND_ENUM] = 'TKIND_ENUM'; +$TYPEKIND[TKIND_RECORD] = 'TKIND_RECORD'; +$TYPEKIND[TKIND_MODULE] = 'TKIND_MODULE'; +$TYPEKIND[TKIND_INTERFACE] = 'TKIND_INTERFACE'; +$TYPEKIND[TKIND_DISPATCH] = 'TKIND_DISPATCH'; +$TYPEKIND[TKIND_COCLASS] = 'TKIND_COCLASS'; +$TYPEKIND[TKIND_ALIAS] = 'TKIND_ALIAS'; +$TYPEKIND[TKIND_UNION] = 'TKIND_UNION'; + +# Implemented Type Flags +# ---------------------- + +sub IMPLTYPEFLAG_FDEFAULT () { 0x1; } +sub IMPLTYPEFLAG_FSOURCE () { 0x2; } +sub IMPLTYPEFLAG_FRESTRICTED () { 0x4; } +sub IMPLTYPEFLAG_FDEFAULTVTABLE () { 0x800; } + +$IMPLTYPEFLAGS{IMPLTYPEFLAG_FDEFAULT()} = IMPLTYPEFLAG_FDEFAULT; +$IMPLTYPEFLAGS{IMPLTYPEFLAG_FSOURCE()} = IMPLTYPEFLAG_FSOURCE; +$IMPLTYPEFLAGS{IMPLTYPEFLAG_FRESTRICTED()} = IMPLTYPEFLAG_FRESTRICTED; +$IMPLTYPEFLAGS{IMPLTYPEFLAG_FDEFAULTVTABLE()} = IMPLTYPEFLAG_FDEFAULTVTABLE; + +# Parameter Flags +# --------------- + +sub PARAMFLAG_NONE () { 0; } +sub PARAMFLAG_FIN () { 0x1; } +sub PARAMFLAG_FOUT () { 0x2; } +sub PARAMFLAG_FLCID () { 0x4; } +sub PARAMFLAG_FRETVAL () { 0x8; } +sub PARAMFLAG_FOPT () { 0x10; } +sub PARAMFLAG_FHASDEFAULT () { 0x20; } + +$PARAMFLAGS{PARAMFLAG_NONE()} = PARAMFLAG_NONE; +$PARAMFLAGS{PARAMFLAG_FIN()} = PARAMFLAG_FIN; +$PARAMFLAGS{PARAMFLAG_FOUT()} = PARAMFLAG_FOUT; +$PARAMFLAGS{PARAMFLAG_FLCID()} = PARAMFLAG_FLCID; +$PARAMFLAGS{PARAMFLAG_FRETVAL()} = PARAMFLAG_FRETVAL; +$PARAMFLAGS{PARAMFLAG_FOPT()} = PARAMFLAG_FOPT; +$PARAMFLAGS{PARAMFLAG_FHASDEFAULT()} = PARAMFLAG_FHASDEFAULT; + +# Function Flags +# -------------- + +sub FUNCFLAG_FRESTRICTED () { 0x1; } +sub FUNCFLAG_FSOURCE () { 0x2; } +sub FUNCFLAG_FBINDABLE () { 0x4; } +sub FUNCFLAG_FREQUESTEDIT () { 0x8; } +sub FUNCFLAG_FDISPLAYBIND () { 0x10; } +sub FUNCFLAG_FDEFAULTBIND () { 0x20; } +sub FUNCFLAG_FHIDDEN () { 0x40; } +sub FUNCFLAG_FUSESGETLASTERROR () { 0x80; } +sub FUNCFLAG_FDEFAULTCOLLELEM () { 0x100; } +sub FUNCFLAG_FUIDEFAULT () { 0x200; } +sub FUNCFLAG_FNONBROWSABLE () { 0x400; } +sub FUNCFLAG_FREPLACEABLE () { 0x800; } +sub FUNCFLAG_FIMMEDIATEBIND () { 0x1000; } + +$FUNCFLAGS{FUNCFLAG_FRESTRICTED()} = FUNCFLAG_FRESTRICTED; +$FUNCFLAGS{FUNCFLAG_FSOURCE()} = FUNCFLAG_FSOURCE; +$FUNCFLAGS{FUNCFLAG_FBINDABLE()} = FUNCFLAG_FBINDABLE; +$FUNCFLAGS{FUNCFLAG_FREQUESTEDIT()} = FUNCFLAG_FREQUESTEDIT; +$FUNCFLAGS{FUNCFLAG_FDISPLAYBIND()} = FUNCFLAG_FDISPLAYBIND; +$FUNCFLAGS{FUNCFLAG_FDEFAULTBIND()} = FUNCFLAG_FDEFAULTBIND; +$FUNCFLAGS{FUNCFLAG_FHIDDEN()} = FUNCFLAG_FHIDDEN; +$FUNCFLAGS{FUNCFLAG_FUSESGETLASTERROR()} = FUNCFLAG_FUSESGETLASTERROR; +$FUNCFLAGS{FUNCFLAG_FDEFAULTCOLLELEM()} = FUNCFLAG_FDEFAULTCOLLELEM; +$FUNCFLAGS{FUNCFLAG_FUIDEFAULT()} = FUNCFLAG_FUIDEFAULT; +$FUNCFLAGS{FUNCFLAG_FNONBROWSABLE()} = FUNCFLAG_FNONBROWSABLE; +$FUNCFLAGS{FUNCFLAG_FREPLACEABLE()} = FUNCFLAG_FREPLACEABLE; +$FUNCFLAGS{FUNCFLAG_FIMMEDIATEBIND()} = FUNCFLAG_FIMMEDIATEBIND; + +# Calling conventions +# ------------------- + +sub CC_FASTCALL () { 0; } +sub CC_CDECL () { 1; } +sub CC_MSCPASCAL () { CC_CDECL() + 1; } +sub CC_PASCAL () { CC_MSCPASCAL; } +sub CC_MACPASCAL () { CC_PASCAL() + 1; } +sub CC_STDCALL () { CC_MACPASCAL() + 1; } +sub CC_FPFASTCALL () { CC_STDCALL() + 1; } +sub CC_SYSCALL () { CC_FPFASTCALL() + 1; } +sub CC_MPWCDECL () { CC_SYSCALL() + 1; } +sub CC_MPWPASCAL () { CC_MPWCDECL() + 1; } +sub CC_MAX () { CC_MPWPASCAL() + 1; } + +$CALLCONV[CC_FASTCALL] = 'CC_FASTCALL'; +$CALLCONV[CC_CDECL] = 'CC_CDECL'; +$CALLCONV[CC_PASCAL] = 'CC_PASCAL'; +$CALLCONV[CC_MACPASCAL] = 'CC_MACPASCAL'; +$CALLCONV[CC_STDCALL] = 'CC_STDCALL'; +$CALLCONV[CC_FPFASTCALL] = 'CC_FPFASTCALL'; +$CALLCONV[CC_SYSCALL] = 'CC_SYSCALL'; +$CALLCONV[CC_MPWCDECL] = 'CC_MPWCDECL'; +$CALLCONV[CC_MPWPASCAL] = 'CC_MPWPASCAL'; + +# Function Kind +# ------------- + +sub FUNC_VIRTUAL () { 0; } +sub FUNC_PUREVIRTUAL () { FUNC_VIRTUAL() + 1; } +sub FUNC_NONVIRTUAL () { FUNC_PUREVIRTUAL() + 1; } +sub FUNC_STATIC () { FUNC_NONVIRTUAL() + 1; } +sub FUNC_DISPATCH () { FUNC_STATIC() + 1; } + +$FUNCKIND[FUNC_VIRTUAL] = 'FUNC_VIRTUAL'; +$FUNCKIND[FUNC_PUREVIRTUAL] = 'FUNC_PUREVIRTUAL'; +$FUNCKIND[FUNC_NONVIRTUAL] = 'FUNC_NONVIRTUAL'; +$FUNCKIND[FUNC_STATIC] = 'FUNC_STATIC'; +$FUNCKIND[FUNC_DISPATCH] = 'FUNC_DISPATCH'; + +# Invoke Kind +# ----------- + +sub INVOKE_FUNC () { 1; } +sub INVOKE_PROPERTYGET () { 2; } +sub INVOKE_PROPERTYPUT () { 4; } +sub INVOKE_PROPERTYPUTREF () { 8; } + +$INVOKEKIND{INVOKE_FUNC()} = INVOKE_FUNC; +$INVOKEKIND{INVOKE_PROPERTYGET()} = INVOKE_PROPERTYGET; +$INVOKEKIND{INVOKE_PROPERTYPUT()} = INVOKE_PROPERTYPUT; +$INVOKEKIND{INVOKE_PROPERTYPUTREF()} = INVOKE_PROPERTYPUTREF; + +# Variable Flags +# -------------- + +sub VARFLAG_FREADONLY () { 0x1; } +sub VARFLAG_FSOURCE () { 0x2; } +sub VARFLAG_FBINDABLE () { 0x4; } +sub VARFLAG_FREQUESTEDIT () { 0x8; } +sub VARFLAG_FDISPLAYBIND () { 0x10; } +sub VARFLAG_FDEFAULTBIND () { 0x20; } +sub VARFLAG_FHIDDEN () { 0x40; } +sub VARFLAG_FRESTRICTED () { 0x80; } +sub VARFLAG_FDEFAULTCOLLELEM () { 0x100; } +sub VARFLAG_FUIDEFAULT () { 0x200; } +sub VARFLAG_FNONBROWSABLE () { 0x400; } +sub VARFLAG_FREPLACEABLE () { 0x800; } +sub VARFLAG_FIMMEDIATEBIND () { 0x1000; } + +$VARFLAGS{VARFLAG_FREADONLY()} = VARFLAG_FREADONLY; +$VARFLAGS{VARFLAG_FSOURCE()} = VARFLAG_FSOURCE; +$VARFLAGS{VARFLAG_FBINDABLE()} = VARFLAG_FBINDABLE; +$VARFLAGS{VARFLAG_FREQUESTEDIT()} = VARFLAG_FREQUESTEDIT; +$VARFLAGS{VARFLAG_FDISPLAYBIND()} = VARFLAG_FDISPLAYBIND; +$VARFLAGS{VARFLAG_FDEFAULTBIND()} = VARFLAG_FDEFAULTBIND; +$VARFLAGS{VARFLAG_FHIDDEN()} = VARFLAG_FHIDDEN; +$VARFLAGS{VARFLAG_FRESTRICTED()} = VARFLAG_FRESTRICTED; +$VARFLAGS{VARFLAG_FDEFAULTCOLLELEM()} = VARFLAG_FDEFAULTCOLLELEM; +$VARFLAGS{VARFLAG_FUIDEFAULT()} = VARFLAG_FUIDEFAULT; +$VARFLAGS{VARFLAG_FNONBROWSABLE()} = VARFLAG_FNONBROWSABLE; +$VARFLAGS{VARFLAG_FREPLACEABLE()} = VARFLAG_FREPLACEABLE; +$VARFLAGS{VARFLAG_FIMMEDIATEBIND()} = VARFLAG_FIMMEDIATEBIND; + + +# Variant Types +# ------------- + +sub VT_EMPTY () { 0; } +sub VT_NULL () { 1; } +sub VT_I2 () { 2; } +sub VT_I4 () { 3; } +sub VT_R4 () { 4; } +sub VT_R8 () { 5; } +sub VT_CY () { 6; } +sub VT_DATE () { 7; } +sub VT_BSTR () { 8; } +sub VT_DISPATCH () { 9; } +sub VT_ERROR () { 10; } +sub VT_BOOL () { 11; } +sub VT_VARIANT () { 12; } +sub VT_UNKNOWN () { 13; } +sub VT_DECIMAL () { 14; } +sub VT_I1 () { 16; } +sub VT_UI1 () { 17; } +sub VT_UI2 () { 18; } +sub VT_UI4 () { 19; } +sub VT_I8 () { 20; } +sub VT_UI8 () { 21; } +sub VT_INT () { 22; } +sub VT_UINT () { 23; } +sub VT_VOID () { 24; } +sub VT_HRESULT () { 25; } +sub VT_PTR () { 26; } +sub VT_SAFEARRAY () { 27; } +sub VT_CARRAY () { 28; } +sub VT_USERDEFINED () { 29; } +sub VT_LPSTR () { 30; } +sub VT_LPWSTR () { 31; } +sub VT_FILETIME () { 64; } +sub VT_BLOB () { 65; } +sub VT_STREAM () { 66; } +sub VT_STORAGE () { 67; } +sub VT_STREAMED_OBJECT () { 68; } +sub VT_STORED_OBJECT () { 69; } +sub VT_BLOB_OBJECT () { 70; } +sub VT_CF () { 71; } +sub VT_CLSID () { 72; } +sub VT_VECTOR () { 0x1000; } +sub VT_ARRAY () { 0x2000; } +sub VT_BYREF () { 0x4000; } +sub VT_RESERVED () { 0x8000; } +sub VT_ILLEGAL () { 0xffff; } +sub VT_ILLEGALMASKED () { 0xfff; } +sub VT_TYPEMASK () { 0xfff; } + +$VT[VT_EMPTY] = 'VT_EMPTY'; +$VT[VT_NULL] = 'VT_NULL'; +$VT[VT_I2] = 'VT_I2'; +$VT[VT_I4] = 'VT_I4'; +$VT[VT_R4] = 'VT_R4'; +$VT[VT_R8] = 'VT_R8'; +$VT[VT_CY] = 'VT_CY'; +$VT[VT_DATE] = 'VT_DATE'; +$VT[VT_BSTR] = 'VT_BSTR'; +$VT[VT_DISPATCH] = 'VT_DISPATCH'; +$VT[VT_ERROR] = 'VT_ERROR'; +$VT[VT_BOOL] = 'VT_BOOL'; +$VT[VT_VARIANT] = 'VT_VARIANT'; +$VT[VT_UNKNOWN] = 'VT_UNKNOWN'; +$VT[VT_DECIMAL] = 'VT_DECIMAL'; +$VT[VT_I1] = 'VT_I1'; +$VT[VT_UI1] = 'VT_UI1'; +$VT[VT_UI2] = 'VT_UI2'; +$VT[VT_UI4] = 'VT_UI4'; +$VT[VT_I8] = 'VT_I8'; +$VT[VT_UI8] = 'VT_UI8'; +$VT[VT_INT] = 'VT_INT'; +$VT[VT_UINT] = 'VT_UINT'; +$VT[VT_VOID] = 'VT_VOID'; +$VT[VT_HRESULT] = 'VT_HRESULT'; +$VT[VT_PTR] = 'VT_PTR'; +$VT[VT_SAFEARRAY] = 'VT_SAFEARRAY'; +$VT[VT_CARRAY] = 'VT_CARRAY'; +$VT[VT_USERDEFINED] = 'VT_USERDEFINED'; +$VT[VT_LPSTR] = 'VT_LPSTR'; +$VT[VT_LPWSTR] = 'VT_LPWSTR'; +$VT[VT_FILETIME] = 'VT_FILETIME'; +$VT[VT_BLOB] = 'VT_BLOB'; +$VT[VT_STREAM] = 'VT_STREAM'; +$VT[VT_STORAGE] = 'VT_STORAGE'; +$VT[VT_STREAMED_OBJECT] = 'VT_STREAMED_OBJECT'; +$VT[VT_STORED_OBJECT] = 'VT_STORED_OBJECT'; +$VT[VT_BLOB_OBJECT] = 'VT_BLOB_OBJECT'; +$VT[VT_CF] = 'VT_CF'; +$VT[VT_CLSID] = 'VT_CLSID'; +$VT[VT_VECTOR] = 'VT_VECTOR'; +$VT[VT_ARRAY] = 'VT_ARRAY'; +$VT[VT_BYREF] = 'VT_BYREF'; +$VT[VT_RESERVED] = 'VT_RESERVED'; +$VT[VT_ILLEGAL] = 'VT_ILLEGAL'; +$VT[VT_ILLEGALMASKED] = 'VT_ILLEGALMASKED'; +$VT[VT_TYPEMASK] = 'VT_TYPEMASK'; + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Variant.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Variant.pm new file mode 100644 index 0000000000..38fc604820 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Variant.pm @@ -0,0 +1,577 @@ +# The documentation is at the __END__ + +package Win32::OLE::Variant; +require Win32::OLE; # Make sure the XS bootstrap has been called + +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK); + +use Exporter; +@ISA = qw(Exporter); + +@EXPORT = qw( + Variant + VT_EMPTY VT_NULL VT_I2 VT_I4 VT_R4 VT_R8 VT_CY VT_DATE VT_BSTR + VT_DISPATCH VT_ERROR VT_BOOL VT_VARIANT VT_UNKNOWN VT_DECIMAL VT_UI1 + VT_ARRAY VT_BYREF + ); + +@EXPORT_OK = qw(CP_ACP CP_OEMCP nothing nullstring); + +# Automation data types. +sub VT_EMPTY {0;} +sub VT_NULL {1;} +sub VT_I2 {2;} +sub VT_I4 {3;} +sub VT_R4 {4;} +sub VT_R8 {5;} +sub VT_CY {6;} +sub VT_DATE {7;} +sub VT_BSTR {8;} +sub VT_DISPATCH {9;} +sub VT_ERROR {10;} +sub VT_BOOL {11;} +sub VT_VARIANT {12;} +sub VT_UNKNOWN {13;} +sub VT_DECIMAL {14;} # Officially not allowed in VARIANTARGs +sub VT_UI1 {17;} + +sub VT_ARRAY {0x2000;} +sub VT_BYREF {0x4000;} + + +# For backward compatibility +sub CP_ACP {0;} # ANSI codepage +sub CP_OEMCP {1;} # OEM codepage + +use overload + # '+' => 'Add', '-' => 'Sub', '*' => 'Mul', '/' => 'Div', + '""' => sub {$_[0]->As(VT_BSTR)}, + '0+' => sub {$_[0]->As(VT_R8)}, + fallback => 1; + +sub Variant { + return Win32::OLE::Variant->new(@_); +} + +sub nothing { + return Win32::OLE::Variant->new(VT_DISPATCH); +} + +sub nullstring { + return Win32::OLE::Variant->new(VT_BSTR); +} + +1; + +__END__ + +=head1 NAME + +Win32::OLE::Variant - Create and modify OLE VARIANT variables + +=head1 SYNOPSIS + + use Win32::OLE::Variant; + my $var = Variant(VT_DATE, 'Jan 1,1970'); + $OleObject->{value} = $var; + $OleObject->Method($var); + + +=head1 DESCRIPTION + +The IDispatch interface used by the Perl OLE module uses a universal +argument type called VARIANT. This is basically an object containing +a data type and the actual data value. The data type is specified by +the VT_xxx constants. + +=head2 Functions + +=over 8 + +=item nothing() + +The nothing() function returns an empty VT_DISPATCH variant. It can be +used to clear an object reference stored in a property + + use Win32::OLE::Variant qw(:DEFAULT nothing); + # ... + $object->{Property} = nothing; + +This has the same effect as the Visual Basic statement + + Set object.Property = Nothing + +The nothing() function is B<not> exported by default. + +=item nullstring() + +The nullstring() function returns a VT_BSTR variant with a NULL string +pointer. This is B<not> the same as a VT_BSTR variant with an empty +string "". The nullstring() value is the same as the vbNullString +constant in Visual Basic. + +The nullstring() function is B<not> exported by default. + +=item Variant(TYPE, DATA) + +This is just a function alias of the C<Win32::OLE::Variant->new()> +method (see below). This function is exported by default. + +=back + +=head2 Methods + +=over 8 + +=item new(TYPE, DATA) + +This method returns a Win32::OLE::Variant object of the specified +TYPE that contains the given DATA. The Win32::OLE::Variant object +can be used to specify data types other than IV, NV or PV (which are +supported transparently). See L<Variants> below for details. + +For VT_EMPTY and VT_NULL variants, the DATA argument may be omitted. +For all non-VT_ARRAY variants DATA specifies the initial value. + +To create a SAFEARRAY variant, you have to specify the VT_ARRAY flag in +addition to the variant base type of the array elements. In this cases +DATA must be a list specifying the dimensions of the array. Each element +can be either an element count (indices 0 to count-1) or an array +reference pointing to the lower and upper array bounds of this dimension: + + my $Array = Win32::OLE::Variant->new(VT_ARRAY|VT_R8, [1,2], 2); + +This creates a 2-dimensional SAFEARRAY of doubles with 4 elements: +(1,0), (1,1), (2,0) and (2,1). + +A special case is the creation of one-dimensional VT_UI1 arrays with +a string DATA argument: + + my $String = Variant(VT_ARRAY|VT_UI1, "String"); + +This creates a 6 element character array initialized to "String". For +backward compatibility VT_UI1 with a string initializer automatically +implies VT_ARRAY. The next line is equivalent to the previous example: + + my $String = Variant(VT_UI1, "String"); + +If you really need a single character VT_UI1 variant, you have to create +it using a numeric intializer: + + my $Char = Variant(VT_UI1, ord('A')); + +=item As(TYPE) + +C<As> converts the VARIANT to the new type before converting to a +Perl value. This take the current LCID setting into account. For +example a string might contain a ',' as the decimal point character. +Using C<$variant->As(VT_R8)> will correctly return the floating +point value. + +The underlying variant object is NOT changed by this method. + +=item ChangeType(TYPE) + +This method changes the type of the contained VARIANT in place. It +returns the object itself, not the converted value. + +=item Copy([DIM]) + +This method creates a copy of the object. If the original variant had +the VT_BYREF bit set then the new object will contain a copy of the +referenced data and not a reference to the same old data. The new +object will not have the VT_BYREF bit set. + + my $Var = Variant(VT_I4|VT_ARRAY|VT_BYREF, [1,5], 3); + my $Copy = $Var->Copy; + +The type of C<$Copy> is now VT_I4|VT_ARRAY and the value is a copy of +the other SAFEARRAY. Changes to elements of C<$Var> will not be reflected +in C<$Copy> and vice versa. + +The C<Copy> method can also be used to extract a single element of a +VT_ARRAY | VT_VARIANT object. In this case the array indices must be +specified as a list DIM: + + my $Int = $Var->Copy(1, 2); + +C<$Int> is now a VT_I4 Variant object containing the value of element (1,2). + +=item Currency([FORMAT[, LCID]]) + +This method converts the VARIANT value into a formatted currency string. The +FORMAT can be either an integer constant or a hash reference. Valid constants +are 0 and LOCALE_NOUSEROVERRIDE. You get the value of LOCALE_NOUSEROVERRIDE +from the Win32::OLE::NLS module: + + use Win32::OLE::NLS qw(:LOCALE); + +LOCALE_NOUSEROVERRIDE tells the method to use the system default currency +format for the specified locale, disregarding any changes that might have +been made through the control panel application. + +The hash reference could contain the following keys: + + NumDigits number of fractional digits + LeadingZero whether to use leading zeroes in decimal fields + Grouping size of each group of digits to the left of the decimal + DecimalSep decimal separator string + ThousandSep thousand separator string + NegativeOrder see L<Win32::OLE::NLS/LOCALE_ICURRENCY> + PositiveOrder see L<Win32::OLE::NLS/LOCALE_INEGCURR> + CurrencySymbol currency symbol string + +For example: + + use Win32::OLE::Variant; + use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG :DATE :TIME); + my $lcidGerman = MAKELCID(MAKELANGID(LANG_GERMAN, SUBLANG_NEUTRAL)); + my $v = Variant(VT_CY, "-922337203685477.5808"); + print $v->Currency({CurrencySymbol => "Tuits"}, $lcidGerman), "\n"; + +will print: + + -922.337.203.685.477,58 Tuits + +=item Date([FORMAT[, LCID]]) + +Converts the VARIANT into a formatted date string. FORMAT can be either +one of the following integer constants or a format string: + + LOCALE_NOUSEROVERRIDE system default date format for this locale + DATE_SHORTDATE use the short date format (default) + DATE_LONGDATE use the long date format + DATE_YEARMONTH use the year/month format + DATE_USE_ALT_CALENDAR use the alternate calendar, if one exists + DATE_LTRREADING left-to-right reading order layout + DATE_RTLREADING right-to left reading order layout + +The constants are available from the Win32::OLE::NLS module: + + use Win32::OLE::NLS qw(:LOCALE :DATE); + +The following elements can be used to construct a date format string. +Characters must be specified exactly as given below (e.g. "dd" B<not> "DD"). +Spaces can be inserted anywhere between formatting codes, other verbatim +text should be included in single quotes. + + d day of month + dd day of month with leading zero for single-digit days + ddd day of week: three-letter abbreviation (LOCALE_SABBREVDAYNAME) + dddd day of week: full name (LOCALE_SDAYNAME) + M month + MM month with leading zero for single-digit months + MMM month: three-letter abbreviation (LOCALE_SABBREVMONTHNAME) + MMMM month: full name (LOCALE_SMONTHNAME) + y year as last two digits + yy year as last two digits with leading zero for years less than 10 + yyyy year represented by full four digits + gg period/era string + +For example: + + my $v = Variant(VT_DATE, "April 1 99"); + print $v->Date(DATE_LONGDATE), "\n"; + print $v->Date("ddd',' MMM dd yy"), "\n"; + +will print: + + Thursday, April 01, 1999 + Thu, Apr 01 99 + +=item Dim() + +Returns a list of array bounds for a VT_ARRAY variant. The list contains +an array reference for each dimension of the variant's SAFEARRAY. This +reference points to an array containing the lower and upper bounds for +this dimension. For example: + + my @Dim = $Var->Dim; + +Now C<@Dim> contains the following list: C<([1,5], [0,2])>. + +=item Get(DIM) + +For normal variants C<Get> returns the value of the variant, just like the +C<Value> method. For VT_ARRAY variants C<Get> retrieves the value of a single +array element. In this case C<DIM> must be a list of array indices. E.g. + + my $Val = $Var->Get(2,0); + +As a special case for one dimensional VT_UI1|VT_ARRAY variants the C<Get> +method without arguments returns the character array as a Perl string. + + print $String->Get, "\n"; + +=item IsNothing() + +Tests if the object is an empty VT_DISPATCH variant. See also nothing(). + +=item IsNullString() + +Tests if the object is an empty VT_BSTR variant. See also nullstring(). + +=item LastError() + +The use of the C<Win32::OLE::Variant->LastError()> method is deprecated. +Please use the C<Win32::OLE->LastError()> class method instead. + +=item Number([FORMAT[, LCID]]) + +This method converts the VARIANT value into a formatted number string. The +FORMAT can be either an integer constant or a hash reference. Valid constants +are 0 and LOCALE_NOUSEROVERRIDE. You get the value of LOCALE_NOUSEROVERRIDE +from the Win32::OLE::NLS module: + + use Win32::OLE::NLS qw(:LOCALE); + +LOCALE_NOUSEROVERRIDE tells the method to use the system default number +format for the specified locale, disregarding any changes that might have +been made through the control panel application. + +The hash reference could contain the following keys: + + NumDigits number of fractional digits + LeadingZero whether to use leading zeroes in decimal fields + Grouping size of each group of digits to the left of the decimal + DecimalSep decimal separator string + ThousandSep thousand separator string + NegativeOrder see L<Win32::OLE::NLS/LOCALE_INEGNUMBER> + +=item Put(DIM, VALUE) + +The C<Put> method is used to assign a new value to a variant. The value will +be coerced into the current type of the variant. E.g.: + + my $Var = Variant(VT_I4, 42); + $Var->Put(3.1415); + +This changes the value of the variant to C<3> because the type is VT_I4. + +For VT_ARRAY type variants the indices for each dimension of the contained +SAFEARRAY must be specified in front of the new value: + + $Array->Put(1, 1, 2.7); + +It is also possible to assign values to *every* element of the SAFEARRAY at +once using a single Put() method call: + + $Array->Put([[1,2], [3,4]]); + +In this case the argument to Put() must be an array reference and the +dimensions of the Perl list-of-lists must match the dimensions of the +SAFEARRAY exactly. + +The are a few special cases for one-dimensional VT_UI1 arrays: The VALUE +can be specified as a string instead of a number. This will set the selected +character to the first character of the string or to '\0' if the string was +empty: + + my $String = Variant(VT_UI1|VT_ARRAY, "ABCDE"); + $String->Put(1, "123"); + $String->Put(3, ord('Z')); + $String->Put(4, ''); + +This will set the value of C<$String> to C<"A1CZ\0">. If the index is omitted +then the string is copied to the value completely. The string is truncated +if it is longer than the size of the VT_UI1 array. The result will be padded +with '\0's if the string is shorter: + + $String->Put("String"); + +Now C<$String> contains the value "Strin". + +C<Put> returns the Variant object itself so that multiple C<Put> calls can be +chained together: + + $Array->Put(0,0,$First_value)->Put(0,1,$Another_value); + +=item Time([FORMAT[, LCID]]) + +Converts the VARIANT into a formatted time string. FORMAT can be either +one of the following integer constants or a format string: + + LOCALE_NOUSEROVERRIDE system default time format for this locale + TIME_NOMINUTESORSECONDS don't use minutes or seconds + TIME_NOSECONDS don't use seconds + TIME_NOTIMEMARKER don't use a time marker + TIME_FORCE24HOURFORMAT always use a 24-hour time format + +The constants are available from the Win32::OLE::NLS module: + + use Win32::OLE::NLS qw(:LOCALE :TIME); + +The following elements can be used to construct a time format string. +Characters must be specified exactly as given below (e.g. "dd" B<not> "DD"). +Spaces can be inserted anywhere between formatting codes, other verbatim +text should be included in single quotes. + + h hours; 12-hour clock + hh hours with leading zero for single-digit hours; 12-hour clock + H hours; 24-hour clock + HH hours with leading zero for single-digit hours; 24-hour clock + m minutes + mm minutes with leading zero for single-digit minutes + s seconds + ss seconds with leading zero for single-digit seconds + t one character time marker string, such as A or P + tt multicharacter time marker string, such as AM or PM + +For example: + + my $v = Variant(VT_DATE, "April 1 99 2:23 pm"); + print $v->Time, "\n"; + print $v->Time(TIME_FORCE24HOURFORMAT|TIME_NOTIMEMARKER), "\n"; + print $v->Time("hh.mm.ss tt"), "\n"; + +will print: + + 2:23:00 PM + 14:23:00 + 02.23.00 PM + +=item Type() + +The C<Type> method returns the variant type of the contained VARIANT. + +=item Unicode() + +The C<Unicode> method returns a C<Unicode::String> object. This contains +the BSTR value of the variant in network byte order. If the variant is +not currently in VT_BSTR format then a VT_BSTR copy will be produced first. + +=item Value() + +The C<Value> method returns the value of the VARIANT as a Perl value. The +conversion is performed in the same manner as all return values of +Win32::OLE method calls are converted. + +=back + +=head2 Overloading + +The Win32::OLE::Variant package has overloaded the conversion to +string and number formats. Therefore variant objects can be used in +arithmetic and string operations without applying the C<Value> +method first. + +=head2 Class Variables + +The Win32::OLE::Variant class used to have its own set of class variables +like C<$CP>, C<$LCID> and C<$Warn>. In version 0.1003 and later of the +Win32::OLE module these variables have been eliminated. Now the settings +of Win32::OLE are used by the Win32::OLE::Variant module too. Please read +the documentation of the C<Win32::OLE->Option> class method. + + +=head2 Constants + +These constants are exported by default: + + VT_EMPTY + VT_NULL + VT_I2 + VT_I4 + VT_R4 + VT_R8 + VT_CY + VT_DATE + VT_BSTR + VT_DISPATCH + VT_ERROR + VT_BOOL + VT_VARIANT + VT_UNKNOWN + VT_DECIMAL + VT_UI1 + + VT_ARRAY + VT_BYREF + +VT_DECIMAL is not on the official list of allowable OLE Automation +datatypes. But even Microsoft ADO seems to sometimes return values +of Recordset fields in VT_DECIMAL format. + +=head2 Variants + +A Variant is a data type that is used to pass data between OLE +connections. + +The default behavior is to convert each perl scalar variable into +an OLE Variant according to the internal perl representation. +The following type correspondence holds: + + C type Perl type OLE type + ------ --------- -------- + int IV VT_I4 + double NV VT_R8 + char * PV VT_BSTR + void * ref to AV VT_ARRAY + ? undef VT_ERROR + ? Win32::OLE object VT_DISPATCH + +Note that VT_BSTR is a wide character or Unicode string. This presents a +problem if you want to pass in binary data as a parameter as 0x00 is +inserted between all the bytes in your data. The C<Variant()> method +provides a solution to this. With Variants the script writer can specify +the OLE variant type that the parameter should be converted to. Currently +supported types are: + + VT_UI1 unsigned char + VT_I2 signed int (2 bytes) + VT_I4 signed int (4 bytes) + VT_R4 float (4 bytes) + VT_R8 float (8 bytes) + VT_DATE OLE Date + VT_BSTR OLE String + VT_CY OLE Currency + VT_BOOL OLE Boolean + +When VT_DATE and VT_CY objects are created, the input parameter is treated +as a Perl string type, which is then converted to VT_BSTR, and finally to +VT_DATE of VT_CY using the C<VariantChangeType()> OLE API function. +See L<Win32::OLE/EXAMPLES> for how these types can be used. + +=head2 Variant arrays + +A variant can not only contain a single value but also a multi-dimensional +array of values (called a SAFEARRAY). In this case the VT_ARRAY flag must +be added to the base variant type, e.g. C<VT_I4 | VT_ARRAY> for an array of +integers. The VT_EMPTY and VT_NULL types are invalid for SAFEARRAYs. It +is possible to create an array of variants: C<VT_VARIANT | VT_ARRAY>. In this +case each element of the array can have a different type (including VT_EMPTY +and VT_NULL). The elements of a VT_VARIANT SAFEARRAY cannot have either of the +VT_ARRAY or VT_BYREF flags set. + +The lower and upper bounds for each dimension can be specified separately. +They do not have to have all the same lower bound (unlike Perl's arrays). + +=head2 Variants by reference + +Some OLE servers expect parameters passed by reference so that they +can be changed in the method call. This allows methods to easily +return multiple values. There is preliminary support for this in +the Win32::OLE::Variant module: + + my $x = Variant(VT_I4|VT_BYREF, 0); + my $y = Variant(VT_I4|VT_BYREF, 0); + $Corel->GetSize($x, $y); + print "Size is $x by $y\n"; + +After the C<GetSize> method call C<$x> and C<$y> will be set to +the respective sizes. They will still be variants. In the print +statement the overloading converts them to string representation +automatically. + +VT_BYREF is now supported for all variant types (including SAFEARRAYs). +It can also be used to pass an OLE object by reference: + + my $Results = $App->CreateResultsObject; + $Object->Method(Variant(VT_DISPATCH|VT_BYREF, $Results)); + +=head1 AUTHORS/COPYRIGHT + +This module is part of the Win32::OLE distribution. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Shortcut.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Shortcut.pm new file mode 100644 index 0000000000..f284678828 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Shortcut.pm @@ -0,0 +1,752 @@ +package Win32::Shortcut; +####################################################################### +# +# Win32::Shortcut - Perl Module for Shell Link Interface +# ^^^^^^^^^^^^^^^ +# This module creates an object oriented interface to the Win32 +# Shell Links (IShellLink interface). +# +####################################################################### + +$VERSION = "0.08"; + +require Exporter; +require DynaLoader; + +@ISA= qw( Exporter DynaLoader ); +@EXPORT = qw( + SW_SHOWMAXIMIZED + SW_SHOWMINNOACTIVE + SW_SHOWNORMAL +); + + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. +# + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $!; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($!) { + my(undef, $file, $line) = caller; + die "Win32::Shortcut::$constname is not defined, used at $file line $line."; + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +####################################################################### +# PUBLIC METHODS +# + +#======== +sub new { +#======== + my($class, $file) = @_; + my($ilink, $ifile) = _Instance(); + return unless $ilink && $ifile; + + my $self = bless { + ilink => $ilink, + ifile => $ifile, + File => "", + Path => "", + Arguments => "", + WorkingDirectory => "", + Description => "", + ShowCmd => 0, + Hotkey => 0, + IconLocation => "", + IconNumber => 0, + }; + + + if ($file) { + $self->{File} = $file; + $self->Load($file); + } + + return $self; +} + +#========= +sub Load { +#========= + my($self, $file) = @_; + return undef unless ref($self); + + my $result = _Load($self->{'ilink'}, $self->{'ifile'}, $file); + + if ($result) { + + # fill the properties of $self + $self->{'File'} = $file; + $self->{'Path'} = _GetPath($self->{'ilink'}, $self->{'ifile'},0); + $self->{'ShortPath'} = _GetPath($self->{'ilink'}, $self->{'ifile'},1); + $self->{'Arguments'} = _GetArguments($self->{'ilink'}, $self->{'ifile'}); + $self->{'WorkingDirectory'} = _GetWorkingDirectory($self->{'ilink'}, $self->{'ifile'}); + $self->{'Description'} = _GetDescription($self->{'ilink'}, $self->{'ifile'}); + $self->{'ShowCmd'} = _GetShowCmd($self->{'ilink'}, $self->{'ifile'}); + $self->{'Hotkey'} = _GetHotkey($self->{'ilink'}, $self->{'ifile'}); + ($self->{'IconLocation'}, + $self->{'IconNumber'}) = _GetIconLocation($self->{'ilink'}, $self->{'ifile'}); + } + return $result; +} + + +#======== +sub Set { +#======== + my($self, $path, $arguments, $dir, $description, $show, $hotkey, + $iconlocation, $iconnumber) = @_; + return undef unless ref($self); + + $self->{'Path'} = $path; + $self->{'Arguments'} = $arguments; + $self->{'WorkingDirectory'} = $dir; + $self->{'Description'} = $description; + $self->{'ShowCmd'} = $show; + $self->{'Hotkey'} = $hotkey; + $self->{'IconLocation'} = $iconlocation; + $self->{'IconNumber'} = $iconnumber; + return 1; +} + + +#========= +sub Save { +#========= + my($self, $file) = @_; + return unless ref($self); + + $file = $self->{'File'} unless $file; + return unless $file; + + require Win32 unless defined &Win32::GetFullPathName; + $file = Win32::GetFullPathName($file); + + _SetPath($self->{'ilink'}, $self->{'ifile'}, $self->{'Path'}); + _SetArguments($self->{'ilink'}, $self->{'ifile'}, $self->{'Arguments'}); + _SetWorkingDirectory($self->{'ilink'}, $self->{'ifile'}, $self->{'WorkingDirectory'}); + _SetDescription($self->{'ilink'}, $self->{'ifile'}, $self->{'Description'}); + _SetShowCmd($self->{'ilink'}, $self->{'ifile'}, $self->{'ShowCmd'}); + _SetHotkey($self->{'ilink'}, $self->{'ifile'}, $self->{'Hotkey'}); + _SetIconLocation($self->{'ilink'}, $self->{'ifile'}, + $self->{'IconLocation'}, $self->{'IconNumber'}); + + my $result = _Save($self->{'ilink'}, $self->{'ifile'}, $file); + if ($result) { + $self->{'File'} = $file unless $self->{'File'}; + } + return $result; +} + +#============ +sub Resolve { +#============ + my($self, $flags) = @_; + return undef unless ref($self); + $flags = 1 unless defined($flags); + my $result = _Resolve($self->{'ilink'}, $self->{'ifile'}, $flags); + return $result; +} + + +#========== +sub Close { +#========== + my($self) = @_; + return undef unless ref($self); + + my $result = _Release($self->{'ilink'}, $self->{'ifile'}); + $self->{'released'} = 1; + return $result; +} + +#========= +sub Path { +#========= + my($self, $value) = @_; + return undef unless ref($self); + + if(not defined($value)) { + return $self->{'Path'}; + } else { + $self->{'Path'} = $value; + } + return $self->{'Path'}; +} + +#============== +sub ShortPath { +#============== + my($self) = @_; + return undef unless ref($self); + return $self->{'ShortPath'}; +} + +#============== +sub Arguments { +#============== + my($self, $value) = @_; + return undef unless ref($self); + + if(not defined($value)) { + return $self->{'Arguments'}; + } else { + $self->{'Arguments'} = $value; + } + return $self->{'Arguments'}; +} + +#===================== +sub WorkingDirectory { +#===================== + my($self, $value) = @_; + return undef unless ref($self); + + if(not defined($value)) { + return $self->{'WorkingDirectory'}; + } else { + $self->{'WorkingDirectory'} = $value; + } + return $self->{'WorkingDirectory'}; +} + + +#================ +sub Description { +#================ + my($self, $value) = @_; + return undef unless ref($self); + + if(not defined($value)) { + return $self->{'Description'}; + } else { + $self->{'Description'} = $value; + } + return $self->{'Description'}; +} + +#============ +sub ShowCmd { +#============ + my($self, $value) = @_; + return undef unless ref($self); + + if(not defined($value)) { + return $self->{'ShowCmd'}; + } else { + $self->{'ShowCmd'} = $value; + } + return $self->{'ShowCmd'}; +} + +#=========== +sub Hotkey { +#=========== + my($self, $value) = @_; + return undef unless ref($self); + + if(not defined($value)) { + return $self->{'Hotkey'}; + } else { + $self->{'Hotkey'} = $value; + } + return $self->{'Hotkey'}; +} + +#================= +sub IconLocation { +#================= + my($self, $value) = @_; + return undef unless ref($self); + + if(not defined($value)) { + return $self->{'IconLocation'}; + } else { + $self->{'IconLocation'} = $value; + } + return $self->{'IconLocation'}; +} + +#=============== +sub IconNumber { +#=============== + my($self, $value) = @_; + return undef unless ref($self); + + if(not defined($value)) { + return $self->{'IconNumber'}; + } else { + $self->{'IconNumber'} = $value; + } + return $self->{'IconNumber'}; +} + +#============ +sub Version { +#============ + # [dada] to get rid of the "used only once" warning... + return $VERSION; +} + + +####################################################################### +# PRIVATE METHODS +# + +#============ +sub DESTROY { +#============ + my($self) = @_; + + if (not $self->{'released'}) { + _Release($self->{'ilink'}, $self->{'ifile'}); + $self->{'released'} = 1; + } +} + +bootstrap Win32::Shortcut; + +1; + +__END__ + +=head1 NAME + +Win32::Shortcut - Perl Module to deal with Windows Shortcuts + +=head1 SYNOPSIS + +This module implements the Win32 IShellLink Interface to allow +management of shortcut files from Perl. + + use Win32::Shortcut; + + $LINK = Win32::Shortcut->new(); + $LINK->{'Path'} = "C:\\Directory\\Target.exe"; + $LINK->{'Description'} = "Target executable"; + $LINK->Save("Target.lnk"); + $LINK->Close(); + +=head1 REFERENCE + +=head2 General Usage + +To use this module, first add the following line at the beginning of +your script: + + use Win32::Shortcut; + +Then, use this command to create a shortcut object: + + $LINK = Win32::Shortcut->new(); + +This function will create a C<$LINK> object on which you can apply the +Methods and Properties explained later. + +The object is not yet a shortcut file; it is just the definition of a +shortcut. Basically, you can do 2 things: + +=over + +=item 1. Load a shortcut file into the object. + +=item 2. Save the object into a shortcut file. + +=back + +For the rest, the object can be accessed as it were a normal +associative array reference. It has the following keys (here referred +as properties): + + $LINK->{'File'} + $LINK->{'Path'} $LINK->Path() + $LINK->{'ShortPath'} + $LINK->{'WorkingDirectory'} $LINK->WorkingDirectory() + $LINK->{'Arguments'} $LINK->Arguments() + $LINK->{'Description'} $LINK->Description() + $LINK->{'ShowCmd'} $LINK->ShowCmd() + $LINK->{'Hotkey'} $LINK->Hotkey() + $LINK->{'IconLocation'} $LINK->IconLocation() + $LINK->{'IconNumber'} $LINK->IconNumber() + +Thus, assuming you have a shortcut file named C<test.lnk> in your +current directory, this simple script will tell you where this shortcut +points to: + + use Win32::Shortcut; + $LINK = Win32::Shortcut->new(); + $LINK->Load("test.lnk"); + print "Shortcut to: $LINK->{'Path'} $LINK->{'Arguments'} \n"; + $LINK->Close(); + +But you can also modify its values: + + use Win32::Shortcut; + $LINK = Win32::Shortcut->new(); + $LINK->Load("test.lnk"); + $LINK->{'Path'} =~ s/C:/D:/i; # move the target from C: to D: + $LINK->{'ShowCmd'} = SW_NORMAL; # runs in a normal window + +and then you can save your changes to the shortcut file with this +command: + + $LINK->Save(); + $LINK->Close(); + +or you can save it with another name, creating a new shortcut file: + + $LINK->Save("test2.lnk"); + $LINK->Close(); + +Finally, you can create a completely new shortcut: + + $LINK = Win32::Shortcut->new(); + $LINK->{'Path'} = "C:\\PERL5\\BIN\\PERL.EXE"; + $LINK->{'Arguments'} = "-v"; + $LINK->{'WorkingDirectory'} = "C:\PERL5\\BIN"; + $LINK->{'Description'} = "Prints out the version of Perl"; + $LINK->{'ShowCmd'} = SW_SHOWMAXIMIZED; + $LINK->Save("Perl Version Info.lnk"); + $LINK->Close(); + +Note also that in the examples above the two lines: + + $LINK = Win32::Shortcut->new(); + $LINK->Load("test.lnk"); + +can be collapsed to: + + $LINK = Win32::Shortcut->new("test.lnk"); + + +=head2 Methods + +=over + +=item B<Close> + +Closes a shortcut object. Note that it is not "strictly" required to +close the objects you created, since the Win32::Shortcut objects are +automatically closed when the program ends (or when you somehow destroy +such an object). + +Note also that a shortcut is not automatically saved when it is closed, +even if you modified it. You have to call Save in order to apply +modifications to a shortcut file. + +Example: + + $LINK->Close(); + +=item B<Load> I<file> + +Loads the content of the shortcut file named I<file> in a shortcut +object and fill the properties of the object with its values. Will +return B<undef> on errors, or a true value if everything was +successful. + +Example: + + $LINK->Load("test.lnk") or print "test.lnk not found!"; + + print join("\n", $LINK->Path, + $LINK->ShortPath, + $LINK->Arguments, + $LINK->WorkingDirectory, + $LINK->Description, + $LINK->ShowCmd, + $LINK->Hotkey, + $LINK->IconLocation, + $LINK->IconNumber); + } + +=item B<new Win32::Shortcut> I<[file]> + +Creates a new shortcut object. If a filename is passed in I<file>, +automatically Loads this file also. Returns the object created or +B<undef> on errors. + +Example: + + $LINK = Win32::Shortcut->new(); + + $RegEdit = Win32::Shortcut->new("Registry Editor.lnk"); + die "File not found" if not $RegEdit; + +=item B<Resolve> I<[flag]> + +Attempts to automatically resolve a shortcut and returns the resolved +path, or B<undef> on errors; in case no resolution was made, the path +is returned unchanged. Note that the path is automatically updated in +the Path property of the shortcut. + +By default this method acts quietly, but if you pass a value of 0 +(zero) in the I<flag> parameter, it will eventually post a dialog box +prompting the user for more information. + +Example: + + # if the target doesn't exist... + if(! -f $LINK->Path) { + # save the actual target for comparison + $oldpath = $LINK->Path; + + # try to resolve it (with dialog box) + $newpath = $LINK->Resolve(0); + + die "Not resolved..." if $newpath == $oldpath; + } + +=item B<Save> I<[file]> + +Saves the content of the shortcut object into the file named I<file>. +If I<file> is omitted, it is taken from the File property of the object +(which, if not changed, is the name of the last Loaded file). + +If no file was loaded and the File property doesn't contain a valid +filename, the method will return B<undef>, which will also be returned +on errors. A true value will be returned if everything was successful. + +Example: + + $LINK->Save(); + $LINK->Save("Copy of " . $LINK->{'File'}); + +=item B<Set> I<path, arguments, workingdirectory, description, showcmd, +hotkey, iconlocation, iconnumber> + +Sets all the properties of the shortcut object with a single command. +This method is supplied for convenience only, you can also set those +values changing the values of the properties. + +Example: + + $LINK->Set("C:\\PERL5\\BIN\\PERL.EXE", + "-v", + "C:\\PERL5\\BIN", + "Prints out the version of Perl", + SW_SHOWMAXIMIZED, + hex('0x0337'), + "C:\\WINDOWS\\SYSTEM\\COOL.DLL", + 1); + + # it is the same of... + $LINK->Path("C:\\PERL5\\BIN\\PERL.EXE"); + $LINK->Arguments("-v"); + $LINK->WorkingDirectory("C:\\PERL5\\BIN"); + $LINK->Description("Prints out the version of Perl"); + $LINK->ShowCmd(SW_SHOWMAXIMIZED); + $LINK->Hotkey(hex('0x0337')); + $LINK->IconLocation("C:\\WINDOWS\\SYSTEM\\COOL.DLL"); + $LINK->IconNumber(1); + +=back + +=head2 Properties + +The properties of a shortcut object can be accessed as: + + $OBJECT->{'property'} + +Eg., assuming that you have created a shortcut object with: + + $LINK=new Win32::Shortcut(); + +you can for example see its description with: + + print $LINK->{'Description'}; + +You can of course also set it: + + $LINK->{'Description'}="This is a description"; + +From version 0.02, those properties have also a corresponding method +(subroutine), so you can write the 2 lines above using this syntax too: + + print $LINK->Description; + $LINK->Description("This is a description"); + +The properties of a shortcut reflect the content of the Shortcut +Properties Dialog Box, which can be obtained by clicking the third +mouse button on a shortcut file in the Windows 95 (or NT 4.0) Explorer +and choosing "Properties" (well, I hope you already knew :). + +The fields corresponding to the single properties are marked in B<bold> +in the following list. + +=over + +=item B<Arguments> + +The arguments associated with the shell link object. They will be +passed to the targeted program (see Path) when it gets executed. In +fact, joined with Path, this parameter forms the "B<Target>" field of a +Shortcut Properties Dialog Box. + +=item B<Description> + +An optional description given to the shortcut. Seems to be missing in +the Shortcut Properties Dialog Box (not yet implemented?). + +=item B<File> + +The filename of the shortcut file opened with Load, and/or the filename +under which the shortcut will be saved with Save (if the I<file> +argument is not specified). + +=item B<Hotkey> + +The hotkey associated to the shortcut, in the form of a 2-byte number +of which the first byte identifies the modifiers (Ctrl, Alt, Shift... +but I didn't find out how it works) and the second is the ASCII code of +the character key. Correspond to the "B<Shortcut key>" field of a +Shortcut Properties Dialog Box. + +=item B<IconLocation> + +The file that contain the icon for the shortcut. Seems actually to +always return nothing (YMMV, I hope...). + +=item B<IconNumber> + +The number of the icon for the shortcut in the file pointed by +IconLocation, in case more that one icon is contained in that file (I +suppose this, documentation isn't so clear at this point). + +=item B<Path> + +The target of the shortcut. This is (joined with Arguments) the content +of the "B<Target>" field in a Shortcut Properties Dialog Box. + +=item B<ShortPath> + +Same as Path, but expressed in a DOS-readable format (8.3 characters +filenames). It is available as read-only (well, you can change it, but +it has no effect on the shortcut; change Path instead) once you Load a +shortcut file. + +=item B<ShowCmd> + +The condition of the window in which the program will be executed (can +be Normal, Minimized or Maximized). Correspond to the "B<Run>" field of +a Shortcut Properties Dialog Box. + +Allowed values are: + +B<Value> B<Meaning> B<Constant> + + 1 Normal Window SW_SHOWNORMAL + 3 Maximized SW_SHOWMAXIMIZED + 7 Minimized SW_SHOWMINNOACTIVE + +Any other value (theoretically should) result in a Normal Window +display. + +=item B<WorkingDirectory> + +The directory in which the targeted program will be executed. +Correspond to the "B<Start in>" field of a Shortcut Properties Dialog +Box. + +=back + +=head2 Constants + +The following constants are exported in the main namespace of your +script using Win32::Shortcut: + +=over + +=item * SW_SHOWNORMAL + +=item * SW_SHOWMAXIMIZED + +=item * SW_SHOWMINNOACTIVE + +=back + +Those constants are the allowed values for the ShowCmd property. + + + +=head1 VERSION HISTORY + +B<0.03 (07 Apr 1997)> + +=over + +=item * The PLL file now comes in 2 versions, one for Perl version +5.001 (build 110) and one for Perl version 5.003 (build 300 and higher, +EXCEPT 304). + +=item * Added an installation program which will automatically copy the +right files in the right place. + +=back + +B<0.02 (21 Jan 1997)> + +=over + +=item * Added methods matching properties to reduce typing overhead +(eg. Alt-123 and 125...). + +=back + +B<0.01 (15 Jan 1997)> + +=over + +=item * + +First public release. + +=item * + +Added "Set" and "Resolve" and the properties "Hotkey", "IconLocation" +and "IconNumber". + +=back + +B<0.01a (10 Jan 1997)> + +=over + +=item * + +First implementation of the IShellLink interface (wow, it works!); can +"Load", "Save", and modify properties of shortcut files. + +=back + +=head1 AUTHOR + +Aldo Calpini L<dada@perl.it> + +Distributed under the terms of Larry Wall's Artistic License. + +=head1 CREDITS + +Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the +Perl-Win32-Users community. + +=head1 DISCLAIMER + +I<This program is FREE; you can redistribute, modify, disassemble, or +even reverse engineer this software at your will. Keep in mind, +however, that NOTHING IS GUARANTEED to work and everything you do is AT +YOUR OWN RISK - I will not take responsibility for any damage, loss of +money and/or health that may arise from the use of this program!> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/TieRegistry.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/TieRegistry.pm new file mode 100644 index 0000000000..4cda39e0ce --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/TieRegistry.pm @@ -0,0 +1,3803 @@ +package Win32::TieRegistry; + +# Win32/TieRegistry.pm -- Perl module to easily use a Registry +# (on Win32 systems so far). +# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/. + +# +# Skip to "=head" line for user documentation. +# +use 5.006; +use strict; +use Carp; +use Tie::Hash (); + +use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK ); +BEGIN { + $PACK = 'Win32::TieRegistry'; + $VERSION = '0.30'; + @ISA = 'Tie::Hash'; +} + +# Required other modules: +use Win32API::Registry 0.24 qw( :KEY_ :HKEY_ :REG_ ); + +#Optional other modules: +use vars qw( $_NoMoreItems $_FileNotFound $_TooSmall $_MoreData $_SetDualVar ); + +if ( eval { require Win32::WinError } ) { + $_NoMoreItems = Win32::WinError::constant("ERROR_NO_MORE_ITEMS",0); + $_FileNotFound = Win32::WinError::constant("ERROR_FILE_NOT_FOUND",0); + $_TooSmall = Win32::WinError::constant("ERROR_INSUFFICIENT_BUFFER",0); + $_MoreData = Win32::WinError::constant("ERROR_MORE_DATA",0); +} else { + $_NoMoreItems = "^No more data"; + $_FileNotFound = "cannot find the file"; + $_TooSmall = " data area passed to "; + $_MoreData = "^more data is avail"; +} +if ( $_SetDualVar = eval { require SetDualVar } ) { + import SetDualVar; +} + +#Implementation details: +# When opened: +# HANDLE long; actual handle value +# MACHINE string; name of remote machine ("" if local) +# PATH list ref; machine-relative full path for this key: +# ["LMachine","System","Disk"] +# ["HKEY_LOCAL_MACHINE","System","Disk"] +# DELIM char; delimiter used to separate subkeys (def="\\") +# OS_DELIM char; always "\\" for Win32 +# ACCESS long; usually KEY_ALL_ACCESS, perhaps KEY_READ, etc. +# ROOTS string; var name for "Lmachine"->HKEY_LOCAL_MACHINE map +# FLAGS int; bits to control certain options +# Often: +# VALUES ref to list of value names (data/type never cached) +# SUBKEYS ref to list of subkey names +# SUBCLASSES ref to list of subkey classes +# SUBTIMES ref to list of subkey write times +# MEMBERS ref to list of subkey_name.DELIM's, DELIM.value_name's +# MEMBHASH hash ref to with MEMBERS as keys and 1's as values +# Once Key "Info" requested: +# Class CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen +# MaxValNameLen MaxValDataLen SecurityLen LastWrite +# If is tied to a hash and iterating over key values: +# PREVIDX int; index of last MEMBERS element return +# If is the key object returned by Load(): +# UNLOADME list ref; information about Load()ed key +# If is a subkey of a "loaded" key other than the one returned by Load(): +# DEPENDON obj ref; object that can't be destroyed before us + + +#Package-local variables: + +# Option flag bits: +use vars qw( + $Flag_ArrVal $Flag_TieVal $Flag_DualTyp $Flag_DualBin + $Flag_FastDel $Flag_HexDWord $Flag_Split $Flag_FixNulls +); +BEGIN { + $Flag_ArrVal = 0x0001; + $Flag_TieVal = 0x0002; + $Flag_FastDel = 0x0004; + $Flag_HexDWord = 0x0008; + $Flag_Split = 0x0010; + $Flag_DualTyp = 0x0020; + $Flag_DualBin = 0x0040; + $Flag_FixNulls = 0x0080; +} + +use vars qw( $RegObj %_Roots %RegHash $Registry ); + +# Short-hand for HKEY_* constants: +%_Roots= ( + "Classes" => HKEY_CLASSES_ROOT, + "CUser" => HKEY_CURRENT_USER, + "LMachine" => HKEY_LOCAL_MACHINE, + "Users" => HKEY_USERS, + "PerfData" => HKEY_PERFORMANCE_DATA, # Too picky to be useful + "CConfig" => HKEY_CURRENT_CONFIG, + "DynData" => HKEY_DYN_DATA, # Too picky to be useful +); + +# Basic master Registry object: +$RegObj= {}; +@$RegObj{qw( HANDLE MACHINE PATH DELIM OS_DELIM ACCESS FLAGS ROOTS )}= ( + "NONE", "", [], "\\", "\\", + KEY_READ|KEY_WRITE, $Flag_HexDWord|$Flag_FixNulls, "${PACK}::_Roots" ); +$RegObj->{FLAGS} |= $Flag_DualTyp|$Flag_DualBin if $_SetDualVar; +bless $RegObj; + +# Fill cache for master Registry object: +@$RegObj{qw( VALUES SUBKEYS SUBCLASSES SUBTIMES )}= ( + [], [ keys(%_Roots) ], [], [] ); +grep( s#$#$RegObj->{DELIM}#, + @{ $RegObj->{MEMBERS}= [ @{$RegObj->{SUBKEYS}} ] } ); +@$RegObj{qw( Class MaxSubKeyLen MaxSubClassLen MaxValNameLen + MaxValDataLen SecurityLen LastWrite CntSubKeys CntValues )}= + ( "", 0, 0, 0, 0, 0, 0, 0, 0 ); + +# Create master Registry tied hash: +$RegObj->Tie( \%RegHash ); + +# Create master Registry combination object and tied hash reference: +$Registry= \%RegHash; +bless $Registry; + + +# Preloaded methods go here. + + +# Map option names to name of subroutine that controls that option: +use vars qw( @_opt_subs %_opt_subs ); +@_opt_subs= qw( Delimiter ArrayValues TieValues SplitMultis DWordsToHex + FastDelete FixSzNulls DualTypes DualBinVals AllowLoad AllowSave ); +@_opt_subs{@_opt_subs}= @_opt_subs; + +sub import +{ + my $pkg = shift(@_); + my $level = $Exporter::ExportLevel; + my $expto = caller($level); + my @export = (); + my @consts = (); + my $registry = $Registry->Clone; + local( $_ ); + while( @_ ) { + $_= shift(@_); + if( /^\$(\w+::)*\w+$/ ) { + push( @export, "ObjVar" ) if /^\$RegObj$/; + push( @export, $_ ); + } elsif( /^\%(\w+::)*\w+$/ ) { + push( @export, $_ ); + } elsif( /^[$%]/ ) { + croak "${PACK}->import: Invalid variable name ($_)"; + } elsif( /^:/ || /^(H?KEY|REG)_/ ) { + push( @consts, $_ ); + } elsif( ! @_ ) { + croak "${PACK}->import: Missing argument after option ($_)"; + } elsif( exists $_opt_subs{$_} ) { + $_= $_opt_subs{$_}; + $registry->$_( shift(@_) ); + } elsif( /^TiedRef$/ ) { + $_= shift(@_); + if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) { + $_= '$'.$_ unless '$' eq $1; + } elsif( "SCALAR" ne ref($_) ) { + croak "${PACK}->import: Invalid var after TiedRef ($_)"; + } + push( @export, $_ ); + } elsif( /^TiedHash$/ ) { + $_= shift(@_); + if( ! ref($_) && /^(\%?)(\w+::)*\w+$/ ) { + $_= '%'.$_ unless '%' eq $1; + } elsif( "HASH" ne ref($_) ) { + croak "${PACK}->import: Invalid var after TiedHash ($_)"; + } + push( @export, $_ ); + } elsif( /^ObjectRef$/ ) { + $_= shift(@_); + if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) { + push( @export, "ObjVar" ); + $_= '$'.$_ unless '$' eq $1; + } elsif( "SCALAR" eq ref($_) ) { + push( @export, "ObjRef" ); + } else { + croak "${PACK}->import: Invalid var after ObjectRef ($_)"; + } + push( @export, $_ ); + } elsif( /^ExportLevel$/ ) { + $level= shift(@_); + $expto= caller($level); + } elsif( /^ExportTo$/ ) { + undef $level; + $expto= caller($level); + } else { + croak "${PACK}->import: Invalid option ($_)"; + } + } + Win32API::Registry->export( $expto, @consts ) if @consts; + @export= ('$Registry') unless @export; + while( @export ) { + $_= shift( @export ); + if( /^\$((?:\w+::)*)(\w+)$/ ) { + my( $pack, $sym )= ( $1, $2 ); + $pack= $expto unless defined($pack) && "" ne $pack; + no strict 'refs'; + *{"${pack}::$sym"}= \${"${pack}::$sym"}; + ${"${pack}::$sym"}= $registry; + } elsif( /^\%((?:\w+::)*)(\w+)$/ ) { + my( $pack, $sym )= ( $1, $2 ); + $pack= $expto unless defined($pack) && "" ne $pack; + no strict 'refs'; + *{"${pack}::$sym"}= \%{"${pack}::$sym"}; + $registry->Tie( \%{"${pack}::$sym"} ); + } elsif( "SCALAR" eq ref($_) ) { + $$_= $registry; + } elsif( "HASH" eq ref($_) ) { + $registry->Tie( $_ ); + } elsif( /^ObjVar$/ ) { + $_= shift( @_ ); + /^\$((?:\w+::)*)(\w+)$/; + my( $pack, $sym )= ( $1, $2 ); + $pack= $expto unless defined($pack) && "" ne $pack; + no strict 'refs'; + *{"${pack}::$sym"}= \${"${pack}::$sym"}; + ${"${pack}::$sym"}= $registry->ObjectRef; + } elsif( /^ObjRef$/ ) { + ${shift(@_)}= $registry->ObjectRef; + } else { + die "Impossible var to export ($_)"; + } + } +} + + +use vars qw( @_new_Opts %_new_Opts ); +@_new_Opts= qw( ACCESS DELIM MACHINE DEPENDON ); +@_new_Opts{@_new_Opts}= (1) x @_new_Opts; + +sub _new +{ + my $this= shift( @_ ); + $this= tied(%$this) if ref($this) && tied(%$this); + my $class= ref($this) || $this; + my $self= {}; + my( $handle, $rpath, $opts )= @_; + if( @_ < 2 || "ARRAY" ne ref($rpath) || 3 < @_ + || 3 == @_ && "HASH" ne ref($opts) ) { + croak "Usage: ${PACK}->_new( \$handle, \\\@path, {OPT=>VAL,...} );\n", + " options: @_new_Opts\nCalled"; + } + @$self{qw( HANDLE PATH )}= ( $handle, $rpath ); + @$self{qw( MACHINE ACCESS DELIM OS_DELIM ROOTS FLAGS )}= + ( $this->Machine, $this->Access, $this->Delimiter, + $this->OS_Delimiter, $this->_Roots, $this->_Flags ); + if( ref($opts) ) { + my @err= grep( ! $_new_Opts{$_}, keys(%$opts) ); + @err and croak "${PACK}->_new: Invalid options (@err)"; + @$self{ keys(%$opts) }= values(%$opts); + } + bless $self, $class; + return $self; +} + + +sub _split +{ + my $self= shift( @_ ); + $self= tied(%$self) if tied(%$self); + my $path= shift( @_ ); + my $delim= @_ ? shift(@_) : $self->Delimiter; + my $list= [ split( /\Q$delim/, $path ) ]; + return $list; +} + + +sub _rootKey +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $keyPath= shift(@_); + my $delim= @_ ? shift(@_) : $self->Delimiter; + my( $root, $subPath ); + if( "ARRAY" eq ref($keyPath) ) { + $subPath= $keyPath; + } else { + $subPath= $self->_split( $keyPath, $delim ); + } + $root= shift( @$subPath ); + if( $root =~ /^HKEY_/ ) { + my $handle= Win32API::Registry::constant($root,0); + $handle or croak "Invalid HKEY_ constant ($root): $!"; + return( $self->_new( $handle, [$root], {DELIM=>$delim} ), + $subPath ); + } elsif( $root =~ /^([-+]|0x)?\d/ ) { + return( $self->_new( $root, [sprintf("0x%lX",$root)], + {DELIM=>$delim} ), + $subPath ); + } else { + my $roots= $self->Roots; + if( $roots->{$root} ) { + return( $self->_new( $roots->{$root}, [$root], {DELIM=>$delim} ), + $subPath ); + } + croak "No such root key ($root)"; + } +} + + +sub _open +{ + my $this = shift(@_); + $this = tied(%$this) if ref($this) && tied(%$this); + my $subPath = shift(@_); + my $sam = @_ ? shift(@_) : $this->Access; + my $subKey = join( $this->OS_Delimiter, @$subPath ); + my $handle = 0; + $this->RegOpenKeyEx( $subKey, 0, $sam, $handle ) or return (); + return $this->_new( $handle, [ @{$this->_Path}, @$subPath ], + { ACCESS=>$sam, ( defined($this->{UNLOADME}) ? ("DEPENDON",$this) + : defined($this->{DEPENDON}) ? ("DEPENDON",$this->{DEPENDON}) : () ) + } ); +} + + +sub ObjectRef +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + return $self; +} + + +sub _constant +{ + my( $name, $desc )= @_; + my $value= Win32API::Registry::constant( $name, 0 ); + my $func= (caller(1))[3]; + if( 0 == $value ) { + if( $! =~ /invalid/i ) { + croak "$func: Invalid $desc ($name)"; + } elsif( 0 != $! ) { + croak "$func: \u$desc ($name) not support on this platform"; + } + } + return $value; +} + + +sub _connect +{ + my $this= shift(@_); + $this= tied(%$this) if ref($this) && tied(%$this); + my $subPath= pop(@_); + $subPath= $this->_split( $subPath ) unless ref($subPath); + my $machine= @_ ? shift(@_) : shift(@$subPath); + my $handle= 0; + my( $temp )= $this->_rootKey( [@$subPath] ); + $temp->RegConnectRegistry( $machine, $temp->Handle, $handle ) + or return (); + my $self= $this->_new( $handle, [shift(@$subPath)], {MACHINE=>$machine} ); + return( $self, $subPath ); +} + + +use vars qw( @Connect_Opts %Connect_Opts ); +@Connect_Opts= qw(Access Delimiter); +@Connect_Opts{@Connect_Opts}= (1) x @Connect_Opts; + +sub Connect +{ + my $this= shift(@_); + my $tied= ref($this) && tied(%$this); + $this= tied(%$this) if $tied; + my( $machine, $key, $opts )= @_; + my $delim= ""; + my $sam; + my $subPath; + if( @_ < 2 || 3 < @_ + || 3 == @_ && "HASH" ne ref($opts) ) { + croak "Usage: \$obj= ${PACK}->Connect(", + " \$Machine, \$subKey, { OPT=>VAL,... } );\n", + " options: @Connect_Opts\nCalled"; + } + if( ref($opts) ) { + my @err= grep( ! $Connect_Opts{$_}, keys(%$opts) ); + @err and croak "${PACK}->Connect: Invalid options (@err)"; + } + $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter}); + $delim= $this->Delimiter if "" eq $delim; + $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access; + $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/; + ( $this, $subPath )= $this->_connect( $machine, $key ); + return () unless defined($this); + my $self= $this->_open( $subPath, $sam ); + return () unless defined($self); + $self->Delimiter( $delim ); + $self= $self->TiedRef if $tied; + return $self; +} + + +my @_newVirtual_keys= qw( MEMBERS VALUES SUBKEYS SUBTIMES SUBCLASSES + Class SecurityLen LastWrite CntValues CntSubKeys + MaxValNameLen MaxValDataLen MaxSubKeyLen MaxSubClassLen ); + +sub _newVirtual +{ + my $self= shift(@_); + my( $rPath, $root, $opts )= @_; + my $new= $self->_new( "NONE", $rPath, $opts ) + or return (); + @{$new}{@_newVirtual_keys}= @{$root->ObjectRef}{@_newVirtual_keys}; + return $new; +} + + +#$key= new Win32::TieRegistry "LMachine/System/Disk"; +#$key= new Win32::TieRegistry "//Server1/LMachine/System/Disk"; +#Win32::TieRegistry->new( HKEY_LOCAL_MACHINE, {DELIM=>"/",ACCESS=>KEY_READ} ); +#Win32::TieRegistry->new( [ HKEY_LOCAL_MACHINE, ".../..." ], {DELIM=>$DELIM} ); +#$key->new( ... ); + +use vars qw( @new_Opts %new_Opts ); +@new_Opts= qw(Access Delimiter); +@new_Opts{@new_Opts}= (1) x @new_Opts; + +sub new +{ + my $this= shift( @_ ); + $this= tied(%$this) if ref($this) && tied(%$this); + if( ! ref($this) ) { + no strict "refs"; + my $self= ${"${this}::Registry"}; + croak "${this}->new failed since ${PACK}::new sees that ", + "\$${this}::Registry is not an object." + if ! ref($self); + $this= $self->Clone; + } + my( $subKey, $opts )= @_; + my $delim= ""; + my $dlen; + my $sam; + my $subPath; + if( @_ < 1 || 2 < @_ + || 2 == @_ && "HASH" ne ref($opts) ) { + croak "Usage: \$obj= ${PACK}->new( \$subKey, { OPT=>VAL,... } );\n", + " options: @new_Opts\nCalled"; + } + if( defined($opts) ) { + my @err= grep( ! $new_Opts{$_}, keys(%$opts) ); + @err and die "${PACK}->new: Invalid options (@err)"; + } + $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter}); + $delim= $this->Delimiter if "" eq $delim; + $dlen= length($delim); + $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access; + $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/; + if( "ARRAY" eq ref($subKey) ) { + $subPath= $subKey; + if( "NONE" eq $this->Handle && @$subPath ) { + ( $this, $subPath )= $this->_rootKey( $subPath ); + } + } elsif( $delim x 2 eq substr($subKey,0,2*$dlen) ) { + my $path= $this->_split( substr($subKey,2*$dlen), $delim ); + my $mach= shift(@$path); + if( ! @$path ) { + return $this->_newVirtual( $path, $Registry, + {MACHINE=>$mach,DELIM=>$delim,ACCESS=>$sam} ); + } + ( $this, $subPath )= $this->_connect( $mach, $path ); + return () if ! defined($this); + if( 0 == @$subPath ) { + $this->Delimiter( $delim ); + return $this; + } + } elsif( $delim eq substr($subKey,0,$dlen) ) { + ( $this, $subPath )= $this->_rootKey( substr($subKey,$dlen), $delim ); + } elsif( "NONE" eq $this->Handle && "" ne $subKey ) { + my( $mach )= $this->Machine; + if( $mach ) { + ( $this, $subPath )= $this->_connect( $mach, $subKey ); + } else { + ( $this, $subPath )= $this->_rootKey( $subKey, $delim ); + } + } else { + $subPath= $this->_split( $subKey, $delim ); + } + return () unless defined($this); + if( 0 == @$subPath && "NONE" eq $this->Handle ) { + return $this->_newVirtual( $this->_Path, $this, + { DELIM=>$delim, ACCESS=>$sam } ); + } + my $self= $this->_open( $subPath, $sam ); + return () unless defined($self); + $self->Delimiter( $delim ); + return $self; +} + + +sub Open +{ + my $self= shift(@_); + my $tied= ref($self) && tied(%$self); + $self= tied(%$self) if $tied; + $self= $self->new( @_ ); + $self= $self->TiedRef if defined($self) && $tied; + return $self; +} + + +sub Clone +{ + my $self= shift( @_ ); + my $new= $self->Open(""); + return $new; +} + + +{ my @flush; + sub Flush + { + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $flush )= @_; + @_ and croak "Usage: \$key->Flush( \$bFlush );"; + return 0 if "NONE" eq $self->Handle; + @flush= qw( VALUES SUBKEYS SUBCLASSES SUBTIMES MEMBERS Class + CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen + MaxValNameLen MaxValDataLen SecurityLen LastWrite PREVIDX ) + unless @flush; + delete( @$self{@flush} ); + if( defined($flush) && $flush ) { + return $self->RegFlushKey(); + } else { + return 1; + } + } +} + + +sub _DualVal +{ + my( $hRef, $num )= @_; + if( $_SetDualVar && $$hRef{$num} ) { + &SetDualVar( $num, "$$hRef{$num}", 0+$num ); + } + return $num; +} + + +use vars qw( @_RegDataTypes %_RegDataTypes ); +@_RegDataTypes= qw( REG_SZ REG_EXPAND_SZ REG_BINARY REG_LINK REG_MULTI_SZ + REG_DWORD_LITTLE_ENDIAN REG_DWORD_BIG_ENDIAN REG_DWORD + REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR + REG_RESOURCE_REQUIREMENTS_LIST REG_NONE ); +# Make sure that REG_DWORD appears _after_ other REG_DWORD_* +# items above and that REG_NONE appears _last_. +foreach( @_RegDataTypes ) { + $_RegDataTypes{Win32API::Registry::constant($_,0)}= $_; +} + +sub GetValue +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + 1 == @_ or croak "Usage: (\$data,\$type)= \$key->GetValue('ValName');"; + my( $valName )= @_; + my( $valType, $valData, $dLen )= (0,"",0); + return () if "NONE" eq $self->Handle; + $self->RegQueryValueEx( $valName, [], $valType, $valData, + $dLen= ( defined($self->{MaxValDataLen}) ? $self->{MaxValDataLen} : 0 ) + ) or return (); + if( REG_DWORD == $valType ) { + my $val= unpack("L",$valData); + $valData= sprintf "0x%08.8lX", $val if $self->DWordsToHex; + &SetDualVar( $valData, $valData, $val ) if $self->DualBinVals + } elsif( REG_BINARY == $valType && length($valData) <= 4 ) { + &SetDualVar( $valData, $valData, hex reverse unpack("h*",$valData) ) + if $self->DualBinVals; + } elsif( ( REG_SZ == $valType || REG_EXPAND_SZ == $valType ) + && $self->FixSzNulls ) { + substr($valData,-1)= "" if "\0" eq substr($valData,-1); + } elsif( REG_MULTI_SZ == $valType && $self->SplitMultis ) { + ## $valData =~ s/\0\0$//; # Why does this often fail?? + substr($valData,-2)= "" if "\0\0" eq substr($valData,-2); + $valData= [ split( /\0/, $valData, -1 ) ] + } + if( ! wantarray ) { + return $valData; + } elsif( ! $self->DualTypes ) { + return( $valData, $valType ); + } else { + return( $valData, _DualVal( \%_RegDataTypes, $valType ) ); + } +} + + +sub _ErrNum +{ + # return $^E; + return Win32::GetLastError(); +} + + +sub _ErrMsg +{ + # return $^E; + return Win32::FormatMessage( Win32::GetLastError() ); +} + +sub _Err +{ + my $err; + # return $^E; + return _ErrMsg if ! $_SetDualVar; + return &SetDualVar( $err, _ErrMsg, _ErrNum ); +} + +sub _NoMoreItems +{ + return + $_NoMoreItems =~ /^\d/ + ? _ErrNum == $_NoMoreItems + : _ErrMsg =~ /$_NoMoreItems/io; +} + + +sub _FileNotFound +{ + return + $_FileNotFound =~ /^\d/ + ? _ErrNum == $_FileNotFound + : _ErrMsg =~ /$_FileNotFound/io; +} + + +sub _TooSmall +{ + return + $_TooSmall =~ /^\d/ + ? _ErrNum == $_TooSmall + : _ErrMsg =~ /$_TooSmall/io; +} + + +sub _MoreData +{ + return + $_MoreData =~ /^\d/ + ? _ErrNum == $_MoreData + : _ErrMsg =~ /$_MoreData/io; +} + + +sub _enumValues +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( @names )= (); + my $pos= 0; + my $name= ""; + my $nlen= 1+$self->Information("MaxValNameLen"); + while( $self->RegEnumValue($pos++,$name,my $nlen1=$nlen,[],[],[],[]) ) { + #RegEnumValue modifies $nlen1 + push( @names, $name ); + } + if( ! _NoMoreItems() ) { + return (); + } + $self->{VALUES}= \@names; + return 1; +} + + +sub ValueNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@names= \$key->ValueNames;"; + $self->_enumValues unless $self->{VALUES}; + return @{$self->{VALUES}}; +} + + +sub _enumSubKeys +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( @subkeys, @classes, @times )= (); + my $pos= 0; + my( $subkey, $class, $time )= ("","",""); + my( $namSiz, $clsSiz )= $self->Information( + qw( MaxSubKeyLen MaxSubClassLen )); + $namSiz++; $clsSiz++; + my $namSiz1 = $namSiz; + while( $self->RegEnumKeyEx( + $pos++, $subkey, $namSiz, [], $class, $clsSiz, $time ) ) { + push( @subkeys, $subkey ); + push( @classes, $class ); + push( @times, $time ); + $namSiz = $namSiz1; #RegEnumKeyEx modifies $namSiz + } + if( ! _NoMoreItems() ) { + return (); + } + $self->{SUBKEYS}= \@subkeys; + $self->{SUBCLASSES}= \@classes; + $self->{SUBTIMES}= \@times; + return 1; +} + + +sub SubKeyNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@names= \$key->SubKeyNames;"; + $self->_enumSubKeys unless $self->{SUBKEYS}; + return @{$self->{SUBKEYS}}; +} + + +sub SubKeyClasses +{ + my $self= shift(@_); + @_ and croak "Usage: \@classes= \$key->SubKeyClasses;"; + $self->_enumSubKeys unless $self->{SUBCLASSES}; + return @{$self->{SUBCLASSES}}; +} + + +sub SubKeyTimes +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@times= \$key->SubKeyTimes;"; + $self->_enumSubKeys unless $self->{SUBTIMES}; + return @{$self->{SUBTIMES}}; +} + + +sub _MemberNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$arrayRef= \$key->_MemberNames;"; + if( ! $self->{MEMBERS} ) { + $self->_enumValues unless $self->{VALUES}; + $self->_enumSubKeys unless $self->{SUBKEYS}; + my( @members )= ( map( $_.$self->{DELIM}, @{$self->{SUBKEYS}} ), + map( $self->{DELIM}.$_, @{$self->{VALUES}} ) ); + $self->{MEMBERS}= \@members; + } + return $self->{MEMBERS}; +} + + +sub _MembersHash +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$hashRef= \$key->_MembersHash;"; + if( ! $self->{MEMBHASH} ) { + my $aRef= $self->_MemberNames; + $self->{MEMBHASH}= {}; + @{$self->{MEMBHASH}}{@$aRef}= (1) x @$aRef; + } + return $self->{MEMBHASH}; +} + + +sub MemberNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@members= \$key->MemberNames;"; + return @{$self->_MemberNames}; +} + + +sub Information +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $time, $nkeys, $nvals, $xsec, $xkey, $xcls, $xname, $xdata )= + ("",0,0,0,0,0,0,0); + my $clen= 8; + if( ! $self->RegQueryInfoKey( [], [], $nkeys, $xkey, $xcls, + $nvals, $xname, $xdata, $xsec, $time ) ) { + return (); + } + if( defined($self->{Class}) ) { + $clen= length($self->{Class}); + } else { + $self->{Class}= ""; + } + while( ! $self->RegQueryInfoKey( $self->{Class}, $clen, + [],[],[],[],[],[],[],[],[]) + && _MoreData ) { + $clen *= 2; + } + my( %info ); + @info{ qw( LastWrite CntSubKeys CntValues SecurityLen + MaxValDataLen MaxSubKeyLen MaxSubClassLen MaxValNameLen ) + }= ( $time, $nkeys, $nvals, $xsec, + $xdata, $xkey, $xcls, $xname ); + if( @_ ) { + my( %check ); + @check{keys(%info)}= keys(%info); + my( @err )= grep( ! $check{$_}, @_ ); + if( @err ) { + croak "${PACK}::Information- Invalid info requested (@err)"; + } + return @info{@_}; + } else { + return %info; + } +} + + +sub Delimiter +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + $self= $RegObj unless ref($self); + my( $oldDelim )= $self->{DELIM}; + if( 1 == @_ && "" ne "$_[0]" ) { + delete $self->{MEMBERS}; + delete $self->{MEMBHASH}; + $self->{DELIM}= "$_[0]"; + } elsif( 0 != @_ ) { + croak "Usage: \$oldDelim= \$key->Delimiter(\$newDelim);"; + } + return $oldDelim; +} + + +sub Handle +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$handle= \$key->Handle;"; + $self= $RegObj unless ref($self); + return $self->{HANDLE}; +} + + +sub Path +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$path= \$key->Path;"; + my $delim= $self->{DELIM}; + $self= $RegObj unless ref($self); + if( "" eq $self->{MACHINE} ) { + return( $delim . join( $delim, @{$self->{PATH}} ) . $delim ); + } else { + return( $delim x 2 + . join( $delim, $self->{MACHINE}, @{$self->{PATH}} ) + . $delim ); + } +} + + +sub _Path +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$arrRef= \$key->_Path;"; + $self= $RegObj unless ref($self); + return $self->{PATH}; +} + + +sub Machine +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$machine= \$key->Machine;"; + $self= $RegObj unless ref($self); + return $self->{MACHINE}; +} + + +sub Access +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$access= \$key->Access;"; + $self= $RegObj unless ref($self); + return $self->{ACCESS}; +} + + +sub OS_Delimiter +{ + my $self= shift(@_); + @_ and croak "Usage: \$backslash= \$key->OS_Delimiter;"; + return $self->{OS_DELIM}; +} + + +sub _Roots +{ + my $self= shift(@_); + $self= tied(%$self) if ref($self) && tied(%$self); + @_ and croak "Usage: \$varName= \$key->_Roots;"; + $self= $RegObj unless ref($self); + return $self->{ROOTS}; +} + + +sub Roots +{ + my $self= shift(@_); + $self= tied(%$self) if ref($self) && tied(%$self); + @_ and croak "Usage: \$hashRef= \$key->Roots;"; + $self= $RegObj unless ref($self); + return eval "\\%$self->{ROOTS}"; +} + + +sub TIEHASH +{ + my( $this )= shift(@_); + $this= tied(%$this) if ref($this) && tied(%$this); + my( $key )= @_; + if( 1 == @_ && ref($key) && "$key" =~ /=/ ) { + return $key; # $key is already an object (blessed reference). + } + return $this->new( @_ ); +} + + +sub Tie +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $hRef )= @_; + if( 1 != @_ || ! ref($hRef) || "$hRef" !~ /(^|=)HASH\(/ ) { + croak "Usage: \$key->Tie(\\\%hash);"; + } + return tie %$hRef, ref($self), $self; +} + + +sub TiedRef +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $hRef= @_ ? shift(@_) : {}; + return () if ! defined($self); + $self->Tie($hRef); + bless $hRef, ref($self); + return $hRef; +} + + +sub _Flags +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlags= $self->{FLAGS}; + if( 1 == @_ ) { + $self->{FLAGS}= shift(@_); + } elsif( 0 != @_ ) { + croak "Usage: \$oldBits= \$key->_Flags(\$newBits);"; + } + return $oldFlags; +} + + +sub ArrayValues +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_ArrVal == ( $Flag_ArrVal & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_ArrVal; + } else { + $self->{FLAGS} &= ~( $Flag_ArrVal | $Flag_TieVal ); + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->ArrayValues(\$newBool);"; + } + return $oldFlag; +} + + +sub TieValues +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_TieVal == ( $Flag_TieVal & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + croak "${PACK}->TieValues cannot be enabled with this version"; + $self->{FLAGS} |= $Flag_TieVal; + } else { + $self->{FLAGS} &= ~$Flag_TieVal; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->TieValues(\$newBool);"; + } + return $oldFlag; +} + + +sub FastDelete +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_FastDel == ( $Flag_FastDel & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_FastDel; + } else { + $self->{FLAGS} &= ~$Flag_FastDel; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->FastDelete(\$newBool);"; + } + return $oldFlag; +} + + +sub SplitMultis +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_Split == ( $Flag_Split & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_Split; + } else { + $self->{FLAGS} &= ~$Flag_Split; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->SplitMultis(\$newBool);"; + } + return $oldFlag; +} + + +sub DWordsToHex +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_HexDWord == ( $Flag_HexDWord & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_HexDWord; + } else { + $self->{FLAGS} &= ~$Flag_HexDWord; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->DWordsToHex(\$newBool);"; + } + return $oldFlag; +} + + +sub FixSzNulls +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_FixNulls == ( $Flag_FixNulls & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_FixNulls; + } else { + $self->{FLAGS} &= ~$Flag_FixNulls; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->FixSzNulls(\$newBool);"; + } + return $oldFlag; +} + + +sub DualTypes +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_DualTyp == ( $Flag_DualTyp & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + croak "${PACK}->DualTypes cannot be enabled since ", + "SetDualVar module not installed" + unless $_SetDualVar; + $self->{FLAGS} |= $Flag_DualTyp; + } else { + $self->{FLAGS} &= ~$Flag_DualTyp; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->DualTypes(\$newBool);"; + } + return $oldFlag; +} + + +sub DualBinVals +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_DualBin == ( $Flag_DualBin & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + croak "${PACK}->DualBinVals cannot be enabled since ", + "SetDualVar module not installed" + unless $_SetDualVar; + $self->{FLAGS} |= $Flag_DualBin; + } else { + $self->{FLAGS} &= ~$Flag_DualBin; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->DualBinVals(\$newBool);"; + } + return $oldFlag; +} + + +sub GetOptions +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $opt, $meth ); + if( ! @_ || 1 == @_ && "HASH" eq ref($_[0]) ) { + my $href= @_ ? $_[0] : {}; + foreach $opt ( grep !/^Allow/, @_opt_subs ) { + $meth= $_opt_subs{$opt}; + $href->{$opt}= $self->$meth(); + } + return @_ ? $self : $href; + } + my @old; + foreach $opt ( @_ ) { + $meth= $_opt_subs{$opt}; + if( defined $meth ) { + if( $opt eq "AllowLoad" || $opt eq "AllowSave" ) { + croak "${PACK}->GetOptions: Getting current setting of $opt ", + "not supported in this release"; + } + push( @old, $self->$meth() ); + } else { + croak "${PACK}->GetOptions: Invalid option ($opt) ", + "not one of ( ", join(" ",grep !/^Allow/, @_opt_subs), " )"; + } + } + return wantarray ? @old : $old[-1]; +} + + +sub SetOptions +{ + my $self= shift(@_); + # Don't get object if hash ref so "ref" returns original ref. + my( $opt, $meth, @old ); + while( @_ ) { + $opt= shift(@_); + $meth= $_opt_subs{$opt}; + if( ! @_ ) { + croak "${PACK}->SetOptions: Option value missing ", + "after option name ($opt)"; + } elsif( defined $meth ) { + push( @old, $self->$meth( shift(@_) ) ); + } elsif( $opt eq substr("reference",0,length($opt)) ) { + shift(@_) if @_; + push( @old, $self ); + } else { + croak "${PACK}->SetOptions: Invalid option ($opt) ", + "not one of ( @_opt_subs )"; + } + } + return wantarray ? @old : $old[-1]; +} + + +sub _parseTiedEnt +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $ent= shift(@_); + my $delim= shift(@_); + my $dlen= length( $delim ); + my $parent= @_ ? shift(@_) : 0; + my $off; + if( $delim x 2 eq substr($ent,0,2*$dlen) && "NONE" eq $self->Handle ) { + if( 0 <= ( $off= index( $ent, $delim x 2, 2*$dlen ) ) ) { + return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) ); + } elsif( $delim eq substr($ent,-$dlen) ) { + return( substr($ent,0,-$dlen) ); + } elsif( 2*$dlen <= ( $off= rindex( $ent, $delim ) ) ) { + return( substr( $ent, 0, $off ), + undef, substr( $ent, $dlen+$off ) ); + } elsif( $parent ) { + return(); + } else { + return( $ent ); + } + } elsif( $delim eq substr($ent,0,$dlen) && "NONE" ne $self->Handle ) { + return( undef, substr($ent,$dlen) ); + } elsif( $self->{MEMBERS} && $self->_MembersHash->{$ent} ) { + return( substr($ent,0,-$dlen) ); + } elsif( 0 <= ( $off= index( $ent, $delim x 2 ) ) ) { + return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) ); + } elsif( $delim eq substr($ent,-$dlen) ) { + if( $parent + && 0 <= ( $off= rindex( $ent, $delim, length($ent)-2*$dlen ) ) ) { + return( substr($ent,0,$off), + undef, undef, substr($ent,$dlen+$off,-$dlen) ); + } else { + return( substr($ent,0,-$dlen) ); + } + } elsif( 0 <= ( $off= rindex( $ent, $delim ) ) ) { + return( + substr( $ent, 0, $off ), undef, substr( $ent, $dlen+$off ) ); + } else { + return( undef, undef, $ent ); + } +} + + +sub _FetchValue +{ + my $self= shift( @_ ); + my( $val, $createKey )= @_; + my( $data, $type ); + if( ( $data, $type )= $self->GetValue( $val ) ) { + return $self->ArrayValues ? [ $data, $type ] + : wantarray ? ( $data, $type ) + : $data; + } elsif( $createKey and $data= $self->new($val) ) { + return $data->TiedRef; + } else { + return (); + } +} + + +sub FETCH +{ + my $self= shift(@_); + my $ent= shift(@_); + my $delim= $self->Delimiter; + my( $key, $val, $ambig )= $self->_parseTiedEnt( $ent, $delim, 0 ); + my $sub; + if( defined($key) ) { + if( defined($self->{MEMBHASH}) + && $self->{MEMBHASH}->{$key.$delim} + && 0 <= index($key,$delim) ) { + return () + unless $sub= $self->new( $key, + {"Delimiter"=>$self->OS_Delimiter} ); + $sub->Delimiter($delim); + } else { + return () + unless $sub= $self->new( $key ); + } + } else { + $sub= $self; + } + if( defined($val) ) { + return $sub->_FetchValue( $val ); + } elsif( ! defined($ambig) ) { + return $sub->TiedRef; + } elsif( defined($key) ) { + return $sub->FETCH( $ambig ); + } else { + return $sub->_FetchValue( $ambig, "" ne $ambig ); + } +} + + +sub _FetchOld +{ + my( $self, $key )= @_; + my $old= $self->FETCH($key); + if( $old ) { + my $copy= {}; + %$copy= %$old; + return $copy; + } + # return $^E; + return _Err; +} + + +sub DELETE +{ + my $self= shift(@_); + my $ent= shift(@_); + my $delim= $self->Delimiter; + my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 ); + my $sub; + my $fast= defined(wantarray) ? $self->FastDelete : 2; + my $old= 1; # Value returned if FastDelete is set. + if( defined($key) + && ( defined($val) || defined($ambig) || defined($subkey) ) ) { + return () + unless $sub= $self->new( $key ); + } else { + $sub= $self; + } + if( defined($val) ) { + $old= $sub->GetValue($val) || _Err unless 2 <= $fast; + $sub->RegDeleteValue( $val ); + } elsif( defined($subkey) ) { + $old= $sub->_FetchOld( $subkey.$delim ) unless $fast; + $sub->RegDeleteKey( $subkey ); + } elsif( defined($ambig) ) { + if( defined($key) ) { + $old= $sub->DELETE($ambig); + } else { + $old= $sub->GetValue($ambig) || _Err unless 2 <= $fast; + if( defined( $old ) ) { + $sub->RegDeleteValue( $ambig ); + } else { + $old= $sub->_FetchOld( $ambig.$delim ) unless $fast; + $sub->RegDeleteKey( $ambig ); + } + } + } elsif( defined($key) ) { + $old= $sub->_FetchOld( $key.$delim ) unless $fast; + $sub->RegDeleteKey( $key ); + } else { + croak "${PACK}->DELETE: Key ($ent) can never be deleted"; + } + return $old; +} + + +sub SetValue +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $name= shift(@_); + my $data= shift(@_); + my( $type )= @_; + my $size; + if( ! defined($type) ) { + if( "ARRAY" eq ref($data) ) { + croak "${PACK}->SetValue: Value is array reference but ", + "no data type given" + unless 2 == @$data; + ( $data, $type )= @$data; + } else { + $type= REG_SZ; + } + } + $type= _constant($type,"registry value data type") if $type =~ /^REG_/; + if( REG_MULTI_SZ == $type && "ARRAY" eq ref($data) ) { + $data= join( "\0", @$data ) . "\0\0"; + ## $data= pack( "a*" x (1+@$data), map( $_."\0", @$data, "" ) ); + } elsif( ( REG_SZ == $type || REG_EXPAND_SZ == $type ) + && $self->FixSzNulls ) { + $data .= "\0" unless "\0" eq substr($data,0,-1); + } elsif( REG_DWORD == $type && $data =~ /^0x[0-9a-fA-F]{3,}$/ ) { + $data= pack( "L", hex($data) ); + # We could to $data=pack("L",$data) for REG_DWORD but I see + # no nice way to always distinguish when to do this or not. + } + return $self->RegSetValueEx( $name, 0, $type, $data, length($data) ); +} + + +sub StoreKey +{ + my $this= shift(@_); + $this= tied(%$this) if ref($this) && tied(%$this); + my $subKey= shift(@_); + my $data= shift(@_); + my $ent; + my $self; + if( ! ref($data) || "$data" !~ /(^|=)HASH/ ) { + croak "${PACK}->StoreKey: For ", $this->Path.$subKey, ",\n", + " subkey data must be a HASH reference"; + } + if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) { + $self= $this->CreateKey( $subKey, delete $$data{""} ); + } else { + $self= $this->CreateKey( $subKey ); + } + return () if ! defined($self); + foreach $ent ( keys(%$data) ) { + return () + unless $self->STORE( $ent, $$data{$ent} ); + } + return $self; +} + + +# = { "" => {OPT=>VAL}, "val"=>[], "key"=>{} } creates a new key +# = "string" creates a new REG_SZ value +# = [ data, type ] creates a new value +sub STORE +{ + my $self= shift(@_); + my $ent= shift(@_); + my $data= shift(@_); + my $delim= $self->Delimiter; + my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 ); + my $sub; + if( defined($key) + && ( defined($val) || defined($ambig) || defined($subkey) ) ) { + return () + unless $sub= $self->new( $key ); + } else { + $sub= $self; + } + if( defined($val) ) { + croak "${PACK}->STORE: For ", $sub->Path.$delim.$val, ",\n", + " value data cannot be a HASH reference" + if ref($data) && "$data" =~ /(^|=)HASH/; + $sub->SetValue( $val, $data ); + } elsif( defined($subkey) ) { + croak "${PACK}->STORE: For ", $sub->Path.$subkey.$delim, ",\n", + " subkey data must be a HASH reference" + unless ref($data) && "$data" =~ /(^|=)HASH/; + $sub->StoreKey( $subkey, $data ); + } elsif( defined($ambig) ) { + if( ref($data) && "$data" =~ /(^|=)HASH/ ) { + $sub->StoreKey( $ambig, $data ); + } else { + $sub->SetValue( $ambig, $data ); + } + } elsif( defined($key) ) { + croak "${PACK}->STORE: For ", $sub->Path.$key.$delim, ",\n", + " subkey data must be a HASH reference" + unless ref($data) && "$data" =~ /(^|=)HASH/; + $sub->StoreKey( $key, $data ); + } else { + croak "${PACK}->STORE: Key ($ent) can never be created nor set"; + } +} + + +sub EXISTS +{ + my $self= shift(@_); + my $ent= shift(@_); + return defined( $self->FETCH($ent) ); +} + + +sub FIRSTKEY +{ + my $self= shift(@_); + my $members= $self->_MemberNames; + $self->{PREVIDX}= 0; + return @{$members} ? $members->[0] : undef; +} + + +sub NEXTKEY +{ + my $self= shift(@_); + my $prev= shift(@_); + my $idx= $self->{PREVIDX}; + my $members= $self->_MemberNames; + if( ! defined($idx) || $prev ne $members->[$idx] ) { + $idx= 0; + while( $idx < @$members && $prev ne $members->[$idx] ) { + $idx++; + } + } + $self->{PREVIDX}= ++$idx; + return $members->[$idx]; +} + + +sub DESTROY +{ + my $self= shift(@_); + return if tied(%$self); + my $unload; + eval { $unload= $self->{UNLOADME}; 1 } + or return; + my $debug= $ENV{DEBUG_TIE_REGISTRY}; + if( defined($debug) ) { + if( 1 < $debug ) { + my $hand= $self->Handle; + my $dep= $self->{DEPENDON}; + carp "${PACK} destroying ", $self->Path, " (", + "NONE" eq $hand ? $hand : sprintf("0x%lX",$hand), ")", + defined($dep) ? (" [depends on ",$dep->Path,"]") : (); + } else { + warn "${PACK} destroying ", $self->Path, ".\n"; + } + } + $self->RegCloseKey + unless "NONE" eq $self->Handle; + if( defined($unload) ) { + if( defined($debug) && 1 < $debug ) { + my( $obj, $subKey, $file )= @$unload; + warn "Unloading ", $self->Path, + " (from ", $obj->Path, ", $subKey)...\n"; + } + $self->UnLoad + || warn "Couldn't unload ", $self->Path, ": ", _ErrMsg, "\n"; + ## carp "Never unloaded ${PACK}::Load($$unload[2])"; + } + #delete $self->{DEPENDON}; +} + + +use vars qw( @CreateKey_Opts %CreateKey_Opts %_KeyDispNames ); +@CreateKey_Opts= qw( Access Class Options Delimiter + Disposition Security Volatile Backup ); +@CreateKey_Opts{@CreateKey_Opts}= (1) x @CreateKey_Opts; +%_KeyDispNames= ( REG_CREATED_NEW_KEY() => "REG_CREATED_NEW_KEY", + REG_OPENED_EXISTING_KEY() => "REG_OPENED_EXISTING_KEY" ); + +sub CreateKey +{ + my $self= shift(@_); + my $tied= tied(%$self); + $self= tied(%$self) if $tied; + my( $subKey, $opts )= @_; + my( $sam )= $self->Access; + my( $delim )= $self->Delimiter; + my( $class )= ""; + my( $flags )= 0; + my( $secure )= []; + my( $garb )= []; + my( $result )= \$garb; + my( $handle )= 0; + if( @_ < 1 || 2 < @_ + || 2 == @_ && "HASH" ne ref($opts) ) { + croak "Usage: \$new= \$old->CreateKey( \$subKey, {OPT=>VAL,...} );\n", + " options: @CreateKey_Opts\nCalled"; + } + if( defined($opts) ) { + $sam= $opts->{"Access"} if defined($opts->{"Access"}); + $class= $opts->{Class} if defined($opts->{Class}); + $flags= $opts->{Options} if defined($opts->{Options}); + $delim= $opts->{"Delimiter"} if defined($opts->{"Delimiter"}); + $secure= $opts->{Security} if defined($opts->{Security}); + if( defined($opts->{Disposition}) ) { + "SCALAR" eq ref($opts->{Disposition}) + or croak "${PACK}->CreateKey option `Disposition'", + " must provide a scalar reference"; + $result= $opts->{Disposition}; + } + if( 0 == $flags ) { + $flags |= REG_OPTION_VOLATILE + if defined($opts->{Volatile}) && $opts->{Volatile}; + $flags |= REG_OPTION_BACKUP_RESTORE + if defined($opts->{Backup}) && $opts->{Backup}; + } + } + my $subPath= ref($subKey) ? $subKey : $self->_split($subKey,$delim); + $subKey= join( $self->OS_Delimiter, @$subPath ); + $self->RegCreateKeyEx( $subKey, 0, $class, $flags, $sam, + $secure, $handle, $$result ) + or return (); + if( ! ref($$result) && $self->DualTypes ) { + $$result= _DualVal( \%_KeyDispNames, $$result ); + } + my $new= $self->_new( $handle, [ @{$self->_Path}, @{$subPath} ] ); + $new->{ACCESS}= $sam; + $new->{DELIM}= $delim; + $new= $new->TiedRef if $tied; + return $new; +} + + +use vars qw( $Load_Cnt @Load_Opts %Load_Opts ); +$Load_Cnt= 0; +@Load_Opts= qw(NewSubKey); +@Load_Opts{@Load_Opts}= (1) x @Load_Opts; + +sub Load +{ + my $this= shift(@_); + my $tied= ref($this) && tied(%$this); + $this= tied(%$this) if $tied; + my( $file, $subKey, $opts )= @_; + if( 2 == @_ && "HASH" eq ref($subKey) ) { + $opts= $subKey; + undef $subKey; + } + @_ < 1 || 3 < @_ || defined($opts) && "HASH" ne ref($opts) + and croak "Usage: \$key= ", + "${PACK}->Load( \$fileName, [\$newSubKey,] {OPT=>VAL...} );\n", + " options: @Load_Opts @new_Opts\nCalled"; + if( defined($opts) && exists($opts->{NewSubKey}) ) { + $subKey= delete $opts->{NewSubKey}; + } + if( ! defined( $subKey ) ) { + if( "" ne $this->Machine ) { + ( $this )= $this->_connect( [$this->Machine,"LMachine"] ); + } else { + ( $this )= $this->_rootKey( "LMachine" ); # Could also be "Users" + } + $subKey= "PerlTie:$$." . ++$Load_Cnt; + } + $this->RegLoadKey( $subKey, $file ) + or return (); + my $self= $this->new( $subKey, defined($opts) ? $opts : () ); + if( ! defined( $self ) ) { + { my $err= Win32::GetLastError(); + #{ local( $^E ); #} + $this->RegUnLoadKey( $subKey ) or carp + "Can't unload $subKey from ", $this->Path, ": ", _ErrMsg, "\n"; + Win32::SetLastError($err); + } + return (); + } + $self->{UNLOADME}= [ $this, $subKey, $file ]; + $self= $self->TiedRef if $tied; + return $self; +} + + +sub UnLoad +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$key->UnLoad;"; + my $unload= $self->{UNLOADME}; + "ARRAY" eq ref($unload) + or croak "${PACK}->UnLoad called on a key which was not Load()ed"; + my( $obj, $subKey, $file )= @$unload; + $self->RegCloseKey; + return Win32API::Registry::RegUnLoadKey( $obj->Handle, $subKey ); +} + + +sub AllowSave +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + return $self->AllowPriv( "SeBackupPrivilege", @_ ); +} + + +sub AllowLoad +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + return $self->AllowPriv( "SeRestorePrivilege", @_ ); +} + + +# RegNotifyChangeKeyValue( hKey, bWatchSubtree, iNotifyFilter, hEvent, bAsync ) + + +sub RegCloseKey { my $self= shift(@_); + Win32API::Registry::RegCloseKey $self->Handle, @_; } +sub RegConnectRegistry { my $self= shift(@_); + Win32API::Registry::RegConnectRegistry @_; } +sub RegCreateKey { my $self= shift(@_); + Win32API::Registry::RegCreateKey $self->Handle, @_; } +sub RegCreateKeyEx { my $self= shift(@_); + Win32API::Registry::RegCreateKeyEx $self->Handle, @_; } +sub RegDeleteKey { my $self= shift(@_); + Win32API::Registry::RegDeleteKey $self->Handle, @_; } +sub RegDeleteValue { my $self= shift(@_); + Win32API::Registry::RegDeleteValue $self->Handle, @_; } +sub RegEnumKey { my $self= shift(@_); + Win32API::Registry::RegEnumKey $self->Handle, @_; } +sub RegEnumKeyEx { my $self= shift(@_); + Win32API::Registry::RegEnumKeyEx $self->Handle, @_; } +sub RegEnumValue { my $self= shift(@_); + Win32API::Registry::RegEnumValue $self->Handle, @_; } +sub RegFlushKey { my $self= shift(@_); + Win32API::Registry::RegFlushKey $self->Handle, @_; } +sub RegGetKeySecurity { my $self= shift(@_); + Win32API::Registry::RegGetKeySecurity $self->Handle, @_; } +sub RegLoadKey { my $self= shift(@_); + Win32API::Registry::RegLoadKey $self->Handle, @_; } +sub RegNotifyChangeKeyValue { my $self= shift(@_); + Win32API::Registry::RegNotifyChangeKeyValue $self->Handle, @_; } +sub RegOpenKey { my $self= shift(@_); + Win32API::Registry::RegOpenKey $self->Handle, @_; } +sub RegOpenKeyEx { my $self= shift(@_); + Win32API::Registry::RegOpenKeyEx $self->Handle, @_; } +sub RegQueryInfoKey { my $self= shift(@_); + Win32API::Registry::RegQueryInfoKey $self->Handle, @_; } +sub RegQueryMultipleValues { my $self= shift(@_); + Win32API::Registry::RegQueryMultipleValues $self->Handle, @_; } +sub RegQueryValue { my $self= shift(@_); + Win32API::Registry::RegQueryValue $self->Handle, @_; } +sub RegQueryValueEx { my $self= shift(@_); + Win32API::Registry::RegQueryValueEx $self->Handle, @_; } +sub RegReplaceKey { my $self= shift(@_); + Win32API::Registry::RegReplaceKey $self->Handle, @_; } +sub RegRestoreKey { my $self= shift(@_); + Win32API::Registry::RegRestoreKey $self->Handle, @_; } +sub RegSaveKey { my $self= shift(@_); + Win32API::Registry::RegSaveKey $self->Handle, @_; } +sub RegSetKeySecurity { my $self= shift(@_); + Win32API::Registry::RegSetKeySecurity $self->Handle, @_; } +sub RegSetValue { my $self= shift(@_); + Win32API::Registry::RegSetValue $self->Handle, @_; } +sub RegSetValueEx { my $self= shift(@_); + Win32API::Registry::RegSetValueEx $self->Handle, @_; } +sub RegUnLoadKey { my $self= shift(@_); + Win32API::Registry::RegUnLoadKey $self->Handle, @_; } +sub AllowPriv { my $self= shift(@_); + Win32API::Registry::AllowPriv @_; } + + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; + +__END__ + +=pod + +=head1 NAME + +Win32::TieRegistry - Manipulate the Win32 Registry + +=head1 SYNOPSIS + + use Win32::TieRegistry 0.20 ( UseOptionName=>UseOptionValue[,...] ); + + $Registry->SomeMethodCall(arg1,...); + + $subKey= $Registry->{"Key\\SubKey\\"}; + $valueData= $Registry->{"Key\\SubKey\\\\ValueName"}; + $Registry->{"Key\\SubKey\\"}= { "NewSubKey" => {...} }; + $Registry->{"Key\\SubKey\\\\ValueName"}= "NewValueData"; + $Registry->{"\\ValueName"}= [ pack("fmt",$data), REG_DATATYPE ]; + +=head1 EXAMPLES + + use Win32::TieRegistry( Delimiter=>"#", ArrayValues=>0 ); + $pound= $Registry->Delimiter("/"); + $diskKey= $Registry->{"LMachine/System/Disk/"} + or die "Can't read LMachine/System/Disk key: $^E\n"; + $data= $diskKey->{"/Information"} + or die "Can't read LMachine/System/Disk//Information value: $^E\n"; + $remoteKey= $Registry->{"//ServerA/LMachine/System/"} + or die "Can't read //ServerA/LMachine/System/ key: $^E\n"; + $remoteData= $remoteKey->{"Disk//Information"} + or die "Can't read ServerA's System/Disk//Information value: $^E\n"; + foreach $entry ( keys(%$diskKey) ) { + ... + } + foreach $subKey ( $diskKey->SubKeyNames ) { + ... + } + $diskKey->AllowSave( 1 ); + $diskKey->RegSaveKey( "C:/TEMP/DiskReg", [] ); + +=head1 DESCRIPTION + +The I<Win32::TieRegistry> module lets you manipulate the Registry +via objects [as in "object oriented"] or via tied hashes. But +you will probably mostly use a combination reference, that is, a +reference to a tied hash that has also been made an object so that +you can mix both access methods [as shown above]. + +If you did not get this module as part of L<libwin32>, you might +want to get a recent version of L<libwin32> from CPAN which should +include this module and the I<Win32API::Registry> module that it +uses. + +Skip to the L<SUMMARY> section if you just want to dive in and start +using the Registry from Perl. + +Accessing and manipulating the registry is extremely simple using +I<Win32::TieRegistry>. A single, simple expression can return +you almost any bit of information stored in the Registry. +I<Win32::TieRegistry> also gives you full access to the "raw" +underlying API calls so that you can do anything with the Registry +in Perl that you could do in C. But the "simple" interface has +been carefully designed to handle almost all operations itself +without imposing arbitrary limits while providing sensible +defaults so you can list only the parameters you care about. + +But first, an overview of the Registry itself. + +=head2 The Registry + +The Registry is a forest: a collection of several tree structures. +The root of each tree is a key. These root keys are identified by +predefined constants whose names start with "HKEY_". Although all +keys have a few attributes associated with each [a class, a time +stamp, and security information], the most important aspect of keys +is that each can contain subkeys and can contain values. + +Each subkey has a name: a string which cannot be blank and cannot +contain the delimiter character [backslash: C<'\\'>] nor nul +[C<'\0'>]. Each subkey is also a key and so can contain subkeys +and values [and has a class, time stamp, and security information]. + +Each value has a name: a string which B<can> be blank and B<can> +contain the delimiter character [backslash: C<'\\'>] and any +character except for null, C<'\0'>. Each value also has data +associated with it. Each value's data is a contiguous chunk of +bytes, which is exactly what a Perl string value is so Perl +strings will usually be used to represent value data. + +Each value also has a data type which says how to interpret the +value data. The primary data types are: + +=over + +=item REG_SZ + +A null-terminated string. + +=item REG_EXPAND_SZ + +A null-terminated string which contains substrings consisting of a +percent sign [C<'%'>], an environment variable name, then a percent +sign, that should be replaced with the value associate with that +environment variable. The system does I<not> automatically do this +substitution. + +=item REG_BINARY + +Some arbitrary binary value. You can think of these as being +"packed" into a string. + +If your system has the L<SetDualVar> module installed, +the C<DualBinVals()> option wasn't turned off, and you +fetch a C<REG_BINARY> value of 4 bytes or fewer, then +you can use the returned value in a numeric context to +get at the "unpacked" numeric value. See C<GetValue()> +for more information. + +=item REG_MULTI_SZ + +Several null-terminated strings concatenated together with an +extra trailing C<'\0'> at the end of the list. Note that the list +can include empty strings so use the value's length to determine +the end of the list, not the first occurrence of C<'\0\0'>. +It is best to set the C<SplitMultis()> option so I<Win32::TieRegistry> +will split these values into an array of strings for you. + +=item REG_DWORD + +A long [4-byte] integer value. These values are expected either +packed into a 4-character string or as a hex string of B<more than> +4 characters [but I<not> as a numeric value, unfortunately, as there is +no sure way to tell a numeric value from a packed 4-byte string that +just happens to be a string containing a valid numeric value]. + +How such values are returned depends on the C<DualBinVals()> and +C<DWordsToHex()> options. See C<GetValue()> for details. + +=back + +In the underlying Registry calls, most places which take a +subkey name also allow you to pass in a subkey "path" -- a +string of several subkey names separated by the delimiter +character, backslash [C<'\\'>]. For example, doing +C<RegOpenKeyEx(HKEY_LOCAL_MACHINE,"SYSTEM\\DISK",...)> is much +like opening the C<"SYSTEM"> subkey of C<HKEY_LOCAL_MACHINE>, +then opening its C<"DISK"> subkey, then closing the C<"SYSTEM"> +subkey. + +All of the I<Win32::TieRegistry> features allow you to use your +own delimiter in place of the system's delimiter, [C<'\\'>]. In +most of our examples we will use a forward slash [C<'/'>] as our +delimiter as it is easier to read and less error prone to use when +writing Perl code since you have to type two backslashes for each +backslash you want in a string. Note that this is true even when +using single quotes -- C<'\\HostName\LMachine\'> is an invalid +string and must be written as C<'\\\\HostName\\LMachine\\'>. + +You can also connect to the registry of other computers on your +network. This will be discussed more later. + +Although the Registry does not have a single root key, the +I<Win32::TieRegistry> module creates a virtual root key for you +which has all of the I<HKEY_*> keys as subkeys. + +=head2 Tied Hashes Documentation + +Before you can use a tied hash, you must create one. One way to +do that is via: + + use Win32::TieRegistry ( TiedHash => '%RegHash' ); + +which exports a C<%RegHash> variable into your package and ties it +to the virtual root key of the Registry. An alternate method is: + + my %RegHash; + use Win32::TieRegistry ( TiedHash => \%RegHash ); + +There are also several ways you can tie a hash variable to any +other key of the Registry, which are discussed later. + +Note that you will most likely use C<$Registry> instead of using +a tied hash. C<$Registry> is a reference to a hash that has +been tied to the virtual root of your computer's Registry [as if, +C<$Registry= \%RegHash>]. So you would use C<$Registry-E<gt>{Key}> +rather than C<$RegHash{Key}> and use C<keys %{$Registry}> rather +than C<keys %RegHash>, for example. + +For each hash which has been tied to a Registry key, the Perl +C<keys> function will return a list containing the name of each +of the key's subkeys with a delimiter character appended to it and +containing the name of each of the key's values with a delimiter +prepended to it. For example: + + keys( %{ $Registry->{"HKEY_CLASSES_ROOT\\batfile\\"} } ) + +might yield the following list value: + + ( "DefaultIcon\\", # The subkey named "DefaultIcon" + "shell\\", # The subkey named "shell" + "shellex\\", # The subkey named "shellex" + "\\", # The default value [named ""] + "\\EditFlags" ) # The value named "EditFlags" + +For the virtual root key, short-hand subkey names are used as +shown below. You can use the short-hand name, the regular +I<HKEY_*> name, or any numeric value to access these keys, but +the short-hand names are all that will be returned by the C<keys> +function. + +=over + +=item "Classes" for HKEY_CLASSES_ROOT + +Contains mappings between file name extensions and the uses +for such files along with configuration information for COM +[MicroSoft's Common Object Model] objects. Usually a link to +the C<"SOFTWARE\\Classes"> subkey of the C<HKEY_LOCAL_MACHINE> +key. + +=item "CUser" for HKEY_CURRENT_USER + +Contains information specific to the currently logged-in user. +Mostly software configuration information. Usually a link to +a subkey of the C<HKEY_USERS> key. + +=item "LMachine" for HKEY_LOCAL_MACHINE + +Contains all manner of information about the computer. + +=item "Users" for HKEY_USERS + +Contains one subkey, C<".DEFAULT">, which gets copied to a new +subkey whenever a new user is added. Also contains a subkey for +each user of the system, though only those for active users +[usually only one] are loaded at any given time. + +=item "PerfData" for HKEY_PERFORMANCE_DATA + +Used to access data about system performance. Access via this key +is "special" and all but the most carefully constructed calls will +fail, usually with C<ERROR_INSUFFICIENT_BUFFER>. For example, you +can't enumerate key names without also enumerating values which +require huge buffers but the exact buffer size required cannot be +determined beforehand because C<RegQueryInfoKey()> B<always> fails +with C<ERROR_INSUFFICIENT_BUFFER> for C<HKEY_PERFORMANCE_DATA> no +matter how it is called. So it is currently not very useful to +tie a hash to this key. You can use it to create an object to use +for making carefully constructed calls to the underlying Reg*() +routines. + +=item "CConfig" for HKEY_CURRENT_CONFIG + +Contains minimal information about the computer's current +configuration that is required very early in the boot process. +For example, setting for the display adapter such as screen +resolution and refresh rate are found in here. + +=item "DynData" for HKEY_DYN_DATA + +Dynamic data. We have found no documentation for this key. + +=back + +A tied hash is much like a regular hash variable in Perl -- you give +it a key string inside braces, [C<{> and C<}>], and it gives you +back a value [or lets you set a value]. For I<Win32::TieRegistry> +hashes, there are two types of values that will be returned. + +=over + +=item SubKeys + +If you give it a string which represents a subkey, then it will +give you back a reference to a hash which has been tied to that +subkey. It can't return the hash itself, so it returns a +reference to it. It also blesses that reference so that it is +also an object so you can use it to call method functions. + +=item Values + +If you give it a string which is a value name, then it will give +you back a string which is the data for that value. Alternately, +you can request that it give you both the data value string and +the data value type [we discuss how to request this later]. In +this case, it would return a reference to an array where the value +data string is element C<[0]> and the value data type is element +C<[1]>. + +=back + +The key string which you use in the tied hash must be interpreted +to determine whether it is a value name or a key name or a path +that combines several of these or even other things. There are +two simple rules that make this interpretation easy and +unambiguous: + + Put a delimiter after each key name. + Put a delimiter in front of each value name. + +Exactly how the key string will be interpreted is governed by the +following cases, in the order listed. These cases are designed +to "do what you mean". Most of the time you won't have to think +about them, especially if you follow the two simple rules above. +After the list of cases we give several examples which should be +clear enough so feel free to skip to them unless you are worried +about the details. + +=over + +=item Remote machines + +If the hash is tied to the virtual root of the registry [or the +virtual root of a remote machine's registry], then we treat hash +key strings which start with the delimiter character specially. + +If the hash key string starts with two delimiters in a row, then +those should be immediately followed by the name of a remote +machine whose registry we wish to connect to. That can be +followed by a delimiter and more subkey names, etc. If the +machine name is not following by anything, then a virtual root +for the remote machine's registry is created, a hash is tied to +it, and a reference to that hash it is returned. + +=item Hash key string starts with the delimiter + +If the hash is tied to a virtual root key, then the leading +delimiter is ignored. It should be followed by a valid Registry +root key name [either a short-hand name like C<"LMachine">, an +I<HKEY_*> value, or a numeric value]. This alternate notation is +allowed in order to be more consistent with the C<Open()> method +function. + +For all other Registry keys, the leading delimiter indicates +that the rest of the string is a value name. The leading +delimiter is stripped and the rest of the string [which can +be empty and can contain more delimiters] is used as a value +name with no further parsing. + +=item Exact match with direct subkey name followed by delimiter + +If you have already called the Perl C<keys> function on the tied +hash [or have already called C<MemberNames> on the object] and the +hash key string exactly matches one of the strings returned, then +no further parsing is done. In other words, if the key string +exactly matches the name of a direct subkey with a delimiter +appended, then a reference to a hash tied to that subkey is +returned [but only if C<keys> or C<MemberNames> has already +been called for that tied hash]. + +This is only important if you have selected a delimiter other than +the system default delimiter and one of the subkey names contains +the delimiter you have chosen. This rule allows you to deal with +subkeys which contain your chosen delimiter in their name as long +as you only traverse subkeys one level at a time and always +enumerate the list of members before doing so. + +The main advantage of this is that Perl code which recursively +traverses a hash will work on hashes tied to Registry keys even if +a non-default delimiter has been selected. + +=item Hash key string contains two delimiters in a row + +If the hash key string contains two [or more] delimiters in a row, +then the string is split between the first pair of delimiters. +The first part is interpreted as a subkey name or a path of subkey +names separated by delimiters and with a trailing delimiter. The +second part is interpreted as a value name with one leading +delimiter [any extra delimiters are considered part of the value +name]. + +=item Hash key string ends with a delimiter + +If the key string ends with a delimiter, then it is treated +as a subkey name or path of subkey names separated by delimiters. + +=item Hash key string contains a delimiter + +If the key string contains a delimiter, then it is split after +the last delimiter. The first part is treated as a subkey name or +path of subkey names separated by delimiters. The second part +is ambiguous and is treated as outlined in the next item. + +=item Hash key string contains no delimiters + +If the hash key string contains no delimiters, then it is ambiguous. + +If you are reading from the hash [fetching], then we first use the +key string as a value name. If there is a value with a matching +name in the Registry key which the hash is tied to, then the value +data string [and possibly the value data type] is returned. +Otherwise, we retry by using the hash key string as a subkey name. +If there is a subkey with a matching name, then we return a +reference to a hash tied to that subkey. Otherwise we return +C<undef>. + +If you are writing to the hash [storing], then we use the key +string as a subkey name only if the value you are storing is a +reference to a hash value. Otherwise we use the key string as +a value name. + +=back + +=head3 Examples + +Here are some examples showing different ways of accessing Registry +information using references to tied hashes: + +=over + +=item Canonical value fetch + + $tip18= $Registry->{"HKEY_LOCAL_MACHINE\\Software\\Microsoft\\" + . 'Windows\\CurrentVersion\\Explorer\\Tips\\\\18'}; + +Should return the text of important tip number 18. Note that two +backslashes, C<"\\">, are required to get a single backslash into +a Perl double-quoted or single-qouted string. Note that C<"\\"> +is appended to each key name [C<"HKEY_LOCAL_MACHINE"> through +C<"Tips">] and C<"\\"> is prepended to the value name, C<"18">. + +=item Changing your delimiter + + $Registry->Delimiter("/"); + $tip18= $Registry->{"HKEY_LOCAL_MACHINE/Software/Microsoft/" + . 'Windows/CurrentVersion/Explorer/Tips//18'}; + +This usually makes things easier to read when working in Perl. +All remaining examples will assume the delimiter has been changed +as above. + +=item Using intermediate keys + + $ms= $Registry->{"LMachine/Software/Microsoft/"}; + $tips= $ms->{"Windows/CurrentVersion/Explorer/Tips/"}; + $tip18= $winlogon->{"/18"}; + +Same as above but opens more keys into the Registry which lets you +efficiently re-access those intermediate keys. This is slightly +less efficient if you never reuse those intermediate keys. + +=item Chaining in a single statement + + $tip18= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"}->{"/18"}; + +Like above, this creates intermediate key objects then uses +them to access other data. Once this statement finishes, the +intermediate key objects are destroyed. Several handles into +the Registry are opened and closed by this statement so it is +less efficient but there are times when this will be useful. + +=item Even less efficient example of chaining + + $tip18= $Registry->{"LMachine/Software/Microsoft"}-> + {"Windows/CurrentVersion/Explorer/Tips"}->{"/18"}; + +Because we left off the trailing delimiters, I<Win32::TieRegistry> +doesn't know whether final names, C<"Microsoft"> and C<"Tips">, +are subkey names or value names. So this statement ends up +executing the same code as the next one. + +=item What the above really does + + $tip18= $Registry->{"LMachine/Software/"}->{"Microsoft"}-> + {"Windows/CurrentVersion/Explorer/"}->{"Tips"}->{"/18"}; + +With more chains to go through, more temporary objects are created +and later destroyed than in our first chaining example. Also, +when C<"Microsoft"> is looked up, I<Win32::TieRegistry> first +tries to open it as a value and fails then tries it as a subkey. +The same is true for when it looks up C<"Tips">. + +=item Getting all of the tips + + $tips= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"} + or die "Can't find the Windows tips: $^E\n"; + foreach( keys %$tips ) { + print "$_: ", $tips->{$_}, "\n"; + } + +First notice that we actually check for failure for the first +time. We are assuming that the C<"Tips"> key contains no subkeys. +Otherwise the C<print> statement would show something like +C<"Win32::TieRegistry=HASH(0xc03ebc)"> for each subkey. + +The output from the above code will start something like: + + /0: If you don't know how to do something,[...] + +=back + +=head3 Deleting items + +You can use the Perl C<delete> function to delete a value from a +Registry key or to delete a subkey as long that subkey contains +no subkeys of its own. See L<More Examples>, below, for more +information. + +=head3 Storing items + +You can use the Perl assignment operator [C<=>] to create new +keys, create new values, or replace values. The values you store +should be in the same format as the values you would fetch from a +tied hash. For example, you can use a single assignment statement +to copy an entire Registry tree. The following statement: + + $Registry->{"LMachine/Software/Classes/Tie_Registry/"}= + $Registry->{"LMachine/Software/Classes/batfile/"}; + +creates a C<"Tie_Registry"> subkey under the C<"Software\\Classes"> +subkey of the C<HKEY_LOCAL_MACHINE> key. Then it populates it +with copies of all of the subkeys and values in the C<"batfile"> +subkey and all of its subkeys. Note that you need to have +called C<$Registry-E<gt>ArrayValues(1)> for the proper value data +type information to be copied. Note also that this release of +I<Win32::TieRegistry> does not copy key attributes such as class +name and security information [this is planned for a future release]. + +The following statement creates a whole subtree in the Registry: + + $Registry->{"LMachine/Software/FooCorp/"}= { + "FooWriter/" => { + "/Version" => "4.032", + "Startup/" => { + "/Title" => "Foo Writer Deluxe ][", + "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ], + "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ], + }, + "Compatibility/" => { + "/AutoConvert" => "Always", + "/Default Palette" => "Windows Colors", + }, + }, + "/License", => "0123-9C8EF1-09-FC", + }; + +Note that all but the last Registry key used on the left-hand +side of the assignment [that is, "LMachine/Software/" but not +"FooCorp/"] must already exist for this statement to succeed. + +By using the leading a trailing delimiters on each subkey name and +value name, I<Win32::TieRegistry> will tell you if you try to assign +subkey information to a value or visa-versa. + +=head3 More examples + +=over + +=item Adding a new tip + + $tips= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"} + or die "Can't find the Windows tips: $^E\n"; + $tips{'/186'}= "Be very careful when making changes to the Registry!"; + +=item Deleting our new tip + + $tips= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"} + or die "Can't find the Windows tips: $^E\n"; + $tip186= delete $tips{'/186'}; + +Note that Perl's C<delete> function returns the value that was deleted. + +=item Adding a new tip differently + + $Registry->{"LMachine/Software/Microsoft/" . + "Windows/CurrentVersion/Explorer/Tips//186"}= + "Be very careful when making changes to the Registry!"; + +=item Deleting differently + + $tip186= delete $Registry->{"LMachine/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips//186"}; + +Note that this only deletes the tail of what we looked up, the +C<"186"> value, not any of the keys listed. + +=item Deleting a key + +WARNING: The following code will delete all information about the +current user's tip preferences. Actually executing this command +would probably cause the user to see the Welcome screen the next +time they log in and may cause more serious problems. This +statement is shown as an example only and should not be used when +experimenting. + + $tips= delete $Registry->{"CUser/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips/"}; + +This deletes the C<"Tips"> key and the values it contains. The +C<delete> function will return a reference to a hash [not a tied +hash] containing the value names and value data that were deleted. + +The information to be returned is copied from the Registry into a +regular Perl hash before the key is deleted. If the key has many +subkeys, this copying could take a significant amount of memory +and/or processor time. So you can disable this process by calling +the C<FastDelete> member function: + + $prevSetting= $regKey->FastDelete(1); + +which will cause all subsequent delete operations via C<$regKey> +to simply return a true value if they succeed. This optimization +is automatically done if you use C<delete> in a void context. + +=item Technical notes on deleting + +If you use C<delete> to delete a Registry key or value and use +the return value, then I<Win32::TieRegistry> usually looks up the +current contents of that key or value so they can be returned if +the deletion is successful. If the deletion succeeds but the +attempt to lookup the old contents failed, then the return value +of C<delete> will be C<$^E> from the failed part of the operation. + +=item Undeleting a key + + $Registry->{"LMachine/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips/"}= $tips; + +This adds back what we just deleted. Note that this version of +I<Win32::TieRegistry> will use defaults for the key attributes +[such as class name and security] and will not restore the +previous attributes. + +=item Not deleting a key + +WARNING: Actually executing the following code could cause +serious problems. This statement is shown as an example only and +should not be used when experimenting. + + $res= delete $Registry->{"CUser/Software/Microsoft/Windows/"} + defined($res) || die "Can't delete URL key: $^E\n"; + +Since the "Windows" key should contain subkeys, that C<delete> +statement should make no changes to the Registry, return C<undef>, +and set C<$^E> to "Access is denied". + +=item Not deleting again + + $tips= $Registry->{"CUser/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips/"}; + delete $tips; + +The Perl C<delete> function requires that its argument be an +expression that ends in a hash element lookup [or hash slice], +which is not the case here. The C<delete> function doesn't +know which hash $tips came from and so can't delete it. + +=back + +=head2 Objects Documentation + +The following member functions are defined for use on +I<Win32::TieRegistry> objects: + +=over + +=item new + +The C<new> method creates a new I<Win32::TieRegistry> object. +C<new> is mostly a synonym for C<Open()> so see C<Open()> below for +information on what arguments to pass in. Examples: + + $machKey= Win32::TieRegistry->new("LMachine") + or die "Can't access HKEY_LOCAL_MACHINE key: $^E\n"; + $userKey= Win32::TieRegistry->new("CUser") + or die "Can't access HKEY_CURRENT_USER key: $^E\n"; + +Note that calling C<new> via a reference to a tied hash returns +a simple object, not a reference to a tied hash. + +=item Open + +=item $subKey= $key->Open( $sSubKey, $rhOptions ) + +The C<Open> method opens a Registry key and returns a new +I<Win32::TieRegistry> object associated with that Registry key. +If C<Open> is called via a reference to a tied hash, then C<Open> +returns another reference to a tied hash. Otherwise C<Open> +returns a simple object and you should then use C<TiedRef> to get +a reference to a tied hash. + +C<$sSubKey> is a string specifying a subkey to be opened. +Alternately C<$sSubKey> can be a reference to an array value +containing the list of increasingly deep subkeys specifying the +path to the subkey to be opened. + +C<$rhOptions> is an optional reference to a hash containing extra +options. The C<Open> method supports two options, C<"Delimiter"> +and C<"Access">, and C<$rhOptions> should have only have zero or +more of these strings as keys. See the "Examples" section below +for more information. + +The C<"Delimiter"> option specifies what string [usually a single +character] will be used as the delimiter to be appended to subkey +names and prepended to value names. If this option is not specified, +the new key [C<$subKey>] inherits the delimiter of the old key +[C<$key>]. + +The C<"Access"> option specifies what level of access to the +Registry key you wish to have once it has been opened. If this +option is not specified, the new key [C<$subKey>] is opened with +the same access level used when the old key [C<$key>] was opened. +The virtual root of the Registry pretends it was opened with +access C<KEY_READ()|KEY_WRITE()> so this is the default access when +opening keys directory via C<$Registry>. If you don't plan on +modifying a key, you should open it with C<KEY_READ> access as +you may not have C<KEY_WRITE> access to it or some of its subkeys. + +If the C<"Access"> option value is a string that starts with +C<"KEY_">, then it should match B<one> of the predefined access +levels [probably C<"KEY_READ">, C<"KEY_WRITE">, or +C<"KEY_ALL_ACCESS">] exported by the I<Win32API::Registry> module. +Otherwise, a numeric value is expected. For maximum flexibility, +include C<use Win32::TieRegistry qw(:KEY_);>, for example, near +the top of your script so you can specify more complicated access +levels such as C<KEY_READ()|KEY_WRITE()>. + +If C<$sSubKey> does not begin with the delimiter [or C<$sSubKey> +is an array reference], then the path to the subkey to be opened +will be relative to the path of the original key [C<$key>]. If +C<$sSubKey> begins with a single delimiter, then the path to the +subkey to be opened will be relative to the virtual root of the +Registry on whichever machine the original key resides. If +C<$sSubKey> begins with two consecutive delimiters, then those +must be followed by a machine name which causes the C<Connect()> +method function to be called. + +Examples: + + $machKey= $Registry->Open( "LMachine", {Access=>KEY_READ(),Delimiter=>"/"} ) + or die "Can't open HKEY_LOCAL_MACHINE key: $^E\n"; + $swKey= $machKey->Open( "Software" ); + $logonKey= $swKey->Open( "Microsoft/Windows NT/CurrentVersion/Winlogon/" ); + $NTversKey= $swKey->Open( ["Microsoft","Windows NT","CurrentVersion"] ); + $versKey= $swKey->Open( qw(Microsoft Windows CurrentVersion) ); + + $remoteKey= $Registry->Open( "//HostA/LMachine/System/", {Delimiter=>"/"} ) + or die "Can't connect to HostA or can't open subkey: $^E\n"; + +=item Clone + +=item $copy= $key->Clone + +Creates a new object that is associated with the same Registry key +as the invoking object. + +=item Connect + +=item $remoteKey= $Registry->Connect( $sMachineName, $sKeyPath, $rhOptions ) + +The C<Connect> method connects to the Registry of a remote machine, +and opens a key within it, then returns a new I<Win32::TieRegistry> +object associated with that remote Registry key. If C<Connect> +was called using a reference to a tied hash, then the return value +will also be a reference to a tied hash [or C<undef>]. Otherwise, +if you wish to use the returned object as a tied hash [not just as +an object], then use the C<TiedRef> method function after C<Connect>. + +C<$sMachineName> is the name of the remote machine. You don't have +to precede the machine name with two delimiter characters. + +C<$sKeyPath> is a string specifying the remote key to be opened. +Alternately C<$sKeyPath> can be a reference to an array value +containing the list of increasingly deep keys specifying the path +to the key to be opened. + +C<$rhOptions> is an optional reference to a hash containing extra +options. The C<Connect> method supports two options, C<"Delimiter"> +and C<"Access">. See the C<Open> method documentation for more +information on these options. + +C<$sKeyPath> is already relative to the virtual root of the Registry +of the remote machine. A single leading delimiter on C<sKeyPath> +will be ignored and is not required. + +C<$sKeyPath> can be empty in which case C<Connect> will return an +object representing the virtual root key of the remote Registry. +Each subsequent use of C<Open> on this virtual root key will call +the system C<RegConnectRegistry> function. + +The C<Connect> method can be called via any I<Win32::TieRegistry> +object, not just C<$Registry>. Attributes such as the desired +level of access and the delimiter will be inherited from the +object used but the C<$sKeyPath> will always be relative to the +virtual root of the remote machine's registry. + +Examples: + + $remMachKey= $Registry->Connect( "HostA", "LMachine", {Delimiter->"/"} ) + or die "Can't connect to HostA's HKEY_LOCAL_MACHINE key: $^E\n"; + + $remVersKey= $remMachKey->Connect( "www.microsoft.com", + "LMachine/Software/Microsoft/Inetsrv/CurrentVersion/", + { Access=>KEY_READ, Delimiter=>"/" } ) + or die "Can't check what version of IIS Microsoft is running: $^E\n"; + + $remVersKey= $remMachKey->Connect( "www", + qw(LMachine Software Microsoft Inetsrv CurrentVersion) ) + or die "Can't check what version of IIS we are running: $^E\n"; + +=item ObjectRef + +=item $object_ref= $obj_or_hash_ref->ObjectRef + +For a simple object, just returns itself [C<<$obj == $obj->ObjectRef>>]. + +For a reference to a tied hash [if it is also an object], C<ObjectRef> +returns the simple object that the hash is tied to. + +This is primarily useful when debugging since typing C<x $Registry> +will try to display your I<entire> registry contents to your screen. +But the debugger command C<<x $Registry->ObjectRef>> will just dump +the implementation details of the underlying object to your screen. + +=item Flush( $bFlush ) + +Flushes all cached information about the Registry key so that future +uses will get fresh data from the Registry. + +If the optional C<$bFlush> is specified and a true value, then +C<RegFlushKey()> will be called, which is almost never necessary. + +=item GetValue + +=item $ValueData= $key->GetValue( $sValueName ) + +=item ($ValueData,$ValueType)= $key->GetValue( $sValueName ) + +Gets a Registry value's data and data type. + +C<$ValueData> is usually just a Perl string that contains the +value data [packed into it]. For certain types of data, however, +C<$ValueData> may be processed as described below. + +C<$ValueType> is the C<REG_*> constant describing the type of value +data stored in C<$ValueData>. If the C<DualTypes()> option is on, +then C<$ValueType> will be a dual value. That is, when used in a +numeric context, C<$ValueType> will give the numeric value of a +C<REG_*> constant. However, when used in a non-numeric context, +C<$ValueType> will return the name of the C<REG_*> constant, for +example C<"REG_SZ"> [note the quotes]. So both of the following +can be true at the same time: + + $ValueType == REG_SZ() + $ValueType eq "REG_SZ" + +=over + +=item REG_SZ and REG_EXPAND_SZ + +If the C<FixSzNulls()> option is on, then the trailing C<'\0'> will be +stripped [unless there isn't one] before values of type C<REG_SZ> +and C<REG_EXPAND_SZ> are returned. Note that C<SetValue()> will add +a trailing C<'\0'> under similar circumstances. + +=item REG_MULTI_SZ + +If the C<SplitMultis()> option is on, then values of this type are +returned as a reference to an array containing the strings. For +example, a value that, with C<SplitMultis()> off, would be returned as: + + "Value1\000Value2\000\000" + +would be returned, with C<SplitMultis()> on, as: + + [ "Value1", "Value2" ] + +=item REG_DWORD + +If the C<DualBinVals()> option is on, then the value is returned +as a scalar containing both a string and a number [much like +the C<$!> variable -- see the L<SetDualVar> module for more +information] where the number part is the "unpacked" value. +Use the returned value in a numeric context to access this part +of the value. For example: + + $num= 0 + $Registry->{"CUser/Console//ColorTable01"}; + +If the C<DWordsToHex()> option is off, the string part of the +returned value is a packed, 4-byte string [use C<unpack("L",$value)> +to get the numeric value. + +If C<DWordsToHex()> is on, the string part of the returned value is +a 10-character hex strings [with leading "0x"]. You can use +C<hex($value)> to get the numeric value. + +Note that C<SetValue()> will properly understand each of these +returned value formats no matter how C<DualBinVals()> is set. + +=back + +=item ValueNames + +=item @names= $key->ValueNames + +Returns the list of value names stored directly in a Registry key. +Note that the names returned do I<not> have a delimiter prepended +to them like with C<MemberNames()> and tied hashes. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item SubKeyNames + +=item @key_names= $key->SubKeyNames + +Returns the list of subkey names stored directly in a Registry key. +Note that the names returned do I<not> have a delimiter appended +to them like with C<MemberNames()> and tied hashes. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item SubKeyClasses + +=item @classes= $key->SubKeyClasses + +Returns the list of classes for subkeys stored directly in a +Registry key. The classes are returned in the same order as +the subkey names returned by C<SubKeyNames()>. + +=item SubKeyTimes + +=item @times= $key->SubKeyTimes + +Returns the list of last-modified times for subkeys stored +directly in a Registry key. The times are returned in the same +order as the subkey names returned by C<SubKeyNames()>. Each +time is a C<FILETIME> structure packed into a Perl string. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item MemberNames + +=item @members= $key->MemberNames + +Returns the list of subkey names and value names stored directly +in a Registry key. Subkey names have a delimiter appended to the +end and value names have a delimiter prepended to the front. + +Note that a value name could end in a delimiter [or could be C<""> +so that the member name returned is just a delimiter] so the +presence or absence of the leading delimiter is what should be +used to determine whether a particular name is for a subkey or a +value, not the presence or absence of a trailing delimiter. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item Information + +=item %info= $key->Information + +=item @items= $key->Information( @itemNames ); + +Returns the following information about a Registry key: + +=over + +=item LastWrite + +A C<FILETIME> structure indicating when the key was last modified +and packed into a Perl string. + +=item CntSubKeys + +The number of subkeys stored directly in this key. + +=item CntValues + +The number of values stored directly in this key. + +=item SecurityLen + +The length [in bytes] of the largest[?] C<SECURITY_DESCRIPTOR> +associated with the Registry key. + +=item MaxValDataLen + +The length [in bytes] of the longest value data associated with +a value stored in this key. + +=item MaxSubKeyLen + +The length [in chars] of the longest subkey name associated with +a subkey stored in this key. + +=item MaxSubClassLen + +The length [in chars] of the longest class name associated with +a subkey stored directly in this key. + +=item MaxValNameLen + +The length [in chars] of the longest value name associated with +a value stored in this key. + +=back + +With no arguments, returns a hash [not a reference to a hash] where +the keys are the names for the items given above and the values +are the information describe above. For example: + + %info= ( "CntValues" => 25, # Key contains 25 values. + "MaxValNameLen" => 20, # One of which has a 20-char name. + "MaxValDataLen" => 42, # One of which has a 42-byte value. + "CntSubKeys" => 1, # Key has 1 immediate subkey. + "MaxSubKeyLen" => 13, # One of which has a 12-char name. + "MaxSubClassLen" => 0, # All of which have class names of "". + "SecurityLen" => 232, # One SECURITY_DESCRIPTOR is 232 bytes. + "LastWrite" => "\x90mZ\cX{\xA3\xBD\cA\c@\cA" + # Key was last modifed 1998/06/01 16:29:32 GMT + ); + +With arguments, each one must be the name of a item given above. +The return value is the information associated with the listed +names. In other words: + + return $key->Information( @names ); + +returns the same list as: + + %info= $key->Information; + return @info{@names}; + +=item Delimiter + +=item $oldDelim= $key->Delimiter + +=item $oldDelim= $key->Delimiter( $newDelim ) + +Gets and possibly changes the delimiter used for this object. The +delimiter is appended to subkey names and prepended to value names +in many return values. It is also used when parsing keys passed +to tied hashes. + +The delimiter defaults to backslash (C<'\\'>) but is inherited from +the object used to create a new object and can be specified by an +option when a new object is created. + +=item Handle + +=item $handle= $key->Handle + +Returns the raw C<HKEY> handle for the associated Registry key as +an integer value. This value can then be used to Reg*() calls +from I<Win32API::Registry>. However, it is usually easier to just +call the I<Win32API::Registry> calls directly via: + + $key->RegNotifyChangeKeyValue( ... ); + +For the virtual root of the local or a remote Registry, +C<Handle()> return C<"NONE">. + +=item Path + +=item $path= $key->Path + +Returns a string describing the path of key names to this +Registry key. The string is built so that if it were passed +to C<< $Registry->Open() >>, it would reopen the same Registry key +[except in the rare case where one of the key names contains +C<< $key->Delimiter >>]. + +=item Machine + +=item $computerName= $key->Machine + +Returns the name of the computer [or "machine"] on which this Registry +key resides. Returns C<""> for local Registry keys. + +=item Access + +Returns the numeric value of the bit mask used to specify the +types of access requested when this Registry key was opened. Can +be compared to C<KEY_*> values. + +=item OS_Delimiter + +Returns the delimiter used by the operating system's RegOpenKeyEx() +call. For Win32, this is always backslash (C<"\\">). + +=item Roots + +Returns the mapping from root key names like C<"LMachine"> to their +associated C<HKEY_*> constants. Primarily for internal use and +subject to change. + +=item Tie + +=item $key->Tie( \%hash ); + +Ties the referenced hash to that Registry key. Pretty much the +same as + + tie %hash, ref($key), $key; + +Since C<ref($key)> is the class [package] to tie the hash to and +C<TIEHASH()> just returns its argument, C<$key>, [without calling +C<new()>] when it sees that it is already a blessed object. + +=item TiedRef + +=item $TiedHashRef= $hash_or_obj_ref->TiedRef + +For a simple object, returns a reference to a hash tied to the +object. Used to promote a simple object into a combined object +and hash ref. + +If already a reference to a tied hash [that is also an object], +it just returns itself [C<< $ref == $ref->TiedRef >>]. + +Mostly used internally. + +=item ArrayValues + +=item $oldBool= $key->ArrayValues + +=item $oldBool= $key->ArrayValues( $newBool ) + +Gets the current setting of the C<ArrayValues> option and possibly +turns it on or off. + +When off, Registry values fetched via a tied hash are returned as +just a value scalar [the same as C<GetValue()> in a scalar context]. +When on, they are returned as a reference to an array containing +the value data as the C<[0]> element and the data type as the C<[1]> +element. + +=item TieValues + +=item $oldBool= TieValues + +=item $oldBool= TieValues( $newBool ) + +Gets the current setting of the C<TieValues> option and possibly +turns it on or off. + +Turning this option on is not yet supported in this release of +I<Win32::TieRegistry>. In a future release, turning this option +on will cause Registry values returned from a tied hash to be +a tied array that you can use to modify the value in the Registry. + +=item FastDelete + +=item $oldBool= $key->FastDelete + +=item $oldBool= $key->FastDelete( $newBool ) + +Gets the current setting of the C<FastDelete> option and possibly +turns it on or off. + +When on, successfully deleting a Registry key [via a tied hash] +simply returns C<1>. + +When off, successfully deleting a Registry key [via a tied hash +and not in a void context] returns a reference to a hash that +contains the values present in the key when it was deleted. This +hash is just like that returned when referencing the key before it +was deleted except that it is an ordinary hash, not one tied to +the I<Win32::TieRegistry> package. + +Note that deleting either a Registry key or value via a tied hash +I<in a void context> prevents any overhead in trying to build an +appropriate return value. + +Note that deleting a Registry I<value> via a tied hash [not in +a void context] returns the value data even if <FastDelete> is on. + +=item SplitMultis + +=item $oldBool= $key->SplitMultis + +=item $oldBool= $key->SplitMultis( $newBool ) + +Gets the current setting of the C<SplitMultis> option and possibly +turns it on or off. + +If on, Registry values of type C<REG_MULTI_SZ> are returned as +a reference to an array of strings. See C<GetValue()> for more +information. + +=item DWordsToHex + +=item $oldBool= $key->DWordsToHex + +=item $oldBool= $key->DWordsToHex( $newBool ) + +Gets the current setting of the C<DWordsToHex> option and possibly +turns it on or off. + +If on, Registry values of type C<REG_DWORD> are returned as a hex +string with leading C<"0x"> and longer than 4 characters. See +C<GetValue()> for more information. + +=item FixSzNulls + +=item $oldBool= $key->FixSzNulls + +=item $oldBool= $key->FixSzNulls( $newBool ) + +Gets the current setting of the C<FixSzNulls> option and possibly +turns it on or off. + +If on, Registry values of type C<REG_SZ> and C<REG_EXPAND_SZ> have +trailing C<'\0'>s added before they are set and stripped before +they are returned. See C<GetValue()> and C<SetValue()> for more +information. + +=item DualTypes + +=item $oldBool= $key->DualTypes + +=item $oldBool= $key->DualTypes( $newBool ) + +Gets the current setting of the C<DualTypes> option and possibly +turns it on or off. + +If on, data types are returned as a combined numeric/string value +holding both the numeric value of a C<REG_*> constant and the +string value of the constant's name. See C<GetValue()> for +more information. + +=item DualBinVals + +=item $oldBool= $key->DualBinVals + +=item $oldBool= $key->DualBinVals( $newBool ) + +Gets the current setting of the C<DualBinVals> option and possibly +turns it on or off. + +If on, Registry value data of type C<REG_BINARY> and no more than +4 bytes long and Registry values of type C<REG_DWORD> are returned +as a combined numeric/string value where the numeric value is the +"unpacked" binary value as returned by: + + hex reverse unpack( "h*", $valData ) + +on a "little-endian" computer. [Would be C<hex unpack("H*",$valData)> +on a "big-endian" computer if this module is ever ported to one.] + +See C<GetValue()> for more information. + +=item GetOptions + +=item @oldOptValues= $key->GetOptions( @optionNames ) + +=item $refHashOfOldOpts= $key->GetOptions() + +=item $key->GetOptions( \%hashForOldOpts ) + +Returns the current setting of any of the following options: + + Delimiter FixSzNulls DWordsToHex + ArrayValues SplitMultis DualBinVals + TieValues FastDelete DualTypes + +Pass in one or more of the above names (as strings) to get back +an array of the corresponding current settings in the same order: + + my( $fastDel, $delim )= $key->GetOptions("FastDelete","Delimiter"); + +Pass in no arguments to get back a reference to a hash where +the above option names are the keys and the values are +the corresponding current settings for each option: + + my $href= $key->GetOptions(); + my $delim= $href->{Delimiter}; + +Pass in a single reference to a hash to have the above key/value +pairs I<added> to the referenced hash. For this case, the +return value is the original object so further methods can be +chained after the call to GetOptions: + + my %oldOpts; + $key->GetOptions( \%oldOpts )->SetOptions( Delimiter => "/" ); + +=item SetOptions + +=item @oldOpts= $key->SetOptions( optNames=>$optValue,... ) + +Changes the current setting of any of the following options, +returning the previous setting(s): + + Delimiter FixSzNulls DWordsToHex AllowLoad + ArrayValues SplitMultis DualBinVals AllowSave + TieValues FastDelete DualTypes + +For C<AllowLoad> and C<AllowSave>, instead of the previous +setting, C<SetOptions> returns whether or not the change was +successful. + +In a scalar context, returns only the last item. The last +option can also be specified as C<"ref"> or C<"r"> [which doesn't +need to be followed by a value] to allow chaining: + + $key->SetOptions(AllowSave=>1,"ref")->RegSaveKey(...) + +=item SetValue + +=item $okay= $key->SetValue( $ValueName, $ValueData ); + +=item $okay= $key->SetValue( $ValueName, $ValueData, $ValueType ); + +Adds or replaces a Registry value. Returns a true value if +successfully, false otherwise. + +C<$ValueName> is the name of the value to add or replace and +should I<not> have a delimiter prepended to it. Case is ignored. + +C<$ValueType> is assumed to be C<REG_SZ> if it is omitted. Otherwise, +it should be one the C<REG_*> constants. + +C<$ValueData> is the data to be stored in the value, probably packed +into a Perl string. Other supported formats for value data are +listed below for each possible C<$ValueType>. + +=over + +=item REG_SZ or REG_EXPAND_SZ + +The only special processing for these values is the addition of +the required trailing C<'\0'> if it is missing. This can be +turned off by disabling the C<FixSzNulls> option. + +=item REG_MULTI_SZ + +These values can also be specified as a reference to a list of +strings. For example, the following two lines are equivalent: + + $key->SetValue( "Val1\000Value2\000LastVal\000\000", "REG_MULTI_SZ" ); + $key->SetValue( ["Val1","Value2","LastVal"], "REG_MULTI_SZ" ); + +Note that if the required two trailing nulls (C<"\000\000">) are +missing, then this release of C<SetValue()> will I<not> add them. + +=item REG_DWORD + +These values can also be specified as a hex value with the leading +C<"0x"> included and totaling I<more than> 4 bytes. These will be +packed into a 4-byte string via: + + $data= pack( "L", hex($data) ); + +=item REG_BINARY + +This value type is listed just to emphasize that no alternate +format is supported for it. In particular, you should I<not> pass +in a numeric value for this type of data. C<SetValue()> cannot +distinguish such from a packed string that just happens to match +a numeric value and so will treat it as a packed string. + +=back + +An alternate calling format: + + $okay= $key->SetValue( $ValueName, [ $ValueData, $ValueType ] ); + +[two arguments, the second of which is a reference to an array +containing the value data and value type] is supported to ease +using tied hashes with C<SetValue()>. + +=item CreateKey + +=item $newKey= $key->CreateKey( $subKey ); + +=item $newKey= $key->CreateKey( $subKey, { Option=>OptVal,... } ); + +Creates a Registry key or just updates attributes of one. Calls +C<RegCreateKeyEx()> then, if it succeeded, creates an object +associated with the [possibly new] subkey. + +C<$subKey> is the name of a subkey [or a path to one] to be +created or updated. It can also be a reference to an array +containing a list of subkey names. + +The second argument, if it exists, should be a reference to a +hash specifying options either to be passed to C<RegCreateKeyEx()> +or to be used when creating the associated object. The following +items are the supported keys for this options hash: + +=over + +=item Delimiter + +Specifies the delimiter to be used to parse C<$subKey> and to be +used in the new object. Defaults to C<< $key->Delimiter >>. + +=item Access + +Specifies the types of access requested when the subkey is opened. +Should be a numeric bit mask that combines one or more C<KEY_*> +constant values. + +=item Class + +The name to assign as the class of the new or updated subkey. +Defaults to C<""> as we have never seen a use for this information. + +=item Disposition + +Lets you specify a reference to a scalar where, upon success, will be +stored either C<REG_CREATED_NEW_KEY()> or C<REG_OPENED_EXISTING_KEY()> +depending on whether a new key was created or an existing key was +opened. + +If you, for example, did C<use Win32::TieRegistry qw(REG_CREATED_NEW_KEY)> +then you can use C<REG_CREATED_NEW_KEY()> to compare against the numeric +value stored in the referenced scalar. + +If the C<DualTypes> option is enabled, then in addition to the +numeric value described above, the referenced scalar will also +have a string value equal to either C<"REG_CREATED_NEW_KEY"> or +C<"REG_OPENED_EXISTING_KEY">, as appropriate. + +=item Security + +Lets you specify a C<SECURITY_ATTRIBUTES> structure packed into a +Perl string. See C<Win32API::Registry::RegCreateKeyEx()> for more +information. + +=item Volatile + +If true, specifies that the new key should be volatile, that is, +stored only in memory and not backed by a hive file [and not saved +if the computer is rebooted]. This option is ignored under +Windows 95. Specifying C<Volatile=E<gt>1> is the same as +specifying C<Options=E<gt>REG_OPTION_VOLATILE>. + +=item Backup + +If true, specifies that the new key should be opened for +backup/restore access. The C<Access> option is ignored. If the +calling process has enabled C<"SeBackupPrivilege">, then the +subkey is opened with C<KEY_READ> access as the C<"LocalSystem"> +user which should have access to all subkeys. If the calling +process has enabled C<"SeRestorePrivilege">, then the subkey is +opened with C<KEY_WRITE> access as the C<"LocalSystem"> user which +should have access to all subkeys. + +This option is ignored under Windows 95. Specifying C<Backup=E<gt>1> +is the same as specifying C<Options=E<gt>REG_OPTION_BACKUP_RESTORE>. + +=item Options + +Lets you specify options to the C<RegOpenKeyEx()> call. The value +for this option should be a numeric value combining zero or more +of the C<REG_OPTION_*> bit masks. You may with to used the +C<Volatile> and/or C<Backup> options instead of this one. + +=back + +=item StoreKey + +=item $newKey= $key->StoreKey( $subKey, \%Contents ); + +Primarily for internal use. + +Used to create or update a Registry key and any number of subkeys +or values under it or its subkeys. + +C<$subKey> is the name of a subkey to be created [or a path of +subkey names separated by delimiters]. If that subkey already +exists, then it is updated. + +C<\%Contents> is a reference to a hash containing pairs of +value names with value data and/or subkey names with hash +references similar to C<\%Contents>. Each of these cause +a value or subkey of C<$subKey> to be created or updated. + +If C<$Contents{""}> exists and is a reference to a hash, then +it used as the options argument when C<CreateKey()> is called +for C<$subKey>. This allows you to specify ... + + if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) { + $self= $this->CreateKey( $subKey, delete $$data{""} ); + +=item Load + +=item $newKey= $key->Load( $file ) + +=item $newKey= $key->Load( $file, $newSubKey ) + +=item $newKey= $key->Load( $file, $newSubKey, { Option=>OptVal... } ) + +=item $newKey= $key->Load( $file, { Option=>OptVal... } ) + +Loads a hive file into a Registry. That is, creates a new subkey +and associates a hive file with it. + +C<$file> is a hive file, that is a file created by calling +C<RegSaveKey()>. The C<$file> path is interpreted relative to +C<%SystemRoot%/System32/config> on the machine where C<$key> +resides. + +C<$newSubKey> is the name to be given to the new subkey. If +C<$newSubKey> is specified, then C<$key> must be +C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS> of the local computer +or a remote computer and C<$newSubKey> should not contain any +occurrences of either the delimiter or the OS delimiter. + +If C<$newSubKey> is not specified, then it is as if C<$key> +was C<$Registry-E<gt>{LMachine}> and C<$newSubKey> is +C<"PerlTie:999"> where C<"999"> is actually a sequence number +incremented each time this process calls C<Load()>. + +You can specify as the last argument a reference to a hash +containing options. You can specify the same options that you +can specify to C<Open()>. See C<Open()> for more information on +those. In addition, you can specify the option C<"NewSubKey">. +The value of this option is interpreted exactly as if it was +specified as the C<$newSubKey> parameter and overrides the +C<$newSubKey> if one was specified. + +The hive is automatically unloaded when the returned object +[C<$newKey>] is destroyed. Registry key objects opened within +the hive will keep a reference to the C<$newKey> object so that +it will not be destroyed before these keys are closed. + +=item UnLoad + +=item $okay= $key->UnLoad + +Unloads a hive that was loaded via C<Load()>. Cannot unload other +hives. C<$key> must be the return from a previous call to C<Load()>. +C<$key> is closed and then the hive is unloaded. + +=item AllowSave + +=item $okay= AllowSave( $bool ) + +Enables or disables the C<"ReBackupPrivilege"> privilege for the +current process. You will probably have to enable this privilege +before you can use C<RegSaveKey()>. + +The return value indicates whether the operation succeeded, not +whether the privilege was previously enabled. + +=item AllowLoad + +=item $okay= AllowLoad( $bool ) + +Enables or disables the C<"ReRestorePrivilege"> privilege for the +current process. You will probably have to enable this privilege +before you can use C<RegLoadKey()>, C<RegUnLoadKey()>, +C<RegReplaceKey()>, or C<RegRestoreKey> and thus C<Load()> and +C<UnLoad()>. + +The return value indicates whether the operation succeeded, not +whether the privilege was previously enabled. + +=back + +=head2 Exports [C<use> and C<import()>] + +To have nothing imported into your package, use something like: + + use Win32::TieRegistry 0.20 (); + +which would verify that you have at least version 0.20 but wouldn't +call C<import()>. The F<Changes> file can be useful in figuring out +which, if any, prior versions of I<Win32::TieRegistry> you want to +support in your script. + +The code + + use Win32::TieRegistry; + +imports the variable C<$Registry> into your package and sets it +to be a reference to a hash tied to a copy of the master Registry +virtual root object with the default options. One disadvantage +to this "default" usage is that Perl does not support checking +the module version when you use it. + +Alternately, you can specify a list of arguments on the C<use> +line that will be passed to the C<< Win32::TieRegistry->import() >> +method to control what items to import into your package. These +arguments fall into the following broad categories: + +=over + +=item Import a reference to a hash tied to a Registry virtual root + +You can request that a scalar variable be imported (possibly) +and set to be a reference to a hash tied to a Registry virtual root +using any of the following types of arguments or argument pairs: + +=over + +=item "TiedRef", '$scalar' + +=item "TiedRef", '$pack::scalar' + +=item "TiedRef", 'scalar' + +=item "TiedRef", 'pack::scalar' + +All of the above import a scalar named C<$scalar> into your package +(or the package named "pack") and then sets it. + +=item '$scalar' + +=item '$pack::scalar' + +These are equivalent to the previous items to support a more +traditional appearance to the list of exports. Note that the +scalar name cannot be "RegObj" here. + +=item "TiedRef", \$scalar + +=item \$scalar + +These versions don't import anything but set the referenced C<$scalar>. + +=back + +=item Import a hash tied to the Registry virtual root + +You can request that a hash variable be imported (possibly) +and tied to a Registry virtual root using any of the following +types of arguments or argument pairs: + +=over + +=item "TiedHash", '%hash' + +=item "TiedHash", '%pack::hash' + +=item "TiedHash", 'hash' + +=item "TiedHash", 'pack::hash' + +All of the above import a hash named C<%hash> into your package +(or the package named "pack") and then sets it. + +=item '%hash' + +=item '%pack::hash' + +These are equivalent to the previous items to support a more +traditional appearance to the list of exports. + +=item "TiedHash", \%hash + +=item \%hash + +These versions don't import anything but set the referenced C<%hash>. + +=back + +=item Import a Registry virtual root object + +You can request that a scalar variable be imported (possibly) +and set to be a Registry virtual root object using any of the +following types of arguments or argument pairs: + +=over + +=item "ObjectRef", '$scalar' + +=item "ObjectRef", '$pack::scalar' + +=item "ObjectRef", 'scalar' + +=item "ObjectRef", 'pack::scalar' + +All of the above import a scalar named C<$scalar> into your package +(or the package named "pack") and then sets it. + +=item '$RegObj' + +This is equivalent to the previous items for backward compatibility. + +=item "ObjectRef", \$scalar + +This version doesn't import anything but sets the referenced C<$scalar>. + +=back + +=item Import constant(s) exported by I<Win32API::Registry> + +You can list any constants that are exported by I<Win32API::Registry> +to have them imported into your package. These constants have names +starting with "KEY_" or "REG_" (or even "HKEY_"). + +You can also specify C<":KEY_">, C<":REG_">, and even C<":HKEY_"> to +import a whole set of constants. + +See I<Win32API::Registry> documentation for more information. + +=item Options + +You can list any option names that can be listed in the C<SetOptions()> +method call, each followed by the value to use for that option. +A Registry virtual root object is created, all of these options are +set for it, then each variable to be imported/set is associated with +this object. + +In addition, the following special options are supported: + +=over + +=item ExportLevel + +Whether to import variables into your package or some +package that uses your package. Defaults to the value of +C<$Exporter::ExportLevel> and has the same meaning. See +the L<Exporter> module for more information. + +=item ExportTo + +The name of the package to import variables and constants into. +Overrides I<ExportLevel>. + +=back + +=back + +=head3 Specifying constants in your Perl code + +This module was written with a strong emphasis on the convenience of +the module user. Therefore, most places where you can specify a +constant like C<REG_SZ()> also allow you to specify a string +containing the name of the constant, C<"REG_SZ">. This is convenient +because you may not have imported that symbolic constant. + +Perl also emphasizes programmer convenience so the code C<REG_SZ> +can be used to mean C<REG_SZ()> or C<"REG_SZ"> or be illegal. +Note that using C<®_SZ> (as we've seen in much Win32 Perl code) +is not a good idea since it passes the current C<@_> to the +C<constant()> routine of the module which, at the least, can give +you a warning under B<-w>. + +Although greatly a matter of style, the "safest" practice is probably +to specifically list all constants in the C<use Win32::TieRegistry> +statement, specify C<use strict> [or at least C<use strict qw(subs)>], +and use bare constant names when you want the numeric value. This will +detect misspelled constant names at compile time. + + use strict; + my $Registry; + use Win32::TieRegistry 0.20 ( + TiedRef => \$Registry, Delimiter => "/", ArrayValues => 1, + SplitMultis => 1, AllowLoad => 1, + qw( REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ + KEY_READ KEY_WRITE KEY_ALL_ACCESS ), + ); + $Registry->{"LMachine/Software/FooCorp/"}= { + "FooWriter/" => { + "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ ], + "/WindowSize" => [ pack("LL",24,80), REG_BINARY ], + "/TaskBarIcon" => [ "0x0001", REG_DWORD ], + }, + } or die "Can't create Software/FooCorp/: $^E\n"; + +If you don't want to C<use strict qw(subs)>, the second safest practice +is similar to the above but use the C<REG_SZ()> form for constants +when possible and quoted constant names when required. Note that +C<qw()> is a form of quoting. + + use Win32::TieRegistry 0.20 qw( + TiedRef $Registry + Delimiter / ArrayValues 1 SplitMultis 1 AllowLoad 1 + REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ + KEY_READ KEY_WRITE KEY_ALL_ACCESS + ); + $Registry->{"LMachine/Software/FooCorp/"}= { + "FooWriter/" => { + "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ() ], + "/WindowSize" => [ pack("LL",24,80), REG_BINARY() ], + "/TaskBarIcon" => [ "0x0001", REG_DWORD() ], + }, + } or die "Can't create Software/FooCorp/: $^E\n"; + +The examples in this document mostly use quoted constant names +(C<"REG_SZ">) since that works regardless of which constants +you imported and whether or not you have C<use strict> in your +script. It is not the best choice for you to use for real +scripts (vs. examples) because it is less efficient and is not +supported by most other similar modules. + +=head1 SUMMARY + +Most things can be done most easily via tied hashes. Skip down to the +the L<Tied Hashes Summary> to get started quickly. + +=head2 Objects Summary + +Here are quick examples that document the most common functionality +of all of the method functions [except for a few almost useless ones]. + + # Just another way of saying Open(): + $key= Win32::TieRegistry->new("LMachine\\Software\\", + { Access=>KEY_READ()|KEY_WRITE(), Delimiter=>"\\" }); + + # Open a Registry key: + $subKey= $key->Open( "SubKey/SubSubKey/", + { Access=>KEY_ALL_ACCESS, Delimiter=>"/" } ); + + # Connect to a remote Registry key: + $remKey= $Registry->Connect( "MachineName", "LMachine/", + { Access=>KEY_READ, Delimiter=>"/" } ); + + # Get value data: + $valueString= $key->GetValue("ValueName"); + ( $valueString, $valueType )= $key->GetValue("ValueName"); + + # Get list of value names: + @valueNames= $key->ValueNames; + + # Get list of subkey names: + @subKeyNames= $key->SubKeyNames; + + # Get combined list of value names (with leading delimiters) + # and subkey names (with trailing delimiters): + @memberNames= $key->MemberNames; + + # Get all information about a key: + %keyInfo= $key->Information; + # keys(%keyInfo)= qw( Class LastWrite SecurityLen + # CntSubKeys MaxSubKeyLen MaxSubClassLen + # CntValues MaxValNameLen MaxValDataLen ); + + # Get selected information about a key: + ( $class, $cntSubKeys )= $key->Information( "Class", "CntSubKeys" ); + + # Get and/or set delimiter: + $delim= $key->Delimiter; + $oldDelim= $key->Delimiter( $newDelim ); + + # Get "path" for an open key: + $path= $key->Path; + # For example, "/CUser/Control Panel/Mouse/" + # or "//HostName/LMachine/System/DISK/". + + # Get name of machine where key is from: + $mach= $key->Machine; + # Will usually be "" indicating key is on local machine. + + # Control different options (see main documentation for descriptions): + $oldBool= $key->ArrayValues( $newBool ); + $oldBool= $key->FastDelete( $newBool ); + $oldBool= $key->FixSzNulls( $newBool ); + $oldBool= $key->SplitMultis( $newBool ); + $oldBool= $key->DWordsToHex( $newBool ); + $oldBool= $key->DualBinVals( $newBool ); + $oldBool= $key->DualTypes( $newBool ); + @oldBools= $key->SetOptions( ArrayValues=>1, FastDelete=>1, FixSzNulls=>0, + Delimiter=>"/", AllowLoad=>1, AllowSave=>1 ); + @oldBools= $key->GetOptions( ArrayValues, FastDelete, FixSzNulls ); + + # Add or set a value: + $key->SetValue( "ValueName", $valueDataString ); + $key->SetValue( "ValueName", pack($format,$valueData), "REG_BINARY" ); + + # Add or set a key: + $key->CreateKey( "SubKeyName" ); + $key->CreateKey( "SubKeyName", + { Access=>"KEY_ALL_ACCESS", Class=>"ClassName", + Delimiter=>"/", Volatile=>1, Backup=>1 } ); + + # Load an off-line Registry hive file into the on-line Registry: + $newKey= $Registry->Load( "C:/Path/To/Hive/FileName" ); + $newKey= $key->Load( "C:/Path/To/Hive/FileName", "NewSubKeyName", + { Access=>"KEY_READ" } ); + # Unload a Registry hive file loaded via the Load() method: + $newKey->UnLoad; + + # (Dis)Allow yourself to load Registry hive files: + $success= $Registry->AllowLoad( $bool ); + + # (Dis)Allow yourself to save a Registry key to a hive file: + $success= $Registry->AllowSave( $bool ); + + # Save a Registry key to a new hive file: + $key->RegSaveKey( "C:/Path/To/Hive/FileName", [] ); + +=head3 Other Useful Methods + +See I<Win32API::Registry> for more information on these methods. +These methods are provided for coding convenience and are +identical to the I<Win32API::Registry> functions except that these +don't take a handle to a Registry key, instead getting the handle +from the invoking object [C<$key>]. + + $key->RegGetKeySecurity( $iSecInfo, $sSecDesc, $lenSecDesc ); + $key->RegLoadKey( $sSubKeyName, $sPathToFile ); + $key->RegNotifyChangeKeyValue( + $bWatchSubtree, $iNotifyFilter, $hEvent, $bAsync ); + $key->RegQueryMultipleValues( + $structValueEnts, $cntValueEnts, $Buffer, $lenBuffer ); + $key->RegReplaceKey( $sSubKeyName, $sPathToNewFile, $sPathToBackupFile ); + $key->RegRestoreKey( $sPathToFile, $iFlags ); + $key->RegSetKeySecurity( $iSecInfo, $sSecDesc ); + $key->RegUnLoadKey( $sSubKeyName ); + +=head2 Tied Hashes Summary + +For fast learners, this may be the only section you need to read. +Always append one delimiter to the end of each Registry key name +and prepend one delimiter to the front of each Registry value name. + +=head3 Opening keys + + use Win32::TieRegistry ( Delimiter=>"/", ArrayValues=>1 ); + $Registry->Delimiter("/"); # Set delimiter to "/". + $swKey= $Registry->{"LMachine/Software/"}; + $winKey= $swKey->{"Microsoft/Windows/CurrentVersion/"}; + $userKey= $Registry-> + {"CUser/Software/Microsoft/Windows/CurrentVersion/"}; + $remoteKey= $Registry->{"//HostName/LMachine/"}; + +=head3 Reading values + + $progDir= $winKey->{"/ProgramFilesDir"}; # "C:\\Program Files" + $tip21= $winKey->{"Explorer/Tips//21"}; # Text of tip #21. + + $winKey->ArrayValues(1); + ( $devPath, $type )= $winKey->{"/DevicePath"}; + # $devPath eq "%SystemRoot%\\inf" + # $type eq "REG_EXPAND_SZ" [if you have SetDualVar.pm installed] + # $type == REG_EXPAND_SZ() [if did C<use Win32::TieRegistry qw(:REG_)>] + +=head3 Setting values + + $winKey->{"Setup//SourcePath"}= "\\\\SwServer\\SwShare\\Windows"; + # Simple. Assumes data type of REG_SZ. + + $winKey->{"Setup//Installation Sources"}= + [ "D:\x00\\\\SwServer\\SwShare\\Windows\0\0", "REG_MULTI_SZ" ]; + # "\x00" and "\0" used to mark ends of each string and end of list. + + $winKey->{"Setup//Installation Sources"}= + [ ["D:","\\\\SwServer\\SwShare\\Windows"], "REG_MULTI_SZ" ]; + # Alternate method that is easier to read. + + $userKey->{"Explorer/Tips//DisplayInitialTipWindow"}= + [ pack("L",0), "REG_DWORD" ]; + $userKey->{"Explorer/Tips//Next"}= [ pack("S",3), "REG_BINARY" ]; + $userKey->{"Explorer/Tips//Show"}= [ pack("L",0), "REG_BINARY" ]; + +=head3 Adding keys + + $swKey->{"FooCorp/"}= { + "FooWriter/" => { + "/Version" => "4.032", + "Startup/" => { + "/Title" => "Foo Writer Deluxe ][", + "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ], + "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ], + }, + "Compatibility/" => { + "/AutoConvert" => "Always", + "/Default Palette" => "Windows Colors", + }, + }, + "/License", => "0123-9C8EF1-09-FC", + }; + +=head3 Listing all subkeys and values + + @members= keys( %{$swKey} ); + @subKeys= grep( m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) ); + # @subKeys= ( "/", "/EditFlags" ); + @valueNames= grep( ! m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) ); + # @valueNames= ( "DefaultIcon/", "shell/", "shellex/" ); + +=head3 Deleting values or keys with no subkeys + + $oldValue= delete $userKey->{"Explorer/Tips//Next"}; + + $oldValues= delete $userKey->{"Explorer/Tips/"}; + # $oldValues will be reference to hash containing deleted keys values. + +=head3 Closing keys + + undef $swKey; # Explicit way to close a key. + $winKey= "Anything else"; # Implicitly closes a key. + exit 0; # Implicitly closes all keys. + +=head2 Tie::Registry + +This module was originally called I<Tie::Registry>. Changing code +that used I<Tie::Registry> over to I<Win32::TieRegistry> is trivial +as the module name should only be mentioned once, in the C<use> +line. However, finding all of the places that used I<Tie::Registry> +may not be completely trivial so we have included F<Tie/Registry.pm> +which you can install to provide backward compatibility. + +=head1 AUTHOR + +Tye McQueen. See http://www.metronet.com/~tye/ or e-mail +tye@metronet.com with bug reports. + +=head1 SEE ALSO + +I<Win32API::Registry> - Provides access to C<Reg*()>, C<HKEY_*>, +C<KEY_*>, C<REG_*> [required]. + +I<Win32::WinError> - Defines C<ERROR_*> values [optional]. + +L<SetDualVar> - For returning C<REG_*> values as combined +string/integer values [optional]. + +=head1 BUGS + +Because Perl hashes are case sensitive, certain lookups are also +case sensitive. In particular, the root keys ("Classes", "CUser", +"LMachine", "Users", "PerfData", "CConfig", "DynData", and HKEY_*) +must always be entered without changing between upper and lower +case letters. Also, the special rule for matching subkey names +that contain the user-selected delimiter only works if case is +matched. All other key name and value name lookups should be case +insensitive because the underlying Reg*() calls ignore case. + +Information about each key is cached when using a tied hash. +This cache is not flushed nor updated when changes are made, +I<even when the same tied hash is used> to make the changes. + +Current implementations of Perl's "global destruction" phase can +cause objects returned by C<Load()> to be destroyed while keys +within the hive are still open, if the objects still exist when +the script starts to exit. When this happens, the automatic +C<UnLoad()> will report a failure and the hive will remain loaded +in the Registry. + +Trying to C<Load()> a hive file that is located on a remote network +share may silently delete all data from the hive. This is a bug +in the Win32 APIs, not any Perl code or modules. This module does +not try to protect you from this bug. + +There is no test suite. + +=head1 FUTURE DIRECTIONS + +The following items are desired by the author and may appear in a +future release of this module. + +=over + +=item TieValues option + +Currently described in main documentation but no yet implemented. + +=item AutoRefresh option + +Trigger use of C<RegNotifyChangeKeyValue()> to keep tied hash +caches up-to-date even when other programs make changes. + +=item Error options + +Allow the user to have unchecked calls (calls in a "void context") +to automatically report errors via C<warn> or C<die>. + +For complex operations, such a copying an entire subtree, provide +access to detailed information about errors (and perhaps some +warnings) that were encountered. Let the user control whether +the complex operation continues in spite of errors. + +=back + +=head1 COPYRIGHT + +Copyright 1999 - 2006 Tye McQueen. + +Some parts copyright 2007 - 2009 Adam Kennedy. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +# Autoload not currently supported by Perl under Windows. diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/WinError.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/WinError.pm new file mode 100644 index 0000000000..c61347b6ec --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/WinError.pm @@ -0,0 +1,1017 @@ +package Win32::WinError; + +require Exporter; +require DynaLoader; + +$VERSION = '0.04'; + +@ISA = qw(Exporter DynaLoader); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + GetLastError + CACHE_E_FIRST + CACHE_E_LAST + CACHE_E_NOCACHE_UPDATED + CACHE_S_FIRST + CACHE_S_FORMATETC_NOTSUPPORTED + CACHE_S_LAST + CACHE_S_SAMECACHE + CACHE_S_SOMECACHES_NOTUPDATED + CLASSFACTORY_E_FIRST + CLASSFACTORY_E_LAST + CLASSFACTORY_S_FIRST + CLASSFACTORY_S_LAST + CLASS_E_CLASSNOTAVAILABLE + CLASS_E_NOAGGREGATION + CLIENTSITE_E_FIRST + CLIENTSITE_E_LAST + CLIENTSITE_S_FIRST + CLIENTSITE_S_LAST + CLIPBRD_E_BAD_DATA + CLIPBRD_E_CANT_CLOSE + CLIPBRD_E_CANT_EMPTY + CLIPBRD_E_CANT_OPEN + CLIPBRD_E_CANT_SET + CLIPBRD_E_FIRST + CLIPBRD_E_LAST + CLIPBRD_S_FIRST + CLIPBRD_S_LAST + CONVERT10_E_FIRST + CONVERT10_E_LAST + CONVERT10_E_OLESTREAM_BITMAP_TO_DIB + CONVERT10_E_OLESTREAM_FMT + CONVERT10_E_OLESTREAM_GET + CONVERT10_E_OLESTREAM_PUT + CONVERT10_E_STG_DIB_TO_BITMAP + CONVERT10_E_STG_FMT + CONVERT10_E_STG_NO_STD_STREAM + CONVERT10_S_FIRST + CONVERT10_S_LAST + CONVERT10_S_NO_PRESENTATION + CO_E_ALREADYINITIALIZED + CO_E_APPDIDNTREG + CO_E_APPNOTFOUND + CO_E_APPSINGLEUSE + CO_E_BAD_PATH + CO_E_CANTDETERMINECLASS + CO_E_CLASSSTRING + CO_E_CLASS_CREATE_FAILED + CO_E_DLLNOTFOUND + CO_E_ERRORINAPP + CO_E_ERRORINDLL + CO_E_FIRST + CO_E_IIDSTRING + CO_E_INIT_CLASS_CACHE + CO_E_INIT_MEMORY_ALLOCATOR + CO_E_INIT_ONLY_SINGLE_THREADED + CO_E_INIT_RPC_CHANNEL + CO_E_INIT_SCM_EXEC_FAILURE + CO_E_INIT_SCM_FILE_MAPPING_EXISTS + CO_E_INIT_SCM_MAP_VIEW_OF_FILE + CO_E_INIT_SCM_MUTEX_EXISTS + CO_E_INIT_SHARED_ALLOCATOR + CO_E_INIT_TLS + CO_E_INIT_TLS_CHANNEL_CONTROL + CO_E_INIT_TLS_SET_CHANNEL_CONTROL + CO_E_INIT_UNACCEPTED_USER_ALLOCATOR + CO_E_LAST + CO_E_NOTINITIALIZED + CO_E_OBJISREG + CO_E_OBJNOTCONNECTED + CO_E_OBJNOTREG + CO_E_OBJSRV_RPC_FAILURE + CO_E_RELEASED + CO_E_SCM_ERROR + CO_E_SCM_RPC_FAILURE + CO_E_SERVER_EXEC_FAILURE + CO_E_SERVER_STOPPING + CO_E_WRONGOSFORAPP + CO_S_FIRST + CO_S_LAST + DATA_E_FIRST + DATA_E_LAST + DATA_S_FIRST + DATA_S_LAST + DATA_S_SAMEFORMATETC + DISP_E_ARRAYISLOCKED + DISP_E_BADCALLEE + DISP_E_BADINDEX + DISP_E_BADPARAMCOUNT + DISP_E_BADVARTYPE + DISP_E_EXCEPTION + DISP_E_MEMBERNOTFOUND + DISP_E_NONAMEDARGS + DISP_E_NOTACOLLECTION + DISP_E_OVERFLOW + DISP_E_PARAMNOTFOUND + DISP_E_PARAMNOTOPTIONAL + DISP_E_TYPEMISMATCH + DISP_E_UNKNOWNINTERFACE + DISP_E_UNKNOWNLCID + DISP_E_UNKNOWNNAME + DRAGDROP_E_ALREADYREGISTERED + DRAGDROP_E_FIRST + DRAGDROP_E_INVALIDHWND + DRAGDROP_E_LAST + DRAGDROP_E_NOTREGISTERED + DRAGDROP_S_CANCEL + DRAGDROP_S_DROP + DRAGDROP_S_FIRST + DRAGDROP_S_LAST + DRAGDROP_S_USEDEFAULTCURSORS + DV_E_CLIPFORMAT + DV_E_DVASPECT + DV_E_DVTARGETDEVICE + DV_E_DVTARGETDEVICE_SIZE + DV_E_FORMATETC + DV_E_LINDEX + DV_E_NOIVIEWOBJECT + DV_E_STATDATA + DV_E_STGMEDIUM + DV_E_TYMED + ENUM_E_FIRST + ENUM_E_LAST + ENUM_S_FIRST + ENUM_S_LAST + EPT_S_CANT_CREATE + EPT_S_CANT_PERFORM_OP + EPT_S_INVALID_ENTRY + EPT_S_NOT_REGISTERED + ERROR_ACCESS_DENIED + ERROR_ACCOUNT_DISABLED + ERROR_ACCOUNT_EXPIRED + ERROR_ACCOUNT_LOCKED_OUT + ERROR_ACCOUNT_RESTRICTION + ERROR_ACTIVE_CONNECTIONS + ERROR_ADAP_HDW_ERR + ERROR_ADDRESS_ALREADY_ASSOCIATED + ERROR_ADDRESS_NOT_ASSOCIATED + ERROR_ALIAS_EXISTS + ERROR_ALLOTTED_SPACE_EXCEEDED + ERROR_ALREADY_ASSIGNED + ERROR_ALREADY_EXISTS + ERROR_ALREADY_REGISTERED + ERROR_ALREADY_RUNNING_LKG + ERROR_ALREADY_WAITING + ERROR_ARENA_TRASHED + ERROR_ARITHMETIC_OVERFLOW + ERROR_ATOMIC_LOCKS_NOT_SUPPORTED + ERROR_AUTODATASEG_EXCEEDS_64k + ERROR_BADDB + ERROR_BADKEY + ERROR_BAD_ARGUMENTS + ERROR_BAD_COMMAND + ERROR_BAD_DESCRIPTOR_FORMAT + ERROR_BAD_DEVICE + ERROR_BAD_DEV_TYPE + ERROR_BAD_DRIVER + ERROR_BAD_DRIVER_LEVEL + ERROR_BAD_ENVIRONMENT + ERROR_BAD_EXE_FORMAT + ERROR_BAD_FORMAT + ERROR_BAD_IMPERSONATION_LEVEL + ERROR_BAD_INHERITANCE_ACL + ERROR_BAD_LENGTH + ERROR_BAD_LOGON_SESSION_STATE + ERROR_BAD_NETPATH + ERROR_BAD_NET_NAME + ERROR_BAD_NET_RESP + ERROR_BAD_PATHNAME + ERROR_BAD_PIPE + ERROR_BAD_PROFILE + ERROR_BAD_PROVIDER + ERROR_BAD_REM_ADAP + ERROR_BAD_THREADID_ADDR + ERROR_BAD_TOKEN_TYPE + ERROR_BAD_UNIT + ERROR_BAD_USERNAME + ERROR_BAD_VALIDATION_CLASS + ERROR_BEGINNING_OF_MEDIA + ERROR_BOOT_ALREADY_ACCEPTED + ERROR_BROKEN_PIPE + ERROR_BUFFER_OVERFLOW + ERROR_BUSY + ERROR_BUSY_DRIVE + ERROR_BUS_RESET + ERROR_CALL_NOT_IMPLEMENTED + ERROR_CANCELLED + ERROR_CANCEL_VIOLATION + ERROR_CANNOT_COPY + ERROR_CANNOT_FIND_WND_CLASS + ERROR_CANNOT_IMPERSONATE + ERROR_CANNOT_MAKE + ERROR_CANNOT_OPEN_PROFILE + ERROR_CANTOPEN + ERROR_CANTREAD + ERROR_CANTWRITE + ERROR_CANT_ACCESS_DOMAIN_INFO + ERROR_CANT_DISABLE_MANDATORY + ERROR_CANT_OPEN_ANONYMOUS + ERROR_CAN_NOT_COMPLETE + ERROR_CAN_NOT_DEL_LOCAL_WINS + ERROR_CHILD_MUST_BE_VOLATILE + ERROR_CHILD_NOT_COMPLETE + ERROR_CHILD_WINDOW_MENU + ERROR_CIRCULAR_DEPENDENCY + ERROR_CLASS_ALREADY_EXISTS + ERROR_CLASS_DOES_NOT_EXIST + ERROR_CLASS_HAS_WINDOWS + ERROR_CLIPBOARD_NOT_OPEN + ERROR_CLIPPING_NOT_SUPPORTED + ERROR_CONNECTION_ABORTED + ERROR_CONNECTION_ACTIVE + ERROR_CONNECTION_COUNT_LIMIT + ERROR_CONNECTION_INVALID + ERROR_CONNECTION_REFUSED + ERROR_CONNECTION_UNAVAIL + ERROR_CONTROL_ID_NOT_FOUND + ERROR_COUNTER_TIMEOUT + ERROR_CRC + ERROR_CURRENT_DIRECTORY + ERROR_DATABASE_DOES_NOT_EXIST + ERROR_DC_NOT_FOUND + ERROR_DEPENDENT_SERVICES_RUNNING + ERROR_DESTROY_OBJECT_OF_OTHER_THREAD + ERROR_DEVICE_ALREADY_REMEMBERED + ERROR_DEVICE_IN_USE + ERROR_DEVICE_NOT_PARTITIONED + ERROR_DEV_NOT_EXIST + ERROR_DIRECTORY + ERROR_DIRECT_ACCESS_HANDLE + ERROR_DIR_NOT_EMPTY + ERROR_DIR_NOT_ROOT + ERROR_DISCARDED + ERROR_DISK_CHANGE + ERROR_DISK_CORRUPT + ERROR_DISK_FULL + ERROR_DISK_OPERATION_FAILED + ERROR_DISK_RECALIBRATE_FAILED + ERROR_DISK_RESET_FAILED + ERROR_DLL_INIT_FAILED + ERROR_DOMAIN_CONTROLLER_NOT_FOUND + ERROR_DOMAIN_EXISTS + ERROR_DOMAIN_LIMIT_EXCEEDED + ERROR_DOMAIN_TRUST_INCONSISTENT + ERROR_DRIVE_LOCKED + ERROR_DUPLICATE_SERVICE_NAME + ERROR_DUP_DOMAINNAME + ERROR_DUP_NAME + ERROR_DYNLINK_FROM_INVALID_RING + ERROR_EAS_DIDNT_FIT + ERROR_EAS_NOT_SUPPORTED + ERROR_EA_ACCESS_DENIED + ERROR_EA_FILE_CORRUPT + ERROR_EA_LIST_INCONSISTENT + ERROR_EA_TABLE_FULL + ERROR_END_OF_MEDIA + ERROR_ENVVAR_NOT_FOUND + ERROR_EOM_OVERFLOW + ERROR_EVENTLOG_CANT_START + ERROR_EVENTLOG_FILE_CHANGED + ERROR_EVENTLOG_FILE_CORRUPT + ERROR_EXCEPTION_IN_SERVICE + ERROR_EXCL_SEM_ALREADY_OWNED + ERROR_EXE_MARKED_INVALID + ERROR_EXTENDED_ERROR + ERROR_FAILED_SERVICE_CONTROLLER_CONNECT + ERROR_FAIL_I24 + ERROR_FILEMARK_DETECTED + ERROR_FILENAME_EXCED_RANGE + ERROR_FILE_CORRUPT + ERROR_FILE_EXISTS + ERROR_FILE_INVALID + ERROR_FILE_NOT_FOUND + ERROR_FLOPPY_BAD_REGISTERS + ERROR_FLOPPY_ID_MARK_NOT_FOUND + ERROR_FLOPPY_UNKNOWN_ERROR + ERROR_FLOPPY_WRONG_CYLINDER + ERROR_FULLSCREEN_MODE + ERROR_FULL_BACKUP + ERROR_GENERIC_NOT_MAPPED + ERROR_GEN_FAILURE + ERROR_GLOBAL_ONLY_HOOK + ERROR_GRACEFUL_DISCONNECT + ERROR_GROUP_EXISTS + ERROR_HANDLE_DISK_FULL + ERROR_HANDLE_EOF + ERROR_HOOK_NEEDS_HMOD + ERROR_HOOK_NOT_INSTALLED + ERROR_HOST_UNREACHABLE + ERROR_HOTKEY_ALREADY_REGISTERED + ERROR_HOTKEY_NOT_REGISTERED + ERROR_HWNDS_HAVE_DIFF_PARENT + ERROR_ILL_FORMED_PASSWORD + ERROR_INCORRECT_ADDRESS + ERROR_INC_BACKUP + ERROR_INFLOOP_IN_RELOC_CHAIN + ERROR_INSUFFICIENT_BUFFER + ERROR_INTERNAL_DB_CORRUPTION + ERROR_INTERNAL_DB_ERROR + ERROR_INTERNAL_ERROR + ERROR_INVALID_ACCEL_HANDLE + ERROR_INVALID_ACCESS + ERROR_INVALID_ACCOUNT_NAME + ERROR_INVALID_ACL + ERROR_INVALID_ADDRESS + ERROR_INVALID_AT_INTERRUPT_TIME + ERROR_INVALID_BLOCK + ERROR_INVALID_BLOCK_LENGTH + ERROR_INVALID_CATEGORY + ERROR_INVALID_COMBOBOX_MESSAGE + ERROR_INVALID_COMPUTERNAME + ERROR_INVALID_CURSOR_HANDLE + ERROR_INVALID_DATA + ERROR_INVALID_DATATYPE + ERROR_INVALID_DOMAINNAME + ERROR_INVALID_DOMAIN_ROLE + ERROR_INVALID_DOMAIN_STATE + ERROR_INVALID_DRIVE + ERROR_INVALID_DWP_HANDLE + ERROR_INVALID_EA_HANDLE + ERROR_INVALID_EA_NAME + ERROR_INVALID_EDIT_HEIGHT + ERROR_INVALID_ENVIRONMENT + ERROR_INVALID_EVENTNAME + ERROR_INVALID_EVENT_COUNT + ERROR_INVALID_EXE_SIGNATURE + ERROR_INVALID_FILTER_PROC + ERROR_INVALID_FLAGS + ERROR_INVALID_FLAG_NUMBER + ERROR_INVALID_FORM_NAME + ERROR_INVALID_FORM_SIZE + ERROR_INVALID_FUNCTION + ERROR_INVALID_GROUPNAME + ERROR_INVALID_GROUP_ATTRIBUTES + ERROR_INVALID_GW_COMMAND + ERROR_INVALID_HANDLE + ERROR_INVALID_HOOK_FILTER + ERROR_INVALID_HOOK_HANDLE + ERROR_INVALID_ICON_HANDLE + ERROR_INVALID_ID_AUTHORITY + ERROR_INVALID_INDEX + ERROR_INVALID_LB_MESSAGE + ERROR_INVALID_LEVEL + ERROR_INVALID_LIST_FORMAT + ERROR_INVALID_LOGON_HOURS + ERROR_INVALID_LOGON_TYPE + ERROR_INVALID_MEMBER + ERROR_INVALID_MENU_HANDLE + ERROR_INVALID_MESSAGE + ERROR_INVALID_MESSAGEDEST + ERROR_INVALID_MESSAGENAME + ERROR_INVALID_MINALLOCSIZE + ERROR_INVALID_MODULETYPE + ERROR_INVALID_MSGBOX_STYLE + ERROR_INVALID_NAME + ERROR_INVALID_NETNAME + ERROR_INVALID_ORDINAL + ERROR_INVALID_OWNER + ERROR_INVALID_PARAMETER + ERROR_INVALID_PASSWORD + ERROR_INVALID_PASSWORDNAME + ERROR_INVALID_PIXEL_FORMAT + ERROR_INVALID_PRIMARY_GROUP + ERROR_INVALID_PRINTER_COMMAND + ERROR_INVALID_PRINTER_NAME + ERROR_INVALID_PRINTER_STATE + ERROR_INVALID_PRIORITY + ERROR_INVALID_SCROLLBAR_RANGE + ERROR_INVALID_SECURITY_DESCR + ERROR_INVALID_SEGDPL + ERROR_INVALID_SEGMENT_NUMBER + ERROR_INVALID_SEPARATOR_FILE + ERROR_INVALID_SERVER_STATE + ERROR_INVALID_SERVICENAME + ERROR_INVALID_SERVICE_ACCOUNT + ERROR_INVALID_SERVICE_CONTROL + ERROR_INVALID_SERVICE_LOCK + ERROR_INVALID_SHARENAME + ERROR_INVALID_SHOWWIN_COMMAND + ERROR_INVALID_SID + ERROR_INVALID_SIGNAL_NUMBER + ERROR_INVALID_SPI_VALUE + ERROR_INVALID_STACKSEG + ERROR_INVALID_STARTING_CODESEG + ERROR_INVALID_SUB_AUTHORITY + ERROR_INVALID_TARGET_HANDLE + ERROR_INVALID_THREAD_ID + ERROR_INVALID_TIME + ERROR_INVALID_USER_BUFFER + ERROR_INVALID_VERIFY_SWITCH + ERROR_INVALID_WINDOW_HANDLE + ERROR_INVALID_WINDOW_STYLE + ERROR_INVALID_WORKSTATION + ERROR_IOPL_NOT_ENABLED + ERROR_IO_DEVICE + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + ERROR_IRQ_BUSY + ERROR_IS_JOINED + ERROR_IS_JOIN_PATH + ERROR_IS_JOIN_TARGET + ERROR_IS_SUBSTED + ERROR_IS_SUBST_PATH + ERROR_IS_SUBST_TARGET + ERROR_ITERATED_DATA_EXCEEDS_64k + ERROR_JOIN_TO_JOIN + ERROR_JOIN_TO_SUBST + ERROR_JOURNAL_HOOK_SET + ERROR_KEY_DELETED + ERROR_KEY_HAS_CHILDREN + ERROR_LABEL_TOO_LONG + ERROR_LAST_ADMIN + ERROR_LB_WITHOUT_TABSTOPS + ERROR_LISTBOX_ID_NOT_FOUND + ERROR_LM_CROSS_ENCRYPTION_REQUIRED + ERROR_LOCAL_USER_SESSION_KEY + ERROR_LOCKED + ERROR_LOCK_FAILED + ERROR_LOCK_VIOLATION + ERROR_LOGIN_TIME_RESTRICTION + ERROR_LOGIN_WKSTA_RESTRICTION + ERROR_LOGON_FAILURE + ERROR_LOGON_NOT_GRANTED + ERROR_LOGON_SESSION_COLLISION + ERROR_LOGON_SESSION_EXISTS + ERROR_LOGON_TYPE_NOT_GRANTED + ERROR_LOG_FILE_FULL + ERROR_LUIDS_EXHAUSTED + ERROR_MAPPED_ALIGNMENT + ERROR_MAX_THRDS_REACHED + ERROR_MEDIA_CHANGED + ERROR_MEMBERS_PRIMARY_GROUP + ERROR_MEMBER_IN_ALIAS + ERROR_MEMBER_IN_GROUP + ERROR_MEMBER_NOT_IN_ALIAS + ERROR_MEMBER_NOT_IN_GROUP + ERROR_METAFILE_NOT_SUPPORTED + ERROR_META_EXPANSION_TOO_LONG + ERROR_MOD_NOT_FOUND + ERROR_MORE_DATA + ERROR_MORE_WRITES + ERROR_MR_MID_NOT_FOUND + ERROR_NEGATIVE_SEEK + ERROR_NESTING_NOT_ALLOWED + ERROR_NETLOGON_NOT_STARTED + ERROR_NETNAME_DELETED + ERROR_NETWORK_ACCESS_DENIED + ERROR_NETWORK_BUSY + ERROR_NETWORK_UNREACHABLE + ERROR_NET_WRITE_FAULT + ERROR_NOACCESS + ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT + ERROR_NOLOGON_SERVER_TRUST_ACCOUNT + ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT + ERROR_NONE_MAPPED + ERROR_NON_MDICHILD_WINDOW + ERROR_NOTIFY_ENUM_DIR + ERROR_NOT_ALL_ASSIGNED + ERROR_NOT_CHILD_WINDOW + ERROR_NOT_CONNECTED + ERROR_NOT_CONTAINER + ERROR_NOT_DOS_DISK + ERROR_NOT_ENOUGH_MEMORY + ERROR_NOT_ENOUGH_QUOTA + ERROR_NOT_ENOUGH_SERVER_MEMORY + ERROR_NOT_JOINED + ERROR_NOT_LOCKED + ERROR_NOT_LOGON_PROCESS + ERROR_NOT_OWNER + ERROR_NOT_READY + ERROR_NOT_REGISTRY_FILE + ERROR_NOT_SAME_DEVICE + ERROR_NOT_SUBSTED + ERROR_NOT_SUPPORTED + ERROR_NO_BROWSER_SERVERS_FOUND + ERROR_NO_DATA + ERROR_NO_DATA_DETECTED + ERROR_NO_IMPERSONATION_TOKEN + ERROR_NO_INHERITANCE + ERROR_NO_LOGON_SERVERS + ERROR_NO_LOG_SPACE + ERROR_NO_MEDIA_IN_DRIVE + ERROR_NO_MORE_FILES + ERROR_NO_MORE_ITEMS + ERROR_NO_MORE_SEARCH_HANDLES + ERROR_NO_NETWORK + ERROR_NO_NET_OR_BAD_PATH + ERROR_NO_PROC_SLOTS + ERROR_NO_QUOTAS_FOR_ACCOUNT + ERROR_NO_SCROLLBARS + ERROR_NO_SECURITY_ON_OBJECT + ERROR_NO_SHUTDOWN_IN_PROGRESS + ERROR_NO_SIGNAL_SENT + ERROR_NO_SPOOL_SPACE + ERROR_NO_SUCH_ALIAS + ERROR_NO_SUCH_DOMAIN + ERROR_NO_SUCH_GROUP + ERROR_NO_SUCH_LOGON_SESSION + ERROR_NO_SUCH_MEMBER + ERROR_NO_SUCH_PACKAGE + ERROR_NO_SUCH_PRIVILEGE + ERROR_NO_SUCH_USER + ERROR_NO_SYSTEM_MENU + ERROR_NO_TOKEN + ERROR_NO_TRUST_LSA_SECRET + ERROR_NO_TRUST_SAM_ACCOUNT + ERROR_NO_UNICODE_TRANSLATION + ERROR_NO_USER_SESSION_KEY + ERROR_NO_VOLUME_LABEL + ERROR_NO_WILDCARD_CHARACTERS + ERROR_NT_CROSS_ENCRYPTION_REQUIRED + ERROR_NULL_LM_PASSWORD + ERROR_OPEN_FAILED + ERROR_OPEN_FILES + ERROR_OPERATION_ABORTED + ERROR_OUTOFMEMORY + ERROR_OUT_OF_PAPER + ERROR_OUT_OF_STRUCTURES + ERROR_PARTIAL_COPY + ERROR_PARTITION_FAILURE + ERROR_PASSWORD_EXPIRED + ERROR_PASSWORD_MUST_CHANGE + ERROR_PASSWORD_RESTRICTION + ERROR_PATH_BUSY + ERROR_PATH_NOT_FOUND + ERROR_PIPE_BUSY + ERROR_PIPE_CONNECTED + ERROR_PIPE_LISTENING + ERROR_PIPE_NOT_CONNECTED + ERROR_POPUP_ALREADY_ACTIVE + ERROR_PORT_UNREACHABLE + ERROR_POSSIBLE_DEADLOCK + ERROR_PRINTER_ALREADY_EXISTS + ERROR_PRINTER_DELETED + ERROR_PRINTER_DRIVER_ALREADY_INSTALLED + ERROR_PRINTER_DRIVER_IN_USE + ERROR_PRINTQ_FULL + ERROR_PRINT_CANCELLED + ERROR_PRINT_MONITOR_ALREADY_INSTALLED + ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED + ERROR_PRIVATE_DIALOG_INDEX + ERROR_PRIVILEGE_NOT_HELD + ERROR_PROCESS_ABORTED + ERROR_PROC_NOT_FOUND + ERROR_PROTOCOL_UNREACHABLE + ERROR_READ_FAULT + ERROR_REC_NON_EXISTENT + ERROR_REDIRECTOR_HAS_OPEN_HANDLES + ERROR_REDIR_PAUSED + ERROR_REGISTRY_CORRUPT + ERROR_REGISTRY_IO_FAILED + ERROR_REGISTRY_RECOVERED + ERROR_RELOC_CHAIN_XEEDS_SEGLIM + ERROR_REMOTE_SESSION_LIMIT_EXCEEDED + ERROR_REM_NOT_LIST + ERROR_REQUEST_ABORTED + ERROR_REQ_NOT_ACCEP + ERROR_RESOURCE_DATA_NOT_FOUND + ERROR_RESOURCE_LANG_NOT_FOUND + ERROR_RESOURCE_NAME_NOT_FOUND + ERROR_RESOURCE_TYPE_NOT_FOUND + ERROR_RETRY + ERROR_REVISION_MISMATCH + ERROR_RING2SEG_MUST_BE_MOVABLE + ERROR_RING2_STACK_IN_USE + ERROR_RPL_NOT_ALLOWED + ERROR_RXACT_COMMIT_FAILURE + ERROR_RXACT_INVALID_STATE + ERROR_SAME_DRIVE + ERROR_SCREEN_ALREADY_LOCKED + ERROR_SECRET_TOO_LONG + ERROR_SECTOR_NOT_FOUND + ERROR_SEEK + ERROR_SEEK_ON_DEVICE + ERROR_SEM_IS_SET + ERROR_SEM_NOT_FOUND + ERROR_SEM_OWNER_DIED + ERROR_SEM_TIMEOUT + ERROR_SEM_USER_LIMIT + ERROR_SERIAL_NO_DEVICE + ERROR_SERVER_DISABLED + ERROR_SERVER_HAS_OPEN_HANDLES + ERROR_SERVER_NOT_DISABLED + ERROR_SERVICE_ALREADY_RUNNING + ERROR_SERVICE_CANNOT_ACCEPT_CTRL + ERROR_SERVICE_DATABASE_LOCKED + ERROR_SERVICE_DEPENDENCY_DELETED + ERROR_SERVICE_DEPENDENCY_FAIL + ERROR_SERVICE_DISABLED + ERROR_SERVICE_DOES_NOT_EXIST + ERROR_SERVICE_EXISTS + ERROR_SERVICE_LOGON_FAILED + ERROR_SERVICE_MARKED_FOR_DELETE + ERROR_SERVICE_NEVER_STARTED + ERROR_SERVICE_NOT_ACTIVE + ERROR_SERVICE_NOT_FOUND + ERROR_SERVICE_NO_THREAD + ERROR_SERVICE_REQUEST_TIMEOUT + ERROR_SERVICE_SPECIFIC_ERROR + ERROR_SERVICE_START_HANG + ERROR_SESSION_CREDENTIAL_CONFLICT + ERROR_SETCOUNT_ON_BAD_LB + ERROR_SETMARK_DETECTED + ERROR_SHARING_BUFFER_EXCEEDED + ERROR_SHARING_PAUSED + ERROR_SHARING_VIOLATION + ERROR_SHUTDOWN_IN_PROGRESS + ERROR_SIGNAL_PENDING + ERROR_SIGNAL_REFUSED + ERROR_SOME_NOT_MAPPED + ERROR_SPECIAL_ACCOUNT + ERROR_SPECIAL_GROUP + ERROR_SPECIAL_USER + ERROR_SPL_NO_ADDJOB + ERROR_SPL_NO_STARTDOC + ERROR_SPOOL_FILE_NOT_FOUND + ERROR_STACK_OVERFLOW + ERROR_STATIC_INIT + ERROR_SUBST_TO_JOIN + ERROR_SUBST_TO_SUBST + ERROR_SUCCESS + ERROR_SWAPERROR + ERROR_SYSTEM_TRACE + ERROR_THREAD_1_INACTIVE + ERROR_TLW_WITH_WSCHILD + ERROR_TOKEN_ALREADY_IN_USE + ERROR_TOO_MANY_CMDS + ERROR_TOO_MANY_CONTEXT_IDS + ERROR_TOO_MANY_LUIDS_REQUESTED + ERROR_TOO_MANY_MODULES + ERROR_TOO_MANY_MUXWAITERS + ERROR_TOO_MANY_NAMES + ERROR_TOO_MANY_OPEN_FILES + ERROR_TOO_MANY_POSTS + ERROR_TOO_MANY_SECRETS + ERROR_TOO_MANY_SEMAPHORES + ERROR_TOO_MANY_SEM_REQUESTS + ERROR_TOO_MANY_SESS + ERROR_TOO_MANY_SIDS + ERROR_TOO_MANY_TCBS + ERROR_TRANSFORM_NOT_SUPPORTED + ERROR_TRUSTED_DOMAIN_FAILURE + ERROR_TRUSTED_RELATIONSHIP_FAILURE + ERROR_TRUST_FAILURE + ERROR_UNABLE_TO_LOCK_MEDIA + ERROR_UNABLE_TO_UNLOAD_MEDIA + ERROR_UNEXP_NET_ERR + ERROR_UNKNOWN_PORT + ERROR_UNKNOWN_PRINTER_DRIVER + ERROR_UNKNOWN_PRINTPROCESSOR + ERROR_UNKNOWN_PRINT_MONITOR + ERROR_UNKNOWN_REVISION + ERROR_UNRECOGNIZED_MEDIA + ERROR_UNRECOGNIZED_VOLUME + ERROR_USER_EXISTS + ERROR_USER_MAPPED_FILE + ERROR_VC_DISCONNECTED + ERROR_WAIT_NO_CHILDREN + ERROR_WINDOW_NOT_COMBOBOX + ERROR_WINDOW_NOT_DIALOG + ERROR_WINDOW_OF_OTHER_THREAD + ERROR_WINS_INTERNAL + ERROR_WRITE_FAULT + ERROR_WRITE_PROTECT + ERROR_WRONG_DISK + ERROR_WRONG_PASSWORD + E_ABORT + E_ACCESSDENIED + E_FAIL + E_HANDLE + E_INVALIDARG + E_NOINTERFACE + E_NOTIMPL + E_OUTOFMEMORY + E_POINTER + E_UNEXPECTED + FACILITY_CONTROL + FACILITY_DISPATCH + FACILITY_ITF + FACILITY_NT_BIT + FACILITY_NULL + FACILITY_RPC + FACILITY_STORAGE + FACILITY_WIN32 + FACILITY_WINDOWS + INPLACE_E_FIRST + INPLACE_E_LAST + INPLACE_E_NOTOOLSPACE + INPLACE_E_NOTUNDOABLE + INPLACE_S_FIRST + INPLACE_S_LAST + INPLACE_S_TRUNCATED + MARSHAL_E_FIRST + MARSHAL_E_LAST + MARSHAL_S_FIRST + MARSHAL_S_LAST + MEM_E_INVALID_LINK + MEM_E_INVALID_ROOT + MEM_E_INVALID_SIZE + MK_E_CANTOPENFILE + MK_E_CONNECTMANUALLY + MK_E_ENUMERATION_FAILED + MK_E_EXCEEDEDDEADLINE + MK_E_FIRST + MK_E_INTERMEDIATEINTERFACENOTSUPPORTED + MK_E_INVALIDEXTENSION + MK_E_LAST + MK_E_MUSTBOTHERUSER + MK_E_NEEDGENERIC + MK_E_NOINVERSE + MK_E_NOOBJECT + MK_E_NOPREFIX + MK_E_NOSTORAGE + MK_E_NOTBINDABLE + MK_E_NOTBOUND + MK_E_NO_NORMALIZED + MK_E_SYNTAX + MK_E_UNAVAILABLE + MK_S_FIRST + MK_S_HIM + MK_S_LAST + MK_S_ME + MK_S_MONIKERALREADYREGISTERED + MK_S_REDUCED_TO_SELF + MK_S_US + NOERROR + NO_ERROR + OLEOBJ_E_FIRST + OLEOBJ_E_INVALIDVERB + OLEOBJ_E_LAST + OLEOBJ_E_NOVERBS + OLEOBJ_S_CANNOT_DOVERB_NOW + OLEOBJ_S_FIRST + OLEOBJ_S_INVALIDHWND + OLEOBJ_S_INVALIDVERB + OLEOBJ_S_LAST + OLE_E_ADVF + OLE_E_ADVISENOTSUPPORTED + OLE_E_BLANK + OLE_E_CANTCONVERT + OLE_E_CANT_BINDTOSOURCE + OLE_E_CANT_GETMONIKER + OLE_E_CLASSDIFF + OLE_E_ENUM_NOMORE + OLE_E_FIRST + OLE_E_INVALIDHWND + OLE_E_INVALIDRECT + OLE_E_LAST + OLE_E_NOCACHE + OLE_E_NOCONNECTION + OLE_E_NOSTORAGE + OLE_E_NOTRUNNING + OLE_E_NOT_INPLACEACTIVE + OLE_E_OLEVERB + OLE_E_PROMPTSAVECANCELLED + OLE_E_STATIC + OLE_E_WRONGCOMPOBJ + OLE_S_FIRST + OLE_S_LAST + OLE_S_MAC_CLIPFORMAT + OLE_S_STATIC + OLE_S_USEREG + REGDB_E_CLASSNOTREG + REGDB_E_FIRST + REGDB_E_IIDNOTREG + REGDB_E_INVALIDVALUE + REGDB_E_KEYMISSING + REGDB_E_LAST + REGDB_E_READREGDB + REGDB_E_WRITEREGDB + REGDB_S_FIRST + REGDB_S_LAST + RPC_E_ATTEMPTED_MULTITHREAD + RPC_E_CALL_CANCELED + RPC_E_CALL_REJECTED + RPC_E_CANTCALLOUT_AGAIN + RPC_E_CANTCALLOUT_INASYNCCALL + RPC_E_CANTCALLOUT_INEXTERNALCALL + RPC_E_CANTCALLOUT_ININPUTSYNCCALL + RPC_E_CANTPOST_INSENDCALL + RPC_E_CANTTRANSMIT_CALL + RPC_E_CHANGED_MODE + RPC_E_CLIENT_CANTMARSHAL_DATA + RPC_E_CLIENT_CANTUNMARSHAL_DATA + RPC_E_CLIENT_DIED + RPC_E_CONNECTION_TERMINATED + RPC_E_DISCONNECTED + RPC_E_FAULT + RPC_E_INVALIDMETHOD + RPC_E_INVALID_CALLDATA + RPC_E_INVALID_DATA + RPC_E_INVALID_DATAPACKET + RPC_E_INVALID_PARAMETER + RPC_E_NOT_REGISTERED + RPC_E_OUT_OF_RESOURCES + RPC_E_RETRY + RPC_E_SERVERCALL_REJECTED + RPC_E_SERVERCALL_RETRYLATER + RPC_E_SERVERFAULT + RPC_E_SERVER_CANTMARSHAL_DATA + RPC_E_SERVER_CANTUNMARSHAL_DATA + RPC_E_SERVER_DIED + RPC_E_SERVER_DIED_DNE + RPC_E_SYS_CALL_FAILED + RPC_E_THREAD_NOT_INIT + RPC_E_UNEXPECTED + RPC_E_WRONG_THREAD + RPC_S_ADDRESS_ERROR + RPC_S_ALREADY_LISTENING + RPC_S_ALREADY_REGISTERED + RPC_S_BINDING_HAS_NO_AUTH + RPC_S_BINDING_INCOMPLETE + RPC_S_CALL_CANCELLED + RPC_S_CALL_FAILED + RPC_S_CALL_FAILED_DNE + RPC_S_CALL_IN_PROGRESS + RPC_S_CANNOT_SUPPORT + RPC_S_CANT_CREATE_ENDPOINT + RPC_S_COMM_FAILURE + RPC_S_DUPLICATE_ENDPOINT + RPC_S_ENTRY_ALREADY_EXISTS + RPC_S_ENTRY_NOT_FOUND + RPC_S_FP_DIV_ZERO + RPC_S_FP_OVERFLOW + RPC_S_FP_UNDERFLOW + RPC_S_GROUP_MEMBER_NOT_FOUND + RPC_S_INCOMPLETE_NAME + RPC_S_INTERFACE_NOT_FOUND + RPC_S_INTERNAL_ERROR + RPC_S_INVALID_AUTH_IDENTITY + RPC_S_INVALID_BINDING + RPC_S_INVALID_BOUND + RPC_S_INVALID_ENDPOINT_FORMAT + RPC_S_INVALID_NAF_ID + RPC_S_INVALID_NAME_SYNTAX + RPC_S_INVALID_NETWORK_OPTIONS + RPC_S_INVALID_NET_ADDR + RPC_S_INVALID_OBJECT + RPC_S_INVALID_RPC_PROTSEQ + RPC_S_INVALID_STRING_BINDING + RPC_S_INVALID_STRING_UUID + RPC_S_INVALID_TAG + RPC_S_INVALID_TIMEOUT + RPC_S_INVALID_VERS_OPTION + RPC_S_MAX_CALLS_TOO_SMALL + RPC_S_NAME_SERVICE_UNAVAILABLE + RPC_S_NOTHING_TO_EXPORT + RPC_S_NOT_ALL_OBJS_UNEXPORTED + RPC_S_NOT_CANCELLED + RPC_S_NOT_LISTENING + RPC_S_NOT_RPC_ERROR + RPC_S_NO_BINDINGS + RPC_S_NO_CALL_ACTIVE + RPC_S_NO_CONTEXT_AVAILABLE + RPC_S_NO_ENDPOINT_FOUND + RPC_S_NO_ENTRY_NAME + RPC_S_NO_INTERFACES + RPC_S_NO_MORE_BINDINGS + RPC_S_NO_MORE_MEMBERS + RPC_S_NO_PRINC_NAME + RPC_S_NO_PROTSEQS + RPC_S_NO_PROTSEQS_REGISTERED + RPC_S_OBJECT_NOT_FOUND + RPC_S_OUT_OF_RESOURCES + RPC_S_PROCNUM_OUT_OF_RANGE + RPC_S_PROTOCOL_ERROR + RPC_S_PROTSEQ_NOT_FOUND + RPC_S_PROTSEQ_NOT_SUPPORTED + RPC_S_SEC_PKG_ERROR + RPC_S_SERVER_TOO_BUSY + RPC_S_SERVER_UNAVAILABLE + RPC_S_STRING_TOO_LONG + RPC_S_TYPE_ALREADY_REGISTERED + RPC_S_UNKNOWN_AUTHN_LEVEL + RPC_S_UNKNOWN_AUTHN_SERVICE + RPC_S_UNKNOWN_AUTHN_TYPE + RPC_S_UNKNOWN_AUTHZ_SERVICE + RPC_S_UNKNOWN_IF + RPC_S_UNKNOWN_MGR_TYPE + RPC_S_UNSUPPORTED_AUTHN_LEVEL + RPC_S_UNSUPPORTED_NAME_SYNTAX + RPC_S_UNSUPPORTED_TRANS_SYN + RPC_S_UNSUPPORTED_TYPE + RPC_S_UUID_LOCAL_ONLY + RPC_S_UUID_NO_ADDRESS + RPC_S_WRONG_KIND_OF_BINDING + RPC_S_ZERO_DIVIDE + RPC_X_BAD_STUB_DATA + RPC_X_BYTE_COUNT_TOO_SMALL + RPC_X_ENUM_VALUE_OUT_OF_RANGE + RPC_X_INVALID_ES_ACTION + RPC_X_NO_MORE_ENTRIES + RPC_X_NULL_REF_POINTER + RPC_X_SS_CANNOT_GET_CALL_HANDLE + RPC_X_SS_CHAR_TRANS_OPEN_FAIL + RPC_X_SS_CHAR_TRANS_SHORT_FILE + RPC_X_SS_CONTEXT_DAMAGED + RPC_X_SS_HANDLES_MISMATCH + RPC_X_SS_IN_NULL_CONTEXT + RPC_X_WRONG_ES_VERSION + RPC_X_WRONG_STUB_VERSION + SEVERITY_ERROR + SEVERITY_SUCCESS + STG_E_ABNORMALAPIEXIT + STG_E_ACCESSDENIED + STG_E_CANTSAVE + STG_E_DISKISWRITEPROTECTED + STG_E_EXTANTMARSHALLINGS + STG_E_FILEALREADYEXISTS + STG_E_FILENOTFOUND + STG_E_INSUFFICIENTMEMORY + STG_E_INUSE + STG_E_INVALIDFLAG + STG_E_INVALIDFUNCTION + STG_E_INVALIDHANDLE + STG_E_INVALIDHEADER + STG_E_INVALIDNAME + STG_E_INVALIDPARAMETER + STG_E_INVALIDPOINTER + STG_E_LOCKVIOLATION + STG_E_MEDIUMFULL + STG_E_NOMOREFILES + STG_E_NOTCURRENT + STG_E_NOTFILEBASEDSTORAGE + STG_E_OLDDLL + STG_E_OLDFORMAT + STG_E_PATHNOTFOUND + STG_E_READFAULT + STG_E_REVERTED + STG_E_SEEKERROR + STG_E_SHAREREQUIRED + STG_E_SHAREVIOLATION + STG_E_TOOMANYOPENFILES + STG_E_UNIMPLEMENTEDFUNCTION + STG_E_UNKNOWN + STG_E_WRITEFAULT + STG_S_CONVERTED + S_FALSE + S_OK + TYPE_E_AMBIGUOUSNAME + TYPE_E_BADMODULEKIND + TYPE_E_BUFFERTOOSMALL + TYPE_E_CANTCREATETMPFILE + TYPE_E_CANTLOADLIBRARY + TYPE_E_CIRCULARTYPE + TYPE_E_DLLFUNCTIONNOTFOUND + TYPE_E_DUPLICATEID + TYPE_E_ELEMENTNOTFOUND + TYPE_E_INCONSISTENTPROPFUNCS + TYPE_E_INVALIDID + TYPE_E_INVALIDSTATE + TYPE_E_INVDATAREAD + TYPE_E_IOERROR + TYPE_E_LIBNOTREGISTERED + TYPE_E_NAMECONFLICT + TYPE_E_OUTOFBOUNDS + TYPE_E_QUALIFIEDNAMEDISALLOWED + TYPE_E_REGISTRYACCESS + TYPE_E_SIZETOOBIG + TYPE_E_TYPEMISMATCH + TYPE_E_UNDEFINEDTYPE + TYPE_E_UNKNOWNLCID + TYPE_E_UNSUPFORMAT + TYPE_E_WRONGTYPEKIND + VIEW_E_DRAW + VIEW_E_FIRST + VIEW_E_LAST + VIEW_S_ALREADY_FROZEN + VIEW_S_FIRST + VIEW_S_LAST +); + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + local $^E = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::WinError macro $constname, used at $file line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Win32::WinError; + +# Preloaded methods go here. + +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; +__END__ diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32API/Registry.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32API/Registry.pm new file mode 100644 index 0000000000..1004ea1b09 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32API/Registry.pm @@ -0,0 +1,1779 @@ +# Registry.pm -- Low-level access to functions/constants from WINREG.h
+
+package Win32API::Registry;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); #@EXPORT_FAIL);
+$VERSION= '0.33';
+
+require Exporter;
+require DynaLoader;
+@ISA= qw(Exporter DynaLoader);
+
+@EXPORT= qw();
+%EXPORT_TAGS= (
+ Func => [qw( regConstant regLastError
+ AllowPriv AbortSystemShutdown InitiateSystemShutdown
+ RegCloseKey RegConnectRegistry RegCreateKey
+ RegCreateKeyEx RegDeleteKey RegDeleteValue
+ RegEnumKey RegEnumKeyEx RegEnumValue
+ RegFlushKey RegGetKeySecurity RegLoadKey
+ RegNotifyChangeKeyValue RegOpenKey RegOpenKeyEx
+ RegQueryInfoKey RegQueryMultipleValues RegQueryValue
+ RegQueryValueEx RegReplaceKey RegRestoreKey
+ RegSaveKey RegSetKeySecurity RegSetValue
+ RegSetValueEx RegUnLoadKey )],
+ FuncA => [qw(
+ AbortSystemShutdownA InitiateSystemShutdownA
+ RegConnectRegistryA RegCreateKeyA RegCreateKeyExA
+ RegDeleteKeyA RegDeleteValueA RegEnumKeyA
+ RegEnumKeyExA RegEnumValueA RegLoadKeyA
+ RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA
+ RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA
+ RegReplaceKeyA RegRestoreKeyA RegSaveKeyA
+ RegSetValueA RegSetValueExA RegUnLoadKeyA )],
+ FuncW => [qw(
+ AbortSystemShutdownW InitiateSystemShutdownW
+ RegConnectRegistryW RegCreateKeyW RegCreateKeyExW
+ RegDeleteKeyW RegDeleteValueW RegEnumKeyW
+ RegEnumKeyExW RegEnumValueW RegLoadKeyW
+ RegOpenKeyW RegOpenKeyExW RegQueryInfoKeyW
+ RegQueryMultipleValuesW RegQueryValueW RegQueryValueExW
+ RegReplaceKeyW RegRestoreKeyW RegSaveKeyW
+ RegSetValueW RegSetValueExW RegUnLoadKeyW )],
+ HKEY_ => [qw(
+ HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER
+ HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA
+ HKEY_USERS )],
+ KEY_ => [qw(
+ KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
+ KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
+ KEY_READ KEY_WRITE KEY_EXECUTE
+ KEY_ALL_ACCESS),
+ 'KEY_DELETE', # DELETE (0x00010000L)
+ 'KEY_READ_CONTROL', # READ_CONTROL (0x00020000L)
+ 'KEY_WRITE_DAC', # WRITE_DAC (0x00040000L)
+ 'KEY_WRITE_OWNER', # WRITE_OWNER (0x00080000L)
+ 'KEY_SYNCHRONIZE', # SYNCHRONIZE (0x00100000L) (not used)
+ ],
+ REG_ => [qw(
+ REG_OPTION_RESERVED REG_OPTION_NON_VOLATILE REG_OPTION_VOLATILE
+ REG_OPTION_CREATE_LINK REG_OPTION_BACKUP_RESTORE
+ REG_OPTION_OPEN_LINK REG_LEGAL_OPTION REG_CREATED_NEW_KEY
+ REG_OPENED_EXISTING_KEY REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE
+ REG_NO_LAZY_FLUSH REG_NOTIFY_CHANGE_ATTRIBUTES
+ REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET
+ REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_CHANGE_FILTER
+ REG_NONE REG_SZ REG_EXPAND_SZ
+ REG_BINARY REG_DWORD REG_DWORD_LITTLE_ENDIAN
+ REG_DWORD_BIG_ENDIAN REG_LINK REG_MULTI_SZ
+ REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR
+ REG_RESOURCE_REQUIREMENTS_LIST )],
+ SE_ => [qw(
+ SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME
+ SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME
+ SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME
+ SE_CREATE_TOKEN_NAME SE_DEBUG_NAME
+ SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME
+ SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME
+ SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME
+ SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME
+ SE_SECURITY_NAME SE_SHUTDOWN_NAME
+ SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME
+ SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME
+ SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME )],
+);
+@EXPORT_OK= ();
+{ my $ref;
+ foreach $ref ( values(%EXPORT_TAGS) ) {
+ push( @EXPORT_OK, @$ref ) unless $ref->[0] =~ /^SE_/;
+ }
+}
+$EXPORT_TAGS{ALL}= [ @EXPORT_OK ]; # \@EXPORT_OK once SE_* settles down.
+# push( @EXPORT_OK, "JHEREG_TACOSALAD" ); # Used to test Mkconst2perl
+push( @EXPORT_OK, @{$EXPORT_TAGS{SE_}} );
+
+bootstrap Win32API::Registry $VERSION;
+
+# Preloaded methods go here.
+
+# To convert C constants to Perl code in cRegistry.pc
+# [instead of C or C++ code in cRegistry.h]:
+# * Modify F<Makefile.PL> to add WriteMakeFile() =>
+# CONST2PERL/postamble => [[ "Win32API::Registry" => ]] WRITE_PERL => 1.
+# * Either comment out C<#include "cRegistry.h"> from F<Registry.xs>
+# or make F<cRegistry.h> an empty file.
+# * Make sure the following C<if> block is not commented out.
+# * "nmake clean", "perl Makefile.PL", "nmake"
+
+if( ! defined ®_NONE ) {
+ require "Win32API/Registry/cRegistry.pc";
+}
+
+# This would be convenient but inconsistent and hard to explain:
+#push( @{$EXPORT_TAGS{ALL}}, @{$EXPORT_TAGS{SE_}} )
+# if defined &SE_TCB_NAME;
+
+sub regConstant
+{
+ my( $name )= @_;
+ if( 1 != @_ || ! $name || $name =~ /\W/ ) {
+ require Carp;
+ Carp::croak( 'Usage: ',__PACKAGE__,'::regConstant("CONST_NAME")' );
+ }
+ my $proto= prototype $name;
+ if( defined \&$name
+ && defined $proto
+ && "" eq $proto ) {
+ no strict 'refs';
+ return &$name;
+ }
+ return undef;
+}
+
+# We provide this for backwards compatibility:
+sub constant
+{
+ my( $name )= @_;
+ my $value= regConstant( $name );
+ if( defined $value ) {
+ $!= 0;
+ return $value;
+ }
+ $!= 11; # EINVAL
+ return 0;
+}
+
+BEGIN {
+ my $code= 'return _regLastError(@_)';
+ local( $!, $^E )= ( 1, 1 );
+ if( $! ne $^E ) {
+ $code= '
+ local( $^E )= _regLastError(@_);
+ my $ret= $^E;
+ return $ret;
+ ';
+ }
+ eval "sub regLastError { $code }";
+ die "$@" if $@;
+}
+
+# Since we ISA DynaLoader which ISA AutoLoader, we ISA AutoLoader so we
+# need this next chunk to prevent Win32API::Registry->nonesuch() from
+# looking for "nonesuch.al" and producing confusing error messages:
+use vars qw($AUTOLOAD);
+sub AUTOLOAD {
+ require Carp;
+ Carp::croak(
+ "Can't locate method $AUTOLOAD via package Win32API::Registry" );
+}
+
+# Replace "&rout;" with "goto &rout;" when that is supported on Win32.
+
+# Let user omit all buffer sizes:
+sub RegEnumKeyExA {
+ if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); }
+ &_RegEnumKeyExA;
+}
+sub RegEnumKeyExW {
+ if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); }
+ &_RegEnumKeyExW;
+}
+sub RegEnumValueA {
+ if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); }
+ &_RegEnumValueA;
+}
+sub RegEnumValueW {
+ if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); }
+ &_RegEnumValueW;
+}
+sub RegQueryInfoKeyA {
+ if( 11 == @_ ) { splice(@_,2,0,[]); }
+ &_RegQueryInfoKeyA;
+}
+sub RegQueryInfoKeyW {
+ if( 11 == @_ ) { splice(@_,2,0,[]); }
+ &_RegQueryInfoKeyW;
+}
+
+sub RegEnumKeyA {
+ push(@_,[]) if 3 == @_;
+ &_RegEnumKeyA;
+}
+sub RegEnumKeyW {
+ push(@_,[]) if 3 == @_;
+ &_RegEnumKeyW;
+}
+sub RegGetKeySecurity {
+ push(@_,[]) if 3 == @_;
+ &_RegGetKeySecurity;
+}
+sub RegQueryMultipleValuesA {
+ push(@_,[]) if 4 == @_;
+ &_RegQueryMultipleValuesA;
+}
+sub RegQueryMultipleValuesW {
+ push(@_,[]) if 4 == @_;
+ &_RegQueryMultipleValuesW;
+}
+sub RegQueryValueA {
+ push(@_,[]) if 3 == @_;
+ &_RegQueryValueA;
+}
+sub RegQueryValueW {
+ push(@_,[]) if 3 == @_;
+ &_RegQueryValueW;
+}
+sub RegQueryValueExA {
+ push(@_,[]) if 5 == @_;
+ &_RegQueryValueExA;
+}
+sub RegQueryValueExW {
+ push(@_,[]) if 5 == @_;
+ &_RegQueryValueExW;
+}
+sub RegSetValueA {
+ push(@_,0) if 4 == @_;
+ &_RegSetValueA;
+}
+sub RegSetValueW {
+ push(@_,0) if 4 == @_;
+ &_RegSetValueW;
+}
+sub RegSetValueExA {
+ push(@_,0) if 5 == @_;
+ &_RegSetValueExA;
+}
+sub RegSetValueExW {
+ push(@_,0) if 5 == @_;
+ &_RegSetValueExW;
+}
+
+# Aliases for non-Unicode functions:
+sub AbortSystemShutdown { &AbortSystemShutdownA; }
+sub InitiateSystemShutdown { &InitiateSystemShutdownA; }
+sub RegConnectRegistry { &RegConnectRegistryA; }
+sub RegCreateKey { &RegCreateKeyA; }
+sub RegCreateKeyEx { &RegCreateKeyExA; }
+sub RegDeleteKey { &RegDeleteKeyA; }
+sub RegDeleteValue { &RegDeleteValueA; }
+sub RegEnumKey { &RegEnumKeyA; }
+sub RegEnumKeyEx { &RegEnumKeyExA; }
+sub RegEnumValue { &RegEnumValueA; }
+sub RegLoadKey { &RegLoadKeyA; }
+sub RegOpenKey { &RegOpenKeyA; }
+sub RegOpenKeyEx { &RegOpenKeyExA; }
+sub RegQueryInfoKey { &RegQueryInfoKeyA; }
+sub RegQueryMultipleValues { &RegQueryMultipleValuesA; }
+sub RegQueryValue { &RegQueryValueA; }
+sub RegQueryValueEx { &RegQueryValueExA; }
+sub RegReplaceKey { &RegReplaceKeyA; }
+sub RegRestoreKey { &RegRestoreKeyA; }
+sub RegSaveKey { &RegSaveKeyA; }
+sub RegSetValue { &RegSetValueA; }
+sub RegSetValueEx { &RegSetValueExA; }
+sub RegUnLoadKey { &RegUnLoadKeyA; }
+
+1;
+__END__
+
+=head1 NAME
+
+Win32API::Registry - Low-level access to Win32 system API calls from WINREG.H
+
+=head1 SYNOPSIS
+
+ use Win32API::Registry 0.21 qw( :ALL );
+
+ RegOpenKeyEx( HKEY_LOCAL_MACHINE, "SYSTEM\\Disk", 0, KEY_READ, $key )
+ or die "Can't open HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ",
+ regLastError(),"\n";
+ RegQueryValueEx( $key, "Information", [], $type, $data, [] )
+ or die "Can't read HKEY_L*MACHINE\\SYSTEM\\Disk\\Information: ",
+ regLastError(),"\n";
+ [...]
+ RegCloseKey( $key )
+ or die "Can't close HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ",
+ regLastError(),"\n";
+
+=head1 DESCRIPTION
+
+This provides fairly low-level access to the Win32 System API
+calls dealing with the Registry [mostly from WINREG.H]. This
+is mostly intended to be used by other modules such as
+C<Win32::TieRegistry> [which provides an extremely Perl-friendly
+method for using the Registry].
+
+For a description of the logical structure of the Registry, see
+the documentation for the C<Win32::TieRegistry> module.
+
+To pass in C<NULL> as the pointer to an optional buffer, pass in
+an empty list reference, C<[]>.
+
+Beyond raw access to the API calls and related constants, this module
+handles smart buffer allocation and translation of return codes.
+
+All calls return a true value for success and a false value for
+failure. After any failure, C<$^E> should automatically be set
+to indicate the reason. However, current versions of Perl often
+overwrite C<$^E> too quickly, so you can use C<regLastError()>
+instead, which is only set by Win32API::Registry routines.
+C<regLastError()> is also good if you have a really old version
+of Perl that does not connect C<$^E> to C<GetLastError()> on
+Win32.
+
+Note that C<$!> is not set by these routines except by
+C<Win32API::Registry::constant()> when a constant is not defined.
+
+=head2 Exports
+
+Nothing is exported by default. The following tags can be used to
+have sets of symbols exported.
+
+[Note that much of the following documentation refers to the
+behavior of the underlying API calls which may vary in current
+and future versions of the Win32 API without any changes to this
+module. Therefore you should check the Win32 API documentation
+directly when needed.]
+
+=over
+
+=item :Func
+
+The basic function names:
+
+=over
+
+=item AllowPriv
+
+=item C<AllowPriv( $sPrivName, $bEnable )>
+
+Not a Win32 API call. Enables or disables a specific privilege for
+the current process. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure. This routine
+does not provide a way to tell if a privilege is currently enabled.
+
+C<$sPrivname> is a Win32 privilege name [see L</:SE_>]. For example,
+C<"SeBackupPrivilege"> [a.k.a. C<SE_BACKUP_NAME>] controls whether
+you can use C<RegSaveKey()> and C<"SeRestorePrivilege"> [a.k.a.
+C<SE_RESTORE_NAME>] controls whether you can use C<RegLoadKey()>.
+
+If C<$bEnable> is true, then C<AllowPriv()> tries to enable the
+privilege. Otherwise it tries to disable the privilege.
+
+=item AbortSystemShutdown
+
+=item C<AbortSystemShutdown( $sComputerName )>
+
+Tries to abort a remote shutdown request previously made via
+C<InitiateSystemShutdown()>. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+=item InitiateSystemShutdown
+
+=item C<InitiateSystemShutdown( $sComputer, $sMessage, $uTimeoutSecs, $bForce, $bReboot )>
+
+Requests that a [remote] computer be shutdown or rebooted.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$sComputer> is the name [or address] of the computer to be
+shutdown or rebooted. You can use C<[]> [for C<NULL>] or C<"">
+to indicate the local computer.
+
+C<$sMessage> is the message to be displayed in a pop-up window
+on the desktop of the computer to be shutdown or rebooted until
+the timeout expires or the shutdown is aborted via
+C<AbortSystemShutdown()>. With C<$iTimeoutSecs == 0>, the
+message will never be visible.
+
+C<$iTimeoutSecs> is the number of seconds to wait before starting
+the shutdown.
+
+If C<$bForce> is false, then any applications running on the remote
+computer get a chance to prompt the remote user whether they want
+to save changes. Also, for any applications that do not exit quickly
+enough, the operating system will prompt the user whether they wish
+to wait longer for the application to exit or force it to exit now.
+At any of these prompts the user can press B<CANCEL> to abort the
+shutdown but if no applications have unsaved data, they will likely
+all exit quickly and the shutdown will progress with the remote user
+having no option to cancel the shutdown.
+
+If C<$bForce> is true, all applications are told to exit immediately
+and so will not prompt the user even if there is unsaved data. Any
+applications that take too long to exit will be forcibly killed after
+a short time. The only way to abort the shutdown is to call
+C<AbortSystemShutdown()> before the timeout expires and there is no
+way to abort the shutdown once it has begun.
+
+If C<$bReboot> is true, the computer will automatically reboot once
+the shutdown is complete. If C<$bReboot> is false, then when the
+shutdown is complete the computer will halt at a screen indicating
+that the shutdown is complete and offering a way for the user to
+start to boot the computer.
+
+You must have the C<"SeRemoteShutdownPrivilege"> privilege
+on the remote computer for this call to succeed. If shutting
+down the local computer, then the calling process must have
+the C<"SeShutdownPrivilege"> privilege and have it enabled.
+
+=item RegCloseKey
+
+=item C<RegCloseKey( $hKey )>
+
+Closes the handle to a Registry key returned by C<RegOpenKeyEx()>,
+C<RegConnectRegistry()>, C<RegCreateKeyEx()>, or a few other
+routines. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+=item RegConnectRegistry
+
+=item C<RegConnectRegistry( $sComputer, $hRootKey, $ohKey )>
+
+Connects to one of the root Registry keys of a remote computer.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$sComputer> is the name [or address] of a remote computer
+whose Registry you wish to access.
+
+C<$hKey> must be either C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS>
+and specifies which root Registry key on the remote computer
+you wish to have access to.
+
+C<$phKey> will be set to the handle to be used to access the
+remote Registry key if the call succeeds.
+
+=item regConstant
+
+=item C<$value= regConstant( $sConstantName )>
+
+Fetch the value of a constant. Returns C<undef> if C<$sConstantName>
+is not the name of a constant supported by this module. Never sets
+C<$!> nor C<$^E>.
+
+This function is rarely used since you will usually get the value of a
+constant by having that constant imported into your package by listing
+the constant name in the C<use Win32API::Registry> statement and then
+simply using the constant name in your code [perhaps followed by
+C<()>]. This function is useful for verifying constant names not in
+Perl code, for example, after prompting a user to type in a constant
+name.
+
+=item RegCreateKey
+
+=item C<RegCreateKey( $hKey, $sSubKey, $ohSubKey )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegCreateKeyEx()> instead.
+
+=item RegCreateKeyEx
+
+=item C<RegCreateKeyEx( $hKey, $sSubKey, $uZero, $sClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )>
+
+Creates a new Registry subkey. Returns a true value if successful and
+a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of the new subkey to be created.
+
+C<$iZero> is reserved for future use and should always be specified
+as C<0>.
+
+C<$sClass> is a string to be used as the class for the new
+subkey. We are not aware of any current use for Registry key
+class information so the empty string, C<"">, should usually
+be used here.
+
+C<$iOpts> is a numeric value containing bits that control options
+used while creating the new subkey. C<REG_OPTION_NON_VOLATILE>
+is the default. C<REG_OPTION_VOLATILE> [which is ignored on
+Windows 95] means the data stored under this key is not kept
+in a file and will not be preserved when the system reboots.
+C<REG_OPTION_BACKUP_RESTORE> [also ignored on Windows 95] means
+ignore the C<$iAccess> parameter and try to open the new key with
+the access required to backup or restore the key.
+
+C<$iAccess> is a numeric mask of bits specifying what type of
+access is desired when opening the new subkey. See C<RegOpenKeyEx()>.
+
+C<$pSecAttr> is a C<SECURITY_ATTRIBUTES> structure packed into
+a Perl string which controls whether the returned handle can be
+inherited by child processes. Normally you would pass C<[]> for
+this parameter to have C<NULL> passed to the underlying API
+indicating that the handle cannot be inherited. If not under
+Windows95, then C<$pSecAttr> also allows you to specify
+C<SECURITY_DESCRIPTOR> that controls which users will have
+what type of access to the new key -- otherwise the new key
+inherits its security from its parent key.
+
+C<$phKey> will be set to the handle to be used to access the new
+subkey if the call succeeds.
+
+C<$piDisp> will be set to either C<REG_CREATED_NEW_KEY> or
+C<REG_OPENED_EXISTING_KEY> to indicate for which reason the
+call succeeded. Can be specified as C<[]> if you don't care.
+
+If C<$phKey> and C<$piDisp> start out as integers, then they will
+probably remain unchanged if the call fails.
+
+=item RegDeleteKey
+
+=item C<RegDeleteKey( $hKey, $sSubKey )>
+
+Deletes a subkey of an open Registry key provided that the subkey
+contains no subkeys of its own [but the subkey may contain values].
+Returns a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of the subkey to be deleted.
+
+=item RegDeleteValue
+
+=item C<RegDeleteValue( $hKey, $sValueName )>
+
+Deletes a value from an open Registry key. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sValueKey> is the name of the value to be deleted.
+
+=item RegEnumKey
+
+=item C<RegEnumKey( $hKey, $uIndex, $osName, $ilNameSize )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegEnumKeyEx()> instead.
+
+=item RegEnumKeyEx
+
+=item C<RegEnumKeyEx( $hKey, $uIndex, $osName, $iolName, $pNull, $osClass, $iolClass, $opftLastWrite )>
+
+Lets you enumerate the names of all of the subkeys directly under
+an open Registry key. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iIndex> is the sequence number of the immediate subkey that
+you want information on. Start with this value as C<0> then
+repeat the call incrementing this value each time until the
+call fails with C<$^E>/C<regLastError()> numerically equal to
+C<ERROR_NO_MORE_ITEMS>.
+
+C<$sName> will be set to the name of the subkey. Can be C<[]> if
+you don't care about the name.
+
+C<$plName> initially specifies the [minimum] buffer size to be
+allocated for C<$sName>. Will be set to the length of the subkey
+name if the requested subkey exists even if C<$sName> isn't
+successfully set to the subkey name. See L<Buffer sizes> for
+more information.
+
+C<$pNull> is reserved for future used and should be passed as C<[]>.
+
+C<$sClass> will be set to the class name for the subkey. Can be
+C<[]> if you don't care about the class.
+
+C<$plClass> initially specifies the [minimum] buffer size to be
+allocated for C<$sClass> and will be set to the length of the
+subkey class name if the requested subkey exists. See L<Buffer
+sizes> for more information.
+
+C<$pftLastWrite> will be set to a C<FILETIME> structure packed
+into a Perl string and indicating when the subkey was last changed.
+Can be C<[]>.
+
+You may omit both C<$plName> and C<$plClass> to get the same effect
+as passing in C<[]> for each of them.
+
+=item RegEnumValue
+
+=item C<RegEnumValue( $hKey, $uIndex, $osValName, $iolValName, $pNull, $ouType, $opValData, $iolValData )>
+
+Lets you enumerate the names of all of the values contained in an
+open Registry key. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iIndex> is the sequence number of the value that you want
+information on. Start with this value as C<0> then repeat the
+call incrementing this value each time until the call fails with
+C<ERROR_NO_MORE_ITEMS>.
+
+C<$sValName> will be set to the name of the value. Can be C<[]>
+if you don't care about the name.
+
+C<$plValName> initially specifies the [minimum] buffer size to be
+allocated for C<$sValName>. Will be set to the length of the value
+name if the requested value exists even if C<$sValName> isn't
+successfully set to the value name. See L<Buffer sizes> for
+more information.
+
+C<$pNull> is reserved for future used and should be passed as C<[]>.
+
+C<$piType> will be set to the type of data stored in the value data.
+If the call succeeds, it will be set to a C<REG_*> value unless
+passed in as C<[]>.
+
+C<$pValData> will be set to the data [packed into a Perl string]
+that is stored in the requested value. Can be C<[]> if you don't
+care about the value data.
+
+C<$plValData> initially specifies the [minimum] buffer size to be
+allocated for C<$sValData> and will be set to the length of the
+value data if the requested value exists. See L<Buffer sizes> for
+more information.
+
+You may omit both C<$plValName> and C<$plValData> to get the same
+effect as passing in C<[]> for each of them.
+
+=item RegFlushKey
+
+=item C<RegFlushKey( $hKey )>
+
+Forces the data stored under an open Registry key to be flushed
+to the disk file where the data is preserved between reboots.
+Forced flushing is not guaranteed to be efficient so this routine
+should almost never be called. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+=item RegGetKeySecurity
+
+=item C<RegGetKeySecurity( $hKey, $uSecInfo, $opSecDesc, $iolSecDesc )>
+
+Retrieves one of the C<SECURITY_DESCRIPTOR> structures describing
+part of the security for an open Registry key. Returns a true value
+if successful and a false value [and sets C<$^E>/C<regLastError()>]
+on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iSecInfo> is a numeric C<SECURITY_INFORMATION> value that
+specifies which parts of the C<SECURITY_DESCRIPTOR> structure
+to retrieve. Should be C<OWNER_SECURITY_INFORMATION>,
+C<GROUP_SECURITY_INFORMATION>, C<DACL_SECURITY_INFORMATION>, or
+or C<SACL_SECURITY_INFORMATION> or two or more of these bits
+combined using C<|>.
+
+C<$pSecDesc> will be set to the requested C<SECURITY_DESCRIPTOR>
+structure [packed into a Perl string].
+
+C<$plSecDesc> initially specifies the [minimum] buffer size to be
+allocated for C<$sSecDesc> and will be set to the length of the
+security descriptor. See L<Buffer sizes> for more information.
+You may omit this parameter to get the same effect as passing in
+C<[]> for it.
+
+=item regLastError
+
+=item C<$svError= regLastError();>
+
+=item C<regLastError( $uError );>
+
+Returns the last error encountered by a routine from this module.
+It is just like C<$^E> except it isn't changed by anything except
+routines from this module. Ideally you could just use C<$^E>, but
+current versions of Perl often overwrite C<$^E> before you get a
+chance to check it and really old versions of Perl don't really
+support C<$^E> under Win32.
+
+Just like C<$^E>, in a numeric context C<regLastError()> returns
+the numeric error value while in a string context it returns a
+text description of the error [actually it returns a Perl scalar
+that contains both values so C<$x= regLastError()> causes C<$x>
+to give different values in string vs. numeric contexts]. On old
+versions of Perl where C<$^E> isn't tied to C<GetLastError()>,
+C<regLastError> simply returns the number of the error and you'll
+need to use <Win32::FormatMessage> to get the error string.
+
+The last form sets the error returned by future calls to
+C<regLastError()> and should not be used often. C<$uError> must
+be a numeric error code. Also returns the dual-valued version
+of C<$uError>.
+
+=item RegLoadKey
+
+=item C<RegLoadKey( $hKey, $sSubKey, $sFileName )>
+
+Loads a hive file. That is, it creates a new subkey in the
+Registry and associates that subkey with a disk file that contains
+a Registry hive so that the new subkey can be used to access the
+keys and values stored in that hive. Hives are usually created
+via C<RegSaveKey()>. Returns a true value if successful and a
+false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that can have hives
+loaded to it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>,
+or a remote version of one of these from a call to
+C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the new subkey to created and associated
+with the hive file.
+
+C<$sFileName> is the name of the hive file to be loaded. This
+file name is interpreted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides. If C<$sFileName> is on a FAT file
+system, then its name must not have an extension.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+WARNING: Loading of hive files via a network share may silently
+corrupt the hive and so should not be attempted [this is a problem
+in at least some versions of the underlying API which this module
+does not try to fix or avoid]. To access a hive file located on a
+remote computer, connect to the remote computer's Registry and load
+the hive via that.
+
+=item RegNotifyChangeKeyValue
+
+=item C<RegNotifyChangeKeyValue( $hKey, $bWatchSubtree, $uNotifyFilter, $hEvent, $bAsync )>
+
+Arranges for your process to be notified when part of the Registry
+is changed. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call] for which you wish to be notified when any changes
+are made to it.
+
+If C<$bWatchSubtree> is true, then changes to any subkey or
+descendant of C<$hKey> are also reported.
+
+C<$iNotifyFilter> controllers what types of changes are reported. It
+is a numeric value containing one or more of the following bit masks:
+
+=over
+
+=item C<REG_NOTIFY_CHANGE_NAME>
+
+Notify if a subkey is added or deleted to a monitored key.
+
+=item C<REG_NOTIFY_CHANGE_LAST_SET>
+
+Notify if a value in a monitored key is added, deleted, or modified.
+
+=item C<REG_NOTIFY_CHANGE_SECURITY>
+
+Notify if a security descriptor of a monitored key is changed.
+
+=item C<REG_NOTIFY_CHANGE_ATTRIBUTES>
+
+Notify if any attributes of a monitored key are changed [class
+name or security descriptors].
+
+=back
+
+C<$hEvent> is ignored unless C<$bAsync> is true. Otherwise, C<$hEvent>
+is a handle to a Win32 I<event> that will be signaled when changes are
+to be reported.
+
+If C<$bAsync> is true, then C<RegNotifyChangeKeyValue()> returns
+immediately and uses C<$hEvent> to notify your process of changes.
+If C<$bAsync> is false, then C<RegNotifyChangeKeyValue()> does
+not return until there is a change to be notified of.
+
+This routine does not work with Registry keys on remote computers.
+
+=item RegOpenKey
+
+=item C<RegOpenKey( $hKey, $sSubKey, $ohSubKey )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegOpenKeyEx()> instead.
+
+=item RegOpenKeyEx
+
+=item C<RegOpenKeyEx( $hKey, $sSubKey, $uOptions, $uAccess, $ohSubKey )>
+
+Opens an existing Registry key. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of an existing subkey to be opened.
+Can be C<""> or C<[]> to open an additional handle to the
+key specified by C<$hKey>.
+
+C<$iOptions> is a numeric value containing bits that control options
+used while opening the subkey. There are currently no supported
+options so this parameter should be specified as C<0>.
+
+C<$iAccess> is a numeric mask of bits specifying what type of
+access is desired when opening the new subkey. Should be a
+combination of one or more of the following bit masks:
+
+=over
+
+=item C<KEY_ALL_ACCESS>
+
+ KEY_READ | KEY_WRITE | KEY_CREATE_LINK
+
+=item C<KEY_READ>
+
+ KEY_QUERY_VALUE | KEY_ENUMERATE_SUBKEYS | KEY_NOTIFY | STANDARD_RIGHTS_READ
+
+=item C<KEY_WRITE>
+
+ KEY_SET_VALUE | KEY_CREATE_SUB_KEY | STANDARD_RIGHTS_WRITE
+
+=item C<KEY_QUERY_VALUE>
+
+=item C<KEY_SET_VALUE>
+
+=item C<KEY_ENUMERATE_SUB_KEYS>
+
+=item C<KEY_CREATE_SUB_KEY>
+
+=item C<KEY_NOTIFY>
+
+Allows you to use C<RegNotifyChangeKeyValue()> on the opened key.
+
+=item C<KEY_EXECUTE>
+
+Same as C<KEY_READ>.
+
+=item C<KEY_CREATE_LINK>
+
+Gives you permission to create a symbolic link like
+C<HKEY_CLASSES_ROOT> and C<HKEY_CURRENT_USER>, though the method for
+doing so is not documented [and probably requires use of the mostly
+undocumented "native" routines, C<Nt*()> a.k.a. C<Zw*()>].
+
+=back
+
+C<$phKey> will be set to the handle to be used to access the new subkey
+if the call succeeds.
+
+=item RegQueryInfoKey
+
+=item C<RegQueryInfoKey( $hKey, $osClass, $iolClass, $pNull, $ocSubKeys, $olSubKey, $olSubClass, $ocValues, $olValName, $olValData, $olSecDesc, $opftTime )>
+
+Gets miscellaneous information about an open Registry key.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sClass> will be set to the class name for the key. Can be
+C<[]> if you don't care about the class.
+
+C<$plClass> initially specifies the [minimum] buffer size to be
+allocated for C<$sClass> and will be set to the length of the
+key's class name. See L<Buffer sizes> for more information.
+You may omit this parameter to get the same effect as passing in
+C<[]> for it.
+
+C<$pNull> is reserved for future use and should be passed as C<[]>.
+
+C<$pcSubKeys> will be set to the count of the number of subkeys
+directly under this key. Can be C<[]>.
+
+C<$plSubKey> will be set to the length of the longest subkey name.
+Can be C<[]>.
+
+C<$plSubClass> will be set to the length of the longest class name
+used with an immediate subkey of this key. Can be C<[]>.
+
+C<$pcValues> will be set to the count of the number of values in
+this key. Can be C<[]>.
+
+C<$plValName> will be set to the length of the longest value name
+in this key. Can be C<[]>.
+
+C<$plValData> will be set to the length of the longest value data
+in this key. Can be C<[]>.
+
+C<$plSecDesc> will be set to the length of this key's full security
+descriptor.
+
+C<$pftTime> will be set to a C<FILETIME> structure packed
+into a Perl string and indicating when this key was last changed.
+Can be C<[]>.
+
+=item RegQueryMultipleValues
+
+=item C<RegQueryMultipleValues( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )>
+
+Allows you to use a single call to query several values from a single
+open Registry key to maximize efficiency. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$pValueEnts> should contain a list of C<VALENT> structures packed
+into a single Perl string. Each C<VALENT> structure should have
+the C<ve_valuename> entry [the first 4 bytes] pointing to a string
+containing the name of a value stored in this key. The remaining
+fields are set if the function succeeds.
+
+C<$cValueEnts> should contain the count of the number of C<VALENT>
+structures contained in C<$pValueEnts>.
+
+C<$pBuffer> will be set to the data from all of the requested values
+concatenated into a single Perl string.
+
+C<$plBuffer> initially specifies the [minimum] buffer size to be
+allocated for C<$sBuffer> and will be set to the total length of
+the data to be written to C<$sBuffer>. See L<Buffer sizes> for
+more information. You may omit this parameter to get the same
+effect as passing in C<[]> for it.
+
+Here is sample code to populate C<$pValueEnts>:
+
+ # @ValueNames= ...list of value name strings...;
+ $cValueEnts= @ValueNames;
+ $pValueEnts= pack( " p x4 x4 x4 " x $cValueEnts, @ValueNames );
+
+Here is sample code to retrieve the data type and data length
+returned in C<$pValueEnts>:
+
+ @Lengths= unpack( " x4 L x4 x4 " x $cValueEnts, $pValueEnts );
+ @Types= unpack( " x4 x4 x4 L " x $cValueEnts, $pValueEnts );
+
+Given the above, and assuming you haven't modified C<$sBuffer> since
+the call, you can also extract the value data strings from C<$sBuffer>
+by using the pointers returned in C<$pValueEnts>:
+
+ @Data= unpack( join( "", map {" x4 x4 P$_ x4 "} @Lengths ),
+ $pValueEnts );
+
+Much better is to use the lengths and extract directly from
+C<$sBuffer> using C<unpack()> [or C<substr()>]:
+
+ @Data= unpack( join("",map("P$_",@Lengths)), $sBuffer );
+
+=item RegQueryValue
+
+=item C<RegQueryValue( $hKey, $sSubKey, $osValueData, $iolValueData )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegQueryValueEx()> instead. This routine can only
+query unnamed values [a.k.a. "default values"], that is, values with
+a name of C<"">.
+
+=item RegQueryValueEx
+
+=item C<RegQueryValueEx( $hKey, $sValueName, $pNull, $ouType, $opValueData, $iolValueData )>
+
+Lets you look up value data stored in an open Registry key by
+specifying the value name. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sValueName> is the name of the value whose data you wish to
+retrieve.
+
+C<$pNull> this parameter is reserved for future use and should be
+specified as C<[]>.
+
+C<$piType> will be set to indicate what type of data is stored in
+the named value. Will be set to a C<REG_*> value if the function
+succeeds.
+
+C<$pValueData> will be set to the value data [packed into a Perl
+string] that is stored in the named value. Can be C<[]> if you
+don't care about the value data.
+
+C<$plValueData> initially specifies the [minimum] buffer size to be
+allocated for C<$sValueData> and will be set to the size [always
+in bytes] of the data to be written to C<$sValueData>, even if
+C<$sValueData> is not successfully written to. See L<Buffer sizes>
+for more information.
+
+=item RegReplaceKey
+
+=item C<RegReplaceKey( $hKey, $sSubKey, $sNewFile, $sOldFile )>
+
+Lets you replace an entire hive when the system is next booted.
+Returns a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that has hive(s)
+loaded in it. This must be C<HKEY_LOCAL_MACHINE>,
+C<HKEY_USERS>, or a remote version of one of these from
+a call to C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the subkey of C<$hKey> whose hive
+you wish to have replaced on the next reboot.
+
+C<$sNewFile> is the name of a file that will replace the existing
+hive file when the system reboots.
+
+C<$sOldFile> is the file name to save the current hive file to
+when the system reboots.
+
+C<$sNewFile> and C<$sOldFile> are interpreted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides [I think]. If either file is [would be]
+on a FAT file system, then its name must not have an extension.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+=item RegRestoreKey
+
+=item C<RegRestoreKey( $hKey, $sFileName, $uFlags )>
+
+Reads in a hive file and copies its contents over an existing
+Registry tree. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sFileName> is the name of the hive file to be read. For each
+value and subkey in this file, a value or subkey will be added
+or replaced in C<$hKey>.
+
+C<$uFlags> is usually C<0>. It can also be C<REG_WHOLE_HIVE_VOLATILE>
+which, rather than copying the hive over the existing key,
+replaces the existing key with a temporary, memory-only Registry
+key and then copies the hive contents into it. This option only
+works if C<$hKey> is C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>, or a
+remote version of one of these from a call to C<RegConnectRegistry()>.
+
+C<RegRestoreKey> does I<not> delete values nor keys from the
+existing Registry tree when there is no corresponding value/key
+in the hive file.
+
+=item RegSaveKey
+
+=item C<RegSaveKey( $hKey, $sFileName, $pSecAttr )>
+
+Dumps any open Registry key and all of its subkeys and values into
+a new hive file. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sFileName> is the name of the file that the Registry tree
+should be saved to. It is interpreted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides. If C<$sFileName> is on a FAT file system,
+then it must not have an extension.
+
+C<$pSecAttr> contains a C<SECURITY_ATTRIBUTES> structure that specifies
+the permissions to be set on the new file that is created. This can
+be C<[]>.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+=item RegSetKeySecurity
+
+=item C<RegSetKeySecurity( $hKey, $uSecInfo, $pSecDesc )>
+
+Sets [part of] the C<SECURITY_DESCRIPTOR> structure describing part
+of the security for an open Registry key. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$uSecInfo> is a numeric C<SECURITY_INFORMATION> value that
+specifies which C<SECURITY_DESCRIPTOR> structure to set. Should
+be C<OWNER_SECURITY_INFORMATION>, C<GROUP_SECURITY_INFORMATION>,
+C<DACL_SECURITY_INFORMATION>, or C<SACL_SECURITY_INFORMATION>
+or two or more of these bits combined using C<|>.
+
+C<$pSecDesc> contains the new C<SECURITY_DESCRIPTOR> structure
+packed into a Perl string.
+
+=item RegSetValue
+
+=item C<RegSetValue( $hKey, $sSubKey, $uType, $sValueData, $lValueData )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegSetValueEx()> instead. This routine can only
+set unnamed values [a.k.a. "default values"].
+
+=item RegSetValueEx
+
+=item C<RegSetValueEx( $hKey, $sName, $uZero, $uType, $pData, $lData )>
+
+Adds or replaces a value in an open Registry key. Returns
+a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sName> is the name of the value to be set.
+
+C<$uZero> is reserved for future use and should be specified as C<0>.
+
+C<$uType> is the type of data stored in C<$pData>. It should
+be a C<REG_*> value.
+
+C<$pData> is the value data packed into a Perl string.
+
+C<$lData> is the length of the value data that is stored in C<$pData>.
+You will usually omit this parameter or pass in C<0> to have
+C<length($pData)> used. In both of these cases, if C<$iType> is
+C<REG_SZ> or C<REG_EXPAND_SZ>, C<RegSetValueEx()> will append a
+trailing C<'\0'> to the end of C<$pData> [unless there is already
+one].
+
+=item RegUnLoadKey
+
+=item C<RegUnLoadKey( $hKey, $sSubKey )>
+
+Unloads a previously loaded hive file. That is, closes the
+hive file then deletes the subkey that was providing access
+to it. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that has hives
+loaded in it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>,
+or a remote version of one of these from a call to
+C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the subkey whose hive you wish to
+have unloaded.
+
+=item :FuncA
+
+The ASCII-specific function names.
+
+Each of these is identical to the version listed above without the
+trailing "A":
+
+ AbortSystemShutdownA InitiateSystemShutdownA
+ RegConnectRegistryA RegCreateKeyA RegCreateKeyExA
+ RegDeleteKeyA RegDeleteValueA RegEnumKeyA
+ RegEnumKeyExA RegEnumValueA RegLoadKeyA
+ RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA
+ RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA
+ RegReplaceKeyA RegRestoreKeyA RegSaveKeyA
+ RegSetValueA RegSetValueExA RegUnLoadKeyA
+
+=item :FuncW
+
+The UNICODE-specific function names. These are the same as the
+versions listed above without the trailing "W" except that string
+parameters are UNICODE strings rather than ASCII strings, as
+indicated.
+
+=item AbortSystemShutdownW
+
+=item C<AbortSystemShutdownW( $swComputerName )>
+
+C<$swComputerName> is UNICODE.
+
+=item InitiateSystemShutdownW
+
+=item C<InitiateSystemShutdownW( $swComputer, $swMessage, $uTimeoutSecs, $bForce, $bReboot )>
+
+C<$swComputer> and C<$swMessage> are UNICODE.
+
+=item RegConnectRegistryW
+
+=item C<RegConnectRegistryW( $swComputer, $hRootKey, $ohKey )>
+
+C<$swComputer> is UNICODE.
+
+=item RegCreateKeyW
+
+=item C<RegCreateKeyW( $hKey, $swSubKey, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegCreateKeyExW
+
+=item C<RegCreateKeyExW( $hKey, $swSubKey, $uZero, $swClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )>
+
+C<$swSubKey> and C<$swClass> are UNICODE.
+
+=item RegDeleteKeyW
+
+=item C<RegDeleteKeyW( $hKey, $swSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegDeleteValueW
+
+=item C<RegDeleteValueW( $hKey, $swValueName )>
+
+C<$swValueName> is UNICODE.
+
+=item RegEnumKeyW
+
+=item C<RegEnumKeyW( $hKey, $uIndex, $oswName, $ilwNameSize )>
+
+C<$oswName> is UNICODE and C<$ilwNameSize> is measured as number of
+C<WCHAR>s.
+
+=item RegEnumKeyExW
+
+=item C<RegEnumKeyExW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $oswClass, $iolwClass, $opftLastWrite )>
+
+C<$swName> and C<$swClass> are UNICODE and C<$iolwName> and C<$iolwClass>
+are measured as number of C<WCHAR>s.
+
+=item RegEnumValueW
+
+=item C<RegEnumValueW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $ouType, $opData, $iolData )>
+
+C<$oswName> is UNICODE and C<$iolwName> is measured as number
+of C<WCHAR>s.
+
+C<$opData> is UNICODE if C<$piType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number
+of bytes even in these cases.
+
+=item RegLoadKeyW
+
+=item C<RegLoadKeyW( $hKey, $swSubKey, $swFileName )>
+
+C<$swSubKey> and C<$swFileName> are UNICODE.
+
+=item RegOpenKeyW
+
+=item C<RegOpenKeyW( $hKey, $swSubKey, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegOpenKeyExW
+
+=item C<RegOpenKeyExW( $hKey, $swSubKey, $uOptions, $uAccess, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegQueryInfoKeyW
+
+=item C<RegQueryInfoKeyW( $hKey, $oswClass, $iolwClass, $pNull, $ocSubKeys, $olwSubKey, $olwSubClass, $ocValues, $olwValName, $olValData, $olSecDesc, $opftTime )>
+
+C<$swClass> is UNICODE. C<$iolwClass>, C<$olwSubKey>, C<$olwSubClass>,
+and C<$olwValName> are measured as number of C<WCHAR>s. Note that
+C<$olValData> is measured as number of bytes.
+
+=item RegQueryMultipleValuesW
+
+=item C<RegQueryMultipleValuesW( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )>
+
+The C<ve_valuename> fields of the C<VALENT> [actually C<VALENTW>]
+structures in C<$ioarValueEnts> are UNICODE. Values of type C<REG_SZ>,
+C<REG_EXPAND_SZ>, and C<REG_MULTI_SZ> are written to C<$opBuffer>
+in UNICODE. Note that C<$iolBuffer> and the C<ve_valuelen> fields
+of the C<VALENT> [C<VALENTW>] structures are measured as number of
+bytes.
+
+=item RegQueryValueW
+
+=item C<RegQueryValueW( $hKey, $swSubKey, $oswValueData, $iolValueData )>
+
+C<$swSubKey> and C<$oswValueData> are UNICODE. Note that
+C<$iolValueData> is measured as number of bytes.
+
+=item RegQueryValueExW
+
+=item C<RegQueryValueExW( $hKey, $swName, $pNull, $ouType, $opData, $iolData )>
+
+C<$swName> is UNICODE.
+
+C<$opData> is UNICODE if C<$ouType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number of
+bytes even in these cases.
+
+=item RegReplaceKeyW
+
+=item C<RegReplaceKeyW( $hKey, $swSubKey, $swNewFile, $swOldFile )>
+
+C<$swSubKey>, C<$swNewFile>, and C<$swOldFile> are UNICODE.
+
+=item RegRestoreKeyW
+
+=item C<RegRestoreKeyW( $hKey, $swFileName, $uFlags )>
+
+C<$swFileName> is UNICODE.
+
+=item RegSaveKeyW
+
+=item C<RegSaveKeyW( $hKey, $swFileName, $pSecAttr )>
+
+C<$swFileName> is UNICODE.
+
+=item RegSetValueW
+
+=item C<RegSetValueW( $hKey, $swSubKey, $uType, $swValueData, $lValueData )>
+
+C<$swSubKey> and C<$swValueData> are UNICODE. Note that
+C<$lValueData> is measured as number of bytes even though
+C<$swValueData> is always UNICODE.
+
+=item RegSetValueExW
+
+=item C<RegSetValueExW( $hKey, $swName, $uZero, $uType, $pData, $lData )>
+
+C<$swName> is UNICODE.
+
+C<$pData> is UNICODE if C<$uType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$lData> is measured as number of
+bytes even in these cases.
+
+=item RegUnLoadKeyW
+
+=item C<RegUnLoadKeyW( $hKey, $swSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item :HKEY_
+
+All C<HKEY_*> constants:
+
+ HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER
+ HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA
+ HKEY_USERS
+
+=item :KEY_
+
+All C<KEY_*> constants:
+
+ KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
+ KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
+ KEY_READ KEY_WRITE KEY_EXECUTE
+ KEY_ALL_ACCESS
+
+=item :REG_
+
+All C<REG_*> constants:
+
+ REG_CREATED_NEW_KEY REG_OPENED_EXISTING_KEY
+
+ REG_LEGAL_CHANGE_FILTER REG_NOTIFY_CHANGE_ATTRIBUTES
+ REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET
+ REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_OPTION
+
+ REG_OPTION_BACKUP_RESTORE REG_OPTION_CREATE_LINK
+ REG_OPTION_NON_VOLATILE REG_OPTION_OPEN_LINK
+ REG_OPTION_RESERVED REG_OPTION_VOLATILE
+
+ REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE
+ REG_NO_LAZY_FLUSH
+
+ REG_NONE REG_SZ
+ REG_EXPAND_SZ REG_BINARY
+ REG_DWORD REG_DWORD_LITTLE_ENDIAN
+ REG_DWORD_BIG_ENDIAN REG_LINK
+ REG_MULTI_SZ REG_RESOURCE_LIST
+ REG_FULL_RESOURCE_DESCRIPTOR REG_RESOURCE_REQUIREMENTS_LIST
+
+=item :ALL
+
+All of the above.
+
+=item :SE_
+
+The strings for the following privilege names:
+
+ SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME
+ SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME
+ SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME
+ SE_CREATE_TOKEN_NAME SE_DEBUG_NAME
+ SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME
+ SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME
+ SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME
+ SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME
+ SE_SECURITY_NAME SE_SHUTDOWN_NAME
+ SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME
+ SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME
+ SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME
+
+It can be difficult to successfully build this module in a way
+that makes these constants available. So some builds of this
+module may not make them available. For such builds, trying
+to export any of these constants will cause a fatal error.
+For this reason, none of these symbols are currently included
+in the C<":ALL"> grouping.
+
+=back
+
+=back
+
+=head2 The Win32API:: hierarchy
+
+This and the other Win32API:: modules are meant to expose the
+nearly raw API calls so they can be used from Perl code in any
+way they might be used from C code. This provides the following
+advantages:
+
+=over
+
+=item Many modules can be written by people that don't have a C compiler.
+
+=item Encourages more module code to be written in Perl [not C].
+
+Perl code is often much easier to inspect, debug, customize, and
+enhance than XS code.
+
+=item Allows those already familiar with the Win32 API to get
+off to a quick start.
+
+=item Provides an interactive tool for exploring even obscure
+details of the Win32 API.
+
+It can be very useful to interactively explore ad-hoc calls into
+parts of the Win32 API using:
+
+ perl -de 0
+
+=item Ensures that native Win32 data structures can be used.
+
+This allows maximum efficiency. It also allows data from one
+module [for example, time or security information from the
+C<Win32API::Registry> or C<Win32API::File> modules] to be used
+with other modules [for example, C<Win32API::Time> and
+C<Win32API::SecDesc>].
+
+=item Provides a single version of the XS interface to each API
+call where improvements can be collected.
+
+=back
+
+=head2 Buffer sizes
+
+For each parameter that specifies a buffer size, a value of C<0>
+can be passed. For parameter that are pointers to buffer sizes,
+you can also pass in C<NULL> by specifying an empty list reference,
+C<[]>. Both of these cases will ensure that the variable has
+I<some> buffer space allocated to it and pass in that buffer's
+allocated size. Many of the calls indicate, via C<ERROR_MORE_DATA>,
+that the buffer size was not sufficient and the F<Registry.xs>
+code will automatically enlarge the buffer to the required size
+and repeat the call.
+
+Numeric buffer sizes are used as minimum initial sizes for the
+buffers. The larger of this size and the size of space already
+allocated to the scalar will be passed to the underlying routine.
+If that size was insufficient, and the underlying call provides
+an easy method for determining the needed buffer size, then the
+buffer will be enlarged and the call repeated as above.
+
+The underlying calls define buffer size parameter as unsigned, so
+negative buffer sizes are treated as very large positive buffer
+sizes which usually cause C<malloc()> to fail.
+
+To force the F<Registry.xs> code to pass in a specific value for
+a buffer size, precede the size with an equals sign via C<"=".>.
+Buffer sizes that are passed in as strings starting with an equals
+sign will have the equal sign stripped and the remainder of the string
+interpreted as a number [via C's C<strtoul()> using only base 10]
+which will be passed to the underlying routine [even if the allocated
+buffer is actually larger]. The F<Registry.xs> code will enlarge the
+buffer to the specified size, if needed, but will not enlarge the
+buffer based on the underlying routine requesting more space.
+
+Some Reg*() calls may not currently set the buffer size when they
+return C<ERROR_MORE_DATA>. But some that are not documented as
+doing so, currently do so anyway. So the code assumes that any
+routine I<might> do this and resizes any buffers and repeats the
+call. We hope that eventually all routines will provide this
+feature.
+
+When you use C<[]> for a buffer size, you can still find the
+length of the data returned by using C<length($buffer)>. Note
+that this length will be in bytes while a few of the buffer
+sizes would have been in units of wide characters.
+
+Note that the RegQueryValueEx*() and RegEnumValue*() calls
+will trim the trailing C<'\0'> [if present] from the returned data
+values of type C<REG_SZ> or C<REG_EXPAND_SZ> but only if the
+value data length parameter is omitted [or specified as C<[]>].
+
+The RegSetValueEx*() calls will add a trailing C<'\0'> [if
+missing] to the supplied data values of type C<REG_SZ> and
+C<REG_EXPAND_SZ> but only if the value data length parameter
+is omitted [or specified as C<0>].
+
+=head2 Hungarian Notation
+
+The following abbreviations are used at the start of each parameter
+name to hint at aspects of how the parameter is used. The prefix
+is always in lower case and followed by a capital letter that starts
+the descriptive part of the parameter name. Several of the following
+abbreviations can be combined into a single prefix.
+
+Probably not all of these prefix notations are used by this module.
+This document section may be included in any C<Win32API> module and
+so covers some notations not used by this specific module.
+
+=over
+
+=item s
+
+A string. In C, a C<'\0'>-terminated C<char *>. In Perl, just a
+string except that it will be truncated at the first C<"\0">, if
+it contains one.
+
+=item sw
+
+A wide [UNICODE] string. In C, a C<L'\0'>-terminated C<WCHAR *>.
+In Perl, a string that contains UNICODE data. You can convert a
+string to UNICODE in Perl via:
+
+ $string= "This is an example string";
+ $unicode= pack( "S*", unpack("C*",$string), 0 );
+
+Note how C<, 0> above causes an explicit C<L'\0'> to be added since
+Perl's implicit C<'\0'> that it puts after each of its strings is not
+wide enough to terminate a UNICODE string. So UNICODE strings are
+different than regular strings in that the Perl version of a regular
+string will not include the trailing C<'\0'> while the Perl version
+of a UNICODE string must include the trailing C<L'\0'>.
+
+If a UNICODE string contains no non-ASCII characters, then you
+can convert it back into a normal string via:
+
+ $string= pack( "C*", unpack("S*",$unicode) );
+ $string =~ s/\0$//;
+
+=item p
+
+A pointer to some buffer [usually containing some C<struct>]. In C,
+a C<void *> or some other pointer type. In Perl, a string that is
+usually manipulated using C<pack> and C<unpack>. The "p" is usually
+followed by more prefix character(s) to indicate what type of data is
+stored in the buffer.
+
+=item a
+
+A packed array. In C, an array [usually of C<struct>s]. In Perl, a
+string containing the packed data. The "a" is usually followed by
+more prefix character(s) to indicate the data type of the elements.
+
+These packed arrays are also called "vectors" in places to avoid
+confusion with Perl arrays.
+
+=item n
+
+A generic number. In C, any of the integer or floating point data
+types. In Perl, a number; either an integer, unsigned, or double
+[IV, UV, or NV, respectively]. Usually an integer.
+
+=item iv
+
+A signed integral value. In C, any of the signed integer data types.
+In Perl, an integer [IV].
+
+=item u
+
+An unsigned integral value. In C, any of the unsigned integer data
+types. In Perl, an unsigned integer [UV].
+
+=item d
+
+A floating-point number. In C, a C<float> or C<double> or, perhaps,
+a C<long double>. In Perl, a double-precision floating-point number
+[NV].
+
+=item b
+
+A Boolean value. In C, any integer data type, though usually via
+a type alias of C<bool> or C<BOOL>, containing either a 0 [false] or
+non-zero [true] value. In Perl, a scalar containing a Boolean value
+[C<0>, C<"">, or C<undef> for "false" and anything else for "true"].
+
+=item c
+
+A count of items. In C, any integer data type. In Perl, an unsigned
+integer [UV]. Usually used in conjunction with a "vector" parameter
+[see L</a> above] to indicate the number of elements.
+
+=item l
+
+A length [in bytes]. In C, any integer data type. In Perl, an
+unsigned integer [UV]. Usually used in conjunction with a "string"
+or "pointer" parameter [see L</s> and L</p> above] to indicate the
+buffer size or the size of the value stored in the buffer.
+
+For strings, there is no general rule as to whether the trailing
+C<'\0'> is included in such sizes. For this reason, the C<Win32API>
+modules follow the Perl rule of always allocating one extra byte
+and reporting buffer sizes as being one smaller than allocated in
+case the C<'\0'> is not included in the size.
+
+=item lw
+
+A length measured as number of UNICODE characters. In C, a count
+of C<WCHAR>s. In Perl, an unsigned integer [UV] counting "shorts"
+[see "s" and "S" in C<pack> and C<unpack>].
+
+For UNICODE strings, the trailing C<L'\0'> may or may not be
+included in a length so, again, we always allocate extra room
+for one and don't report that extra space.
+
+=item h
+
+A handle. In C, a C<HANDLE> or more-specific handle data type.
+In Perl, an unsigned integer [UV]. In C, these handles are often
+actually some type of pointer, but Perl just treats them as opaque
+numbers, as it should. This prefix is also used for other pointers
+that are treated as integers in Perl code.
+
+=item r
+
+A record. In C, almost always a C<struct> or perhaps C<union>. Note
+that C C<struct>s are rarely passed by value so the "r" is almost
+always preceded by a "p" or "a" [see L</p> and L</a> above]. For
+the very rare unadorned "r", Perl stores the record in the same way
+as a "pr", that is, in a string. For the very rare case where Perl
+explicitly stores a pointer to the C<struct> rather than storing the
+C<struct> directly in a Perl string, the prefix "pp" or "ppr" or even
+"par" is used.
+
+=item sv
+
+=item rv
+
+=item hv
+
+=item av
+
+=item cv
+
+A Perl data type. Respectively, a scalar value [SV], a reference
+[RV] [usually to a scalar], a hash [HV], a Perl array [AV], or a Perl
+code reference [PVCV]. For the "hv", "av", and "cv" prefixes, a
+leading "rv" is usually assumed. For a parameter to an XS subroutine,
+a prefix of "sv" means the parameter is a scalar and so may be a string
+or a number [or C<undef>] or even both at the same time. So "sv"
+doesn't imply a leading "rv".
+
+=item Input or Output
+
+Whether a parameter is for input data, output data, or both is usually
+not reflected by the data type prefix. In cases where this is not
+obvious nor reflected in the parameter name proper, we may use the
+following in front of the data type prefix.
+
+=over
+
+=item i
+
+An input parameter given to the API [usually omitted].
+
+=item o
+
+An output-only parameter taken from the API. You should not get a
+warning if such a parameter is C<undef> when you pass it into the
+function. You should get an error if such a parameter is read-only.
+You can [usually] pass in C<[]> for such a parameter to have the
+parameter silently ignored.
+
+The output may be written directly into the Perl variable passed
+to the subroutine, the same way the buffer parameter to Perl's
+C<sysread()>. This method is often avoided in Perl because
+the call then lacks any visual cue that some parameters are being
+overwritten. But this method closely matches the C API which is
+what we are trying to do.
+
+=item io
+
+Input given to the API then overwritten with output taken from the
+API. You should get a warning [if B<-w> is in effect] if such a
+parameter is C<undef> when you pass it into the function [unless it
+is a buffer or buffer length parameter]. If the value is read-only,
+then [for most parameters] the output is silently not written. This
+is because it is often convenient to pass in read-only constants for
+many such parameters. You can also usually pass in C<[]> for such
+parameters.
+
+=back
+
+=item pp
+
+=item ppr
+
+=item par
+
+=item pap
+
+These are just unusual combinations of prefix characters described above.
+
+For each, a pointer is stored in a [4-byte] Perl string. You can
+usually use C<unpack "P"> to access the real data from Perl.
+
+For "ppr" [and often for "pp"], the pointer points directly at a
+C C<struct>. For "par", the pointer points to the first element
+of a C [packed] array of C<struct>s. For "pap", the pointer points
+to a C [packed] array of pointers to other things.
+
+=item ap
+
+Here we have a list of pointers packed into a single Perl string.
+
+=back
+
+
+=head1 BUGS
+
+The old ActiveState ports of Perl for Win32 [but not, ActivePerl, the
+ActiveState distributions of standard Perl 5.004 and beyond] do not support
+the tools for building extensions and so do not support this extension.
+
+No routines are provided for using the data returned in the C<FILETIME>
+buffers. Those are in the C<Win32API::Time> module.
+
+No routines are provided for dealing with UNICODE data effectively.
+See L</:FuncW> above for some simple-minded UNICODE methods.
+
+Parts of the module test will fail if used on a version of Perl
+that does not yet set C<$^E> based on C<GetLastError()>.
+
+On NT 4.0 [at least], the RegEnum*() calls do not set the required
+buffer sizes when returning C<ERROR_MORE_DATA> so this module will
+not grow the buffers in such cases. C<Win32::TieRegistry> overcomes
+this by using values from C<RegQueryInfoKey()> for buffer sizes in
+RegEnum* calls.
+
+On NT 4.0 [at least], C<RegQueryInfoKey()> on C<HKEY_PERFORMANCE_DATA>
+never succeeds. Also, C<RegQueryValueEx()> on C<HKEY_PERFORMANCE_DATA>
+never returns the required buffer size. To access C<HKEY_PERFORMANCE_DATA>
+you will need to keep growing the data buffer until the call succeeds.
+
+Because C<goto &subroutine> seems to be buggy under Win32 Perl,
+it is not used in the stubs in F<Registry.pm>.
+
+=head1 AUTHOR
+
+Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/.
+
+=head1 LICENSE
+
+perl
+
+=head1 SEE ALSO
+
+=over
+
+=item L<Win32::TieRegistry>
+
+=item L<Win32::Registry>
+
+=back
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32API/Registry/cRegistry.pc b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32API/Registry/cRegistry.pc new file mode 100644 index 0000000000..f984543fa8 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32API/Registry/cRegistry.pc @@ -0,0 +1,87 @@ +# Generated by cRegistry_pc.cxx.
+# Package Win32API::Registry with options:
+# CPLUSPLUS => q[1]
+# IFDEF => q[ /^SE_/ ? '__cplusplus' : /REG_/ ]
+# IMPORT_LIST => [q[/._/], q[!/[a-z]/]]
+# VALUES => { KEY_DELETE=>q[DELETE], KEY_READ_CONTROL=>q[READ_CONTROL], KEY_WRITE_OWNER=>q[WRITE_OWNER], KEY_SYNCHRONIZE=>q[SYNCHRONIZE], KEY_WRITE_DAC=>q[WRITE_DAC] }
+# WRITE_PERL => q[1]
+# Perl files eval'd:
+# Registry.pm => last if /^\s*(bootstrap|XSLoader::load)\b/
+# C files included:
+# Registry.xs => last if m#/[/*]\s*CONSTS_DEFINED\b|^\s*MODULE\b#
+sub HKEY_CLASSES_ROOT () { 0x80000000 }
+sub HKEY_CURRENT_CONFIG () { 0x80000005 }
+sub HKEY_CURRENT_USER () { 0x80000001 }
+sub HKEY_DYN_DATA () { 0x80000006 }
+sub HKEY_LOCAL_MACHINE () { 0x80000002 }
+sub HKEY_PERFORMANCE_DATA () { 0x80000004 }
+sub HKEY_USERS () { 0x80000003 }
+sub KEY_ALL_ACCESS () { 983103 }
+sub KEY_CREATE_LINK () { 32 }
+sub KEY_CREATE_SUB_KEY () { 4 }
+sub KEY_DELETE () { 65536 }
+sub KEY_ENUMERATE_SUB_KEYS () { 8 }
+sub KEY_EXECUTE () { 131097 }
+sub KEY_NOTIFY () { 16 }
+sub KEY_QUERY_VALUE () { 1 }
+sub KEY_READ () { 131097 }
+sub KEY_READ_CONTROL () { 131072 }
+sub KEY_SET_VALUE () { 2 }
+sub KEY_SYNCHRONIZE () { 1048576 }
+sub KEY_WRITE () { 131078 }
+sub KEY_WRITE_DAC () { 262144 }
+sub KEY_WRITE_OWNER () { 524288 }
+sub REG_BINARY () { 3 }
+sub REG_CREATED_NEW_KEY () { 1 }
+sub REG_DWORD () { 4 }
+sub REG_DWORD_BIG_ENDIAN () { 5 }
+sub REG_DWORD_LITTLE_ENDIAN () { 4 }
+sub REG_EXPAND_SZ () { 2 }
+sub REG_FULL_RESOURCE_DESCRIPTOR () { 9 }
+sub REG_LEGAL_CHANGE_FILTER () { 15 }
+sub REG_LEGAL_OPTION () { 15 }
+sub REG_LINK () { 6 }
+sub REG_MULTI_SZ () { 7 }
+sub REG_NONE () { 0 }
+sub REG_NOTIFY_CHANGE_ATTRIBUTES () { 2 }
+sub REG_NOTIFY_CHANGE_LAST_SET () { 4 }
+sub REG_NOTIFY_CHANGE_NAME () { 1 }
+sub REG_NOTIFY_CHANGE_SECURITY () { 8 }
+sub REG_NO_LAZY_FLUSH () { 4 }
+sub REG_OPENED_EXISTING_KEY () { 2 }
+sub REG_OPTION_BACKUP_RESTORE () { 4 }
+sub REG_OPTION_CREATE_LINK () { 2 }
+sub REG_OPTION_NON_VOLATILE () { 0 }
+sub REG_OPTION_OPEN_LINK () { 8 }
+sub REG_OPTION_RESERVED () { 0 }
+sub REG_OPTION_VOLATILE () { 1 }
+sub REG_REFRESH_HIVE () { 2 }
+sub REG_RESOURCE_LIST () { 8 }
+sub REG_RESOURCE_REQUIREMENTS_LIST () { 10 }
+sub REG_SZ () { 1 }
+sub REG_WHOLE_HIVE_VOLATILE () { 1 }
+sub SE_ASSIGNPRIMARYTOKEN_NAME () { 'SeAssignPrimaryTokenPrivilege' }
+sub SE_AUDIT_NAME () { 'SeAuditPrivilege' }
+sub SE_BACKUP_NAME () { 'SeBackupPrivilege' }
+sub SE_CHANGE_NOTIFY_NAME () { 'SeChangeNotifyPrivilege' }
+sub SE_CREATE_PAGEFILE_NAME () { 'SeCreatePagefilePrivilege' }
+sub SE_CREATE_PERMANENT_NAME () { 'SeCreatePermanentPrivilege' }
+sub SE_CREATE_TOKEN_NAME () { 'SeCreateTokenPrivilege' }
+sub SE_DEBUG_NAME () { 'SeDebugPrivilege' }
+sub SE_INCREASE_QUOTA_NAME () { 'SeIncreaseQuotaPrivilege' }
+sub SE_INC_BASE_PRIORITY_NAME () { 'SeIncreaseBasePriorityPrivilege' }
+sub SE_LOAD_DRIVER_NAME () { 'SeLoadDriverPrivilege' }
+sub SE_LOCK_MEMORY_NAME () { 'SeLockMemoryPrivilege' }
+sub SE_MACHINE_ACCOUNT_NAME () { 'SeMachineAccountPrivilege' }
+sub SE_PROF_SINGLE_PROCESS_NAME () { 'SeProfileSingleProcessPrivilege' }
+sub SE_REMOTE_SHUTDOWN_NAME () { 'SeRemoteShutdownPrivilege' }
+sub SE_RESTORE_NAME () { 'SeRestorePrivilege' }
+sub SE_SECURITY_NAME () { 'SeSecurityPrivilege' }
+sub SE_SHUTDOWN_NAME () { 'SeShutdownPrivilege' }
+sub SE_SYSTEMTIME_NAME () { 'SeSystemtimePrivilege' }
+sub SE_SYSTEM_ENVIRONMENT_NAME () { 'SeSystemEnvironmentPrivilege' }
+sub SE_SYSTEM_PROFILE_NAME () { 'SeSystemProfilePrivilege' }
+sub SE_TAKE_OWNERSHIP_NAME () { 'SeTakeOwnershipPrivilege' }
+sub SE_TCB_NAME () { 'SeTcbPrivilege' }
+sub SE_UNSOLICITED_INPUT_NAME () { 'SeUnsolicitedInputPrivilege' }
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Cpanel/JSON/XS/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Cpanel/JSON/XS/.packlist new file mode 100644 index 0000000000..9cb00193a5 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Cpanel/JSON/XS/.packlist @@ -0,0 +1,6 @@ +C:\tlperl\bin\cpanel_json_xs
+C:\tlperl\bin\cpanel_json_xs.bat
+C:\tlperl\site\lib\Cpanel\JSON\XS.pm
+C:\tlperl\site\lib\Cpanel\JSON\XS\Boolean.pm
+C:\tlperl\site\lib\Cpanel\JSON\XS\Type.pm
+C:\tlperl\site\lib\auto\Cpanel\JSON\XS\XS.dll
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Cpanel/JSON/XS/XS.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Cpanel/JSON/XS/XS.dll Binary files differnew file mode 100644 index 0000000000..90c4962b77 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Cpanel/JSON/XS/XS.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Date/Parse/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Date/Parse/.packlist new file mode 100644 index 0000000000..5e66e1a661 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Date/Parse/.packlist @@ -0,0 +1,37 @@ +C:\tlperl\site\lib\Date\Format.pm
+C:\tlperl\site\lib\Date\Language.pm
+C:\tlperl\site\lib\Date\Language\Afar.pm
+C:\tlperl\site\lib\Date\Language\Amharic.pm
+C:\tlperl\site\lib\Date\Language\Austrian.pm
+C:\tlperl\site\lib\Date\Language\Brazilian.pm
+C:\tlperl\site\lib\Date\Language\Bulgarian.pm
+C:\tlperl\site\lib\Date\Language\Chinese.pm
+C:\tlperl\site\lib\Date\Language\Chinese_GB.pm
+C:\tlperl\site\lib\Date\Language\Czech.pm
+C:\tlperl\site\lib\Date\Language\Danish.pm
+C:\tlperl\site\lib\Date\Language\Dutch.pm
+C:\tlperl\site\lib\Date\Language\English.pm
+C:\tlperl\site\lib\Date\Language\Finnish.pm
+C:\tlperl\site\lib\Date\Language\French.pm
+C:\tlperl\site\lib\Date\Language\Gedeo.pm
+C:\tlperl\site\lib\Date\Language\German.pm
+C:\tlperl\site\lib\Date\Language\Greek.pm
+C:\tlperl\site\lib\Date\Language\Hungarian.pm
+C:\tlperl\site\lib\Date\Language\Icelandic.pm
+C:\tlperl\site\lib\Date\Language\Italian.pm
+C:\tlperl\site\lib\Date\Language\Norwegian.pm
+C:\tlperl\site\lib\Date\Language\Oromo.pm
+C:\tlperl\site\lib\Date\Language\Romanian.pm
+C:\tlperl\site\lib\Date\Language\Russian.pm
+C:\tlperl\site\lib\Date\Language\Russian_cp1251.pm
+C:\tlperl\site\lib\Date\Language\Russian_koi8r.pm
+C:\tlperl\site\lib\Date\Language\Sidama.pm
+C:\tlperl\site\lib\Date\Language\Somali.pm
+C:\tlperl\site\lib\Date\Language\Spanish.pm
+C:\tlperl\site\lib\Date\Language\Swedish.pm
+C:\tlperl\site\lib\Date\Language\Tigrinya.pm
+C:\tlperl\site\lib\Date\Language\TigrinyaEritrean.pm
+C:\tlperl\site\lib\Date\Language\TigrinyaEthiopian.pm
+C:\tlperl\site\lib\Date\Language\Turkish.pm
+C:\tlperl\site\lib\Date\Parse.pm
+C:\tlperl\site\lib\Time\Zone.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Digest/SHA1/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Digest/SHA1/.packlist new file mode 100644 index 0000000000..45cf93670f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Digest/SHA1/.packlist @@ -0,0 +1,2 @@ +C:\tlperl\site\lib\Digest\SHA1.pm
+C:\tlperl\site\lib\auto\Digest\SHA1\SHA1.dll
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Digest/SHA1/SHA1.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Digest/SHA1/SHA1.dll Binary files differnew file mode 100644 index 0000000000..6c5491ba86 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Digest/SHA1/SHA1.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Encode/Locale/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Encode/Locale/.packlist new file mode 100644 index 0000000000..fca67c3c70 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Encode/Locale/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\Encode\Locale.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Encode/compat/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Encode/compat/.packlist new file mode 100644 index 0000000000..d4a2e08bb7 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Encode/compat/.packlist @@ -0,0 +1,4 @@ +C:\tlperl\site\lib\Encode\compat.pm
+C:\tlperl\site\lib\Encode\compat\5006001.pm
+C:\tlperl\site\lib\Encode\compat\Alias.pm
+C:\tlperl\site\lib\Encode\compat\common.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/File/Listing/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/File/Listing/.packlist new file mode 100644 index 0000000000..0d31ba57a1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/File/Listing/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\File\Listing.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/File/Which/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/File/Which/.packlist new file mode 100644 index 0000000000..3ba10e7c5e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/File/Which/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\File\Which.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTML/Parser/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTML/Parser/.packlist new file mode 100644 index 0000000000..6ce7b6a07a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTML/Parser/.packlist @@ -0,0 +1,8 @@ +C:\tlperl\site\lib\HTML\Entities.pm
+C:\tlperl\site\lib\HTML\Filter.pm
+C:\tlperl\site\lib\HTML\HeadParser.pm
+C:\tlperl\site\lib\HTML\LinkExtor.pm
+C:\tlperl\site\lib\HTML\Parser.pm
+C:\tlperl\site\lib\HTML\PullParser.pm
+C:\tlperl\site\lib\HTML\TokeParser.pm
+C:\tlperl\site\lib\auto\HTML\Parser\Parser.dll
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTML/Parser/Parser.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTML/Parser/Parser.dll Binary files differnew file mode 100644 index 0000000000..a2f658366c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTML/Parser/Parser.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTML/Tagset/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTML/Tagset/.packlist new file mode 100644 index 0000000000..b0836c2d77 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTML/Tagset/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\HTML\Tagset.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Cookies/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Cookies/.packlist new file mode 100644 index 0000000000..c1f0a86213 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Cookies/.packlist @@ -0,0 +1,3 @@ +C:\tlperl\site\lib\HTTP\Cookies.pm
+C:\tlperl\site\lib\HTTP\Cookies\Microsoft.pm
+C:\tlperl\site\lib\HTTP\Cookies\Netscape.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Daemon/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Daemon/.packlist new file mode 100644 index 0000000000..20fe206daa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Daemon/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\HTTP\Daemon.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Date/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Date/.packlist new file mode 100644 index 0000000000..8a98075d65 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Date/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\HTTP\Date.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Message/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Message/.packlist new file mode 100644 index 0000000000..80f40bf932 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Message/.packlist @@ -0,0 +1,10 @@ +C:\tlperl\site\lib\HTTP\Config.pm
+C:\tlperl\site\lib\HTTP\Headers.pm
+C:\tlperl\site\lib\HTTP\Headers\Auth.pm
+C:\tlperl\site\lib\HTTP\Headers\ETag.pm
+C:\tlperl\site\lib\HTTP\Headers\Util.pm
+C:\tlperl\site\lib\HTTP\Message.pm
+C:\tlperl\site\lib\HTTP\Request.pm
+C:\tlperl\site\lib\HTTP\Request\Common.pm
+C:\tlperl\site\lib\HTTP\Response.pm
+C:\tlperl\site\lib\HTTP\Status.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Negotiate/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Negotiate/.packlist new file mode 100644 index 0000000000..9d7d8f27c9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/HTTP/Negotiate/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\HTTP\Negotiate.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/IO/HTML/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/IO/HTML/.packlist new file mode 100644 index 0000000000..6cb34ec6af --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/IO/HTML/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\IO\HTML.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/IO/String/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/IO/String/.packlist new file mode 100644 index 0000000000..301a4c1067 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/IO/String/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\IO\String.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/JSON/MaybeXS/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/JSON/MaybeXS/.packlist new file mode 100644 index 0000000000..255fd5c433 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/JSON/MaybeXS/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\JSON\MaybeXS.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/LWP/MediaTypes/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/LWP/MediaTypes/.packlist new file mode 100644 index 0000000000..ad241200dc --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/LWP/MediaTypes/.packlist @@ -0,0 +1,2 @@ +C:\tlperl\site\lib\LWP\MediaTypes.pm
+C:\tlperl\site\lib\LWP\media.types
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Math/Int64/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Math/Int64/.packlist new file mode 100644 index 0000000000..5c97b8b327 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Math/Int64/.packlist @@ -0,0 +1,5 @@ +C:\tlperl\site\lib\Math\Int64.pm
+C:\tlperl\site\lib\Math\Int64\die_on_overflow.pm
+C:\tlperl\site\lib\Math\Int64\native_if_available.pm
+C:\tlperl\site\lib\Math\UInt64.pm
+C:\tlperl\site\lib\auto\Math\Int64\Int64.dll
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Math/Int64/Int64.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Math/Int64/Int64.dll Binary files differnew file mode 100644 index 0000000000..8856f379aa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Math/Int64/Int64.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Mozilla/CA/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Mozilla/CA/.packlist new file mode 100644 index 0000000000..a91ad79eae --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Mozilla/CA/.packlist @@ -0,0 +1,3 @@ +C:\tlperl\site\lib\Mozilla\CA.pm
+C:\tlperl\site\lib\Mozilla\CA\cacert.pem
+C:\tlperl\site\lib\Mozilla\mk-ca-bundle.pl
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Net/HTTP/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Net/HTTP/.packlist new file mode 100644 index 0000000000..e71697e423 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Net/HTTP/.packlist @@ -0,0 +1,4 @@ +C:\tlperl\site\lib\Net\HTTP.pm
+C:\tlperl\site\lib\Net\HTTPS.pm
+C:\tlperl\site\lib\Net\HTTP\Methods.pm
+C:\tlperl\site\lib\Net\HTTP\NB.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Socket/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Socket/.packlist new file mode 100644 index 0000000000..87d1fe32b2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Socket/.packlist @@ -0,0 +1,2 @@ +C:\tlperl\site\lib\Socket.pm
+C:\tlperl\site\lib\auto\Socket\Socket.dll
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Socket/Socket.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Socket/Socket.dll Binary files differnew file mode 100644 index 0000000000..2b8c6eb879 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Socket/Socket.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Test/Fatal/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Test/Fatal/.packlist new file mode 100644 index 0000000000..f8b34dfe0f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Test/Fatal/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\Test\Fatal.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Test/Needs/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Test/Needs/.packlist new file mode 100644 index 0000000000..740b7c46c2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Test/Needs/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\Test\Needs.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Test/RequiresInternet/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Test/RequiresInternet/.packlist new file mode 100644 index 0000000000..2236c52f85 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Test/RequiresInternet/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\Test\RequiresInternet.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Try/Tiny/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Try/Tiny/.packlist new file mode 100644 index 0000000000..44c33603fa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Try/Tiny/.packlist @@ -0,0 +1 @@ +C:\tlperl\site\lib\Try\Tiny.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/URI/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/URI/.packlist new file mode 100644 index 0000000000..9213ecb7b1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/URI/.packlist @@ -0,0 +1,53 @@ +C:\tlperl\site\lib\URI.pm
+C:\tlperl\site\lib\URI\Escape.pm
+C:\tlperl\site\lib\URI\Heuristic.pm
+C:\tlperl\site\lib\URI\IRI.pm
+C:\tlperl\site\lib\URI\QueryParam.pm
+C:\tlperl\site\lib\URI\Split.pm
+C:\tlperl\site\lib\URI\URL.pm
+C:\tlperl\site\lib\URI\WithBase.pm
+C:\tlperl\site\lib\URI\_foreign.pm
+C:\tlperl\site\lib\URI\_generic.pm
+C:\tlperl\site\lib\URI\_idna.pm
+C:\tlperl\site\lib\URI\_ldap.pm
+C:\tlperl\site\lib\URI\_login.pm
+C:\tlperl\site\lib\URI\_punycode.pm
+C:\tlperl\site\lib\URI\_query.pm
+C:\tlperl\site\lib\URI\_segment.pm
+C:\tlperl\site\lib\URI\_server.pm
+C:\tlperl\site\lib\URI\_userpass.pm
+C:\tlperl\site\lib\URI\data.pm
+C:\tlperl\site\lib\URI\file.pm
+C:\tlperl\site\lib\URI\file\Base.pm
+C:\tlperl\site\lib\URI\file\FAT.pm
+C:\tlperl\site\lib\URI\file\Mac.pm
+C:\tlperl\site\lib\URI\file\OS2.pm
+C:\tlperl\site\lib\URI\file\QNX.pm
+C:\tlperl\site\lib\URI\file\Unix.pm
+C:\tlperl\site\lib\URI\file\Win32.pm
+C:\tlperl\site\lib\URI\ftp.pm
+C:\tlperl\site\lib\URI\gopher.pm
+C:\tlperl\site\lib\URI\http.pm
+C:\tlperl\site\lib\URI\https.pm
+C:\tlperl\site\lib\URI\ldap.pm
+C:\tlperl\site\lib\URI\ldapi.pm
+C:\tlperl\site\lib\URI\ldaps.pm
+C:\tlperl\site\lib\URI\mailto.pm
+C:\tlperl\site\lib\URI\mms.pm
+C:\tlperl\site\lib\URI\news.pm
+C:\tlperl\site\lib\URI\nntp.pm
+C:\tlperl\site\lib\URI\pop.pm
+C:\tlperl\site\lib\URI\rlogin.pm
+C:\tlperl\site\lib\URI\rsync.pm
+C:\tlperl\site\lib\URI\rtsp.pm
+C:\tlperl\site\lib\URI\rtspu.pm
+C:\tlperl\site\lib\URI\sftp.pm
+C:\tlperl\site\lib\URI\sip.pm
+C:\tlperl\site\lib\URI\sips.pm
+C:\tlperl\site\lib\URI\snews.pm
+C:\tlperl\site\lib\URI\ssh.pm
+C:\tlperl\site\lib\URI\telnet.pm
+C:\tlperl\site\lib\URI\tn3270.pm
+C:\tlperl\site\lib\URI\urn.pm
+C:\tlperl\site\lib\URI\urn\isbn.pm
+C:\tlperl\site\lib\URI\urn\oid.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/WWW/RobotRules/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/WWW/RobotRules/.packlist new file mode 100644 index 0000000000..854d05abe3 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/WWW/RobotRules/.packlist @@ -0,0 +1,2 @@ +C:\tlperl\site\lib\WWW\RobotRules.pm
+C:\tlperl\site\lib\WWW\RobotRules\AnyDBM_File.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/API/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/API/.packlist new file mode 100644 index 0000000000..1cba447ccf --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/API/.packlist @@ -0,0 +1,7 @@ +C:\tlperl\site\lib\Win32\API.pm
+C:\tlperl\site\lib\Win32\API\Callback.pm
+C:\tlperl\site\lib\Win32\API\Callback\IATPatch.pod
+C:\tlperl\site\lib\Win32\API\Struct.pm
+C:\tlperl\site\lib\Win32\API\Type.pm
+C:\tlperl\site\lib\auto\Win32\API\API.dll
+C:\tlperl\site\lib\auto\Win32\API\Callback\Callback.dll
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/API/API.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/API/API.dll Binary files differnew file mode 100644 index 0000000000..787e19fed9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/API/API.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/API/Callback/Callback.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/API/Callback/Callback.dll Binary files differnew file mode 100644 index 0000000000..9877a24466 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/API/Callback/Callback.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Console/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Console/.packlist new file mode 100644 index 0000000000..1a443fac38 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Console/.packlist @@ -0,0 +1,2 @@ +C:\tlperl\site\lib\Win32\Console.pm
+C:\tlperl\site\lib\auto\Win32\Console\Console.dll
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Console/Console.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Console/Console.dll Binary files differnew file mode 100644 index 0000000000..fe0cbf1d2e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Console/Console.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/OLE/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/OLE/.packlist new file mode 100644 index 0000000000..eb21a2a013 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/OLE/.packlist @@ -0,0 +1,11 @@ +C:\tlperl\site\lib\OLE.pm
+C:\tlperl\site\lib\Win32\OLE.pm
+C:\tlperl\site\lib\Win32\OLE\Const.pm
+C:\tlperl\site\lib\Win32\OLE\Enum.pm
+C:\tlperl\site\lib\Win32\OLE\Lite.pm
+C:\tlperl\site\lib\Win32\OLE\NEWS.pod
+C:\tlperl\site\lib\Win32\OLE\NLS.pm
+C:\tlperl\site\lib\Win32\OLE\TPJ.pod
+C:\tlperl\site\lib\Win32\OLE\TypeInfo.pm
+C:\tlperl\site\lib\Win32\OLE\Variant.pm
+C:\tlperl\site\lib\auto\Win32\OLE\OLE.dll
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/OLE/OLE.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/OLE/OLE.dll Binary files differnew file mode 100644 index 0000000000..0b0103be05 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/OLE/OLE.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Shortcut/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Shortcut/.packlist new file mode 100644 index 0000000000..2969a83465 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Shortcut/.packlist @@ -0,0 +1,2 @@ +C:\tlperl\site\lib\Win32\Shortcut.pm
+C:\tlperl\site\lib\auto\Win32\Shortcut\Shortcut.dll
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Shortcut/Shortcut.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Shortcut/Shortcut.dll Binary files differnew file mode 100644 index 0000000000..42eeda695d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/Shortcut/Shortcut.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/TieRegistry/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/TieRegistry/.packlist new file mode 100644 index 0000000000..090c67dccf --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32/TieRegistry/.packlist @@ -0,0 +1,2 @@ +C:\tlperl\site\lib\Tie\Registry.pm
+C:\tlperl\site\lib\Win32\TieRegistry.pm
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32API/Registry/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32API/Registry/.packlist new file mode 100644 index 0000000000..f86d801641 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32API/Registry/.packlist @@ -0,0 +1,3 @@ +C:\tlperl\site\lib\Win32API\Registry.pm
+C:\tlperl\site\lib\Win32API\Registry\cRegistry.pc
+C:\tlperl\site\lib\auto\Win32API\Registry\Registry.dll
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32API/Registry/Registry.dll b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32API/Registry/Registry.dll Binary files differnew file mode 100644 index 0000000000..f2dd358c53 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/Win32API/Registry/Registry.dll diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/libwww/perl/.packlist b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/libwww/perl/.packlist new file mode 100644 index 0000000000..156f09f720 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/auto/libwww/perl/.packlist @@ -0,0 +1,33 @@ +C:\tlperl\bin\lwp-download
+C:\tlperl\bin\lwp-download.bat
+C:\tlperl\bin\lwp-dump
+C:\tlperl\bin\lwp-dump.bat
+C:\tlperl\bin\lwp-mirror
+C:\tlperl\bin\lwp-mirror.bat
+C:\tlperl\bin\lwp-request
+C:\tlperl\bin\lwp-request.bat
+C:\tlperl\site\lib\LWP.pm
+C:\tlperl\site\lib\LWP\Authen\Basic.pm
+C:\tlperl\site\lib\LWP\Authen\Digest.pm
+C:\tlperl\site\lib\LWP\Authen\Ntlm.pm
+C:\tlperl\site\lib\LWP\ConnCache.pm
+C:\tlperl\site\lib\LWP\Debug.pm
+C:\tlperl\site\lib\LWP\DebugFile.pm
+C:\tlperl\site\lib\LWP\Debug\TraceHTTP.pm
+C:\tlperl\site\lib\LWP\MemberMixin.pm
+C:\tlperl\site\lib\LWP\Protocol.pm
+C:\tlperl\site\lib\LWP\Protocol\cpan.pm
+C:\tlperl\site\lib\LWP\Protocol\data.pm
+C:\tlperl\site\lib\LWP\Protocol\file.pm
+C:\tlperl\site\lib\LWP\Protocol\ftp.pm
+C:\tlperl\site\lib\LWP\Protocol\gopher.pm
+C:\tlperl\site\lib\LWP\Protocol\http.pm
+C:\tlperl\site\lib\LWP\Protocol\loopback.pm
+C:\tlperl\site\lib\LWP\Protocol\mailto.pm
+C:\tlperl\site\lib\LWP\Protocol\nntp.pm
+C:\tlperl\site\lib\LWP\Protocol\nogo.pm
+C:\tlperl\site\lib\LWP\RobotUA.pm
+C:\tlperl\site\lib\LWP\Simple.pm
+C:\tlperl\site\lib\LWP\UserAgent.pm
+C:\tlperl\site\lib\libwww\lwpcook.pod
+C:\tlperl\site\lib\libwww\lwptut.pod
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/libwww/lwpcook.pod b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/libwww/lwpcook.pod new file mode 100644 index 0000000000..b4d4989a6a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/libwww/lwpcook.pod @@ -0,0 +1,310 @@ +=head1 NAME + +lwpcook - The libwww-perl cookbook + +=head1 DESCRIPTION + +This document contain some examples that show typical usage of the +libwww-perl library. You should consult the documentation for the +individual modules for more detail. + +All examples should be runnable programs. You can, in most cases, test +the code sections by piping the program text directly to perl. + + + +=head1 GET + +It is very easy to use this library to just fetch documents from the +net. The LWP::Simple module provides the get() function that return +the document specified by its URL argument: + + use LWP::Simple; + $doc = get 'http://search.cpan.org/dist/libwww-perl/'; + +or, as a perl one-liner using the getprint() function: + + perl -MLWP::Simple -e 'getprint "http://search.cpan.org/dist/libwww-perl/"' + +or, how about fetching the latest perl by running this command: + + perl -MLWP::Simple -e ' + getstore "ftp://ftp.sunet.se/pub/lang/perl/CPAN/src/latest.tar.gz", + "perl.tar.gz"' + +You will probably first want to find a CPAN site closer to you by +running something like the following command: + + perl -MLWP::Simple -e 'getprint "http://www.cpan.org/SITES.html"' + +Enough of this simple stuff! The LWP object oriented interface gives +you more control over the request sent to the server. Using this +interface you have full control over headers sent and how you want to +handle the response returned. + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $ua->agent("$0/0.1 " . $ua->agent); + # $ua->agent("Mozilla/8.0") # pretend we are very capable browser + + $req = HTTP::Request->new( + GET => 'http://search.cpan.org/dist/libwww-perl/'); + $req->header('Accept' => 'text/html'); + + # send request + $res = $ua->request($req); + + # check the outcome + if ($res->is_success) { + print $res->decoded_content; + } + else { + print "Error: " . $res->status_line . "\n"; + } + +The lwp-request program (alias GET) that is distributed with the +library can also be used to fetch documents from WWW servers. + + + +=head1 HEAD + +If you just want to check if a document is present (i.e. the URL is +valid) try to run code that looks like this: + + use LWP::Simple; + + if (head($url)) { + # ok document exists + } + +The head() function really returns a list of meta-information about +the document. The first three values of the list returned are the +document type, the size of the document, and the age of the document. + +More control over the request or access to all header values returned +require that you use the object oriented interface described for GET +above. Just s/GET/HEAD/g. + + +=head1 POST + +There is no simple procedural interface for posting data to a WWW server. You +must use the object oriented interface for this. The most common POST +operation is to access a WWW form application: + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + + my $req = HTTP::Request->new( + POST => 'https://rt.cpan.org/Public/Dist/Display.html'); + $req->content_type('application/x-www-form-urlencoded'); + $req->content('Status=Active&Name=libwww-perl'); + + my $res = $ua->request($req); + print $res->as_string; + +Lazy people use the HTTP::Request::Common module to set up a suitable +POST request message (it handles all the escaping issues) and has a +suitable default for the content_type: + + use HTTP::Request::Common qw(POST); + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + + my $req = POST 'https://rt.cpan.org/Public/Dist/Display.html', + [ Status => 'Active', Name => 'libwww-perl' ]; + + print $ua->request($req)->as_string; + +The lwp-request program (alias POST) that is distributed with the +library can also be used for posting data. + + + +=head1 PROXIES + +Some sites use proxies to go through fire wall machines, or just as +cache in order to improve performance. Proxies can also be used for +accessing resources through protocols not supported directly (or +supported badly :-) by the libwww-perl library. + +You should initialize your proxy setting before you start sending +requests: + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $ua->env_proxy; # initialize from environment variables + # or + $ua->proxy(ftp => 'http://proxy.myorg.com'); + $ua->proxy(wais => 'http://proxy.myorg.com'); + $ua->no_proxy(qw(no se fi)); + + my $req = HTTP::Request->new(GET => 'wais://xxx.com/'); + print $ua->request($req)->as_string; + +The LWP::Simple interface will call env_proxy() for you automatically. +Applications that use the $ua->env_proxy() method will normally not +use the $ua->proxy() and $ua->no_proxy() methods. + +Some proxies also require that you send it a username/password in +order to let requests through. You should be able to add the +required header, with something like this: + + use LWP::UserAgent; + + $ua = LWP::UserAgent->new; + $ua->proxy(['http', 'ftp'] => 'http://username:password@proxy.myorg.com'); + + $req = HTTP::Request->new('GET',"http://www.perl.com"); + + $res = $ua->request($req); + print $res->decoded_content if $res->is_success; + +Replace C<proxy.myorg.com>, C<username> and +C<password> with something suitable for your site. + + +=head1 ACCESS TO PROTECTED DOCUMENTS + +Documents protected by basic authorization can easily be accessed +like this: + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $req = HTTP::Request->new(GET => 'http://www.linpro.no/secret/'); + $req->authorization_basic('aas', 'mypassword'); + print $ua->request($req)->as_string; + +The other alternative is to provide a subclass of I<LWP::UserAgent> that +overrides the get_basic_credentials() method. Study the I<lwp-request> +program for an example of this. + + +=head1 COOKIES + +Some sites like to play games with cookies. By default LWP ignores +cookies provided by the servers it visits. LWP will collect cookies +and respond to cookie requests if you set up a cookie jar. LWP doesn't +provide a cookie jar itself, but if you install L<HTTP::CookieJar::LWP>, +it can be used like this: + + use LWP::UserAgent; + use HTTP::CookieJar::LWP; + + $ua = LWP::UserAgent->new( + cookie_jar => HTTP::CookieJar::LWP->new, + ); + + # and then send requests just as you used to do + $res = $ua->request(HTTP::Request->new(GET => "http://no.yahoo.com/")); + print $res->status_line, "\n"; + +=head1 HTTPS + +URLs with https scheme are accessed in exactly the same way as with +http scheme, provided that an SSL interface module for LWP has been +properly installed (see the F<README.SSL> file found in the +libwww-perl distribution for more details). If no SSL interface is +installed for LWP to use, then you will get "501 Protocol scheme +'https' is not supported" errors when accessing such URLs. + +Here's an example of fetching and printing a WWW page using SSL: + + use LWP::UserAgent; + + my $ua = LWP::UserAgent->new; + my $req = HTTP::Request->new(GET => 'https://www.helsinki.fi/'); + my $res = $ua->request($req); + if ($res->is_success) { + print $res->as_string; + } + else { + print "Failed: ", $res->status_line, "\n"; + } + +=head1 MIRRORING + +If you want to mirror documents from a WWW server, then try to run +code similar to this at regular intervals: + + use LWP::Simple; + + %mirrors = ( + 'http://www.sn.no/' => 'sn.html', + 'http://www.perl.com/' => 'perl.html', + 'http://search.cpan.org/distlibwww-perl/' => 'lwp.html', + 'gopher://gopher.sn.no/' => 'gopher.html', + ); + + while (($url, $localfile) = each(%mirrors)) { + mirror($url, $localfile); + } + +Or, as a perl one-liner: + + perl -MLWP::Simple -e 'mirror("http://www.perl.com/", "perl.html")'; + +The document will not be transferred unless it has been updated. + + + +=head1 LARGE DOCUMENTS + +If the document you want to fetch is too large to be kept in memory, +then you have two alternatives. You can instruct the library to write +the document content to a file (second $ua->request() argument is a file +name): + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + + my $req = HTTP::Request->new(GET => + 'http://www.cpan.org/CPAN/authors/id/O/OA/OALDERS/libwww-perl-6.26.tar.gz'); + $res = $ua->request($req, "libwww-perl.tar.gz"); + if ($res->is_success) { + print "ok\n"; + } + else { + print $res->status_line, "\n"; + } + + +Or you can process the document as it arrives (second $ua->request() +argument is a code reference): + + use LWP::UserAgent; + $ua = LWP::UserAgent->new; + $URL = 'ftp://ftp.isc.org/pub/rfc/rfc-index.txt'; + + my $expected_length; + my $bytes_received = 0; + my $res = + $ua->request(HTTP::Request->new(GET => $URL), + sub { + my($chunk, $res) = @_; + $bytes_received += length($chunk); + unless (defined $expected_length) { + $expected_length = $res->content_length || 0; + } + if ($expected_length) { + printf STDERR "%d%% - ", + 100 * $bytes_received / $expected_length; + } + print STDERR "$bytes_received bytes received\n"; + + # XXX Should really do something with the chunk itself + # print $chunk; + }); + print $res->status_line, "\n"; + + + +=head1 COPYRIGHT + +Copyright 1996-2001, Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/libwww/lwptut.pod b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/libwww/lwptut.pod new file mode 100644 index 0000000000..f9f98a0f15 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/libwww/lwptut.pod @@ -0,0 +1,820 @@ +=head1 NAME + +lwptut -- An LWP Tutorial + +=head1 DESCRIPTION + +LWP (short for "Library for WWW in Perl") is a very popular group of +Perl modules for accessing data on the Web. Like most Perl +module-distributions, each of LWP's component modules comes with +documentation that is a complete reference to its interface. However, +there are so many modules in LWP that it's hard to know where to start +looking for information on how to do even the simplest most common +things. + +Really introducing you to using LWP would require a whole book -- a book +that just happens to exist, called I<Perl & LWP>. But this article +should give you a taste of how you can go about some common tasks with +LWP. + + +=head2 Getting documents with LWP::Simple + +If you just want to get what's at a particular URL, the simplest way +to do it is LWP::Simple's functions. + +In a Perl program, you can call its C<get($url)> function. It will try +getting that URL's content. If it works, then it'll return the +content; but if there's some error, it'll return undef. + + my $url = 'http://www.npr.org/programs/fa/?todayDate=current'; + # Just an example: the URL for the most recent /Fresh Air/ show + + use LWP::Simple; + my $content = get $url; + die "Couldn't get $url" unless defined $content; + + # Then go do things with $content, like this: + + if($content =~ m/jazz/i) { + print "They're talking about jazz today on Fresh Air!\n"; + } + else { + print "Fresh Air is apparently jazzless today.\n"; + } + +The handiest variant on C<get> is C<getprint>, which is useful in Perl +one-liners. If it can get the page whose URL you provide, it sends it +to STDOUT; otherwise it complains to STDERR. + + % perl -MLWP::Simple -e "getprint 'http://www.cpan.org/RECENT'" + +That is the URL of a plain text file that lists new files in CPAN in +the past two weeks. You can easily make it part of a tidy little +shell command, like this one that mails you the list of new +C<Acme::> modules: + + % perl -MLWP::Simple -e "getprint 'http://www.cpan.org/RECENT'" \ + | grep "/by-module/Acme" | mail -s "New Acme modules! Joy!" $USER + +There are other useful functions in LWP::Simple, including one function +for running a HEAD request on a URL (useful for checking links, or +getting the last-revised time of a URL), and two functions for +saving/mirroring a URL to a local file. See L<the LWP::Simple +documentation|LWP::Simple> for the full details, or chapter 2 of I<Perl +& LWP> for more examples. + + + +=for comment + ########################################################################## + + + +=head2 The Basics of the LWP Class Model + +LWP::Simple's functions are handy for simple cases, but its functions +don't support cookies or authorization, don't support setting header +lines in the HTTP request, generally don't support reading header lines +in the HTTP response (notably the full HTTP error message, in case of an +error). To get at all those features, you'll have to use the full LWP +class model. + +While LWP consists of dozens of classes, the main two that you have to +understand are L<LWP::UserAgent> and L<HTTP::Response>. LWP::UserAgent +is a class for "virtual browsers" which you use for performing requests, +and L<HTTP::Response> is a class for the responses (or error messages) +that you get back from those requests. + +The basic idiom is C<< $response = $browser->get($url) >>, or more fully +illustrated: + + # Early in your program: + + use LWP 5.64; # Loads all important LWP classes, and makes + # sure your version is reasonably recent. + + my $browser = LWP::UserAgent->new; + + ... + + # Then later, whenever you need to make a get request: + my $url = 'http://www.npr.org/programs/fa/?todayDate=current'; + + my $response = $browser->get( $url ); + die "Can't get $url -- ", $response->status_line + unless $response->is_success; + + die "Hey, I was expecting HTML, not ", $response->content_type + unless $response->content_type eq 'text/html'; + # or whatever content-type you're equipped to deal with + + # Otherwise, process the content somehow: + + if($response->decoded_content =~ m/jazz/i) { + print "They're talking about jazz today on Fresh Air!\n"; + } + else { + print "Fresh Air is apparently jazzless today.\n"; + } + +There are two objects involved: C<$browser>, which holds an object of +class LWP::UserAgent, and then the C<$response> object, which is of +class HTTP::Response. You really need only one browser object per +program; but every time you make a request, you get back a new +HTTP::Response object, which will have some interesting attributes: + +=over + +=item * + +A status code indicating +success or failure +(which you can test with C<< $response->is_success >>). + +=item * + +An HTTP status +line that is hopefully informative if there's failure (which you can +see with C<< $response->status_line >>, +returning something like "404 Not Found"). + +=item * + +A MIME content-type like "text/html", "image/gif", +"application/xml", etc., which you can see with +C<< $response->content_type >> + +=item * + +The actual content of the response, in C<< $response->decoded_content >>. +If the response is HTML, that's where the HTML source will be; if +it's a GIF, then C<< $response->decoded_content >> will be the binary +GIF data. + +=item * + +And dozens of other convenient and more specific methods that are +documented in the docs for L<HTTP::Response>, and its superclasses +L<HTTP::Message> and L<HTTP::Headers>. + +=back + + + +=for comment + ########################################################################## + + + +=head2 Adding Other HTTP Request Headers + +The most commonly used syntax for requests is C<< $response = +$browser->get($url) >>, but in truth, you can add extra HTTP header +lines to the request by adding a list of key-value pairs after the URL, +like so: + + $response = $browser->get( $url, $key1, $value1, $key2, $value2, ... ); + +For example, here's how to send some commonly used headers, in case +you're dealing with a site that would otherwise reject your request: + + + my @ns_headers = ( + 'User-Agent' => 'Mozilla/4.76 [en] (Win98; U)', + 'Accept' => 'image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png, */*', + 'Accept-Charset' => 'iso-8859-1,*,utf-8', + 'Accept-Language' => 'en-US', + ); + + ... + + $response = $browser->get($url, @ns_headers); + +If you weren't reusing that array, you could just go ahead and do this: + + $response = $browser->get($url, + 'User-Agent' => 'Mozilla/4.76 [en] (Win98; U)', + 'Accept' => 'image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png, */*', + 'Accept-Charset' => 'iso-8859-1,*,utf-8', + 'Accept-Language' => 'en-US', + ); + +If you were only ever changing the 'User-Agent' line, you could just change +the C<$browser> object's default line from "libwww-perl/5.65" (or the like) +to whatever you like, using the LWP::UserAgent C<agent> method: + + $browser->agent('Mozilla/4.76 [en] (Win98; U)'); + + + +=for comment + ########################################################################## + + + +=head2 Enabling Cookies + +A default LWP::UserAgent object acts like a browser with its cookies +support turned off. There are various ways of turning it on, by setting +its C<cookie_jar> attribute. A "cookie jar" is an object representing +a little database of all +the HTTP cookies that a browser knows about. It can correspond to a +file on disk or +an in-memory object that starts out empty, and whose collection of +cookies will disappear once the program is finished running. + +To give a browser an in-memory empty cookie jar, you set its C<cookie_jar> +attribute like so: + + use HTTP::CookieJar::LWP; + $browser->cookie_jar( HTTP::CookieJar::LWP->new ); + +To save a cookie jar to disk, see L<< HTTP::CookieJar/dump_cookies >>. +To load cookies from disk into a jar, see L<< +HTTP::CookieJar/load_cookies >>. + +=for comment + ########################################################################## + + + +=head2 Posting Form Data + +Many HTML forms send data to their server using an HTTP POST request, which +you can send with this syntax: + + $response = $browser->post( $url, + [ + formkey1 => value1, + formkey2 => value2, + ... + ], + ); + +Or if you need to send HTTP headers: + + $response = $browser->post( $url, + [ + formkey1 => value1, + formkey2 => value2, + ... + ], + headerkey1 => value1, + headerkey2 => value2, + ); + +For example, the following program makes a search request to AltaVista +(by sending some form data via an HTTP POST request), and extracts from +the HTML the report of the number of matches: + + use strict; + use warnings; + use LWP 5.64; + my $browser = LWP::UserAgent->new; + + my $word = 'tarragon'; + + my $url = 'http://search.yahoo.com/yhs/search'; + my $response = $browser->post( $url, + [ 'q' => $word, # the Altavista query string + 'fr' => 'altavista', 'pg' => 'q', 'avkw' => 'tgz', 'kl' => 'XX', + ] + ); + die "$url error: ", $response->status_line + unless $response->is_success; + die "Weird content type at $url -- ", $response->content_type + unless $response->content_is_html; + + if( $response->decoded_content =~ m{([0-9,]+)(?:<.*?>)? results for} ) { + # The substring will be like "996,000</strong> results for" + print "$word: $1\n"; + } + else { + print "Couldn't find the match-string in the response\n"; + } + + + +=for comment + ########################################################################## + + + +=head2 Sending GET Form Data + +Some HTML forms convey their form data not by sending the data +in an HTTP POST request, but by making a normal GET request with +the data stuck on the end of the URL. For example, if you went to +C<www.imdb.com> and ran a search on "Blade Runner", the URL you'd see +in your browser window would be: + + http://www.imdb.com/find?s=all&q=Blade+Runner + +To run the same search with LWP, you'd use this idiom, which involves +the URI class: + + use URI; + my $url = URI->new( 'http://www.imdb.com/find' ); + # makes an object representing the URL + + $url->query_form( # And here the form data pairs: + 'q' => 'Blade Runner', + 's' => 'all', + ); + + my $response = $browser->get($url); + +See chapter 5 of I<Perl & LWP> for a longer discussion of HTML forms +and of form data, and chapters 6 through 9 for a longer discussion of +extracting data from HTML. + + + +=head2 Absolutizing URLs + +The URI class that we just mentioned above provides all sorts of methods +for accessing and modifying parts of URLs (such as asking sort of URL it +is with C<< $url->scheme >>, and asking what host it refers to with C<< +$url->host >>, and so on, as described in L<the docs for the URI +class|URI>. However, the methods of most immediate interest +are the C<query_form> method seen above, and now the C<new_abs> method +for taking a probably-relative URL string (like "../foo.html") and getting +back an absolute URL (like "http://www.perl.com/stuff/foo.html"), as +shown here: + + use URI; + $abs = URI->new_abs($maybe_relative, $base); + +For example, consider this program that matches URLs in the HTML +list of new modules in CPAN: + + use strict; + use warnings; + use LWP; + my $browser = LWP::UserAgent->new; + + my $url = 'http://www.cpan.org/RECENT.html'; + my $response = $browser->get($url); + die "Can't get $url -- ", $response->status_line + unless $response->is_success; + + my $html = $response->decoded_content; + while( $html =~ m/<A HREF=\"(.*?)\"/g ) { + print "$1\n"; + } + +When run, it emits output that starts out something like this: + + MIRRORING.FROM + RECENT + RECENT.html + authors/00whois.html + authors/01mailrc.txt.gz + authors/id/A/AA/AASSAD/CHECKSUMS + ... + +However, if you actually want to have those be absolute URLs, you +can use the URI module's C<new_abs> method, by changing the C<while> +loop to this: + + while( $html =~ m/<A HREF=\"(.*?)\"/g ) { + print URI->new_abs( $1, $response->base ) ,"\n"; + } + +(The C<< $response->base >> method from L<HTTP::Message|HTTP::Message> +is for returning what URL +should be used for resolving relative URLs -- it's usually just +the same as the URL that you requested.) + +That program then emits nicely absolute URLs: + + http://www.cpan.org/MIRRORING.FROM + http://www.cpan.org/RECENT + http://www.cpan.org/RECENT.html + http://www.cpan.org/authors/00whois.html + http://www.cpan.org/authors/01mailrc.txt.gz + http://www.cpan.org/authors/id/A/AA/AASSAD/CHECKSUMS + ... + +See chapter 4 of I<Perl & LWP> for a longer discussion of URI objects. + +Of course, using a regexp to match hrefs is a bit simplistic, and for +more robust programs, you'll probably want to use an HTML-parsing module +like L<HTML::LinkExtor> or L<HTML::TokeParser> or even maybe +L<HTML::TreeBuilder>. + + + + +=for comment + ########################################################################## + +=head2 Other Browser Attributes + +LWP::UserAgent objects have many attributes for controlling how they +work. Here are a few notable ones: + +=over + +=item * + +C<< $browser->timeout(15); >> + +This sets this browser object to give up on requests that don't answer +within 15 seconds. + + +=item * + +C<< $browser->protocols_allowed( [ 'http', 'gopher'] ); >> + +This sets this browser object to not speak any protocols other than HTTP +and gopher. If it tries accessing any other kind of URL (like an "ftp:" +or "mailto:" or "news:" URL), then it won't actually try connecting, but +instead will immediately return an error code 500, with a message like +"Access to 'ftp' URIs has been disabled". + + +=item * + +C<< use LWP::ConnCache; $browser->conn_cache(LWP::ConnCache->new()); >> + +This tells the browser object to try using the HTTP/1.1 "Keep-Alive" +feature, which speeds up requests by reusing the same socket connection +for multiple requests to the same server. + + +=item * + +C<< $browser->agent( 'SomeName/1.23 (more info here maybe)' ) >> + +This changes how the browser object will identify itself in +the default "User-Agent" line is its HTTP requests. By default, +it'll send "libwww-perl/I<versionnumber>", like +"libwww-perl/5.65". You can change that to something more descriptive +like this: + + $browser->agent( 'SomeName/3.14 (contact@robotplexus.int)' ); + +Or if need be, you can go in disguise, like this: + + $browser->agent( 'Mozilla/4.0 (compatible; MSIE 5.12; Mac_PowerPC)' ); + + +=item * + +C<< push @{ $ua->requests_redirectable }, 'POST'; >> + +This tells this browser to obey redirection responses to POST requests +(like most modern interactive browsers), even though the HTTP RFC says +that should not normally be done. + + +=back + + +For more options and information, see L<the full documentation for +LWP::UserAgent|LWP::UserAgent>. + + + +=for comment + ########################################################################## + + + +=head2 Writing Polite Robots + +If you want to make sure that your LWP-based program respects F<robots.txt> +files and doesn't make too many requests too fast, you can use the LWP::RobotUA +class instead of the LWP::UserAgent class. + +LWP::RobotUA class is just like LWP::UserAgent, and you can use it like so: + + use LWP::RobotUA; + my $browser = LWP::RobotUA->new('YourSuperBot/1.34', 'you@yoursite.com'); + # Your bot's name and your email address + + my $response = $browser->get($url); + +But HTTP::RobotUA adds these features: + + +=over + +=item * + +If the F<robots.txt> on C<$url>'s server forbids you from accessing +C<$url>, then the C<$browser> object (assuming it's of class LWP::RobotUA) +won't actually request it, but instead will give you back (in C<$response>) a 403 error +with a message "Forbidden by robots.txt". That is, if you have this line: + + die "$url -- ", $response->status_line, "\nAborted" + unless $response->is_success; + +then the program would die with an error message like this: + + http://whatever.site.int/pith/x.html -- 403 Forbidden by robots.txt + Aborted at whateverprogram.pl line 1234 + +=item * + +If this C<$browser> object sees that the last time it talked to +C<$url>'s server was too recently, then it will pause (via C<sleep>) to +avoid making too many requests too often. How long it will pause for, is +by default one minute -- but you can control it with the C<< +$browser->delay( I<minutes> ) >> attribute. + +For example, this code: + + $browser->delay( 7/60 ); + +...means that this browser will pause when it needs to avoid talking to +any given server more than once every 7 seconds. + +=back + +For more options and information, see L<the full documentation for +LWP::RobotUA|LWP::RobotUA>. + + + + + +=for comment + ########################################################################## + +=head2 Using Proxies + +In some cases, you will want to (or will have to) use proxies for +accessing certain sites and/or using certain protocols. This is most +commonly the case when your LWP program is running (or could be running) +on a machine that is behind a firewall. + +To make a browser object use proxies that are defined in the usual +environment variables (C<HTTP_PROXY>, etc.), just call the C<env_proxy> +on a user-agent object before you go making any requests on it. +Specifically: + + use LWP::UserAgent; + my $browser = LWP::UserAgent->new; + + # And before you go making any requests: + $browser->env_proxy; + +For more information on proxy parameters, see L<the LWP::UserAgent +documentation|LWP::UserAgent>, specifically the C<proxy>, C<env_proxy>, +and C<no_proxy> methods. + + + +=for comment + ########################################################################## + +=head2 HTTP Authentication + +Many web sites restrict access to documents by using "HTTP +Authentication". This isn't just any form of "enter your password" +restriction, but is a specific mechanism where the HTTP server sends the +browser an HTTP code that says "That document is part of a protected +'realm', and you can access it only if you re-request it and add some +special authorization headers to your request". + +For example, the Unicode.org admins stop email-harvesting bots from +harvesting the contents of their mailing list archives, by protecting +them with HTTP Authentication, and then publicly stating the username +and password (at C<http://www.unicode.org/mail-arch/>) -- namely +username "unicode-ml" and password "unicode". + +For example, consider this URL, which is part of the protected +area of the web site: + + http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html + +If you access that with a browser, you'll get a prompt +like +"Enter username and password for 'Unicode-MailList-Archives' at server +'www.unicode.org'". + +In LWP, if you just request that URL, like this: + + use LWP; + my $browser = LWP::UserAgent->new; + + my $url = + 'http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html'; + my $response = $browser->get($url); + + die "Error: ", $response->header('WWW-Authenticate') || 'Error accessing', + # ('WWW-Authenticate' is the realm-name) + "\n ", $response->status_line, "\n at $url\n Aborting" + unless $response->is_success; + +Then you'll get this error: + + Error: Basic realm="Unicode-MailList-Archives" + 401 Authorization Required + at http://www.unicode.org/mail-arch/unicode-ml/y2002-m08/0067.html + Aborting at auth1.pl line 9. [or wherever] + +...because the C<$browser> doesn't know any the username and password +for that realm ("Unicode-MailList-Archives") at that host +("www.unicode.org"). The simplest way to let the browser know about this +is to use the C<credentials> method to let it know about a username and +password that it can try using for that realm at that host. The syntax is: + + $browser->credentials( + 'servername:portnumber', + 'realm-name', + 'username' => 'password' + ); + +In most cases, the port number is 80, the default TCP/IP port for HTTP; and +you usually call the C<credentials> method before you make any requests. +For example: + + $browser->credentials( + 'reports.mybazouki.com:80', + 'web_server_usage_reports', + 'plinky' => 'banjo123' + ); + +So if we add the following to the program above, right after the C<< +$browser = LWP::UserAgent->new; >> line... + + $browser->credentials( # add this to our $browser 's "key ring" + 'www.unicode.org:80', + 'Unicode-MailList-Archives', + 'unicode-ml' => 'unicode' + ); + +...then when we run it, the request succeeds, instead of causing the +C<die> to be called. + + + +=for comment + ########################################################################## + +=head2 Accessing HTTPS URLs + +When you access an HTTPS URL, it'll work for you just like an HTTP URL +would -- if your LWP installation has HTTPS support (via an appropriate +Secure Sockets Layer library). For example: + + use LWP; + my $url = 'https://www.paypal.com/'; # Yes, HTTPS! + my $browser = LWP::UserAgent->new; + my $response = $browser->get($url); + die "Error at $url\n ", $response->status_line, "\n Aborting" + unless $response->is_success; + print "Whee, it worked! I got that ", + $response->content_type, " document!\n"; + +If your LWP installation doesn't have HTTPS support set up, then the +response will be unsuccessful, and you'll get this error message: + + Error at https://www.paypal.com/ + 501 Protocol scheme 'https' is not supported + Aborting at paypal.pl line 7. [or whatever program and line] + +If your LWP installation I<does> have HTTPS support installed, then the +response should be successful, and you should be able to consult +C<$response> just like with any normal HTTP response. + +For information about installing HTTPS support for your LWP +installation, see the helpful F<README.SSL> file that comes in the +libwww-perl distribution. + + +=for comment + ########################################################################## + + + +=head2 Getting Large Documents + +When you're requesting a large (or at least potentially large) document, +a problem with the normal way of using the request methods (like C<< +$response = $browser->get($url) >>) is that the response object in +memory will have to hold the whole document -- I<in memory>. If the +response is a thirty megabyte file, this is likely to be quite an +imposition on this process's memory usage. + +A notable alternative is to have LWP save the content to a file on disk, +instead of saving it up in memory. This is the syntax to use: + + $response = $ua->get($url, + ':content_file' => $filespec, + ); + +For example, + + $response = $ua->get('http://search.cpan.org/', + ':content_file' => '/tmp/sco.html' + ); + +When you use this C<:content_file> option, the C<$response> will have +all the normal header lines, but C<< $response->content >> will be +empty. Errors writing to the content file (for example due to +permission denied or the filesystem being full) will be reported via +the C<Client-Aborted> or C<X-Died> response headers, and not the +C<is_success> method: + + if ($response->header('Client-Aborted') eq 'die') { + # handle error ... + +Note that this ":content_file" option isn't supported under older +versions of LWP, so you should consider adding C<use LWP 5.66;> to check +the LWP version, if you think your program might run on systems with +older versions. + +If you need to be compatible with older LWP versions, then use +this syntax, which does the same thing: + + use HTTP::Request::Common; + $response = $ua->request( GET($url), $filespec ); + + +=for comment + ########################################################################## + + +=head1 SEE ALSO + +Remember, this article is just the most rudimentary introduction to +LWP -- to learn more about LWP and LWP-related tasks, you really +must read from the following: + +=over + +=item * + +L<LWP::Simple> -- simple functions for getting/heading/mirroring URLs + +=item * + +L<LWP> -- overview of the libwww-perl modules + +=item * + +L<LWP::UserAgent> -- the class for objects that represent "virtual browsers" + +=item * + +L<HTTP::Response> -- the class for objects that represent the response to +a LWP response, as in C<< $response = $browser->get(...) >> + +=item * + +L<HTTP::Message> and L<HTTP::Headers> -- classes that provide more methods +to HTTP::Response. + +=item * + +L<URI> -- class for objects that represent absolute or relative URLs + +=item * + +L<URI::Escape> -- functions for URL-escaping and URL-unescaping strings +(like turning "this & that" to and from "this%20%26%20that"). + +=item * + +L<HTML::Entities> -- functions for HTML-escaping and HTML-unescaping strings +(like turning "C. & E. BrontE<euml>" to and from "C. & E. Brontë") + +=item * + +L<HTML::TokeParser> and L<HTML::TreeBuilder> -- classes for parsing HTML + +=item * + +L<HTML::LinkExtor> -- class for finding links in HTML documents + +=item * + +The book I<Perl & LWP> by Sean M. Burke. O'Reilly & Associates, +2002. ISBN: 0-596-00178-9, L<http://oreilly.com/catalog/perllwp/>. The +whole book is also available free online: +L<http://lwp.interglacial.com>. + +=back + + +=head1 COPYRIGHT + +Copyright 2002, Sean M. Burke. You can redistribute this document and/or +modify it, but only under the same terms as Perl itself. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=for comment + ########################################################################## + +=cut + +# End of Pod |