[Bps-public-commit] rt-extension-rest2 branch, master, updated. 6098d82dad1d1cc31114784526a2e7acde94080b
Shawn Moore
shawn at bestpractical.com
Wed Jul 19 16:56:12 EDT 2017
The branch, master has been updated
via 6098d82dad1d1cc31114784526a2e7acde94080b (commit)
from 96bea5bb293817f15f7f83d9e7e1bf305b74e812 (commit)
Summary of changes:
MANIFEST | 42 ++-
META.yml | 16 +-
Makefile.PL | 2 +-
README | 453 ++++++++++++++++++++---
inc/Module/Install.pm | 35 +-
inc/Module/Install/Base.pm | 2 +-
inc/Module/Install/Can.pm | 13 +-
inc/Module/Install/Fetch.pm | 2 +-
inc/Module/Install/Include.pm | 2 +-
inc/Module/Install/Makefile.pm | 2 +-
inc/Module/Install/Metadata.pm | 2 +-
inc/Module/Install/RTx.pm | 22 +-
inc/Module/Install/ReadmeFromPod.pm | 2 +-
inc/Module/Install/Win32.pm | 2 +-
inc/Module/Install/WriteAll.pm | 2 +-
inc/YAML/Tiny.pm | 696 ++++++++++++------------------------
inc/unicore/Name.pm | 416 +++++++++++++++++++++
17 files changed, 1140 insertions(+), 571 deletions(-)
create mode 100644 inc/unicore/Name.pm
- Log -----------------------------------------------------------------
commit 6098d82dad1d1cc31114784526a2e7acde94080b
Author: Shawn M Moore <shawn at bestpractical.com>
Date: Wed Jul 19 20:48:21 2017 +0000
Regenerate toolchain
diff --git a/MANIFEST b/MANIFEST
index c74735e..345098c 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -12,6 +12,7 @@ inc/Module/Install/RTx/Runtime.pm
inc/Module/Install/Substitute.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
+inc/unicore/Name.pm
inc/YAML/Tiny.pm
lib/RT/Extension/REST2.pm
lib/RT/Extension/REST2/Dispatcher.pm
@@ -21,22 +22,38 @@ lib/RT/Extension/REST2/Middleware/Log.pm
lib/RT/Extension/REST2/PodViewer.pm
lib/RT/Extension/REST2/PodViewer/HTMLView.pm
lib/RT/Extension/REST2/Resource.pm
+lib/RT/Extension/REST2/Resource/Asset.pm
+lib/RT/Extension/REST2/Resource/Assets.pm
+lib/RT/Extension/REST2/Resource/Attachment.pm
+lib/RT/Extension/REST2/Resource/Attachments.pm
lib/RT/Extension/REST2/Resource/Catalog.pm
lib/RT/Extension/REST2/Resource/Catalogs.pm
lib/RT/Extension/REST2/Resource/Collection.pm
lib/RT/Extension/REST2/Resource/Collection/ProcessPOSTasGET.pm
lib/RT/Extension/REST2/Resource/Collection/QueryByJSON.pm
-lib/RT/Extension/REST2/Resource/Download/CF.pm
+lib/RT/Extension/REST2/Resource/CustomField.pm
+lib/RT/Extension/REST2/Resource/CustomFields.pm
+lib/RT/Extension/REST2/Resource/CustomRole.pm
+lib/RT/Extension/REST2/Resource/CustomRoles.pm
+lib/RT/Extension/REST2/Resource/Group.pm
+lib/RT/Extension/REST2/Resource/Groups.pm
+lib/RT/Extension/REST2/Resource/Message.pm
lib/RT/Extension/REST2/Resource/Queue.pm
lib/RT/Extension/REST2/Resource/Queues.pm
lib/RT/Extension/REST2/Resource/Record.pm
lib/RT/Extension/REST2/Resource/Record/Deletable.pm
lib/RT/Extension/REST2/Resource/Record/DeletableByDisabling.pm
+lib/RT/Extension/REST2/Resource/Record/Hypermedia.pm
lib/RT/Extension/REST2/Resource/Record/Readable.pm
+lib/RT/Extension/REST2/Resource/Record/WithETag.pm
lib/RT/Extension/REST2/Resource/Record/Writable.pm
lib/RT/Extension/REST2/Resource/Role/RequestBodyIsJSON.pm
+lib/RT/Extension/REST2/Resource/Root.pm
+lib/RT/Extension/REST2/Resource/RT.pm
lib/RT/Extension/REST2/Resource/Ticket.pm
lib/RT/Extension/REST2/Resource/Tickets.pm
+lib/RT/Extension/REST2/Resource/Transaction.pm
+lib/RT/Extension/REST2/Resource/Transactions.pm
lib/RT/Extension/REST2/Resource/User.pm
lib/RT/Extension/REST2/Resource/Users.pm
lib/RT/Extension/REST2/Util.pm
@@ -44,14 +61,21 @@ Makefile.PL
MANIFEST This list of files
META.yml
README
-t/acceptance/main.t
-t/acceptance/not_found.t
-t/acceptance/tickets.t
+t/asset-customfields.t
+t/assets.t
+t/catalogs.t
+t/conflict.t
t/lib/RT/Extension/REST2/Test.pm
t/lib/RT/Extension/REST2/Test.pm.in
-t/tmp/acceptance-tickets.t-ODEBGI0a/rt.debug.log
-t/tmp/acceptance-tickets.t-ODEBGI0a/RT_SiteConfig.pm
-t/tmp/acceptance-tickets.t-uM_rUIbS/rt.debug.log
-t/tmp/acceptance-tickets.t-uM_rUIbS/RT_SiteConfig.pm
-t/tmp/ports
+t/not_found.t
+t/queues.t
+t/root.t
+t/search-json.t
+t/ticket-customfields.t
+t/ticket-customroles.t
+t/ticket-links.t
+t/ticket-watchers.t
+t/tickets.t
+t/transactions.t
+t/user-customfields.t
TODO
diff --git a/META.yml b/META.yml
index 58aa284..dfcb67e 100644
--- a/META.yml
+++ b/META.yml
@@ -4,13 +4,14 @@ author:
- 'Best Practical Solutions, LLC <modules at bestpractical.com>'
build_requires:
ExtUtils::MakeMaker: 6.59
+ Test::Deep: 0
Try::Tiny: 0
configure_requires:
ExtUtils::MakeMaker: 6.59
distribution_type: module
dynamic_config: 1
-generated_by: 'Module::Install version 1.16'
-license: gplv2
+generated_by: 'Module::Install version 1.18'
+license: gpl_2
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
@@ -24,7 +25,6 @@ no_index:
recommends:
JSON::XS: 0
requires:
- Class::Method::Modifiers: 0
Encode: 0
JSON: 0
Module::Path: 0
@@ -32,18 +32,16 @@ requires:
Moose: 0
MooseX::NonMoose: 0
MooseX::Role::Parameterized: 0
+ Path::Dispatcher: 0
Plack::Builder: 0
- Plack::Middleware::RequestHeaders: 0
- Plack::Middleware::ReverseProxyPath: 0
Pod::POM: 0
Scalar::Util: 0
Sub::Exporter: 0
- Web::Machine: '0.12'
- Web::Simple: 0
+ Web::Machine: 0.12
namespace::autoclean: 0
perl: 5.10.1
resources:
license: http://opensource.org/licenses/gpl-license.php
-version: '0.10'
-x_module_install_rtx_version: '0.38'
+version: 0.10
+x_module_install_rtx_version: 0.39
x_requires_rt: 4.2.4
diff --git a/Makefile.PL b/Makefile.PL
index 833bc4f..1ad4fdc 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,7 +1,7 @@
use inc::Module::Install;
RTx 'RT-Extension-REST2';
-license 'gplv2';
+license 'gpl_2';
githubmeta('github');
diff --git a/README b/README
index e12bb05..5b90a4b 100644
--- a/README
+++ b/README
@@ -18,67 +18,387 @@ INSTALLATION
Restart your webserver
USAGE
- Summary
- Currently provided endpoints under /REST/2.0/ are:
+ Tutorial
+ To make it easier to authenticate to REST2, we recommend installing
+ RT::Authen::Token. Visit "Logged in as ___" -> Settings -> Auth Tokens.
+ Create an Auth Token, give it any description (such as "REST2 with
+ curl"). Make note of the authentication token it provides to you.
- GET /ticket/:id
- PUT /ticket/:id <JSON body>
- DELETE /ticket/:id
- Sets ticket status to "deleted".
+ For other authentication options see the section "Authentication
+ Methods" below.
- GET /queue/:id
- PUT /queue/:id <JSON body>
- DELETE /queue/:id
- Disables the queue.
+ Authentication
+ Run the following in a terminal, filling in XX_TOKEN_XX from the auth
+ token above and XX_RT_URL_XX with the URL for your RT instance.
- GET /user/:id
- PUT /user/:id <JSON body>
- DELETE /user/:id
- Disables the user.
+ curl -H 'Authorization: token XX_TOKEN_XX' 'XX_RT_URL_XX/REST/2.0/queues/all'
- For queues and users, :id may be the numeric id or the unique name.
+ This does an authenticated request (using the Authorization HTTP header
+ with type token) for all of the queues you can see. You should see a
+ response, typical of search results, like this:
- When a GET request is made, each endpoint returns a JSON representation
- of the specified resource, or a 404 if not found.
+ {
+ "total" : 1,
+ "count" : 1,
+ "page" : 1,
+ "per_page" : 20,
+ "items" : [
+ {
+ "type" : "queue",
+ "id" : "1",
+ "_url" : "XX_RT_URL_XX/REST/2.0/queue/1"
+ }
+ ]
+ }
- When a PUT request is made, the request body should be a modified copy
- (or partial copy) of the JSON representation of the specified resource,
- and the record will be updated.
+ This format is JSON, which is a format for which many programming
+ languages provide libraries for parsing and generating.
- A DELETE request to a resource will delete or disable the underlying
- record.
+ (If you instead see a response like {"message":"Unauthorized"} that
+ indicates RT couldn't process your authentication token successfully;
+ make sure the word "token" appears between "Authorization:" and the auth
+ token that RT provided to you)
- Creating
- POST /ticket
- POST /queue
- POST /user
+ Following Links
+ You can request one of the provided _urls to get more information about
+ that queue.
+
+ curl -H 'Authorization: token XX_TOKEN_XX' 'XX_QUEUE_URL_XX'
+
+ This will give a lot of information, like so:
+
+ {
+ "id" : 1,
+ "Name" : "General",
+ "Description" : "The default queue",
+ "Lifecycle" : "default",
+ ...
+ "CustomFields" : {},
+ "_hyperlinks" : [
+ {
+ "id" : "1",
+ "ref" : "self",
+ "type" : "queue",
+ "_url" : "XX_RT_URL_XX/REST/2.0/queue/1"
+ },
+ {
+ "ref" : "history",
+ "_url" : "XX_RT_URL_XX/REST/2.0/queue/1/history"
+ },
+ {
+ "ref" : "create",
+ "type" : "ticket",
+ "_url" : "XX_RT_URL_XX/REST/2.0/ticket?Queue=1"
+ }
+ ],
+ }
+
+ Of particular note is the _hyperlinks key, which gives you a list of
+ related resources to examine (following the
+ <https://en.wikipedia.org/wiki/HATEOAS> principle). For example an entry
+ with a ref of history lets you examine the transaction log for a record.
+ You can implement your REST API client knowing that any other hypermedia
+ link with a ref of history has the same meaning, regardless of whether
+ it's the history of a queue, ticket, asset, etc.
+
+ Another ref you'll see in _hyperlinks is create, with a type of ticket.
+ This of course gives you the URL to create tickets *in this queue*.
+ Importantly, if your user does *not* have the CreateTicket permission in
+ this queue, then REST2 would simply not include this hyperlink in its
+ response to your request. This allows you to dynamically adapt your
+ client's behavior to its presence or absence, just like the web version
+ of RT does.
+
+ Creating Tickets
+ Let's use the _url from the create hyperlink with type ticket.
+
+ To create a ticket is a bit more involved, since it requires providing a
+ different HTTP verb (POST instead of GET), a Content-Type header (to
+ tell REST2 that your content is JSON instead of, say, XML), and the
+ fields for your new ticket such as Subject. Here is the curl invocation,
+ wrapped to multiple lines for readability.
+
+ curl -X POST
+ -H "Content-Type: application/json"
+ -d '{ "Subject": "hello world" }'
+ -H 'Authorization: token XX_TOKEN_XX'
+ 'XX_TICKET_CREATE_URL_XX'
+
+ If successful, that will provide output like so:
- A POST request to a resource endpoint, without a specific id/name, will
- create a new resource of that type. The request should have a JSON
- payload similar to the ones returned for existing resources.
+ {
+ "_url" : "XX_RT_URL_XX/REST/2.0/ticket/20",
+ "type" : "ticket",
+ "id" : "20"
+ }
- On success, the return status is 201 Created and a Location header
- points to the new resource uri. On failure, the status code indicates
- the nature of the issue, and a descriptive message is in the response
- body.
+ (REST2 also produces the status code of 201 Created with a Location
+ header of the new ticket, which you may choose to use instead of the
+ JSON response)
+
+ We can fetch that _url to continue working with this newly-created
+ ticket. Request the ticket like so (make sure to include the -i flag to
+ see response's HTTP headers).
+
+ curl -i -H 'Authorization: token XX_TOKEN_XX' 'XX_TICKET_URL_XX'
+
+ You'll first see that there are many hyperlinks for tickets, including
+ one for each Lifecycle action you can perform, history, comment,
+ correspond, etc. Again these adapt to whether you have the appropriate
+ permissions to do these actions.
+
+ Additionally you'll see an ETag header for this record, which can be
+ used for conflict avoidance (<https://en.wikipedia.org/wiki/HTTP_ETag>).
+ We'll first try updating this ticket with an *invalid* ETag to see what
+ happens.
+
+ Updating Tickets
+ For updating tickets we use the PUT verb, but otherwise it looks much
+ like a ticket creation.
+
+ curl -X PUT
+ -H "Content-Type: application/json"
+ -H "If-Match: invalid-etag"
+ -d '{ "Subject": "trial update" }'
+ -H 'Authorization: token XX_TOKEN_XX'
+ 'XX_TICKET_URL_XX'
+
+ You'll get an error response like {"message":"Precondition Failed"} and
+ a status code of 412. If you examine the ticket, you'll also see that
+ its Subject was not changed. This is because the If-Match header advises
+ the server to make changes *if and only if* the ticket's ETag matches
+ what you provide. Since it differed, the server refused the request and
+ made no changes.
+
+ Now, try the same request by replacing the value "invalid-etag" in the
+ If-Match request header with the real ETag you'd received when you
+ requested the ticket previously. You'll then get a JSON response like:
+
+ ["Ticket 1: Subject changed from 'hello world' to 'trial update'"]
+
+ which is a list of messages meant for displaying to an end-user.
+
+ If you GET the ticket again, you'll observe that the ETag header now has
+ a different value, indicating that the ticket itself has changed. This
+ means if you were to retry the PUT update with the previous (at the
+ time, expected) ETag you would instead be rejected by the server with
+ Precondition Failed.
+
+ You can use ETag and If-Match headers to avoid race conditions such as
+ two people updating a ticket at the same time. Depending on the
+ sophistication of your client, you may be able to automatically retry
+ the change by incorporating the changes made on the server (for example
+ adding time worked can be automatically be recalculated).
+
+ You may of course choose to ignore the ETag header and not provide
+ If-Match in your requests; RT doesn't require its use.
+
+ Summary
+ RT's REST2 API provides the tools you need to build robust and dynamic
+ integrations. Tools like ETag/If-Match allow you to avoid conflicts such
+ as two people taking a ticket at the same time. Using JSON for all data
+ interchange avoids problems caused by parsing text. Hypermedia links
+ inform your client application of what the user has the ability to do.
+
+ Careful readers will see that, other than our initial entry into the
+ system, we did not *generate* any URLs. We only *followed* links, just
+ like you do when browsing a website on your computer. We've better
+ decoupled the client's implementation from the server's REST API.
+ Additionally, this system lets you be informed of new capabilities in
+ the form of additional hyperlinks.
+
+ Endpoints
+ Currently provided endpoints under /REST/2.0/ are described below.
+ Wherever possible please consider using _hyperlinks hypermedia controls
+ available in response bodies rather than hardcoding URLs.
- Searching
Tickets
GET /tickets?query=<TicketSQL>
+ search for tickets using TicketSQL
+
GET /tickets?simple=1;query=<simple search query>
+ search for tickets using simple search syntax
+
POST /tickets
- With the 'query' and optional 'simple' parameters
+ search for tickets with the 'query' and optional 'simple' parameters
- The query parameter expects TicketSQL by default unless a true value is
- sent for the simple parameter.
+ POST /ticket
+ create a ticket; provide JSON content
- Results are returned in the format described below.
+ GET /ticket/:id
+ retrieve a ticket
+
+ PUT /ticket/:id
+ update a ticket's metadata; provide JSON content
+
+ DELETE /ticket/:id
+ set status to deleted
+
+ POST /ticket/:id/correspond
+ POST /ticket/:id/comment
+ add a reply or comment to the ticket
- Queues and users
+ GET /ticket/:id/history
+ retrieve list of transactions for ticket
+
+ Transactions
+ GET /transactions?query=<JSON>
+ POST /transactions
+ search for transactions using L</JSON searches> syntax
+
+ GET /ticket/:id/history
+ GET /queue/:id/history
+ GET /queue/:name/history
+ GET /asset/:id/history
+ GET /user/:id/history
+ GET /user/:name/history
+ GET /group/:id/history
+ get transactions for record
+
+ GET /transaction/:id
+ retrieve a transaction
+
+ Attachments and Messages
+ GET /attachments?query=<JSON>
+ POST /attachments
+ search for attachments using L</JSON searches> syntax
+
+ GET /transaction/:id/attachments
+ get attachments for transaction
+
+ GET /attachment/:id
+ retrieve an attachment
+
+ Queues
+ GET /queues/all
+ retrieve list of all queues you can see
+
+ GET /queues?query=<JSON>
POST /queues
+ search for queues using L</JSON searches> syntax
+
+ POST /queue
+ create a queue; provide JSON content
+
+ GET /queue/:id
+ GET /queue/:name
+ retrieve a queue by numeric id or name
+
+ PUT /queue/:id
+ PUT /queue/:name
+ update a queue's metadata; provide JSON content
+
+ DELETE /queue/:id
+ DELETE /queue/:name
+ disable queue
+
+ GET /queue/:id/history
+ GET /queue/:name/history
+ retrieve list of transactions for queue
+
+ Assets
+ GET /assets?query=<JSON>
+ POST /assets
+ search for assets using L</JSON searches> syntax
+
+ POST /asset
+ create an asset; provide JSON content
+
+ GET /asset/:id
+ retrieve an asset
+
+ PUT /asset/:id
+ update an asset's metadata; provide JSON content
+
+ DELETE /asset/:id
+ set status to deleted
+
+ GET /asset/:id/history
+ retrieve list of transactions for asset
+
+ Catalogs
+ GET /catalogs/all
+ retrieve list of all catalogs you can see
+
+ GET /catalogs?query=<JSON>
+ POST /catalogs
+ search for catalogs using L</JSON searches> syntax
+
+ POST /catalog
+ create a catalog; provide JSON content
+
+ GET /catalog/:id
+ GET /catalog/:name
+ retrieve a catalog by numeric id or name
+
+ PUT /catalog/:id
+ PUT /catalog/:name
+ update a catalog's metadata; provide JSON content
+
+ DELETE /catalog/:id
+ DELETE /catalog/:name
+ disable catalog
+
+ Users
+ GET /users?query=<JSON>
POST /users
+ search for users using L</JSON searches> syntax
+
+ POST /user
+ create a user; provide JSON content
- These resources accept a basic JSON structure as the search conditions
+ GET /user/:id
+ GET /user/:name
+ retrieve a user by numeric id or username
+
+ PUT /user/:id
+ PUT /user/:name
+ update a user's metadata; provide JSON content
+
+ DELETE /user/:id
+ DELETE /user/:name
+ disable user
+
+ GET /user/:id/history
+ GET /user/:name/history
+ retrieve list of transactions for user
+
+ Groups
+ GET /groups?query=<JSON>
+ POST /groups
+ search for groups using L</JSON searches> syntax
+
+ GET /group/:id
+ retrieve a group (including its members)
+
+ GET /group/:id/history
+ retrieve list of transactions for group
+
+ Custom Fields
+ GET /customfields?query=<JSON>
+ POST /customfields
+ search for custom fields using L</JSON searches> syntax
+
+ GET /customfield/:id
+ retrieve a custom field
+
+ Custom Roles
+ GET /customroles?query=<JSON>
+ POST /customroles
+ search for custom roles using L</JSON searches> syntax
+
+ GET /customrole/:id
+ retrieve a custom role
+
+ Miscellaneous
+ GET /
+ produces this documentation
+
+ GET /rt
+ produces system information
+
+ JSON searches
+ Some resources accept a basic JSON structure as the search conditions
which specifies one or more fields to limit on (using specified
operators and values). An example:
@@ -123,24 +443,54 @@ USAGE
items, but it may be increased up to 100 (or decreased if desired). Page
numbers start at 1.
- Authentication
- Authentication is limited to internal RT usernames and passwords,
- provided via HTTP Basic auth. Most HTTP libraries already have a way of
- providing basic auth credentials when making requests. Using curl, for
- example:
+ Authentication Methods
+ Authentication should always be done over HTTPS/SSL for security. You
+ should only serve up the /REST/2.0/ endpoint over SSL.
+
+ Basic Auth
+ Authentication may use internal RT usernames and passwords, provided via
+ HTTP Basic auth. Most HTTP libraries already have a way of providing
+ basic auth credentials when making requests. Using curl, for example:
+
+ curl -u 'username:password' /path/to/REST/2.0
+
+ Token Auth
+ You may use the RT::Authen::Token extension to authenticate to the REST
+ 2 API. Once you've acquired an authentication token in the web
+ interface, specify the Authorization header with a value of "token" like
+ so:
+
+ curl -H 'Authorization: token …' /path/to/REST/2.0
+
+ If the library or application you're using does not support specifying
+ additional HTTP headers, you may also pass the authentication token as a
+ query parameter like so:
- curl -u username:password …
+ curl /path/to/REST/2.0?token=…
- This sort of authentication should always be done over HTTPS/SSL for
- security. You should only serve up the /REST/2.0/ endpoint over SSL.
+ Cookie Auth
+ Finally, you may reuse an existing cookie from an ordinary web session
+ to authenticate against REST2. This is primarily intended for
+ interacting with REST2 via JavaScript in the browser. Other REST
+ consumers are advised to use the alternatives above.
- Conditional requests (If-Modified-Since)
+ Conditional requests (If-Modified-Since, If-Match)
You can take advantage of the Last-Modified headers returned by most
single resource endpoints. Add a If-Modified-Since header to your
requests for the same resource, using the most recent Last-Modified
value seen, and the API may respond with a 304 Not Modified. You can
also use HEAD requests to check for updates without receiving the actual
- content when there is a newer version.
+ content when there is a newer version. You may also add an
+ If-Unmodified-Since header to your updates to tell the server to refuse
+ updates if the record had been changed since you last retrieved it.
+
+ ETag, If-Match, and If-None-Match work similarly to Last-Modified,
+ If-Modified-Since, and If-Unmodified-Since, except that they don't use a
+ timestamp, which has its own set of tradeoffs. ETag is an opaque value,
+ so it has no meaning to consumers (unlike timestamps). However,
+ timestamps have the disadvantage of having a resolution of seconds, so
+ two updates happening in the same second would produce incorrect
+ results, whereas ETag does not suffer from that problem.
Status codes
The REST API uses the full range of HTTP status codes, and your client
@@ -157,7 +507,8 @@ BUGS
<http://rt.cpan.org/Public/Dist/Display.html?Name=RT-Extension-REST2>.
LICENSE AND COPYRIGHT
- This software is Copyright (c) 2015 by Best Practical Solutions, LLC.
+ This software is Copyright (c) 2015-2017 by Best Practical Solutions,
+ LLC.
This is free software, licensed under:
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index f44ab4d..07525c5 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -31,7 +31,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '1.16';
+ $VERSION = '1.18';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -244,6 +244,8 @@ sub new {
}
return $args{_self} if $args{_self};
+ $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS';
+
$args{dispatch} ||= 'Admin';
$args{prefix} ||= 'inc';
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
@@ -322,7 +324,7 @@ sub find_extensions {
my ($self, $path) = @_;
my @found;
- File::Find::find( sub {
+ File::Find::find( {no_chdir => 1, wanted => sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
@@ -336,7 +338,7 @@ sub find_extensions {
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
- my $content = Module::Install::_read($subpath . '.pm');
+ my $content = Module::Install::_read($File::Find::name);
my $in_pod = 0;
foreach ( split /\n/, $content ) {
$in_pod = 1 if /^=\w/;
@@ -351,7 +353,7 @@ sub find_extensions {
}
push @found, [ $file, $pkg ];
- }, $path ) if -d $path;
+ }}, $path ) if -d $path;
@found;
}
@@ -373,8 +375,6 @@ sub _caller {
return $call;
}
-# Done in evals to avoid confusing Perl::MinimumVersion
-eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
@@ -383,16 +383,6 @@ sub _read {
close FH or die "close($_[0]): $!";
return $string;
}
-END_NEW
-sub _read {
- local *FH;
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
- binmode FH;
- my $string = do { local $/; <FH> };
- close FH or die "close($_[0]): $!";
- return $string;
-}
-END_OLD
sub _readperl {
my $string = Module::Install::_read($_[0]);
@@ -413,8 +403,6 @@ sub _readpod {
return $string;
}
-# Done in evals to avoid confusing Perl::MinimumVersion
-eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
@@ -424,17 +412,6 @@ sub _write {
}
close FH or die "close($_[0]): $!";
}
-END_NEW
-sub _write {
- local *FH;
- open( FH, "> $_[0]" ) or die "open($_[0]): $!";
- binmode FH;
- foreach ( 1 .. $#_ ) {
- print FH $_[$_] or die "print($_[0]): $!";
- }
- close FH or die "close($_[0]): $!";
-}
-END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index 5762a74..b61d424 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.16';
+ $VERSION = '1.18';
}
# Suspend handler for "redefined" warnings
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index d859276..1de368c 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -8,7 +8,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.16';
+ $VERSION = '1.18';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -121,6 +121,15 @@ END_C
# Can we locate a (the) C compiler
sub can_cc {
my $self = shift;
+
+ if ($^O eq 'VMS') {
+ require ExtUtils::CBuilder;
+ my $builder = ExtUtils::CBuilder->new(
+ quiet => 1,
+ );
+ return $builder->have_compiler;
+ }
+
my @chunks = split(/ /, $Config::Config{cc}) or return;
# $Config{cc} may contain args; try to find out the program part
@@ -151,4 +160,4 @@ if ( $^O eq 'cygwin' ) {
__END__
-#line 236
+#line 245
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index 41d3517..54b52cb 100644
--- a/inc/Module/Install/Fetch.pm
+++ b/inc/Module/Install/Fetch.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.16';
+ $VERSION = '1.18';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 2eb1d1f..087da8d 100644
--- a/inc/Module/Install/Include.pm
+++ b/inc/Module/Install/Include.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.16';
+ $VERSION = '1.18';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index e9918d2..8ba3d88 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.16';
+ $VERSION = '1.18';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index 9792685..692ce71 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.16';
+ $VERSION = '1.18';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index 80538d3..3268e7e 100644
--- a/inc/Module/Install/RTx.pm
+++ b/inc/Module/Install/RTx.pm
@@ -8,7 +8,7 @@ no warnings 'once';
use Module::Install::Base;
use base 'Module::Install::Base';
-our $VERSION = '0.38';
+our $VERSION = '0.39';
use FindBin;
use File::Glob ();
@@ -113,11 +113,29 @@ lexicons ::
.
}
+ my $remove_files;
+ if( $extra_args->{'remove_files'} ){
+ $self->include('Module::Install::RTx::Remove');
+ our @remove_files;
+ eval { require "etc/upgrade/remove_files" }
+ or print "No remove file located, no files to remove\n";
+ $remove_files = join ",", map {"q(\$(DESTDIR)$plugin_path/$name/$_)"} @remove_files;
+ }
+
$self->include('Module::Install::RTx::Runtime') if $self->admin;
$self->include_deps( 'YAML::Tiny', 0 ) if $self->admin;
my $postamble = << ".";
install ::
\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Iinc -MModule::Install::RTx::Runtime -e"RTxPlugin()"
+.
+
+ if( $remove_files ){
+ $postamble .= << ".";
+\t\$(NOECHO) \$(PERL) -MModule::Install::RTx::Remove -e \"RTxRemove([$remove_files])\"
+.
+ }
+
+ $postamble .= << ".";
\t\$(NOECHO) \$(PERL) -MExtUtils::Install -e \"install({$args})\"
.
@@ -279,4 +297,4 @@ sub _load_rt_handle {
__END__
-#line 428
+#line 468
diff --git a/inc/Module/Install/ReadmeFromPod.pm b/inc/Module/Install/ReadmeFromPod.pm
index 3634ee0..3738232 100644
--- a/inc/Module/Install/ReadmeFromPod.pm
+++ b/inc/Module/Install/ReadmeFromPod.pm
@@ -7,7 +7,7 @@ use warnings;
use base qw(Module::Install::Base);
use vars qw($VERSION);
-$VERSION = '0.26';
+$VERSION = '0.30';
{
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index 218a66b..b80c900 100644
--- a/inc/Module/Install/Win32.pm
+++ b/inc/Module/Install/Win32.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.16';
+ $VERSION = '1.18';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index 530749b..da279c7 100644
--- a/inc/Module/Install/WriteAll.pm
+++ b/inc/Module/Install/WriteAll.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.16';
+ $VERSION = '1.18';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
diff --git a/inc/YAML/Tiny.pm b/inc/YAML/Tiny.pm
index aa539f7..9a4e291 100644
--- a/inc/YAML/Tiny.pm
+++ b/inc/YAML/Tiny.pm
@@ -1,217 +1,105 @@
#line 1
-use 5.008001; # sane UTF-8 support
-use strict;
-use warnings;
-package YAML::Tiny; # git description: v1.68-2-gcc5324e
-# XXX-INGY is 5.8.1 too old/broken for utf8?
-# XXX-XDG Lancaster consensus was that it was sufficient until
-# proven otherwise
-
-our $VERSION = '1.69';
-
-#####################################################################
-# The YAML::Tiny API.
-#
-# These are the currently documented API functions/methods and
-# exports:
-
-use Exporter;
-our @ISA = qw{ Exporter };
-our @EXPORT = qw{ Load Dump };
-our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
-
-###
-# Functional/Export API:
-
-sub Dump {
- return YAML::Tiny->new(@_)->_dump_string;
-}
-
-# XXX-INGY Returning last document seems a bad behavior.
-# XXX-XDG I think first would seem more natural, but I don't know
-# that it's worth changing now
-sub Load {
- my $self = YAML::Tiny->_load_string(@_);
- if ( wantarray ) {
- return @$self;
- } else {
- # To match YAML.pm, return the last document
- return $self->[-1];
- }
-}
-
-# XXX-INGY Do we really need freeze and thaw?
-# XXX-XDG I don't think so. I'd support deprecating them.
+package YAML::Tiny;
BEGIN {
- *freeze = \&Dump;
- *thaw = \&Load;
+ $YAML::Tiny::AUTHORITY = 'cpan:ADAMK';
}
-
-sub DumpFile {
- my $file = shift;
- return YAML::Tiny->new(@_)->_dump_file($file);
+{
+ $YAML::Tiny::VERSION = '1.56';
}
+# git description: v1.55-3-gc945058
-sub LoadFile {
- my $file = shift;
- my $self = YAML::Tiny->_load_file($file);
- if ( wantarray ) {
- return @$self;
- } else {
- # Return only the last document to match YAML.pm,
- return $self->[-1];
- }
-}
-
-
-###
-# Object Oriented API:
-
-# Create an empty YAML::Tiny object
-# XXX-INGY Why do we use ARRAY object?
-# NOTE: I get it now, but I think it's confusing and not needed.
-# Will change it on a branch later, for review.
-#
-# XXX-XDG I don't support changing it yet. It's a very well-documented
-# "API" of YAML::Tiny. I'd support deprecating it, but Adam suggested
-# we not change it until YAML.pm's own OO API is established so that
-# users only have one API change to digest, not two
-sub new {
- my $class = shift;
- bless [ @_ ], $class;
-}
-# XXX-INGY It probably doesn't matter, and it's probably too late to
-# change, but 'read/write' are the wrong names. Read and Write
-# are actions that take data from storage to memory
-# characters/strings. These take the data to/from storage to native
-# Perl objects, which the terms dump and load are meant. As long as
-# this is a legacy quirk to YAML::Tiny it's ok, but I'd prefer not
-# to add new {read,write}_* methods to this API.
-
-sub read_string {
- my $self = shift;
- $self->_load_string(@_);
-}
+use strict;
+use warnings;
-sub write_string {
- my $self = shift;
- $self->_dump_string(@_);
-}
+# UTF Support?
+sub HAVE_UTF8 () { $] >= 5.007003 }
+BEGIN {
+ if ( HAVE_UTF8 ) {
+ # The string eval helps hide this from Test::MinimumVersion
+ eval "require utf8;";
+ die "Failed to load UTF-8 support" if $@;
+ }
-sub read {
- my $self = shift;
- $self->_load_file(@_);
-}
+ # Class structure
+ require 5.004;
+ require Exporter;
+ require Carp;
+ @YAML::Tiny::ISA = qw{ Exporter };
+ @YAML::Tiny::EXPORT = qw{ Load Dump };
+ @YAML::Tiny::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
-sub write {
- my $self = shift;
- $self->_dump_file(@_);
+ # Error storage
+ $YAML::Tiny::errstr = '';
}
-
-
-
-#####################################################################
-# Constants
+# The character class of all characters we need to escape
+# NOTE: Inlined, since it's only used once
+# my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';
# Printed form of the unprintable characters in the lowest range
# of ASCII characters, listed by ASCII ordinal position.
my @UNPRINTABLE = qw(
- 0 x01 x02 x03 x04 x05 x06 a
- b t n v f r x0E x0F
+ z x01 x02 x03 x04 x05 x06 a
+ x08 t n v f r x0e x0f
x10 x11 x12 x13 x14 x15 x16 x17
- x18 x19 x1A e x1C x1D x1E x1F
+ x18 x19 x1a e x1c x1d x1e x1f
);
# Printable characters for escapes
my %UNESCAPES = (
- 0 => "\x00", z => "\x00", N => "\x85",
- a => "\x07", b => "\x08", t => "\x09",
+ z => "\x00", a => "\x07", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
-# XXX-INGY
-# I(ngy) need to decide if these values should be quoted in
-# YAML::Tiny or not. Probably yes.
-
-# These 3 values have special meaning when unquoted and using the
-# default YAML schema. They need quotes if they are strings.
+# Special magic boolean words
my %QUOTE = map { $_ => 1 } qw{
- null true false
+ null Null NULL
+ y Y yes Yes YES n N no No NO
+ true True TRUE false False FALSE
+ on On ON off Off OFF
};
-# The commented out form is simpler, but overloaded the Perl regex
-# engine due to recursion and backtracking problems on strings
-# larger than 32,000ish characters. Keep it for reference purposes.
-# qr/\"((?:\\.|[^\"])*)\"/
-my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
-my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
-# unquoted re gets trailing space that needs to be stripped
-my $re_capture_unquoted_key = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
-my $re_trailing_comment = qr/(?:\s+\#.*)?/;
-my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/;
-
#####################################################################
-# YAML::Tiny Implementation.
-#
-# These are the private methods that do all the work. They may change
-# at any time.
-
+# Implementation
-###
-# Loader functions:
+# Create an empty YAML::Tiny object
+sub new {
+ my $class = shift;
+ bless [ @_ ], $class;
+}
# Create an object from a file
-sub _load_file {
+sub read {
my $class = ref $_[0] ? ref shift : shift;
# Check the file
- my $file = shift or $class->_error( 'You did not specify a file name' );
- $class->_error( "File '$file' does not exist" )
- unless -e $file;
- $class->_error( "'$file' is a directory, not a file" )
- unless -f _;
- $class->_error( "Insufficient permissions to read '$file'" )
- unless -r _;
-
- # Open unbuffered with strict UTF-8 decoding and no translation layers
- open( my $fh, "<:unix:encoding(UTF-8)", $file );
- unless ( $fh ) {
- $class->_error("Failed to open file '$file': $!");
- }
-
- # flock if available (or warn if not possible for OS-specific reasons)
- if ( _can_flock() ) {
- flock( $fh, Fcntl::LOCK_SH() )
- or warn "Couldn't lock '$file' for reading: $!";
- }
-
- # slurp the contents
- my $contents = eval {
- use warnings FATAL => 'utf8';
- local $/;
- <$fh>
- };
- if ( my $err = $@ ) {
- $class->_error("Error reading from file '$file': $err");
+ my $file = shift or return $class->_error( 'You did not specify a file name' );
+ return $class->_error( "File '$file' does not exist" ) unless -e $file;
+ return $class->_error( "'$file' is a directory, not a file" ) unless -f _;
+ return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
+
+ # Slurp in the file
+ local $/ = undef;
+ local *CFG;
+ unless ( open(CFG, $file) ) {
+ return $class->_error("Failed to open file '$file': $!");
}
-
- # close the file (release the lock)
- unless ( close $fh ) {
- $class->_error("Failed to close file '$file': $!");
+ my $contents = <CFG>;
+ unless ( close(CFG) ) {
+ return $class->_error("Failed to close file '$file': $!");
}
- $class->_load_string( $contents );
+ $class->read_string( $contents );
}
# Create an object from a string
-sub _load_string {
+sub read_string {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless [], $class;
my $string = $_[0];
@@ -220,23 +108,30 @@ sub _load_string {
die \"Did not provide a string to load";
}
- # Check if Perl has it marked as characters, but it's internally
- # inconsistent. E.g. maybe latin1 got read on a :utf8 layer
- if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
- die \<<'...';
-Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
-Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
-...
+ # Byte order marks
+ # NOTE: Keeping this here to educate maintainers
+ # my %BOM = (
+ # "\357\273\277" => 'UTF-8',
+ # "\376\377" => 'UTF-16BE',
+ # "\377\376" => 'UTF-16LE',
+ # "\377\376\0\0" => 'UTF-32LE'
+ # "\0\0\376\377" => 'UTF-32BE',
+ # );
+ if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
+ die \"Stream has a non UTF-8 BOM";
+ } else {
+ # Strip UTF-8 bom if found, we'll just ignore it
+ $string =~ s/^\357\273\277//;
}
- # Ensure Unicode character semantics, even for 0x80-0xff
- utf8::upgrade($string);
-
- # Check for and strip any leading UTF-8 BOM
- $string =~ s/^\x{FEFF}//;
+ # Try to decode as utf8
+ utf8::decode($string) if HAVE_UTF8;
# Check for some special cases
return $self unless length $string;
+ unless ( $string =~ /[\012\015]+\z/ ) {
+ die \"Stream does not end with newline character";
+ }
# Split the file into lines
my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
@@ -246,18 +141,15 @@ Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
# A nibbling parser
- my $in_document = 0;
while ( @lines ) {
# Do we have a document header?
if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
# Handle scalar documents
shift @lines;
if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
- push @$self,
- $self->_load_scalar( "$1", [ undef ], \@lines );
+ push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
next;
}
- $in_document = 1;
}
if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
@@ -266,65 +158,36 @@ Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
while ( @lines and $lines[0] !~ /^---/ ) {
shift @lines;
}
- $in_document = 0;
- # XXX The final '-+$' is to look for -- which ends up being an
- # error later.
- } elsif ( ! $in_document && @$self ) {
- # only the first document can be explicit
- die \"YAML::Tiny failed to classify the line '$lines[0]'";
- } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
+ } elsif ( $lines[0] =~ /^\s*\-/ ) {
# An array at the root
my $document = [ ];
push @$self, $document;
- $self->_load_array( $document, [ 0 ], \@lines );
+ $self->_read_array( $document, [ 0 ], \@lines );
} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
# A hash at the root
my $document = { };
push @$self, $document;
- $self->_load_hash( $document, [ length($1) ], \@lines );
+ $self->_read_hash( $document, [ length($1) ], \@lines );
} else {
- # Shouldn't get here. @lines have whitespace-only lines
- # stripped, and previous match is a line with any
- # non-whitespace. So this clause should only be reachable via
- # a perlbug where \s is not symmetric with \S
-
- # uncoverable statement
die \"YAML::Tiny failed to classify the line '$lines[0]'";
}
}
};
- my $err = $@;
- if ( ref $err eq 'SCALAR' ) {
- $self->_error(${$err});
- } elsif ( $err ) {
- $self->_error($err);
+ if ( ref $@ eq 'SCALAR' ) {
+ return $self->_error(${$@});
+ } elsif ( $@ ) {
+ require Carp;
+ Carp::croak($@);
}
return $self;
}
-sub _unquote_single {
- my ($self, $string) = @_;
- return '' unless length $string;
- $string =~ s/\'\'/\'/g;
- return $string;
-}
-
-sub _unquote_double {
- my ($self, $string) = @_;
- return '' unless length $string;
- $string =~ s/\\"/"/g;
- $string =~
- s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
- {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
- return $string;
-}
-
-# Load a YAML scalar string to the actual Perl scalar
-sub _load_scalar {
+# Deparse a scalar string to the actual scalar
+sub _read_scalar {
my ($self, $string, $indent, $lines) = @_;
# Trim trailing whitespace
@@ -334,13 +197,25 @@ sub _load_scalar {
return undef if $string eq '~';
# Single quote
- if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
- return $self->_unquote_single($1);
+ if ( $string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) {
+ return '' unless defined $1;
+ $string = $1;
+ $string =~ s/\'\'/\'/g;
+ return $string;
}
# Double quote.
- if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
- return $self->_unquote_double($1);
+ # The commented out form is simpler, but overloaded the Perl regex
+ # engine due to recursion and backtracking problems on strings
+ # larger than 32,000ish characters. Keep it for reference purposes.
+ # if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
+ if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/ ) {
+ # Reusing the variable is a little ugly,
+ # but avoids a new variable and a string copy.
+ $string = $1;
+ $string =~ s/\\"/"/g;
+ $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
+ return $string;
}
# Special cases
@@ -352,9 +227,13 @@ sub _load_scalar {
# Regular unquoted string
if ( $string !~ /^[>|]/ ) {
- die \"YAML::Tiny found illegal characters in plain scalar: '$string'"
- if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
- $string =~ /:(?:\s|$)/;
+ if (
+ $string =~ /^(?:-(?:\s|$)|[\@\%\`])/
+ or
+ $string =~ /:(?:\s|$)/
+ ) {
+ die \"YAML::Tiny found illegal characters in plain scalar: '$string'";
+ }
$string =~ s/\s+#.*\z//;
return $string;
}
@@ -382,8 +261,8 @@ sub _load_scalar {
return join( $j, @multiline ) . $t;
}
-# Load an array
-sub _load_array {
+# Parse an array
+sub _read_array {
my ($self, $array, $indent, $lines) = @_;
while ( @$lines ) {
@@ -408,7 +287,12 @@ sub _load_array {
my $indent2 = length("$1");
$lines->[0] =~ s/-/ /;
push @$array, { };
- $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
+ $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
+ # Array entry with a value
+ shift @$lines;
+ push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );
} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
shift @$lines;
@@ -424,28 +308,17 @@ sub _load_array {
} else {
# Naked indenter
push @$array, [ ];
- $self->_load_array(
- $array->[-1], [ @$indent, $indent2 ], $lines
- );
+ $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
}
} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
push @$array, { };
- $self->_load_hash(
- $array->[-1], [ @$indent, length("$1") ], $lines
- );
+ $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
} else {
die \"YAML::Tiny failed to classify line '$lines->[0]'";
}
- } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
- # Array entry with a value
- shift @$lines;
- push @$array, $self->_load_scalar(
- "$2", [ @$indent, undef ], $lines
- );
-
} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
# This is probably a structure like the following...
# ---
@@ -464,8 +337,8 @@ sub _load_array {
return 1;
}
-# Load a hash
-sub _load_hash {
+# Parse an array
+sub _read_hash {
my ($self, $hash, $indent, $lines) = @_;
while ( @$lines ) {
@@ -485,43 +358,19 @@ sub _load_hash {
die \"YAML::Tiny found bad indenting in line '$lines->[0]'";
}
- # Find the key
- my $key;
-
- # Quoted keys
- if ( $lines->[0] =~
- s/^\s*$re_capture_single_quoted$re_key_value_separator//
- ) {
- $key = $self->_unquote_single($1);
- }
- elsif ( $lines->[0] =~
- s/^\s*$re_capture_double_quoted$re_key_value_separator//
- ) {
- $key = $self->_unquote_double($1);
- }
- elsif ( $lines->[0] =~
- s/^\s*$re_capture_unquoted_key$re_key_value_separator//
- ) {
- $key = $1;
- $key =~ s/\s+$//;
- }
- elsif ( $lines->[0] =~ /^\s*\?/ ) {
- die \"YAML::Tiny does not support a feature in line '$lines->[0]'";
- }
- else {
+ # Get the key
+ unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+(?:\#.*)?|$)// ) {
+ if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
+ die \"YAML::Tiny does not support a feature in line '$lines->[0]'";
+ }
die \"YAML::Tiny failed to classify line '$lines->[0]'";
}
-
- if ( exists $hash->{$key} ) {
- warn "YAML::Tiny found a duplicate key '$key' in line '$lines->[0]'";
- }
+ my $key = $1;
# Do we have a value?
if ( length $lines->[0] ) {
# Yes
- $hash->{$key} = $self->_load_scalar(
- shift(@$lines), [ @$indent, undef ], $lines
- );
+ $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
} else {
# An indent
shift @$lines;
@@ -531,9 +380,7 @@ sub _load_hash {
}
if ( $lines->[0] =~ /^(\s*)-/ ) {
$hash->{$key} = [];
- $self->_load_array(
- $hash->{$key}, [ @$indent, length($1) ], $lines
- );
+ $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
} elsif ( $lines->[0] =~ /^(\s*)./ ) {
my $indent2 = length("$1");
if ( $indent->[-1] >= $indent2 ) {
@@ -541,9 +388,7 @@ sub _load_hash {
$hash->{$key} = undef;
} else {
$hash->{$key} = {};
- $self->_load_hash(
- $hash->{$key}, [ @$indent, length($1) ], $lines
- );
+ $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
}
}
}
@@ -552,161 +397,98 @@ sub _load_hash {
return 1;
}
-
-###
-# Dumper functions:
-
# Save an object to a file
-sub _dump_file {
+sub write {
my $self = shift;
+ my $file = shift or return $self->_error('No file name provided');
- require Fcntl;
-
- # Check the file
- my $file = shift or $self->_error( 'You did not specify a file name' );
-
- my $fh;
- # flock if available (or warn if not possible for OS-specific reasons)
- if ( _can_flock() ) {
- # Open without truncation (truncate comes after lock)
- my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
- sysopen( $fh, $file, $flags );
- unless ( $fh ) {
- $self->_error("Failed to open file '$file' for writing: $!");
- }
-
- # Use no translation and strict UTF-8
- binmode( $fh, ":raw:encoding(UTF-8)");
-
- flock( $fh, Fcntl::LOCK_EX() )
- or warn "Couldn't lock '$file' for reading: $!";
-
- # truncate and spew contents
- truncate $fh, 0;
- seek $fh, 0, 0;
- }
- else {
- open $fh, ">:unix:encoding(UTF-8)", $file;
- }
-
- # serialize and spew to the handle
- print {$fh} $self->_dump_string;
-
- # close the file (release the lock)
- unless ( close $fh ) {
- $self->_error("Failed to close file '$file': $!");
- }
+ # Write it to the file
+ open( CFG, '>' . $file ) or return $self->_error(
+ "Failed to open file '$file' for writing: $!"
+ );
+ print CFG $self->write_string;
+ close CFG;
return 1;
}
# Save an object to a string
-sub _dump_string {
+sub write_string {
my $self = shift;
- return '' unless ref $self && @$self;
+ return '' unless @$self;
# Iterate over the documents
my $indent = 0;
my @lines = ();
+ foreach my $cursor ( @$self ) {
+ push @lines, '---';
+
+ # An empty document
+ if ( ! defined $cursor ) {
+ # Do nothing
+
+ # A scalar document
+ } elsif ( ! ref $cursor ) {
+ $lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );
+
+ # A list at the root
+ } elsif ( ref $cursor eq 'ARRAY' ) {
+ unless ( @$cursor ) {
+ $lines[-1] .= ' []';
+ next;
+ }
+ push @lines, $self->_write_array( $cursor, $indent, {} );
- eval {
- foreach my $cursor ( @$self ) {
- push @lines, '---';
-
- # An empty document
- if ( ! defined $cursor ) {
- # Do nothing
-
- # A scalar document
- } elsif ( ! ref $cursor ) {
- $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
-
- # A list at the root
- } elsif ( ref $cursor eq 'ARRAY' ) {
- unless ( @$cursor ) {
- $lines[-1] .= ' []';
- next;
- }
- push @lines, $self->_dump_array( $cursor, $indent, {} );
-
- # A hash at the root
- } elsif ( ref $cursor eq 'HASH' ) {
- unless ( %$cursor ) {
- $lines[-1] .= ' {}';
- next;
- }
- push @lines, $self->_dump_hash( $cursor, $indent, {} );
-
- } else {
- die \("Cannot serialize " . ref($cursor));
+ # A hash at the root
+ } elsif ( ref $cursor eq 'HASH' ) {
+ unless ( %$cursor ) {
+ $lines[-1] .= ' {}';
+ next;
}
+ push @lines, $self->_write_hash( $cursor, $indent, {} );
+
+ } else {
+ Carp::croak("Cannot serialize " . ref($cursor));
}
- };
- if ( ref $@ eq 'SCALAR' ) {
- $self->_error(${$@});
- } elsif ( $@ ) {
- $self->_error($@);
}
join '', map { "$_\n" } @lines;
}
-sub _has_internal_string_value {
- my $value = shift;
- my $b_obj = B::svref_2object(\$value); # for round trip problem
- return $b_obj->FLAGS & B::SVf_POK();
-}
-
-sub _dump_scalar {
+sub _write_scalar {
my $string = $_[1];
- my $is_key = $_[2];
- # Check this before checking length or it winds up looking like a string!
- my $has_string_flag = _has_internal_string_value($string);
return '~' unless defined $string;
return "''" unless length $string;
- if (Scalar::Util::looks_like_number($string)) {
- # keys and values that have been used as strings get quoted
- if ( $is_key || $has_string_flag ) {
- return qq['$string'];
- }
- else {
- return $string;
- }
- }
- if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
+ if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
$string =~ s/\\/\\\\/g;
$string =~ s/"/\\"/g;
$string =~ s/\n/\\n/g;
- $string =~ s/[\x85]/\\N/g;
$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
- $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
return qq|"$string"|;
}
- if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
- $QUOTE{$string}
- ) {
+ if ( $string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string} ) {
return "'$string'";
}
return $string;
}
-sub _dump_array {
+sub _write_array {
my ($self, $array, $indent, $seen) = @_;
if ( $seen->{refaddr($array)}++ ) {
- die \"YAML::Tiny does not support circular references";
+ die "YAML::Tiny does not support circular references";
}
my @lines = ();
foreach my $el ( @$array ) {
my $line = (' ' x $indent) . '-';
my $type = ref $el;
if ( ! $type ) {
- $line .= ' ' . $self->_dump_scalar( $el );
+ $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
- push @lines, $self->_dump_array( $el, $indent + 1, $seen );
+ push @lines, $self->_write_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
@@ -715,38 +497,38 @@ sub _dump_array {
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
- push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
+ push @lines, $self->_write_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
- die \"YAML::Tiny does not support $type references";
+ die "YAML::Tiny does not support $type references";
}
}
@lines;
}
-sub _dump_hash {
+sub _write_hash {
my ($self, $hash, $indent, $seen) = @_;
if ( $seen->{refaddr($hash)}++ ) {
- die \"YAML::Tiny does not support circular references";
+ die "YAML::Tiny does not support circular references";
}
my @lines = ();
foreach my $name ( sort keys %$hash ) {
my $el = $hash->{$name};
- my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":";
+ my $line = (' ' x $indent) . "$name:";
my $type = ref $el;
if ( ! $type ) {
- $line .= ' ' . $self->_dump_scalar( $el );
+ $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
- push @lines, $self->_dump_array( $el, $indent + 1, $seen );
+ push @lines, $self->_write_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
@@ -755,87 +537,92 @@ sub _dump_hash {
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
- push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
+ push @lines, $self->_write_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
- die \"YAML::Tiny does not support $type references";
+ die "YAML::Tiny does not support $type references";
}
}
@lines;
}
-
-
-#####################################################################
-# DEPRECATED API methods:
-
-# Error storage (DEPRECATED as of 1.57)
-our $errstr = '';
-
# Set error
sub _error {
- require Carp;
- $errstr = $_[1];
- $errstr =~ s/ at \S+ line \d+.*//;
- Carp::croak( $errstr );
+ $YAML::Tiny::errstr = $_[1];
+ undef;
}
# Retrieve error
-my $errstr_warned;
sub errstr {
- require Carp;
- Carp::carp( "YAML::Tiny->errstr and \$YAML::Tiny::errstr is deprecated" )
- unless $errstr_warned++;
- $errstr;
+ $YAML::Tiny::errstr;
}
+
#####################################################################
-# Helper functions. Possibly not needed.
+# YAML Compatibility
+
+sub Dump {
+ YAML::Tiny->new(@_)->write_string;
+}
+
+sub Load {
+ my $self = YAML::Tiny->read_string(@_);
+ unless ( $self ) {
+ Carp::croak("Failed to load YAML document from string");
+ }
+ if ( wantarray ) {
+ return @$self;
+ } else {
+ # To match YAML.pm, return the last document
+ return $self->[-1];
+ }
+}
+BEGIN {
+ *freeze = *Dump;
+ *thaw = *Load;
+}
-# Use to detect nv or iv
-use B;
+sub DumpFile {
+ my $file = shift;
+ YAML::Tiny->new(@_)->write($file);
+}
-# XXX-INGY Is flock YAML::Tiny's responsibility?
-# Some platforms can't flock :-(
-# XXX-XDG I think it is. When reading and writing files, we ought
-# to be locking whenever possible. People (foolishly) use YAML
-# files for things like session storage, which has race issues.
-my $HAS_FLOCK;
-sub _can_flock {
- if ( defined $HAS_FLOCK ) {
- return $HAS_FLOCK;
+sub LoadFile {
+ my $self = YAML::Tiny->read($_[0]);
+ unless ( $self ) {
+ Carp::croak("Failed to load YAML document from '" . ($_[0] || '') . "'");
}
- else {
- require Config;
- my $c = \%Config::Config;
- $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
- require Fcntl if $HAS_FLOCK;
- return $HAS_FLOCK;
+ if ( wantarray ) {
+ return @$self;
+ } else {
+ # Return only the last document to match YAML.pm,
+ return $self->[-1];
}
}
-# XXX-INGY Is this core in 5.8.1? Can we remove this?
-# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
+
+
+
#####################################################################
# Use Scalar::Util if possible, otherwise emulate it
-use Scalar::Util ();
BEGIN {
local $@;
- if ( eval { Scalar::Util->VERSION(1.18); } ) {
- *refaddr = *Scalar::Util::refaddr;
- }
- else {
+ eval {
+ require Scalar::Util;
+ };
+ my $v = eval("$Scalar::Util::VERSION") || 0;
+ if ( $@ or $v < 1.18 ) {
eval <<'END_PERL';
# Scalar::Util failed to load or too old
sub refaddr {
@@ -846,29 +633,18 @@ sub refaddr {
$pkg = undef;
}
"$_[0]" =~ /0x(\w+)/;
- my $i = do { no warnings 'portable'; hex $1 };
+ my $i = do { local $^W; hex $1 };
bless $_[0], $pkg if defined $pkg;
$i;
}
END_PERL
+ } else {
+ *refaddr = *Scalar::Util::refaddr;
}
}
-delete $YAML::Tiny::{refaddr};
-
1;
-# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
-# but leaving grey area stuff up here.
-#
-# I would like to change Read/Write to Load/Dump below without
-# changing the actual API names.
-#
-# It might be better to put Load/Dump API in the SYNOPSIS instead of the
-# dubious OO API.
-#
-# null and bool explanations may be outdated.
-
__END__
-#line 1489
+#line 1223
diff --git a/inc/unicore/Name.pm b/inc/unicore/Name.pm
new file mode 100644
index 0000000..15e729b
--- /dev/null
+++ b/inc/unicore/Name.pm
@@ -0,0 +1,416 @@
+#line 1
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is machine-generated by lib/unicore/mktables from the Unicode
+# database, Version 6.2.0. Any changes made here will be lost!
+
+
+# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
+# This file is for internal use by core Perl only. The format and even the
+# name or existence of this file are subject to change without notice. Don't
+# use it directly.
+
+
+package charnames;
+
+# This module contains machine-generated tables and code for the
+# algorithmically-determinable Unicode character names. The following
+# routines can be used to translate between name and code point and vice versa
+
+{ # Closure
+
+ # Matches legal code point. 4-6 hex numbers, If there are 6, the first
+ # two must be 10; if there are 5, the first must not be a 0. Written this
+ # way to decrease backtracking. The first regex allows the code point to
+ # be at the end of a word, but to work properly, the word shouldn't end
+ # with a valid hex character. The second one won't match a code point at
+ # the end of a word, and doesn't have the run-on issue
+ my $run_on_code_point_re = qr/(?^aax: (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b)/;
+ my $code_point_re = qr/(?^aa:\b(?^aax: (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b))/;
+
+ # In the following hash, the keys are the bases of names which include
+ # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The value
+ # of each key is another hash which is used to get the low and high ends
+ # for each range of code points that apply to the name.
+ my %names_ending_in_code_point = (
+'CJK COMPATIBILITY IDEOGRAPH' =>
+{
+'high' =>
+[
+64109,
+64217,
+195101,
+],
+'low' =>
+[
+63744,
+64112,
+194560,
+],
+},
+'CJK UNIFIED IDEOGRAPH' =>
+{
+'high' =>
+[
+19893,
+40908,
+173782,
+177972,
+178205,
+],
+'low' =>
+[
+13312,
+19968,
+131072,
+173824,
+177984,
+],
+},
+
+ );
+
+ # The following hash is a copy of the previous one, except is for loose
+ # matching, so each name has blanks and dashes squeezed out
+ my %loose_names_ending_in_code_point = (
+'CJKCOMPATIBILITYIDEOGRAPH' =>
+{
+'high' =>
+[
+64109,
+64217,
+195101,
+],
+'low' =>
+[
+63744,
+64112,
+194560,
+],
+},
+'CJKUNIFIEDIDEOGRAPH' =>
+{
+'high' =>
+[
+19893,
+40908,
+173782,
+177972,
+178205,
+],
+'low' =>
+[
+13312,
+19968,
+131072,
+173824,
+177984,
+],
+},
+
+ );
+
+ # And the following array gives the inverse mapping from code points to
+ # names. Lowest code points are first
+ my @code_points_ending_in_code_point = (
+
+{
+'high' => 19893,
+'low' => 13312,
+'name' => 'CJK UNIFIED IDEOGRAPH',
+},
+{
+'high' => 40908,
+'low' => 19968,
+'name' => 'CJK UNIFIED IDEOGRAPH',
+},
+{
+'high' => 64109,
+'low' => 63744,
+'name' => 'CJK COMPATIBILITY IDEOGRAPH',
+},
+{
+'high' => 64217,
+'low' => 64112,
+'name' => 'CJK COMPATIBILITY IDEOGRAPH',
+},
+{
+'high' => 173782,
+'low' => 131072,
+'name' => 'CJK UNIFIED IDEOGRAPH',
+},
+{
+'high' => 177972,
+'low' => 173824,
+'name' => 'CJK UNIFIED IDEOGRAPH',
+},
+{
+'high' => 178205,
+'low' => 177984,
+'name' => 'CJK UNIFIED IDEOGRAPH',
+},
+{
+'high' => 195101,
+'low' => 194560,
+'name' => 'CJK COMPATIBILITY IDEOGRAPH',
+},
+,
+
+ );
+
+ # Convert from code point to Jamo short name for use in composing Hangul
+ # syllable names
+ my %Jamo = (
+4352 => 'G',
+4353 => 'GG',
+4354 => 'N',
+4355 => 'D',
+4356 => 'DD',
+4357 => 'R',
+4358 => 'M',
+4359 => 'B',
+4360 => 'BB',
+4361 => 'S',
+4362 => 'SS',
+4363 => '',
+4364 => 'J',
+4365 => 'JJ',
+4366 => 'C',
+4367 => 'K',
+4368 => 'T',
+4369 => 'P',
+4370 => 'H',
+4449 => 'A',
+4450 => 'AE',
+4451 => 'YA',
+4452 => 'YAE',
+4453 => 'EO',
+4454 => 'E',
+4455 => 'YEO',
+4456 => 'YE',
+4457 => 'O',
+4458 => 'WA',
+4459 => 'WAE',
+4460 => 'OE',
+4461 => 'YO',
+4462 => 'U',
+4463 => 'WEO',
+4464 => 'WE',
+4465 => 'WI',
+4466 => 'YU',
+4467 => 'EU',
+4468 => 'YI',
+4469 => 'I',
+4520 => 'G',
+4521 => 'GG',
+4522 => 'GS',
+4523 => 'N',
+4524 => 'NJ',
+4525 => 'NH',
+4526 => 'D',
+4527 => 'L',
+4528 => 'LG',
+4529 => 'LM',
+4530 => 'LB',
+4531 => 'LS',
+4532 => 'LT',
+4533 => 'LP',
+4534 => 'LH',
+4535 => 'M',
+4536 => 'B',
+4537 => 'BS',
+4538 => 'S',
+4539 => 'SS',
+4540 => 'NG',
+4541 => 'J',
+4542 => 'C',
+4543 => 'K',
+4544 => 'T',
+4545 => 'P',
+4546 => 'H',
+
+ );
+
+ # Leading consonant (can be null)
+ my %Jamo_L = (
+'' => 11,
+'B' => 7,
+'BB' => 8,
+'C' => 14,
+'D' => 3,
+'DD' => 4,
+'G' => 0,
+'GG' => 1,
+'H' => 18,
+'J' => 12,
+'JJ' => 13,
+'K' => 15,
+'M' => 6,
+'N' => 2,
+'P' => 17,
+'R' => 5,
+'S' => 9,
+'SS' => 10,
+'T' => 16,
+
+ );
+
+ # Vowel
+ my %Jamo_V = (
+'A' => 0,
+'AE' => 1,
+'E' => 5,
+'EO' => 4,
+'EU' => 18,
+'I' => 20,
+'O' => 8,
+'OE' => 11,
+'U' => 13,
+'WA' => 9,
+'WAE' => 10,
+'WE' => 15,
+'WEO' => 14,
+'WI' => 16,
+'YA' => 2,
+'YAE' => 3,
+'YE' => 7,
+'YEO' => 6,
+'YI' => 19,
+'YO' => 12,
+'YU' => 17,
+
+ );
+
+ # Optional trailing consonant
+ my %Jamo_T = (
+'B' => 17,
+'BS' => 18,
+'C' => 23,
+'D' => 7,
+'G' => 1,
+'GG' => 2,
+'GS' => 3,
+'H' => 27,
+'J' => 22,
+'K' => 24,
+'L' => 8,
+'LB' => 11,
+'LG' => 9,
+'LH' => 15,
+'LM' => 10,
+'LP' => 14,
+'LS' => 12,
+'LT' => 13,
+'M' => 16,
+'N' => 4,
+'NG' => 21,
+'NH' => 6,
+'NJ' => 5,
+'P' => 26,
+'S' => 19,
+'SS' => 20,
+'T' => 25,
+
+ );
+
+ # Computed re that splits up a Hangul name into LVT or LV syllables
+ my $syllable_re = qr/(|B|BB|C|D|DD|G|GG|H|J|JJ|K|M|N|P|R|S|SS|T)(A|AE|E|EO|EU|I|O|OE|U|WA|WAE|WE|WEO|WI|YA|YAE|YE|YEO|YI|YO|YU)(B|BS|C|D|G|GG|GS|H|J|K|L|LB|LG|LH|LM|LP|LS|LT|M|N|NG|NH|NJ|P|S|SS|T)?/;
+
+ my $HANGUL_SYLLABLE = "HANGUL SYLLABLE ";
+ my $loose_HANGUL_SYLLABLE = "HANGULSYLLABLE";
+
+ # These constants names and values were taken from the Unicode standard,
+ # version 5.1, section 3.12. They are used in conjunction with Hangul
+ # syllables
+ my $SBase = 0xAC00;
+ my $LBase = 0x1100;
+ my $VBase = 0x1161;
+ my $TBase = 0x11A7;
+ my $SCount = 11172;
+ my $LCount = 19;
+ my $VCount = 21;
+ my $TCount = 28;
+ my $NCount = $VCount * $TCount;
+
+ sub name_to_code_point_special {
+ my ($name, $loose) = @_;
+
+ # Returns undef if not one of the specially handled names; otherwise
+ # returns the code point equivalent to the input name
+ # $loose is non-zero if to use loose matching, 'name' in that case
+ # must be input as upper case with all blanks and dashes squeezed out.
+
+ if ((! $loose && $name =~ s/$HANGUL_SYLLABLE//)
+ || ($loose && $name =~ s/$loose_HANGUL_SYLLABLE//))
+ {
+ return if $name !~ qr/^$syllable_re$/;
+ my $L = $Jamo_L{$1};
+ my $V = $Jamo_V{$2};
+ my $T = (defined $3) ? $Jamo_T{$3} : 0;
+ return ($L * $VCount + $V) * $TCount + $T + $SBase;
+ }
+
+ # Name must end in 'code_point' for this to handle.
+ return if (($loose && $name !~ /^ (.*?) ($run_on_code_point_re) $/x)
+ || (! $loose && $name !~ /^ (.*) ($code_point_re) $/x));
+
+ my $base = $1;
+ my $code_point = CORE::hex $2;
+ my $names_ref;
+
+ if ($loose) {
+ $names_ref = \%loose_names_ending_in_code_point;
+ }
+ else {
+ return if $base !~ s/-$//;
+ $names_ref = \%names_ending_in_code_point;
+ }
+
+ # Name must be one of the ones which has the code point in it.
+ return if ! $names_ref->{$base};
+
+ # Look through the list of ranges that apply to this name to see if
+ # the code point is in one of them.
+ for (my $i = 0; $i < scalar @{$names_ref->{$base}{'low'}}; $i++) {
+ return if $names_ref->{$base}{'low'}->[$i] > $code_point;
+ next if $names_ref->{$base}{'high'}->[$i] < $code_point;
+
+ # Here, the code point is in the range.
+ return $code_point;
+ }
+
+ # Here, looked like the name had a code point number in it, but
+ # did not match one of the valid ones.
+ return;
+ }
+
+ sub code_point_to_name_special {
+ my $code_point = shift;
+
+ # Returns the name of a code point if algorithmically determinable;
+ # undef if not
+
+ # If in the Hangul range, calculate the name based on Unicode's
+ # algorithm
+ if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) {
+ use integer;
+ my $SIndex = $code_point - $SBase;
+ my $L = $LBase + $SIndex / $NCount;
+ my $V = $VBase + ($SIndex % $NCount) / $TCount;
+ my $T = $TBase + $SIndex % $TCount;
+ $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}";
+ $name .= $Jamo{$T} if $T != $TBase;
+ return $name;
+ }
+
+ # Look through list of these code points for one in range.
+ foreach my $hash (@code_points_ending_in_code_point) {
+ return if $code_point < $hash->{'low'};
+ if ($code_point <= $hash->{'high'}) {
+ return sprintf("%s-%04X", $hash->{'name'}, $code_point);
+ }
+ }
+ return; # None found
+ }
+} # End closure
+
+1;
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list