#!perl

# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;

$fatpacked{"Algorithm/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALGORITHM_DEPENDENCY';
  package Algorithm::Dependency;
  
  =pod
  
  =head1 NAME
  
  Algorithm::Dependency - Base class for implementing various dependency trees
  
  =head1 SYNOPSIS
  
    use Algorithm::Dependency;
    use Algorithm::Dependency::Source::File;
    
    # Load the data from a simple text file
    my $data_source = Algorithm::Dependency::Source::File->new( 'foo.txt' );
    
    # Create the dependency object, and indicate the items that are already
    # selected/installed/etc in the database
    my $dep = Algorithm::Dependency->new(
        source   => $data_source,
        selected => [ 'This', 'That' ]
        ) or die 'Failed to set up dependency algorithm';
    
    # For the item 'Foo', find out the other things we also have to select.
    # This WON'T include the item we selected, 'Foo'.
    my $also = $dep->depends( 'Foo' );
    print $also
    	? "By selecting 'Foo', you are also selecting the following items: "
    		. join( ', ', @$also )
    	: "Nothing else to select for 'Foo'";
    
    # Find out the order we need to act on the items in.
    # This WILL include the item we selected, 'Foo'.
    my $schedule = $dep->schedule( 'Foo' );
  
  =head1 DESCRIPTION
  
  Algorithm::Dependency is a framework for creating simple read-only
  dependency heirachies, where you have a set of items that rely on other
  items in the set, and require actions on them as well.
  
  Despite the most visible of these being software installation systems like
  the CPAN installer, or debian apt-get, they are usefull in other situations.
  This module intentionally uses implementation-neutral words, to avoid
  confusion.
  
  =head2 Terminology
  
  The term C<ITEM> refers to a single entity, such as a single software
  package, in the overall set of possible entities. Internally, this is a
  fairly simple object. See L<Algorithm::Dependency::Item> for details.
  
  The term C<SELECT> means that a particular item, for your purposes, has
  already been acted up in the required way. For example, if the software
  package had already been installed, and didn't need to be re-installed,
  it would be C<SELECTED>.
  
  The term C<SOURCE> refers to a location that contains the master set of
  items. This will be very application specific, and might be a flat file,
  some form of database, the list of files in a folder, or generated
  dynamically.
  
  =head2 General Description
  
  Algorithm::Dependency implements algorithms relating to dependency
  heirachies. To use this framework, all you need is a source for the master
  list of all the items, and a list of those already selected. If your
  dependency heirachy doesn't require the concept of items that are already
  selected, simply don't pass anything to the constructor for it.
  
  Please note that the class Algorithm::Dependency does NOT implement an
  ordering, for speed and simplicity reasons. That is, the C<schedule> it
  provides is not in any particular order. If item 'A' depends on item 'B',
  it will not place B before A in the schedule. This makes it unsuitable for
  things like software installers, as they typically would need B to be
  installed before A, or the installation of A would fail.
  
  For dependency heirachies requiring the items to be acted on in a particular
  order, either top down or bottom up, see L<Algorithm::Dependency::Ordered>.
  It should be more applicable for your needs. This is the the subclass you
  would probably use to implement a simple ( non-versioned ) package
  installation system. Please note that an ordered heirachy has additional
  constraints. For example, circular dependencies ARE legal in a
  non-ordered heirachy, but ARE NOT legal in an ordered heirachy.
  
  =head2 Extending
  
  A module for creating a source from a simple flat file is included. For
  details see L<Algorithm::Dependency::Source::File>. Information on creating
  a source for your particular use is in L<Algorithm::Dependency::Source>.
  
  =head1 METHODS
  
  =cut
  
  use 5.005;
  use strict;
  use Algorithm::Dependency::Item   ();
  use Algorithm::Dependency::Source ();
  use Params::Util qw{_INSTANCE _ARRAY};
  
  use vars qw{$VERSION};
  BEGIN {
  	$VERSION = '1.110';
  }
  
  
  
  
  
  #####################################################################
  # Constructor
  
  =pod
  
  =head2 new %args
  
  The constructor creates a new context object for the dependency algorithms to
  act in. It takes as argument a series of options for creating the object.
  
  =over 4
  
  =item source => $Source
  
  The only compulsory option is the source of the dependency items. This is
  an object of a subclass of L<Algorithm::Dependency::Source>. In practical terms,
  this means you will create the source object before creating the
  Algorithm::Dependency object.
  
  =item selected => [ 'A', 'B', 'C', etc... ]
  
  The C<selected> option provides a list of those items that have already been
  'selected', acted upon, installed, or whatever. If another item depends on one
  in this list, we don't have to include it in the output of the C<schedule> or
  C<depends> methods.
  
  =item ignore_orphans => 1
  
  Normally, the item source is expected to be largely perfect and error free.
  An 'orphan' is an item name that appears as a dependency of another item, but
  doesn't exist, or has been deleted.
  
  By providing the C<ignore_orphans> flag, orphans are simply ignored. Without
  the C<ignore_orphans> flag, an error will be returned if an orphan is found.
  
  =back
  
  The C<new> constructor returns a new Algorithm::Dependency object on success,
  or C<undef> on error.
  
  =cut
  
  sub new {
  	my $class  = shift;
  	my %args   = @_;
  	my $source = _INSTANCE($args{source}, 'Algorithm::Dependency::Source')
  		or return undef;
  
  	# Create the object
  	my $self = bless {
  		source   => $source, # Source object
  		selected => {},
  		}, $class;
  
  	# Were we given the 'ignore_orphans' flag?
  	if ( $args{ignore_orphans} ) {
  		$self->{ignore_orphans} = 1;
  	}
  
  	# Done, unless we have been given some selected items
  	_ARRAY($args{selected}) or return $self;
  
  	# Make sure each of the selected ids exists
  	my %selected = ();
  	foreach my $id ( @{ $args{selected} } ) {
  		# Does the item exist?
  		return undef unless $source->item($id);
  
  		# Is it a duplicate
  		return undef if $selected{$id};
  
  		# Add to the selected index
  		$selected{$id} = 1;
  	}
  
  	$self->{selected} = \%selected;
  	$self;
  }
  
  
  
  
  
  #####################################################################
  # Basic methods
  
  =pod
  
  =head2 source
  
  The C<source> method retrieves the L<Algorithm::Dependency::Source> object
  for the algorithm context.
  
  =cut
  
  sub source { $_[0]->{source} }
  
  =pod
  
  =head2 selected_list
  
  The C<selected_list> method returns, as a list and in alphabetical order,
  the list of the names of the selected items.
  
  =cut
  
  sub selected_list { sort keys %{$_[0]->{selected}} }
  
  =pod
  
  =head2 selected $name
  
  Given an item name, the C<selected> method will return true if the item is
  selected, false is not, or C<undef> if the item does not exist, or an error
  occurs.
  
  =cut
  
  sub selected { $_[0]->{selected}->{$_[1]} }
  
  =pod
  
  =head2 item $name
  
  The C<item> method fetches and returns the item object, as specified by the
  name argument.
  
  Returns an L<Algorithm::Dependency::Item> object on success, or C<undef> if
  an item does not exist for the argument provided.
  
  =cut
  
  sub item { $_[0]->{source}->item($_[1]) }
  
  
  
  
  
  #####################################################################
  # Main algorithm methods
  
  =pod
  
  =head2 depends $name1, ..., $nameN
  
  Given a list of one or more item names, the C<depends> method will return
  a reference to an array containing a list of the names of all the OTHER
  items that also have to be selected to meet dependencies.
  
  That is, if item A depends on B and C then the C<depends> method would
  return a reference to an array with B and C. ( C<[ 'B', 'C' ]> )
  
  If multiple item names are provided, the same applies. The list returned
  will not contain duplicates.
  
  The method returns a reference to an array of item names on success, a
  reference to an empty array if no other items are needed, or C<undef>
  on error.
  
  =cut
  
  sub depends {
  	my $self    = shift;
  	my @stack   = @_ or return undef;
  	my @depends = ();
  	my %checked = ();
  
  	# Process the stack
  	while ( my $id = shift @stack ) {
  		# Does the id exist?
  		my $Item = $self->{source}->item($id)
  		or $self->{ignore_orphans} ? next : return undef;
  
  		# Skip if selected or checked
  		next if $checked{$id};
  
  		# Add its depends to the stack
  		push @stack, $Item->depends;
  		$checked{$id} = 1;
  
  		# Add anything to the final output that wasn't one of
  		# the original input.
  		unless ( scalar grep { $id eq $_ } @_ ) {
  			push @depends, $id;
  		}
  	}
  
  	# Remove any items already selected
  	my $s = $self->{selected};
  	return [ sort grep { ! $s->{$_} } @depends ];
  }
  
  =pod
  
  =head2 schedule $name1, ..., $nameN
  
  Given a list of one or more item names, the C<depends> method will return,
  as a reference to an array, the ordered list of items you should act upon.
  
  This would be the original names provided, plus those added to satisfy
  dependencies, in the prefered order of action. For the normal algorithm,
  where order it not important, this is alphabetical order. This makes it
  easier for someone watching a program operate on the items to determine
  how far you are through the task and makes any logs easier to read.
  
  If any of the names you provided in the arguments is already selected, it
  will not be included in the list.
  
  The method returns a reference to an array of item names on success, a
  reference to an empty array if no items need to be acted upon, or C<undef>
  on error.
  
  =cut
  
  sub schedule {
  	my $self  = shift;
  	my @items = @_ or return undef;
  
  	# Get their dependencies
  	my $depends = $self->depends( @items ) or return undef;
  
  	# Now return a combined list, removing any items already selected.
  	# We are allowed to return an empty list.
  	my $s = $self->{selected};
  	return [ sort grep { ! $s->{$_} } @items, @$depends ];
  }
  
  =pod
  
  =head2 schedule_all;
  
  The C<schedule_all> method acts the same as the C<schedule> method, but 
  returns a schedule that selected all the so-far unselected items.
  
  =cut
  
  sub schedule_all {
  	my $self = shift;
  	$self->schedule( map { $_->id } $self->source->items );
  }
  
  1;
  
  =pod
  
  =head1 TO DO
  
  Add the C<check_source> method, to verify the integrity of the source.
  
  Possibly add Algorithm::Dependency::Versions, to implement an ordered
  dependency tree with versions, like for perl modules.
  
  Currently readonly. Make the whole thing writable, so the module can be
  used as the core of an actual dependency application, as opposed to just
  being a tool.
  
  =head1 SUPPORT
  
  Bugs should be submitted via the CPAN bug tracker, located at
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Algorithm-Dependency>
  
  For general comments, contact the author.
  
  =head1 AUTHOR
  
  Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  =head1 SEE ALSO
  
  L<Algorithm::Dependency::Ordered>, L<Algorithm::Dependency::Item>,
  L<Algorithm::Dependency::Source>, L<Algorithm::Dependency::Source::File>
  
  =head1 COPYRIGHT
  
  Copyright 2003 - 2009 Adam Kennedy.
  
  This program is free software; you can redistribute
  it and/or modify it under the same terms as Perl itself.
  
  The full text of the license can be found in the
  LICENSE file included with this module.
  
  =cut
ALGORITHM_DEPENDENCY

$fatpacked{"Algorithm/Dependency/Item.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALGORITHM_DEPENDENCY_ITEM';
  package Algorithm::Dependency::Item;
  
  =pod
  
  =head1 NAME
  
  Algorithm::Dependency::Item - Implements an item in a dependency heirachy.
  
  =head1 DESCRIPTION
  
  The Algorithm::Dependency::Item class implements a single item within the
  dependency heirachy. It's quite simple, usually created from within a source,
  and not typically created directly. This is provided for those implementing
  their own source. ( See L<Algorithm::Dependency::Source> for details ).
  
  =head1 METHODS
  
  =cut
  
  use 5.005;
  use strict;
  use Algorithm::Dependency ();
  
  use vars qw{$VERSION};
  BEGIN {
  	$VERSION = '1.110';
  }
  
  
  
  
  
  #####################################################################
  # Constructor
  
  =pod
  
  =head2 new $id, @depends
  
  The C<new> constructor takes as its first argument the id ( name ) of the
  item, and any further arguments are assumed to be the ids of other items that
  this one depends on.
  
  Returns a new C<Algorithm::Dependency::Item> on success, or C<undef>
  on error.
  
  =cut
  
  sub new {
  	my $class = shift;
  	my $id    = (defined $_[0] and ! ref $_[0] and $_[0] ne '') ? shift : return undef;
  	bless { id => $id, depends => [ @_ ] }, $class;
  }
  
  =pod
  
  =head2 id
  
  The C<id> method returns the id of the item.
  
  =cut
  
  sub id { $_[0]->{id} }
  
  =pod
  
  =head2 depends
  
  The C<depends> method returns, as a list, the names of the other items that
  this item depends on.
  
  =cut
  
  sub depends { @{$_[0]->{depends}} }
  
  1;
  
  =pod
  
  =head1 SUPPORT
  
  For general comments, contact the author.
  
  To file a bug against this module, in a way you can keep track of, see the
  CPAN bug tracking system.
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Algorithm-Dependency>
  
  =head1 AUTHOR
  
  Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  =head1 SEE ALSO
  
  L<Algorithm::Dependency>
  
  =head1 COPYRIGHT
  
  Copyright 2003 - 2009 Adam Kennedy.
  
  This program is free software; you can redistribute
  it and/or modify it under the same terms as Perl itself.
  
  The full text of the license can be found in the
  LICENSE file included with this module.
  
  =cut
ALGORITHM_DEPENDENCY_ITEM

$fatpacked{"Algorithm/Dependency/Ordered.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALGORITHM_DEPENDENCY_ORDERED';
  package Algorithm::Dependency::Ordered;
  
  =pod
  
  =head1 NAME
  
  Algorithm::Dependency::Ordered - Implements an ordered dependency heirachy
  
  =head1 DESCRIPTION
  
  Algorithm::Dependency::Ordered implements the most common variety of
  L<Algorithm::Dependency>, the one in which the dependencies of an item must
  be acted upon before the item itself can be acted upon.
  
  In use and semantics, this should be used in exactly the same way as for the
  main parent class. Please note that the output of the C<depends> method is
  NOT changed, as the order of the depends is not assumed to be important.
  Only the output of the C<schedule> method is modified to ensure the correct
  order.
  
  For API details, see L<Algorithm::Dependency>.
  
  =cut
  
  use 5.005;
  use strict;
  use Algorithm::Dependency ();
  
  use vars qw{$VERSION @ISA};
  BEGIN {
  	$VERSION = '1.110';
  	@ISA     = 'Algorithm::Dependency';
  }
  
  
  
  
  
  sub schedule {
  	my $self   = shift;
  	my $source = $self->{source};
  	my @items  = @_ or return undef;
  	return undef if grep { ! $source->item($_) } @items;
  
  	# The actual items to select will be the same as for the unordered
  	# version, so we can simplify the algorithm greatly by using the
  	# normal unordered ->schedule method to get the starting list.
  	my $rv    = $self->SUPER::schedule( @items );
  	my @queue = $rv ? @$rv : return undef;
  
  	# Get a working copy of the selected index
  	my %selected = %{ $self->{selected} };
  
  	# If at any time we check every item in the stack without finding
  	# a suitable candidate for addition to the schedule, we have found
  	# a circular reference error. We need to create a marker to track this.
  	my $error_marker = '';
  
  	# Begin the processing loop
  	my @schedule = ();
  	while ( my $id = shift @queue ) {
  		# Have we checked every item in the stack?
  		return undef if $id eq $error_marker;
  
  		# Are there any un-met dependencies
  		my $Item    = $self->{source}->item($id) or return undef;
  		my @missing = grep { ! $selected{$_} } $Item->depends;
  
  		# Remove orphans if we are ignoring them
  		if ( $self->{ignore_orphans} ) {
  			@missing = grep { $self->{source}->item($_) } @missing;
  		}
  
  		if ( @missing ) {
  			# Set the error marker if not already
  			$error_marker = $id unless $error_marker;
  
  			# Add the id back to the end of the queue
  			push @queue, $id;
  			next;
  		}
  
  		# All dependencies have been met. Add the item to the schedule and
  		# to the selected index, and clear the error marker.
  		push @schedule, $id;
  		$selected{$id} = 1;
  		$error_marker  = '';
  	}
  
  	# All items have been added
  	\@schedule;
  }
  
  1;
  
  =pod
  
  =head1 SUPPORT
  
  Bugs should be submitted via the CPAN bug tracker, located at
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Algorithm-Dependency>
  
  For general comments, contact the author.
  
  =head1 AUTHOR
  
  Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  =head1 SEE ALSO
  
  L<Algorithm::Dependency>
  
  =head1 COPYRIGHT
  
  Copyright 2003 - 2009 Adam Kennedy.
  
  This program is free software; you can redistribute
  it and/or modify it under the same terms as Perl itself.
  
  The full text of the license can be found in the
  LICENSE file included with this module.
  
  =cut
ALGORITHM_DEPENDENCY_ORDERED

$fatpacked{"Algorithm/Dependency/Source.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALGORITHM_DEPENDENCY_SOURCE';
  package Algorithm::Dependency::Source;
  
  =pod
  
  =head1 NAME
  
  Algorithm::Dependency::Source - Implements a source of heirachy items
  
  =head1 DESCRIPTION
  
  The Algorithm::Dependency::Source class provides an abstract parent class for
  implementing sources for the heirachy data the algorithm will use. For an
  example of an implementation of this, see
  L<Algorithm::Dependency::Source::File>, which is bundled with the main
  L<Algorithm::Dependency> package.
  
  =head1 METHODS
  
  =cut
  
  use 5.005;
  use strict;
  use Algorithm::Dependency ();
  use Params::Util qw{_SET};
  
  use vars qw{$VERSION};
  BEGIN {
  	$VERSION = '1.110';
  }
  
  
  
  
  
  #####################################################################
  # Constructor
  
  =pod
  
  =head2 new @arguments
  
  Although you cannot directly use the C<new> constructor for
  C<Algorithm::Dependency::Source>, it will work the same in all subclasses.
  
  The constructor takes zero or more subclass specific arguments to define the
  location of the source of the items, and returns a new object. Alrough it
  may check that the arguments you passed are valid, the source will usually
  NOT actually load the items from the source, instead defering the loading
  until you need to use the items.
  
  Returns a new object on success, or C<undef> on error.
  
  =cut
  
  sub new {
  	my $class = shift;
  
  	# This can't be created directly, it must be through
  	# a SUPER::new call
  	if ( $class eq __PACKAGE__ ) {
  		die "Cannot directly instantiate Algorithm::Dependency::Source."
  			. " You must use a subclass";
  	}
  
  	# Create the basic object
  	my $self = bless {
  		# Has the source been loaded
  		loaded      => 0,
  
  		# Indexes
  		items_hash  => undef,
  		items_array => undef,
  		}, $class;
  
  	$self;
  }
  
  =pod
  
  =head2 load
  
  The C<load> method is the public method used to actually load the items from
  their storage location into the the source object. The method will
  automatically called, as needed, in most circumstances. You would generally
  only want to use C<load> manually if you think there may be some uncertainty
  that the source will load correctly, and want to check it will work.
  
  Returns true if the items are loaded successfully, or C<undef> on error.
  
  =cut
  
  sub load {
  	my $self = shift;
  
  	# If this is a reload, clean up in preperation
  	if ( $self->{loaded} ) {
  		$self->{loaded}      = 0;
  		$self->{items_hash}  = undef;
  		$self->{items_array} = undef;
  	}
  
  	# Pass through to the real loader
  	my $items = $self->_load_item_list;
  	return $items unless $items;
  	unless ( _SET($items, 'Algorithm::Dependency::Item') ) {
  		die( ref($self) . "::_load_item_list did not return an Algorithm::Dependency::Item set" );
  	}
  
  	# Add the items
  	foreach my $item ( @$items ) {
  		# Have we added this one already?
  		my $id = $item->id;
  		if ( $self->{items_hash}->{ $id } ) {
  			# Duplicate entry
  			return undef;
  		}
  
  		# Add it
  		push @{ $self->{items_array} }, $item;
  		$self->{items_hash}->{$id} = $item;
  	}
  
  	$self->{loaded} = 1;
  }
  
  =pod
  
  =head2 item $name
  
  The C<item> method fetches and returns the item object specified by the
  name argument.
  
  Returns an L<Algorithm::Dependency::Item> object on success, or C<undef> if
  the named item does not exist in the source.
  
  =cut
  
  sub item {
  	my $self = shift;
  	my $id   = (defined $_[0] and ! ref $_[0] and $_[0] ne '') ? shift : return undef;
  	$self->{loaded} or $self->load or return undef;
  
  	# Return the item (or undef)
  	$self->{items_hash}->{$id};
  }
  
  =pod
  
  =head2 items
  
  The C<items> method returns, as a list of objects, all of the items
  contained in the source. The item objects will be returned in the same order
  as that in the storage location.
  
  Returns a list of L<Algorithm::Dependency::Item> objects on success, or
  C<undef> on error.
  
  =cut
  
  sub items {
  	my $self = shift;
  	$self->{loaded} or $self->load or return undef;
  	@{ $self->{items_array} };
  }
  
  =pod
  
  =head2 missing_dependencies
  
  By default, we are leniant with missing dependencies if the item is neved 
  used. For systems where having a missing dependency can be very bad, the 
  C<missing_dependencies> method checks all Items to make sure their 
  dependencies exist.
  
  If there are any missing dependencies, returns a reference to an array of
  their ids. If there are no missing dependencies, returns 0. Returns 
  C<undef> on error.
  
  =cut
  
  sub missing_dependencies {
  	my $self = shift;
  	$self->{loaded} or $self->load or return undef;
  	
  	# Merged the depends of all the items, and see if
  	# any are missing.
  	my %missing = map  { $_ => 1           }
  	              grep { ! $self->item($_) }
  	              map  { $_->depends       }
  	              $self->items;
  	%missing ? [ sort keys %missing ] : 0;
  }
  
  
  
  
  
  #####################################################################
  # Catch unimplemented methods in subclasses
  
  sub _load_item_list {
  	die "Class $_[0] failed to define the method _load_item_list";
  }
  
  1;
  
  =pod
  
  =head1 EXTENDING
  
  C<Algorithm::Dependency::Source> itself is a fairly thin module, and it
  is intended that you will probably need to extend it to be able to
  extract item data from whatever location you have stored them.
  
  This is usually a fairly simple two step process.
  
  =over 4
  
  =item Overload the C<new> method.
  
  Assuming your subclass takes some form or argument on creation, you will
  need to overload the C<new> method to accept the arguments, validate them,
  and store them in the source object.
  
  =item Define the method C<_load_item_list>.
  
  Leaving our parent's C<load> method to take care of conflict, errors, and
  whatever, the C<_load_item_list> method is used to simply create a list of
  L<Algorithm::Dependency::Item> objects from wherever you store the item,
  and return them as a list.
  
  =back
  
  Having completed these two things, your subclass should be completed. For
  an example of the code, have a look at the source for the simple subclass
  L<Algorithm::Dependency::Source::File>.
  
  =head1 SUPPORT
  
  For general comments, contact the author.
  
  To file a bug against this module, in a way you can keep track of, see the
  CPAN bug tracking system.
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Algorithm-Dependency>
  
  =head1 AUTHOR
  
  Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  =head1 SEE ALSO
  
  L<Algorithm::Dependency>, L<Algorithm::Dependency::Source::File>
  
  =head1 COPYRIGHT
  
  Copyright 2003 - 2009 Adam Kennedy.
  
  This program is free software; you can redistribute
  it and/or modify it under the same terms as Perl itself.
  
  The full text of the license can be found in the
  LICENSE file included with this module.
  
  =cut
ALGORITHM_DEPENDENCY_SOURCE

$fatpacked{"Algorithm/Dependency/Source/File.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALGORITHM_DEPENDENCY_SOURCE_FILE';
  package Algorithm::Dependency::Source::File;
  
  =pod
  
  =head1 NAME
  
  Algorithm::Dependency::Source::File - File source for dependency heirachys
  
  =head1 DESCRIPTION
  
  Algorithm::Dependency::Source::File implements a
  L<source|Algorithm::Dependency::Source> where the items are stored in a flat
  file or a relatively simple format.
  
  =head2 File Format
  
  The file should be an ordinary text file, consisting of a series of lines,
  with each line completely containing the information for a single item.
  Blank lines, or lines beginning with the hash character '#' will be
  ignored as comments.
  
  For a single item line, only word characters will be used. A 'word character'
  consists of all letters and numbers, and the underscore '_' character.
  Anything that is not a word character will be assumed to be a seperator.
  
  The first word will be used as the name or id of the item, and any further
  words in the line will be used as other items that this one depends on. For
  example, all of the following are legal.
  
    # A single item with no dependencies
    Foo
  
    # Another item that depends on the first one
    Bar Foo
  
    # Depending on multiple others
    Bin Foo Bar
  
    # We can use different seperators
    One:Two|Three-Four+Five=Six Seven
  
    # We can also use multiple non-word characters as seperators
    This&*&^*&File:  is& & & :::REALLY()Neat
  
  From the examples above, it should be easy to create your own files.
  
  =head1 METHODS
  
  This documents the methods differing from the ordinary
  L<Algorithm::Dependency::Source> methods.
  
  =cut
  
  use 5.005;
  use strict;
  use Algorithm::Dependency::Source ();
  
  use vars qw{$VERSION @ISA};
  BEGIN {
  	$VERSION = '1.110';
  	@ISA     = 'Algorithm::Dependency::Source';
  }
  
  
  
  
  
  #####################################################################
  # Constructor
  
  =pod
  
  =head2 new $filename
  
  When constructing a new Algorithm::Dependency::Source::File object, an
  argument should be provided of the name of the file to use. The constructor
  will check that the file exists, and is readable, returning C<undef>
  otherwise.
  
  =cut
  
  sub new {
  	my $class    = shift;
  	my $filename = shift or return undef;
  	return undef unless -r $filename;
  
  	# Get the basic source object
  	my $self = $class->SUPER::new() or return undef;
  
  	# Add our arguments
  	$self->{filename} = $filename;
  
  	$self;
  }
  
  
  
  
  
  #####################################################################
  # Private Methods
  
  sub _load_item_list {
  	my $self = shift;
  
  	# Load the contents of the file
  	local $/ = undef;
  	open( FILE, $self->{filename} ) or return undef;
  	defined(my $source = <FILE>)    or return undef;
  	close( FILE )                   or return undef;
  
  	# Split, trim, clean and remove comments
  	my @content = grep { ! /^\s*(?:\#|$)/ } 
  		split /\s*[\015\012][\s\015\012]*/, $source;
  
  	# Parse and build the item list
  	my @Items = ();
  	foreach my $line ( @content ) {
  		# Split the line by non-word characters
  		my @sections = grep { length $_ } split /\W+/, $line;
  		return undef unless scalar @sections;
  
  		# Create the new item
  		my $Item = Algorithm::Dependency::Item->new( @sections ) or return undef;
  		push @Items, $Item;
  	}
  
  	\@Items;
  }
  
  1;
  
  =pod
  
  =head1 SUPPORT
  
  To file a bug against this module, use the CPAN bug tracking system
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Algorithm-Dependency>
  
  For other comments, contact the author.
  
  =head1 AUTHOR
  
  Adam Kennedy <adamk@cpan.org>
  
  =head1 SEE ALSO
  
  L<Algorithm::Dependency>
  
  =head1 COPYRIGHT
  
  Copyright 2003 - 2009 Adam Kennedy.
  
  This program is free software; you can redistribute
  it and/or modify it under the same terms as Perl itself.
  
  The full text of the license can be found in the
  LICENSE file included with this module.
  
  =cut
ALGORITHM_DEPENDENCY_SOURCE_FILE

$fatpacked{"Algorithm/Dependency/Source/HoA.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALGORITHM_DEPENDENCY_SOURCE_HOA';
  package Algorithm::Dependency::Source::HoA;
  
  =pod
  
  =head1 NAME
  
  Algorithm::Dependency::Source::HoA - Source for a HASH of ARRAYs
  
  =head1 SYNOPSIS
  
    # The basic data structure
    my $deps = {
        foo => [ 'bar', 'baz' ],
        bar => [],
        baz => [ 'bar' ],
        };
    
    # Create the source from it
    my $Source = Algorithm::Dependency::Source::HoA->new( $deps );
  
  =head1 DESCRIPTION
  
  C<Algorithm::Dependency::Source::HoA> implements a
  L<source|Algorithm::Dependency::Source> where the items names are provided
  in the most simple form, a reference to a C<HASH> of C<ARRAY> references.
  
  =head1 METHODS
  
  This documents the methods differing from the ordinary
  L<Algorithm::Dependency::Source> methods.
  
  =cut
  
  use 5.005;
  use strict;
  use Algorithm::Dependency::Source ();
  use Params::Util qw{_HASH _ARRAY0};
  
  use vars qw{$VERSION @ISA};
  BEGIN {
  	$VERSION = '1.110';
  	@ISA     = 'Algorithm::Dependency::Source';
  }
  
  
  
  
  
  #####################################################################
  # Constructor
  
  =pod
  
  =head2 new $filename
  
  When constructing a new C<Algorithm::Dependency::Source::HoA> object, an
  argument should be provided of a reference to a HASH of ARRAY references,
  containing the names of other HASH elements.
  
  Returns the object, or C<undef> if the structure is not correct.
  
  =cut
  
  sub new {
  	my $class = shift;
  	my $hash  = _HASH(shift) or return undef;
  	foreach my $deps ( values %$hash ) {
  		_ARRAY0($deps) or return undef;
  	}
  
  	# Get the basic source object
  	my $self = $class->SUPER::new() or return undef;
  
  	# Add our arguments
  	$self->{hash} = $hash;
  
  	$self;
  }
  
  
  
  
  
  #####################################################################
  # Private Methods
  
  sub _load_item_list {
  	my $self = shift;
  
  	# Build the item objects from the data
  	my $hash  = $self->{hash};
  	my @items = map {
  		Algorithm::Dependency::Item->new( $_, @{$hash->{$_}} )
  		or return undef;
  		} keys %$hash;
  
  	\@items;
  }
  
  1;
  
  =pod
  
  =head1 SUPPORT
  
  To file a bug against this module, use the CPAN bug tracking system
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Algorithm-Dependency>
  
  For other comments, contact the author.
  
  =head1 AUTHOR
  
  Adam Kennedy <adamk@cpan.org>
  
  =head1 SEE ALSO
  
  L<Algorithm::Dependency>, L<Algorithm::Dependency::Source>
  
  =head1 COPYRIGHT
  
  Copyright 2003 - 2009 Adam Kennedy.
  
  This program is free software; you can redistribute
  it and/or modify it under the same terms as Perl itself.
  
  The full text of the license can be found in the
  LICENSE file included with this module.
  
  =cut
ALGORITHM_DEPENDENCY_SOURCE_HOA

$fatpacked{"Algorithm/Dependency/Source/Invert.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALGORITHM_DEPENDENCY_SOURCE_INVERT';
  package Algorithm::Dependency::Source::Invert;
  
  =pod
  
  =head1 NAME
  
  Algorithm::Dependency::Source::Invert - Logically invert a source
  
  =head1 SYNOPSIS
  
    my $inverted = Algorithm::Dependency::Source::Invert->new( $source );
  
  =head1 DESCRIPTION
  
  This class creates a source from another source, but with all dependencies
  reversed.
  
  =cut
  
  use 5.005;
  use strict;
  use Params::Util '_INSTANCE';
  use Algorithm::Dependency::Source::HoA ();
  
  use vars qw{$VERSION @ISA};
  BEGIN {
  	$VERSION = '1.110';
  	@ISA     = 'Algorithm::Dependency::Source::HoA';
  }
  
  
  
  
  
  #####################################################################
  # Constructor
  
  sub new {
  	my $class  = shift;
  	my $source = _INSTANCE(shift, 'Algorithm::Dependency::Source') or return undef;
  
  	# Derive a HoA from the original source
  	my @items = $source->items;
  	my %hoa   = map { $_->id => [ ] } @items;
  	foreach my $item ( @items ) {
  		my $id   = $item->id;
  		my @deps = $item->depends;
  		foreach my $dep ( @deps ) {
  			push @{ $hoa{$dep} }, $id;
  		}
  	}
  
  	# Hand off to the parent class
  	$class->SUPER::new( \%hoa );
  }
  
  1;
  
  =pod
  
  =head1 SUPPORT
  
  To file a bug against this module, use the CPAN bug tracking system
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Algorithm-Dependency>
  
  For other comments, contact the author.
  
  =head1 AUTHOR
  
  Adam Kennedy <adamk@cpan.org>
  
  =head1 SEE ALSO
  
  L<Algorithm::Dependency::Source>, L<Algorithm::Dependency::Source::HoA>
  
  =head1 COPYRIGHT
  
  Copyright 2003 - 2009 Adam Kennedy.
  
  This program is free software; you can redistribute
  it and/or modify it under the same terms as Perl itself.
  
  The full text of the license can be found in the
  LICENSE file included with this module.
  
  =cut
ALGORITHM_DEPENDENCY_SOURCE_INVERT

$fatpacked{"Algorithm/Dependency/Weight.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALGORITHM_DEPENDENCY_WEIGHT';
  package Algorithm::Dependency::Weight;
  
  =pod
  
  =head1 NAME
  
  Algorithm::Dependency::Weight - Calculate dependency 'weights'
  
  =head1 SYNOPSIS
  
    # Create a source from a file
    my $Source = Algorithm::Dependency::Source->new( 'file.txt' );
    
    # Create a Weight algorithm object
    my $alg = Algorithm::Dependency::Weight->new( source => $Source );
    
    # Find the weight for a single item
    my $weight = $alg->weight('foo');
    print "The weight of 'foo' is $weight\n";
    
    # Or a group
    my $hash = $alg->weight_hash('foo', 'bar', 'baz');
    print "The weight of 'foo', 'bar', and 'bar' are $hash->{foo},"
        . " $hash->{bar} and $hash->{baz} respectively\n";
    
    # Or all of the items
    my $all = $alg->weight_all;
    print "The following is a list from heaviest to lightest:\n";
    foreach ( sort { $all->{$b} <=> $all->{$a} } keys %$all ) {
        print "$_: $all->{$_}\n";
    }
  
  =head1 DESCRIPTION
  
  In dependency systems, it can often be very useful to calculate
  an aggregate or sum for one or all items. For example, to find
  the "naive install weight" of a Perl distribution (where "naive"
  means you treat each distribution equally), you would want the
  distribtion (1) + all its dependencies (n) + all B<their>
  dependencies (n2) recursively downwards.
  
  If calculated using a normal L<Algorithm::Dependency> object, the
  result would be (in a simple systems) equal to:
  
    # Create your normal (non-ordered alg:dep)
    my $dependency = Algorithm::Dependency->new( ... );
    
    # Find the naive weight for an item
    my $weight = scalar($dependency->schedule('itemname'));
  
  C<Algorithm::Dependency::Weight> provides a way of doing this
  with a little more sophistication, and in a way that should work
  reasonable well across all the L<Algorithm::Dependency> family.
  
  Please note that the this might be a little (or more than a little)
  slower than it could be for the limited case of generating weights
  for all of the items at once in a dependency system with no selected
  items and no circular dependencies. BUT you can at least rely on
  this class to do the job properly regardless of the particulars of
  the situation, which is probably more important.
  
  =head2 METHODS
  
  =cut
  
  use 5.005;
  use strict;
  use List::Util            ();
  use Algorithm::Dependency ();
  use Params::Util qw{_INSTANCE _STRING};
  
  use vars qw{$VERSION};
  BEGIN {
  	$VERSION = '1.110';
  }
  
  
  
  
  
  #####################################################################
  # Constructor and Accessors
  
  =pod
  
  =head2 new @params
  
  The C<new> constructor creates a new C<Algorithm::Dependency::Weight>
  object. It takes a number of key/value pairs as parameters (although
  at the present time only one).
  
  =over 4
  
  =item source => $Source
  
  The C<source> param is mostly the same as for L<Algorithm::Dependency>.
  The one addition is that as a source you can provide an
  L<Algorithm::Dependency> object, and the L<Algorithm::Dependency::Source>
  for that will be used.
  
  =back
  
  Returns a new C<Algorithm::Dependency::Weight> object, or C<undef> on error.
  
  =cut
  
  sub new {
  	my $class = shift;
  	my %args  = @_;
  
  	# Get the source object, or derive it from an existing alg-dep
  	my $source = _INSTANCE($args{source}, 'Algorithm::Dependency')
  		? $args{source}->source
  		: _INSTANCE($args{source}, 'Algorithm::Dependency::Source')
  		or return undef;
  
  	# Build the alg-dep object we use
  	my $algdep = Algorithm::Dependency->new(
  		source         => $source,
  		ignore_orphans => 1,
  		) or return undef;
  
  	# Create the basic object
  	my $self = bless {
  		source => $source,
  		algdep => $algdep,
  		weight => {},
  		}, $class;
  
  	$self;
  }
  
  =pod
  
  =head2 source
  
  The C<source> accessor returns the source used for the weight calculations.
  
  This will be either the one passed to the constructor, or the source from
  inside the C<Algorithm::Dependency> object passed as the C<source> param
  (B<not> the object itself, B<its> source).
  
  =cut
  
  sub source {
  	$_[0]->{source}
  }
  
  
  
  
  
  #####################################################################
  # Algorithm::Dependency::Weight Methods
  
  =pod
  
  =head2 weight $name
  
  The C<weight> method takes the name of a single item and calculates its
  weight based on the configuration of the C<Algorithm::Dependency::Weight>
  object.
  
  Returns the weight as a scalar (which in the naive case will be an
  integer, but in more complex uses may be any real number), or C<undef>
  on error.
  
  =cut
  
  sub weight {
  	my $self = shift;
  	my $id   = defined(_STRING($_[0])) ? shift : return undef;
  	$self->{weight}->{$id} or
  	$self->{weight}->{$id} = $self->_weight($id);
  }
  
  sub _weight {
  	my $self  = shift;
  	my $items = $self->{algdep}->schedule($_[0]) or return undef;
  	scalar(@$items);
  }
  
  =pod
  
  =head2 weight_merged @names
  
  The C<weight_merged> method takes the name of a set of items and
  calculates an aggregated weight for the whole set.
  
  Returns the weight as a scalar, or C<undef> on error.
  
  =cut
  
  sub weight_merged {
  	my $self  = shift;
  	my $items = $self->{algdep}->schedule(@_) or return undef;
  	scalar(@$items);
  }
  
  =pod
  
  =head2 weight_hash @names
  
  The C<weight_hash> method takes a list of item names, and calculates
  their weights.
  
  Returns a reference to a C<HASH> with the item names as keys and weights
  as values, or C<undef> on error.
  
  =cut
  
  sub weight_hash {
  	my $self  = shift;
  	my @names = @_;
  
  	# Iterate over the list
  	my %hash = ();
  	foreach my $name ( @names ) {
  		if ( $self->{weight}->{$name} ) {
  			$hash{$name} = $self->{weight}->{$name};
  			next;
  		}
  		$hash{$name} = $self->weight($name) or return undef;
  	}
  
  	\%hash;
  }
  
  =pod
  
  =head2 weight_all
  
  The C<weight_all> method provides the one-shot method for getting the
  weights of all items at once. Please note that this does not do
  anything different or special, but is slightly faster than iterating
  yourself.
  
  Returns a reference to a C<HASH> with the item names as keys and weights
  as values, or C<undef> on error.
  
  =cut
  
  sub weight_all {
  	my $self  = shift;
  	my @items = $self->source->items;
  	defined $items[0] or return undef;
  	$self->weight_hash( map { $_->id } @items );
  }
  
  1;
  
  =pod
  
  =head1 TO DO
  
  - Add support for non-naive weights via either custom code or method name
  
  =head1 SUPPORT
  
  Bugs should be submitted via the CPAN bug tracker, located at
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Algorithm-Dependency>
  
  For general comments, contact the author.
  
  =head1 AUTHOR
  
  Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  =head1 SEE ALSO
  
  L<Algorithm::Dependency>, L<Algorithm::Dependency::Source>
  
  =head1 COPYRIGHT
  
  Copyright 2003 - 2009 Adam Kennedy.
  
  This program is free software; you can redistribute
  it and/or modify it under the same terms as Perl itself.
  
  The full text of the license can be found in the
  LICENSE file included with this module.
  
  =cut
ALGORITHM_DEPENDENCY_WEIGHT

$fatpacked{"App/pause.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PAUSE';
  package App::pause;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.27'; # VERSION
  
  1;
  # ABSTRACT: A CLI for PAUSE
  
  =head1 DESCRIPTION
  
  This module is just an empty one to ease installation of this distribution (e.g.
  C<< cpanm -n App::pause >>). The real implementation is in
  L<WWW::PAUSE::Simple>. The CLI is L<pause>.
  
  
  =head1 SEE ALSO
  
  L<WWW::PAUSE::Simple>
  
  L<pause>
APP_PAUSE

$fatpacked{"Clone/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLONE_PP';
  package Clone::PP;
  
  use 5.006;
  use strict;
  use warnings;
  use vars qw($VERSION @EXPORT_OK);
  use Exporter;
  
  $VERSION = 1.06;
  
  @EXPORT_OK = qw( clone );
  sub import { goto &Exporter::import } # lazy Exporter
  
  # These methods can be temporarily overridden to work with a given class.
  use vars qw( $CloneSelfMethod $CloneInitMethod );
  $CloneSelfMethod ||= 'clone_self';
  $CloneInitMethod ||= 'clone_init';
  
  # Used to detect looped networks and avoid infinite recursion. 
  use vars qw( %CloneCache );
  
  # Generic cloning function
  sub clone {
    my $source = shift;
  
    return undef if not defined($source);
    
    # Optional depth limit: after a given number of levels, do shallow copy.
    my $depth = shift;
    return $source if ( defined $depth and $depth -- < 1 );
    
    # Maintain a shared cache during recursive calls, then clear it at the end.
    local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} );
    
    return $CloneCache{ $source } if ( defined $CloneCache{ $source } );
    
    # Non-reference values are copied shallowly
    my $ref_type = ref $source or return $source;
    
    # Extract both the structure type and the class name of referent
    my $class_name;
    if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) {
      $class_name = $ref_type;
      $ref_type = $1;
      # Some objects would prefer to clone themselves; check for clone_self().
      return $CloneCache{ $source } = $source->$CloneSelfMethod() 
  				  if $source->can($CloneSelfMethod);
    }
    
    # To make a copy:
    # - Prepare a reference to the same type of structure;
    # - Store it in the cache, to avoid looping if it refers to itself;
    # - Tie in to the same class as the original, if it was tied;
    # - Assign a value to the reference by cloning each item in the original;
    
    my $copy;
    if ($ref_type eq 'HASH') {
      $CloneCache{ $source } = $copy = {};
      if ( my $tied = tied( %$source ) ) { tie %$copy, ref $tied }
      %$copy = map { ! ref($_) ? $_ : clone($_, $depth) } %$source;
    } elsif ($ref_type eq 'ARRAY') {
      $CloneCache{ $source } = $copy = [];
      if ( my $tied = tied( @$source ) ) { tie @$copy, ref $tied }
      @$copy = map { ! ref($_) ? $_ : clone($_, $depth) } @$source;
    } elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') {
      $CloneCache{ $source } = $copy = \( my $var = "" );
      if ( my $tied = tied( $$source ) ) { tie $$copy, ref $tied }
      $$copy = clone($$source, $depth);
    } else {
      # Shallow copy anything else; this handles a reference to code, glob, regex
      $CloneCache{ $source } = $copy = $source;
    }
    
    # - Bless it into the same class as the original, if it was blessed;
    # - If it has a post-cloning initialization method, call it.
    if ( $class_name ) {
      bless $copy, $class_name;
      $copy->$CloneInitMethod() if $copy->can($CloneInitMethod);
    }
    
    return $copy;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Clone::PP - Recursively copy Perl datatypes
  
  =head1 SYNOPSIS
  
    use Clone::PP qw(clone);
    
    $item = { 'foo' => 'bar', 'move' => [ 'zig', 'zag' ]  };
    $copy = clone( $item );
  
    $item = [ 'alpha', 'beta', { 'gamma' => 'vlissides' } ];
    $copy = clone( $item );
  
    $item = Foo->new();
    $copy = clone( $item );
  
  Or as an object method:
  
    require Clone::PP;
    push @Foo::ISA, 'Clone::PP';
    
    $item = Foo->new();
    $copy = $item->clone();
  
  =head1 DESCRIPTION
  
  This module provides a general-purpose clone function to make deep
  copies of Perl data structures. It calls itself recursively to copy
  nested hash, array, scalar and reference types, including tied
  variables and objects.
  
  The clone() function takes a scalar argument to copy. To duplicate
  arrays or hashes, pass them in by reference:
  
    my $copy = clone(\@array);    my @copy = @{ clone(\@array) };
    my $copy = clone(\%hash);     my %copy = %{ clone(\%hash) };
  
  The clone() function also accepts an optional second parameter that
  can be used to limit the depth of the copy. If you pass a limit of
  0, clone will return the same value you supplied; for a limit of
  1, a shallow copy is constructed; for a limit of 2, two layers of
  copying are done, and so on.
  
    my $shallow_copy = clone( $item, 1 );
  
  To allow objects to intervene in the way they are copied, the
  clone() function checks for a couple of optional methods. If an
  object provides a method named C<clone_self>, it is called and the
  result returned without further processing. Alternately, if an
  object provides a method named C<clone_init>, it is called on the
  copied object before it is returned.
  
  =head1 BUGS
  
  Some data types, such as globs, regexes, and code refs, are always copied shallowly.
  
  References to hash elements are not properly duplicated. (This is why two tests in t/dclone.t that are marked "todo".) For example, the following test should succeed but does not:
  
    my $hash = { foo => 1 }; 
    $hash->{bar} = \{ $hash->{foo} }; 
    my $copy = clone( \%hash ); 
    $hash->{foo} = 2; 
    $copy->{foo} = 2; 
    ok( $hash->{bar} == $copy->{bar} );
  
  To report bugs via the CPAN web tracking system, go to 
  C<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone-PP> or send mail 
  to C<Dist=Clone-PP#rt.cpan.org>, replacing C<#> with C<@>.
  
  =head1 SEE ALSO
  
  L<Clone> - a baseclass which provides a C<clone()> method.
  
  L<MooseX::Clone> - find-grained cloning for Moose objects.
  
  The C<dclone()> function in L<Storable>.
  
  L<Data::Clone> -
  polymorphic data cloning (see its documentation for what that means).
  
  L<Clone::Any> - use whichever of the cloning methods is available.
  
  =head1 REPOSITORY
  
  L<https://github.com/neilbowers/Clone-PP>
  
  =head1 AUTHOR AND CREDITS
  
  Developed by Matthew Simon Cavalletto at Evolution Softworks. 
  More free Perl software is available at C<www.evoscript.org>.
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2003 Matthew Simon Cavalletto. You may contact the author
  directly at C<evo@cpan.org> or C<simonm@cavalletto.org>.
  
  Code initially derived from Ref.pm. Portions Copyright 1994 David Muir Sharnoff.
  
  Interface based by Clone by Ray Finch with contributions from chocolateboy.
  Portions Copyright 2001 Ray Finch. Portions Copyright 2001 chocolateboy. 
  
  You may use, modify, and distribute this software under the same terms as Perl.
  
  =cut
CLONE_PP

$fatpacked{"Color/ANSI/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'COLOR_ANSI_UTIL';
  package Color::ANSI::Util;
  
  our $DATE = '2015-01-03'; # DATE
  our $VERSION = '0.14'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(
                         ansi16_to_rgb
                         rgb_to_ansi16
                         rgb_to_ansi16_fg_code
                         ansi16fg
                         rgb_to_ansi16_bg_code
                         ansi16bg
  
                         ansi256_to_rgb
                         rgb_to_ansi256
                         rgb_to_ansi256_fg_code
                         ansi256fg
                         rgb_to_ansi256_bg_code
                         ansi256bg
  
                         rgb_to_ansi24b_fg_code
                         ansi24bfg
                         rgb_to_ansi24b_bg_code
                         ansi24bbg
  
                         rgb_to_ansi_fg_code
                         ansifg
                         rgb_to_ansi_bg_code
                         ansibg
                 );
  
  my %ansi16 = (
      0  => '000000',
      1  => '800000',
      2  => '008000',
      3  => '808000',
      4  => '000080',
      5  => '800080',
      6  => '008080',
      7  => 'c0c0c0',
      8  => '808080',
      9  => 'ff0000',
      10 => '00ff00',
      11 => 'ffff00',
      12 => '0000ff',
      13 => 'ff00ff',
      14 => '00ffff',
      15 => 'ffffff',
  );
  my @revansi16;
  for (sort {$a<=>$b} keys %ansi16) {
      $ansi16{$_} =~ /(..)(..)(..)/;
      push @revansi16, [hex($1), hex($2), hex($3), $_];
  }
  
  my %ansi256 = (
      %ansi16,
  
      16 => '000000',  17 => '00005f',  18 => '000087',  19 => '0000af',  20 => '0000d7',  21 => '0000ff',
      22 => '005f00',  23 => '005f5f',  24 => '005f87',  25 => '005faf',  26 => '005fd7',  27 => '005fff',
      28 => '008700',  29 => '00875f',  30 => '008787',  31 => '0087af',  32 => '0087d7',  33 => '0087ff',
      34 => '00af00',  35 => '00af5f',  36 => '00af87',  37 => '00afaf',  38 => '00afd7',  39 => '00afff',
      40 => '00d700',  41 => '00d75f',  42 => '00d787',  43 => '00d7af',  44 => '00d7d7',  45 => '00d7ff',
      46 => '00ff00',  47 => '00ff5f',  48 => '00ff87',  49 => '00ffaf',  50 => '00ffd7',  51 => '00ffff',
      52 => '5f0000',  53 => '5f005f',  54 => '5f0087',  55 => '5f00af',  56 => '5f00d7',  57 => '5f00ff',
      58 => '5f5f00',  59 => '5f5f5f',  60 => '5f5f87',  61 => '5f5faf',  62 => '5f5fd7',  63 => '5f5fff',
      64 => '5f8700',  65 => '5f875f',  66 => '5f8787',  67 => '5f87af',  68 => '5f87d7',  69 => '5f87ff',
      70 => '5faf00',  71 => '5faf5f',  72 => '5faf87',  73 => '5fafaf',  74 => '5fafd7',  75 => '5fafff',
      76 => '5fd700',  77 => '5fd75f',  78 => '5fd787',  79 => '5fd7af',  80 => '5fd7d7',  81 => '5fd7ff',
      82 => '5fff00',  83 => '5fff5f',  84 => '5fff87',  85 => '5fffaf',  86 => '5fffd7',  87 => '5fffff',
      88 => '870000',  89 => '87005f',  90 => '870087',  91 => '8700af',  92 => '8700d7',  93 => '8700ff',
      94 => '875f00',  95 => '875f5f',  96 => '875f87',  97 => '875faf',  98 => '875fd7',  99 => '875fff',
      100 => '878700', 101 => '87875f', 102 => '878787', 103 => '8787af', 104 => '8787d7', 105 => '8787ff',
      106 => '87af00', 107 => '87af5f', 108 => '87af87', 109 => '87afaf', 110 => '87afd7', 111 => '87afff',
      112 => '87d700', 113 => '87d75f', 114 => '87d787', 115 => '87d7af', 116 => '87d7d7', 117 => '87d7ff',
      118 => '87ff00', 119 => '87ff5f', 120 => '87ff87', 121 => '87ffaf', 122 => '87ffd7', 123 => '87ffff',
      124 => 'af0000', 125 => 'af005f', 126 => 'af0087', 127 => 'af00af', 128 => 'af00d7', 129 => 'af00ff',
      130 => 'af5f00', 131 => 'af5f5f', 132 => 'af5f87', 133 => 'af5faf', 134 => 'af5fd7', 135 => 'af5fff',
      136 => 'af8700', 137 => 'af875f', 138 => 'af8787', 139 => 'af87af', 140 => 'af87d7', 141 => 'af87ff',
      142 => 'afaf00', 143 => 'afaf5f', 144 => 'afaf87', 145 => 'afafaf', 146 => 'afafd7', 147 => 'afafff',
      148 => 'afd700', 149 => 'afd75f', 150 => 'afd787', 151 => 'afd7af', 152 => 'afd7d7', 153 => 'afd7ff',
      154 => 'afff00', 155 => 'afff5f', 156 => 'afff87', 157 => 'afffaf', 158 => 'afffd7', 159 => 'afffff',
      160 => 'd70000', 161 => 'd7005f', 162 => 'd70087', 163 => 'd700af', 164 => 'd700d7', 165 => 'd700ff',
      166 => 'd75f00', 167 => 'd75f5f', 168 => 'd75f87', 169 => 'd75faf', 170 => 'd75fd7', 171 => 'd75fff',
      172 => 'd78700', 173 => 'd7875f', 174 => 'd78787', 175 => 'd787af', 176 => 'd787d7', 177 => 'd787ff',
      178 => 'd7af00', 179 => 'd7af5f', 180 => 'd7af87', 181 => 'd7afaf', 182 => 'd7afd7', 183 => 'd7afff',
      184 => 'd7d700', 185 => 'd7d75f', 186 => 'd7d787', 187 => 'd7d7af', 188 => 'd7d7d7', 189 => 'd7d7ff',
      190 => 'd7ff00', 191 => 'd7ff5f', 192 => 'd7ff87', 193 => 'd7ffaf', 194 => 'd7ffd7', 195 => 'd7ffff',
      196 => 'ff0000', 197 => 'ff005f', 198 => 'ff0087', 199 => 'ff00af', 200 => 'ff00d7', 201 => 'ff00ff',
      202 => 'ff5f00', 203 => 'ff5f5f', 204 => 'ff5f87', 205 => 'ff5faf', 206 => 'ff5fd7', 207 => 'ff5fff',
      208 => 'ff8700', 209 => 'ff875f', 210 => 'ff8787', 211 => 'ff87af', 212 => 'ff87d7', 213 => 'ff87ff',
      214 => 'ffaf00', 215 => 'ffaf5f', 216 => 'ffaf87', 217 => 'ffafaf', 218 => 'ffafd7', 219 => 'ffafff',
      220 => 'ffd700', 221 => 'ffd75f', 222 => 'ffd787', 223 => 'ffd7af', 224 => 'ffd7d7', 225 => 'ffd7ff',
      226 => 'ffff00', 227 => 'ffff5f', 228 => 'ffff87', 229 => 'ffffaf', 230 => 'ffffd7', 231 => 'ffffff',
  
      232 => '080808', 233 => '121212', 234 => '1c1c1c', 235 => '262626', 236 => '303030', 237 => '3a3a3a',
      238 => '444444', 239 => '4e4e4e', 240 => '585858', 241 => '606060', 242 => '666666', 243 => '767676',
      244 => '808080', 245 => '8a8a8a', 246 => '949494', 247 => '9e9e9e', 248 => 'a8a8a8', 249 => 'b2b2b2',
      250 => 'bcbcbc', 251 => 'c6c6c6', 252 => 'd0d0d0', 253 => 'dadada', 254 => 'e4e4e4', 255 => 'eeeeee',
  );
  my @revansi256;
  for (sort {$a<=>$b} keys %ansi256) {
      $ansi256{$_} =~ /(..)(..)(..)/;
      push @revansi256, [hex($1), hex($2), hex($3), $_];
  }
  
  sub ansi16_to_rgb {
      my ($input) = @_;
  
      if ($input =~ /^\d+$/) {
          if ($input >= 0 && $input <= 15) {
              return $ansi16{$input + 0}; # to remove prefix zero e.g. "06"
          } else {
              die "Invalid ANSI 16-color number '$input'";
          }
      } elsif ($input =~ /^(?:(bold|bright) \s )?
                          (black|red|green|yellow|blue|magenta|cyan|white)$/ix) {
          my ($bold, $col) = (lc($1 // ""), lc($2));
          my $i;
          if ($col eq 'black') {
              $i = 0;
          } elsif ($col eq 'red') {
              $i = 1;
          } elsif ($col eq 'green') {
              $i = 2;
          } elsif ($col eq 'yellow') {
              $i = 3;
          } elsif ($col eq 'blue') {
              $i = 4;
          } elsif ($col eq 'magenta') {
              $i = 5;
          } elsif ($col eq 'cyan') {
              $i = 6;
          } elsif ($col eq 'white') {
              $i = 7;
          }
          $i += 8 if $bold;
          return $ansi16{$i};
      } else {
          die "Invalid ANSI 16-color name '$input'";
      }
  }
  
  sub _rgb_to_indexed {
      my ($rgb, $table) = @_;
  
      $rgb =~ /^#?([0-9A-Fa-f]{2})([0-9A-Fa-f]{2})([0-9A-Fa-f]{2})$/
          or die "Invalid RGB input '$rgb'";
      my $r = hex($1);
      my $g = hex($2);
      my $b = hex($3);
  
      my ($minsqdist, $res);
      for my $e (@$table) {
          my $sqdist =
              abs($e->[0]-$r)**2 + abs($e->[1]-$g)**2 + abs($e->[2]-$b)**2;
          # exact match, return immediately
          return $e->[3] if $sqdist == 0;
          if (!defined($minsqdist) || $minsqdist > $sqdist) {
              #say "D:sqdist=$sqdist";
              $minsqdist = $sqdist;
              $res = $e->[3];
          }
      }
      return $res;
  }
  
  sub ansi256_to_rgb {
      my ($input) = @_;
  
      $input += 0;
      exists($ansi256{$input}) or die "Invalid ANSI 256-color index '$input'";
      $ansi256{$input};
  }
  
  sub rgb_to_ansi16 {
      my ($input) = @_;
      _rgb_to_indexed($input, \@revansi16);
  }
  
  sub rgb_to_ansi256 {
      my ($input) = @_;
      _rgb_to_indexed($input, \@revansi256);
  }
  
  sub rgb_to_ansi16_fg_code {
      my ($input) = @_;
  
      my $res = _rgb_to_indexed($input, \@revansi16);
      return "\e[" . ($res >= 8 ? ($res+30-8) . ";1" : ($res+30)) . "m";
  }
  
  sub ansi16fg  { goto &rgb_to_ansi16_fg_code  }
  
  sub rgb_to_ansi16_bg_code {
      my ($input) = @_;
  
      my $res = _rgb_to_indexed($input, \@revansi16);
      return "\e[" . ($res >= 8 ? ($res+40-8) : ($res+40)) . "m";
  }
  
  sub ansi16bg  { goto &rgb_to_ansi16_bg_code  }
  
  sub rgb_to_ansi256_fg_code {
      my ($input) = @_;
  
      my $res = _rgb_to_indexed($input, \@revansi16);
      return "\e[38;5;${res}m";
  }
  
  sub ansi256fg { goto &rgb_to_ansi256_fg_code }
  
  sub rgb_to_ansi256_bg_code {
      my ($input) = @_;
  
      my $res = _rgb_to_indexed($input, \@revansi16);
      return "\e[48;5;${res}m";
  }
  
  sub ansi256bg { goto &rgb_to_ansi256_bg_code }
  
  sub rgb_to_ansi24b_fg_code {
      my ($rgb) = @_;
  
      return sprintf("\e[38;2;%d;%d;%dm",
                     hex(substr($rgb, 0, 2)),
                     hex(substr($rgb, 2, 2)),
                     hex(substr($rgb, 4, 2)));
  }
  
  sub ansi24bfg { goto &rgb_to_ansi24b_fg_code }
  
  sub rgb_to_ansi24b_bg_code {
      my ($rgb) = @_;
  
      return sprintf("\e[48;2;%d;%d;%dm",
                     hex(substr($rgb, 0, 2)),
                     hex(substr($rgb, 2, 2)),
                     hex(substr($rgb, 4, 2)));
  }
  
  sub ansi24bbg { goto &rgb_to_ansi24b_bg_code }
  
  our $_use_termdetsw = 1;
  our $_color_depth; # cache, can be set during testing
  sub _color_depth {
      unless (defined $_color_depth) {
          {
              if (defined $ENV{COLOR_DEPTH}) {
                  $_color_depth = $ENV{COLOR_DEPTH};
                  last;
              }
              if ($_use_termdetsw) {
                  eval { require Term::Detect::Software };
                  if (!$@) {
                      $_color_depth = Term::Detect::Software::detect_terminal_cached()->{color_depth};
                      last;
                  }
              }
              # simple heuristic
              if ($ENV{KONSOLE_DBUS_SERVICE}) {
                  $_color_depth = 2**24;
                  last;
              }
              # safe value
              $_color_depth = 16;
          }
      };
      $_color_depth;
  }
  
  sub rgb_to_ansi_fg_code {
      my ($rgb) = @_;
      my $cd = _color_depth();
      if ($cd >= 2**24) {
          rgb_to_ansi24b_fg_code($rgb);
      } elsif ($cd >= 256) {
          rgb_to_ansi256_fg_code($rgb);
      } else {
          rgb_to_ansi16_fg_code($rgb);
      }
  }
  
  sub ansifg { goto &rgb_to_ansi_fg_code }
  
  sub rgb_to_ansi_bg_code {
      my ($rgb) = @_;
      my $cd = _color_depth();
      if ($cd >= 2**24) {
          rgb_to_ansi24b_bg_code($rgb);
      } elsif ($cd >= 256) {
          rgb_to_ansi256_bg_code($rgb);
      } else {
          rgb_to_ansi16_bg_code($rgb);
      }
  }
  
  sub ansibg { goto &rgb_to_ansi_bg_code }
  
  1;
  # ABSTRACT: Routines for dealing with ANSI colors
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Color::ANSI::Util - Routines for dealing with ANSI colors
  
  =head1 VERSION
  
  This document describes version 0.14 of Color::ANSI::Util (from Perl distribution Color-ANSI-Util), released on 2015-01-03.
  
  =head1 SYNOPSIS
  
   use Color::ANSI::Util qw(
       ansifg
       ansibg
   );
  
   say ansifg("f0c010"); # => "\e[33;1m" (on 16-color terminal)
                         # => "\e[38;5;11m" (on 256-color terminal)
                         # => "\e[38;2;240;192;16m" (on 24-bit-color terminal)
  
   say ansibg("ff5f87"); # => "\e[47m" (on 16-color terminal)
                         # => "\e[48;5;7m" (on 256-color terminal)
                         # => "\e[48;2;255;95;135m" (on 24-bit-color terminal)
  
  There are a bunch of other exportable functions too, mostly for converting
  between RGB and ANSI color (16/256/24bit color depth).
  
  =head1 DESCRIPTION
  
  This module provides routines for dealing with ANSI colors. The two main
  functions are C<ansifg> and C<ansibg>. With those functions, you can specify
  colors in RGB and let it output the correct ANSI color escape code according to
  the color depth support of the terminal (whether 16-color, 256-color, or 24bit).
  There are other functions to convert RGB to ANSI in specific color depths, or
  reverse functions to convert from ANSI to RGB codes.
  
  Keywords: xterm, xterm-256color, terminal
  
  =head1 FUNCTIONS
  
  =head2 ansi16_to_rgb($color) => STR
  
  Convert ANSI-16 color to RGB. C<$color> is number from 0-15, or color names
  "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" with
  "bold" to indicate bold/bright. Return 6-hexdigit, e.g. "ff00cc".
  
  Die on invalid input.
  
  =head2 rgb_to_ansi16($color) => INT
  
  Convert RGB to ANSI-16 color. C<$color> is 6-hexdigit RGB color like "ff00cc".
  Will pick the closest color. Return number from 0-15.
  
  Die on invalid input.
  
  =head2 ansi256_to_rgb($color) => STR
  
  Convert ANSI-256 color to RGB. C<$color> is a number from 0-255. Return
  6-hexdigit, e.g. "ff00cc".
  
  Die on invalid input.
  
  =head2 rgb_to_ansi256($color) => INT
  
  Convert RGB to ANSI-256 color. C<$color> is 6-hexdigit RGB color like "ff00cc".
  Will pick the closest color. Return number between 0-255.
  
  Die on invalid input.
  
  =head2 rgb_to_ansi16_fg_code($rgb) => STR
  
  =head2 ansi16fg($rgb) => STR
  
  Alias for rgb_to_ansi16_fg_code().
  
  =head2 rgb_to_ansi16_bg_code($rgb) => STR
  
  =head2 ansi16bg($rgb) => STR
  
  Alias for rgb_to_ansi16_bg_code().
  
  =head2 rgb_to_ansi256_fg_code($rgb) => STR
  
  =head2 ansi256fg($rgb) => STR
  
  Alias for rgb_to_ansi256_fg_code().
  
  =head2 rgb_to_ansi256_bg_code($rgb) => STR
  
  =head2 ansi256bg($rgb) => STR
  
  Alias for rgb_to_ansi256_bg_code().
  
  =head2 rgb_to_ansi24b_fg_code($rgb) => STR
  
  Return ANSI escape code to set 24bit foreground color. Supported by Konsole and
  Yakuake.
  
  =head2 ansi24bfg($rgb) => STR
  
  Alias for rgb_to_ansi24b_fg_code().
  
  =head2 rgb_to_ansi24b_bg_code($rgb) => STR
  
  Return ANSI escape code to set 24bit background color. Supported by Konsole and
  Yakuake.
  
  =head2 ansi24bbg($rgb) => STR
  
  Alias for rgb_to_ansi24b_bg_code().
  
  =head2 rgb_to_ansi_fg_code($rgb) => STR
  
  Return ANSI escape code to set 24bit/256/16 foreground color (which color depth
  used is determined by C<COLOR_DEPTH> environment setting or from
  L<Term::Detect::Software> if that module is available). In other words, this
  function automatically chooses rgb_to_ansi{24b,256,16}_fg_code().
  
  =head2 ansifg($rgb) => STR
  
  Alias for rgb_to_ansi_fg_code().
  
  =head2 rgb_to_ansi_bg_code($rgb) => STR
  
  Return ANSI escape code to set 24bit/256/16 background color (which color depth
  used is determined by C<COLOR_DEPTH> environment setting or from
  Term::Detect::Software if that module is available). In other words, this
  function automatically chooses rgb_to_ansi{24b,256,16}_bg_code().
  
  =head2 ansibg($rgb) => STR
  
  Alias for rgb_to_ansi_bg_code().
  
  =head1 ENVIRONMENT
  
  =head2 COLOR_DEPTH => INT
  
  Observed by: ansi{fg,bg}.
  
  =head1 BUGS/NOTES
  
  Algorithm for finding closest indexed color from RGB color currently not very
  efficient. Probably can add some threshold square distance, below which we can
  shortcut to the final answer.
  
  =head1 SEE ALSO
  
  L<Term::ANSIColor>
  
  L<http://en.wikipedia.org/wiki/ANSI_escape_code>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Color-ANSI-Util>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Color-ANSI-Util>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Color-ANSI-Util>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
COLOR_ANSI_UTIL

$fatpacked{"Complete.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'COMPLETE';
  package Complete;
  
  our $DATE = '2015-03-04'; # DATE
  our $VERSION = '0.12'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  our $OPT_CI          = ($ENV{COMPLETE_OPT_CI}          // 1) ? 1:0;
  our $OPT_MAP_CASE    = ($ENV{COMPLETE_OPT_MAP_CASE}    // 1) ? 1:0;
  our $OPT_EXP_IM_PATH = ($ENV{COMPLETE_OPT_EXP_IM_PATH} // 1) ? 1:0;
  our $OPT_EXP_IM_PATH_MAX_LEN = ($ENV{COMPLETE_OPT_EXP_IM_PATH_MAX_LEN} // 2)+0;
  our $OPT_DIG_LEAF    = ($ENV{COMPLETE_OPT_DIG_LEAF}    // 1) ? 1:0;
  
  1;
  # ABSTRACT: Convention for Complete::* modules family and common settings
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Complete - Convention for Complete::* modules family and common settings
  
  =head1 VERSION
  
  This document describes version 0.12 of Complete (from Perl distribution Complete), released on 2015-03-04.
  
  =head1 DESCRIPTION
  
  The namespace C<Complete::> is used for the family of modules that deal with
  completion (including, but not limited to, shell tab completion, tab completion
  feature in other CLI-based application, web autocomplete, completion in GUI,
  etc). This (family of) modules try to have a clear separation between general
  completion routine and shell-/environment specific ones, for more reusability.
  
  This POD page gives an overview of the modules in C<Complete::*> namespace,
  establishes convention, and declares common settings.
  
  =head2 Modules
  
  =head3 Generic (non-environment-specific) modules
  
  Modules usually are named after the type of completion answer they provide. For
  example: L<Complete::Unix> completes username/group name,
  L<Complete::Getopt::Long> completes from L<Getopt::Long> specification,
  L<Complete::Module> completes Perl module names, and so on. A current exception
  is L<Complete::Util> which contains several routines to complete from
  common/generic sources (array, hash, file, environment).
  
  =head3 Environment-specific modules
  
  C<Complete::Bash::*> modules are specific to bash shell. See L<Complete::Bash>
  on some of the ways to do bash tab completion with Perl. Other shells are also
  supported. For shell-specific information, please refer to L<Complete::Zsh>,
  L<Complete::Tcsh>, L<Complete::Fish>, as well as their submodules.
  
  C<Complete::*> modules for non-shell environment (like browser or GUI) have not
  been developed. Please check again from time to time in the future.
  
  =head2 C<complete_*()> functions
  
  The main functions that do the actual completion are the C<complete_*()>
  functions. These functions are generic completion routines: they accept the word
  to be completed, zero or more other arguments, and return a completion answer
  structure (see L</"Completion answer structure">).
  
   use Complete::Util qw(complete_array_elem);
   my $ary = complete_array_elem(array=>[qw/apple apricot banana/], word=>'ap');
   # -> ['apple', 'apricot']
  
  Convention for C<complete_*> function:
  
  =over
  
  =item * Accept a hash argument
  
  Example:
  
   complete_array_elem(%args)
  
  Required arguments: C<word> (the word to be completed). Sometimes, for
  lower-level functions, you can accept C<words> and C<cword> instead of C<word>,
  For example, in function C<Complete::Getopt::Long::complete_cli_arg>.
  
  Optional common arguments: C<ci> (bool, whether the matching should be
  case-insensitive, if unspecified should default to C<$Complete::OPT_CI>).
  
  Other arguments: you can define more arguments as you fit. Often there is at
  least one argument to specify or customize the source of completion, for example
  for the function C<Complete::Util::complete_array_elem> there is an C<array>
  argument to specify the source array.
  
  =item * Return completion answer structure
  
  See L</"Completion answer structure">.
  
  =item * Use defaults from global Complete settings, when applicable
  
  See L<"/SETTINGS">
  
  =back
  
  =head2 Completion answer structure
  
  C<complete_*()> functions return completion answer structure. Completion answer
  contains the completion entries as well as extra metadata to give hints to
  formatters/tools. It is a hashref which can contain the following keys:
  
  =over
  
  =item * words => array
  
  This key is required. Its value is an array of completion entries. A completion
  entry can be a string or a hashref. Example:
  
   ['apple', 'apricot'] # array of strings
  
   [{word=>'apple', summary=>'A delicious fruit with thousands of varieties'},
    {word=>'apricot', summary=>'Another delicious fruit'},] # array of hashes
  
  As you can see from the above, each entry can contain description (can be
  displayed in shells that support them, like fish and zsh).
  
  =item * type => str
  
  See L<Complete::Bash>.
  
  =item * path_sep => str
  
  See L<Complete::Bash>.
  
  =item * esc_mode => str
  
  See L<Complete::Bash>.
  
  =item * static => bool
  
  Specify that completion is "static", meaning that it does not depend on external
  state (like filesystem) or a custom code which can return different answer
  everytime completion is requested.
  
  This can be useful for code that wants to generate completion code, like bash
  completion or fish completion. Knowing that completion for an option value is
  static means that completion for that option can be answered from an array
  instead of having to call code/program (faster).
  
  =back
  
  As a shortcut, completion answer can also be an arrayref (just the C<words>)
  without any metadata.
  
  Examples:
  
   # hash form
   {words=>[qw/apple apricot/]}
  
   # another hash form. type=env instructs formatter not to escape '$'
   {words=>[qw/$HOME $ENV/], type=>'env'}
  
   # array form
   ['apple', 'apricot']
  
   # another array form, each entry is a hashref to include description
   [{word=>'apple', summary=>'A delicious fruit with thousands of varieties'},
    {word=>'apricot', summary=>'Another delicious fruit'},] # array of hashes
  
  =head1 SETTINGS
  
  This module also defines some configuration variable. C<Complete::*> modules
  should use the default from these settings, to make it convenient for users to
  change some behavior globally.
  
  The defaults are optimized for convenience and laziness for user typing and
  might change from release to release.
  
  =head2 C<$Complete::OPT_CI> => bool (default: from COMPLETE_OPT_CI or 1)
  
  If set to 1, matching is done case-insensitively. This setting should be
  consulted as the default for all C<ci> arguments in the C<complete_*> functions.
  But users can override this setting by providing value to C<ci> argument.
  
  In bash/readline, this is akin to setting C<completion-ignore-case>.
  
  =head2 C<$Complete::OPT_MAP_CASE> => bool (default: from COMPLETE_OPT_MAP_CASE or 1)
  
  This is exactly like C<completion-map-case> in readline/bash to treat C<_> and
  C<-> as the same when matching.
  
  All L<Complete::Path>-based modules (like L<Complete::Util>'s
  C<complete_file()>), L<Complete::Module>, or L<Complete::Riap> respect this
  setting.
  
  =head2 C<$Complete::OPT_EXP_IM_PATH> => bool (default: from COMPLETE_OPT_EXP_IM_PATH or 1)
  
  Whether to "expand intermediate paths". What is meant by this is something like
  zsh: when you type something like C<cd /h/u/b/myscript> it can be completed to
  C<cd /home/ujang/bin/myscript>.
  
  All L<Complete::Path>-based modules (like L<Complete::Util>'s
  C<complete_file()>, L<Complete::Module>, or L<Complete::Riap>) respect this
  setting.
  
  =head2 C<$Complete::OPT_EXP_IM_PATH_MAX_LEN> => int (default: from COMPLETE_OPT_EXP_IM_PATH_MAX_LEN or 2)
  
  Wehn OPT_EXP_IM_PATH is active, because of the way bash does completion (it cuts
  current word to the shortest common denominator of all completion candidates),
  in some cases this can be annoying because it prevents completion to be done the
  way we want. For example:
  
   l/D/Zi/Plugi/Author<tab>
  
  if we have:
  
   lib/Dist/Zilla/Plugin/Author/
   lib/Dist/Zilla/PluginBundle/Author/
  
  the completion candidates are both the above, and bash cuts our word at the
  buffer to:
  
   lib/Dist/Zilla/Plugin
  
  even if we type C</> and then Tab like this:
  
   lib/Dist/Zilla/Plugin/<tab>
  
  bash will again cuts the buffer to become:
  
   lib/Dist/Zilla/Plugin
  
  To work around (or compromise around) this, the setting
  C<OPT_EXP_IM_PATH_MAX_LEN> is introduced. The default is 2. So if a path element
  is over 2 characters long, expand will not be done. This means in this path:
  
   l/D/Zi/Plugi/Author<tab>
  
  we expand C<l>, C<D>, C<Zi>, but not C<Plugi>. So to get expansion you'll have
  to write:
  
   l/D/Zi/P/Author<tab>
   l/D/Zi/Pl/Author<tab>
  
  which is usually fine.
  
  =head2 C<$Complete::OPT_DIG_LEAF> => bool (default: from COMPLETE_OPT_DIG_LEAF or 1)
  
  (Experimental) When enabled, this option mimics what's seen on GitHub. If a
  directory entry only contains a single subentry, it will directly show the
  subentry (and subsubentry and so on) to save a number of tab presses.
  
  Suppose you have files like this:
  
   a
   b/c/d/e
   c
  
  If you complete for C<b> you will directly get C<b/c/d/e> (the leaf).
  
  This is currently experimental because if you want to complete only directories,
  you won't get b or b/c or b/c/d. Need to think how to solve this.
  
  =head1 ENVIRONMENT
  
  =head2 COMPLETE_OPT_CI => bool
  
  Set default for C<$Complete::OPT_CI>.
  
  =head2 COMPLETE_OPT_MAP_CASE => bool
  
  Set default for C<$Complete::OPT_MAP_CASE>.
  
  =head2 COMPLETE_OPT_EXP_IM_PATH => bool
  
  Set default for C<$Complete::OPT_EXP_IM_PATH>.
  
  =head2 COMPLETE_OPT_EXP_IM_PATH_MAX_LEN => int
  
  Set default for C<$Complete::OPT_EXP_IM_PATH_MAX_LEN>.
  
  =head2 COMPLETE_OPT_DIG_LEAF => bool
  
  Set default for C<$Complete::OPT_DIG_LEAF>.
  
  =head1 SEE ALSO
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Complete>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Complete>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
COMPLETE

$fatpacked{"Complete/Bash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'COMPLETE_BASH';
  package Complete::Bash;
  
  our $DATE = '2015-04-02'; # DATE
  our $VERSION = '0.19'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  #use Complete;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         parse_cmdline
                         parse_options
                         format_completion
                 );
  
  our %SPEC;
  
  $SPEC{':package'} = {
      v => 1.1,
      summary => 'Completion module for bash shell',
      links => [
          {url => 'pm:Complete'},
      ],
  };
  
  sub _expand_tilde {
      my ($user, $slash) = @_;
      my @ent;
      if (length $user) {
          @ent = getpwnam($user);
      } else {
          @ent = getpwuid($>);
          $user = $ent[0];
      }
      return $ent[7] . $slash if @ent;
      "~$user$slash"; # return as-is when failed
  }
  
  sub _add_unquoted {
      no warnings 'uninitialized';
  
      my ($word, $is_cur_word, $after_ws) = @_;
  
      #say "D:add_unquoted word=$word is_cur_word=$is_cur_word after_ws=$after_ws";
  
      $word =~ s!^(~)(\w*)(/|\z) |  # 1) tilde  2) username  3) optional slash
                 \\(.)           |  # 4) escaped char
                 \$(\w+)            # 5) variable name
                !
                    $1 ? (not($after_ws) || $is_cur_word ? "$1$2$3" : _expand_tilde($2, $3)) :
                        $4 ? $4 :
                            ($is_cur_word ? "\$$5" : $ENV{$5})
                                !egx;
      $word;
  }
  
  sub _add_double_quoted {
      no warnings 'uninitialized';
  
      my ($word, $is_cur_word) = @_;
  
      $word =~ s!\\(.)           |  # 1) escaped char
                 \$(\w+)            # 2) variable name
                !
                    $1 ? $1 :
                        ($is_cur_word ? "\$$2" : $ENV{$2})
                            !egx;
      $word;
  }
  
  sub _add_single_quoted {
      my $word = shift;
      $word =~ s/\\(.)/$1/g;
      $word;
  }
  
  $SPEC{parse_cmdline} = {
      v => 1.1,
      summary => 'Parse shell command-line for processing by completion routines',
      description => <<'_',
  
  This function basically converts COMP_LINE (str) and COMP_POINT (int) into
  something like (but not exactly the same as) COMP_WORDS (array) and COMP_CWORD
  (int) that bash supplies to shell functions.
  
  The differences with bash are (these differences are mostly for parsing
  convenience for programs that use this routine):
  
  1) quotes and backslashes are stripped (bash's COMP_WORDS contains all the
  quotes and backslashes);
  
  2) variables are substituted with their values from environment variables except
  for the current word (COMP_WORDS[COMP_CWORD]) (bash does not perform variable
  substitution for COMP_WORDS). However, note that special shell variables that
  are not environment variables like `$0`, `$_`, `$IFS` will not be replaced
  correctly because bash does not export those variables for us.
  
  3) tildes (~) are expanded with user's home directory except for the current
  word (bash does not perform tilde expansion for COMP_WORDS);
  
  4) no word-breaking characters aside from whitespaces and `=` are currently used
  (bash uses COMP_WORDBREAKS which by default also include `:`, `;`, and so on).
  This is done for convenience of parsing of Getopt::Long-based applications. More
  word-breaking characters might be used in the future, e.g. when we want to
  handle complex bash statements like pipes, redirection, etc.
  
  Caveats:
  
  * Due to the way bash parses the command line, the two below are equivalent:
  
      % cmd --foo=bar
      % cmd --foo = bar
  
  Because they both expand to `['--foo', '=', 'bar']`. But obviously
  `Getopt::Long` does not regard the two as equivalent.
  
  _
      args_as => 'array',
      args => {
          cmdline => {
              summary => 'Command-line, defaults to COMP_LINE environment',
              schema => 'str*',
              pos => 0,
          },
          point => {
              summary => 'Point/position to complete in command-line, '.
                  'defaults to COMP_POINT',
              schema => 'int*',
              pos => 1,
          },
      },
      result => {
          schema => ['array*', len=>2],
          description => <<'_',
  
  Return a 2-element array: `[$words, $cword]`. `$words` is array of str,
  equivalent to `COMP_WORDS` provided by bash to shell functions. `$cword` is an
  integer, equivalent to `COMP_CWORD` provided by bash to shell functions. The
  word to be completed is at `$words->[$cword]`.
  
  Note that COMP_LINE includes the command name. If you want the command-line
  arguments only (like in `@ARGV`), you need to strip the first element from
  `$words` and reduce `$cword` by 1.
  
  
  _
      },
      result_naked => 1,
      links => [
      ],
  };
  sub parse_cmdline {
      no warnings 'uninitialized';
      my ($line, $point) = @_;
  
      $line  //= $ENV{COMP_LINE};
      $point //= $ENV{COMP_POINT} // 0;
  
      die "$0: COMP_LINE not set, make sure this script is run under ".
          "bash completion (e.g. through complete -C)\n" unless defined $line;
  
      my @words;
      my $cword;
      my $pos = 0;
      my $pos_min_ws = 0;
      my $after_ws = 1;
      my $chunk;
      my $add_blank;
      my $is_cur_word;
      $line =~ s!(                                                 # 1) everything
                    (")((?: \\\\|\\"|[^"])*)(?:"|\z)(\s*)       |  # 2) open "  3) content  4) space after
                    (')((?: \\\\|\\'|[^'])*)(?:'|\z)(\s*)       |  # 5) open '  6) content  7) space after
                    ((?: \\\\|\\"|\\'|\\=|\\\s|[^"'=\s])+)(\s*) |  # 8) unquoted word  9) space after
                    = |
                    \s+
                )!
                    $pos += length($1);
                    #say "D:<$1> pos=$pos, point=$point, cword=$cword, after_ws=$after_ws";
  
                    if ($2 || $5 || defined($8)) {
                        # double-quoted/single-quoted/unquoted chunk
  
                        if (not(defined $cword)) {
                            $pos_min_ws = $pos - length($2 ? $4 : $5 ? $7 : $9);
                            #say "D:pos_min_ws=$pos_min_ws";
                            if ($point <= $pos_min_ws) {
                                $cword = @words - ($after_ws ? 0 : 1);
                            } elsif ($point < $pos) {
                                $cword = @words + 1 - ($after_ws ? 0 : 1);
                                $add_blank = 1;
                            }
                        }
  
                        if ($after_ws) {
                            $is_cur_word = defined($cword) && $cword==@words;
                        } else {
                            $is_cur_word = defined($cword) && $cword==@words-1;
                        }
                        $chunk =
                            $2 ? _add_double_quoted($3, $is_cur_word) :
                                $5 ? _add_single_quoted($6) :
                                    _add_unquoted($8, $is_cur_word, $after_ws);
                        if ($after_ws) {
                            push @words, $chunk;
                        } else {
                            $words[-1] .= $chunk;
                        }
                        if ($add_blank) {
                            push @words, '';
                            $add_blank = 0;
                        }
                        $after_ws = ($2 ? $4 : $5 ? $7 : $9) ? 1:0;
  
                    } elsif ($1 eq '=') {
                        # equal sign as word-breaking character
                        push @words, '=';
                        $after_ws = 1;
                    } else {
                        # whitespace
                        $after_ws = 1;
                    }
      !egx;
  
      $cword //= @words;
      $words[$cword] //= '';
  
      [\@words, $cword];
  }
  
  $SPEC{parse_options} = {
      v => 1.1,
      summary => 'Parse command-line for options and arguments, '.
          'more or less like Getopt::Long',
      description => <<'_',
  
  Parse command-line into words using `parse_cmdline()` then separate options and
  arguments. Since this routine does not accept `Getopt::Long` (this routine is
  meant to be a generic option parsing of command-lines), it uses a few simple
  rules to server the common cases:
  
  * After `--`, the rest of the words are arguments (just like Getopt::Long).
  
  * If we get something like `-abc` (a single dash followed by several letters) it
    is assumed to be a bundle of short options.
  
  * If we get something like `-MData::Dump` (a single dash, followed by a letter,
    followed by some letters *and* non-letters/numbers) it is assumed to be an
    option (`-M`) followed by a value.
  
  * If we get something like `--foo` it is a long option. If the next word is an
    option (starts with a `-`) then it is assumed that this option does not have
    argument. Otherwise, the next word is assumed to be this option's value.
  
  * Otherwise, it is an argument (that is, permute is assumed).
  
  _
  
      args => {
          cmdline => {
              summary => 'Command-line, defaults to COMP_LINE environment',
              schema => 'str*',
          },
          point => {
              summary => 'Point/position to complete in command-line, '.
                  'defaults to COMP_POINT',
              schema => 'int*',
          },
          words => {
              summary => 'Alternative to passing `cmdline` and `point`',
              schema => ['array*', of=>'str*'],
              description => <<'_',
  
  If you already did a `parse_cmdline()`, you can pass the words result (the first
  element) here to avoid calling `parse_cmdline()` twice.
  
  _
          },
          cword => {
              summary => 'Alternative to passing `cmdline` and `point`',
              schema => ['array*', of=>'str*'],
              description => <<'_',
  
  If you already did a `parse_cmdline()`, you can pass the cword result (the
  second element) here to avoid calling `parse_cmdline()` twice.
  
  _
          },
      },
      result => {
          schema => 'hash*',
      },
  };
  sub parse_options {
      my %args = @_;
  
      my ($words, $cword) = @_;
      if ($args{words}) {
          ($words, $cword) = ($args{words}, $args{cword});
      } else {
          ($words, $cword) = @{parse_cmdline($args{cmdline}, $args{point}, '=')};
      }
  
      my @types;
      my %opts;
      my @argv;
      my $type;
      $types[0] = 'command';
      my $i = 1;
      while ($i < @$words) {
          my $word = $words->[$i];
          if ($word eq '--') {
              if ($i == $cword) {
                  $types[$i] = 'opt_name';
                  $i++; next;
              }
              $types[$i] = 'separator';
              for ($i+1 .. @$words-1) {
                  $types[$_] = 'arg,' . @argv;
                  push @argv, $words->[$_];
              }
              last;
          } elsif ($word =~ /\A-(\w*)\z/) {
              $types[$i] = 'opt_name';
              for (split '', $1) {
                  push @{ $opts{$_} }, undef;
              }
              $i++; next;
          } elsif ($word =~ /\A-([\w?])(.*)/) {
              $types[$i] = 'opt_name';
              # XXX currently not completing option value
              push @{ $opts{$1} }, $2;
              $i++; next;
          } elsif ($word =~ /\A--(\w[\w-]*)\z/) {
              $types[$i] = 'opt_name';
              my $opt = $1;
              $i++;
              if ($i < @$words) {
                  if ($words->[$i] eq '=') {
                      $types[$i] = 'separator';
                      $i++;
                  }
                  if ($words->[$i] =~ /\A-/) {
                      push @{ $opts{$opt} }, undef;
                      next;
                  }
                  $types[$i] = 'opt_val';
                  push @{ $opts{$opt} }, $words->[$i];
                  $i++; next;
              }
          } else {
              $types[$i] = 'arg,' . @argv;
              push @argv, $word;
              $i++; next;
          }
      }
  
      return {
          opts      => \%opts,
          argv      => \@argv,
          cword     => $cword,
          words     => $words,
          word_type => $types[$cword],
          #_types    => \@types,
      };
  }
  
  $SPEC{format_completion} = {
      v => 1.1,
      summary => 'Format completion for output (for shell)',
      description => <<'_',
  
  Bash accepts completion reply in the form of one entry per line to STDOUT. Some
  characters will need to be escaped. This function helps you do the formatting,
  with some options.
  
  This function accepts completion answer structure as described in the `Complete`
  POD. Aside from `words`, this function also recognizes these keys:
  
  * `as` (str): Either `string` (the default) or `array` (to return array of lines
    instead of the lines joined together). Returning array is useful if you are
    doing completion inside `Term::ReadLine`, for example, where the library
    expects an array.
  
  * `esc_mode` (str): Escaping mode for entries. Either `default` (most
    nonalphanumeric characters will be escaped), `shellvar` (like `default`, but
    dollar sign `$` will not be escaped, convenient when completing environment
    variables for example), `filename` (currently equals to `default`), `option`
    (currently equals to `default`), or `none` (no escaping will be done).
  
  * `path_sep` (str): If set, will enable "path mode", useful for
    completing/drilling-down path. Below is the description of "path mode".
  
    In shell, when completing filename (e.g. `foo`) and there is only a single
    possible completion (e.g. `foo` or `foo.txt`), the shell will display the
    completion in the buffer and automatically add a space so the user can move to
    the next argument. This is also true when completing other values like
    variables or program names.
  
    However, when completing directory (e.g. `/et` or `Downloads`) and there is
    solely a single completion possible and it is a directory (e.g. `/etc` or
    `Downloads`), the shell automatically adds the path separator character
    instead (`/etc/` or `Downloads/`). The user can press Tab again to complete
    for files/directories inside that directory, and so on. This is obviously more
    convenient compared to when shell adds a space instead.
  
    The `path_sep` option, when set, will employ a trick to mimic this behaviour.
    The trick is, if you have a completion array of `['foo/']`, it will be changed
    to `['foo/', 'foo/ ']` (the second element is the first element with added
    space at the end) to prevent bash from adding a space automatically.
  
    Path mode is not restricted to completing filesystem paths. Anything path-like
    can use it. For example when you are completing Java or Perl module name (e.g.
    `com.company.product.whatever` or `File::Spec::Unix`) you can use this mode
    (with `path_sep` appropriately set to, e.g. `.` or `::`).
  
  _
      args_as => 'array',
      args => {
          completion => {
              summary => 'Completion answer structure',
              description => <<'_',
  
  Either an array or hash. See function description for more details.
  
  _
              schema=>['any*' => of => ['hash*', 'array*']],
              req=>1,
              pos=>0,
          },
          opts => {
              schema=>'hash*',
              pos=>1,
          },
      },
      result => {
          summary => 'Formatted string (or array, if `as` is set to `array`)',
          schema => ['any*' => of => ['str*', 'array*']],
      },
      result_naked => 1,
  };
  sub format_completion {
      my ($hcomp, $opts) = @_;
  
      $opts //= {};
  
      $hcomp = {words=>$hcomp} unless ref($hcomp) eq 'HASH';
      my $comp     = $hcomp->{words};
      my $as       = $hcomp->{as} // 'string';
      # 'escmode' key is deprecated (Complete 0.11-) and will be removed later
      my $esc_mode = $hcomp->{esc_mode} // $hcomp->{escmode} // 'default';
      my $path_sep = $hcomp->{path_sep};
  
      if (defined($path_sep) && @$comp == 1) {
          my $re = qr/\Q$path_sep\E\z/;
          my $word;
          if (ref($comp->[0]) eq 'HASH') {
              $comp = [$comp->[0], {word=>"$comp->[0] "}] if
                  $comp->[0]{word} =~ $re;
          } else {
              $comp = [$comp->[0], "$comp->[0] "]
                  if $comp->[0] =~ $re;
          }
      }
  
      # XXX this is currently an ad-hoc solution, need to formulate a
      # name/interface for the more generic solution. since bash breaks words
      # differently than us (we only break using '" and whitespace, while bash
      # breaks using characters in $COMP_WORDBREAKS, by default is "'><=;|&(:),
      # this presents a problem we often encounter: if we want to provide with a
      # list of strings containing ':', most often Perl modules/packages, if user
      # types e.g. "Text::AN" and we provide completion ["Text::ANSI"] then bash
      # will change the word at cursor to become "Text::Text::ANSI" since it sees
      # the current word as "AN" and not "Text::AN". the workaround is to chop
      # /^Text::/ from completion answers. btw, we actually chop /^text::/i to
      # handle case-insensitive matching, although this does not have the ability
      # to replace the current word (e.g. if we type 'text::an' then bash can only
      # replace the current word 'an' with 'ANSI). also, we currently only
      # consider ':' since that occurs often.
      if (defined($opts->{word})) {
          if ($opts->{word} =~ s/(.+:)//) {
              my $prefix = $1;
              for (@$comp) {
                  if (ref($_) eq 'HASH') {
                      $_->{word} =~ s/\A\Q$prefix\E//i;
                  } else {
                      s/\A\Q$prefix\E//i;
                  }
              }
          }
      }
  
      my @res;
      for my $entry (@$comp) {
          my $word = ref($entry) eq 'HASH' ? $entry->{word} : $entry;
          if ($esc_mode eq 'shellvar') {
              # don't escape $
              $word =~ s!([^A-Za-z0-9,+._/\$~-])!\\$1!g;
          } elsif ($esc_mode eq 'none') {
              # no escaping
          } else {
              # default
              $word =~ s!([^A-Za-z0-9,+._/:~-])!\\$1!g;
          }
          push @res, $word;
      }
  
      if ($as eq 'array') {
          return \@res;
      } else {
          return join("", map {($_, "\n")} @res);
      }
  }
  
  1;
  # ABSTRACT: Completion module for bash shell
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Complete::Bash - Completion module for bash shell
  
  =head1 VERSION
  
  This document describes version 0.19 of Complete::Bash (from Perl distribution Complete-Bash), released on 2015-04-02.
  
  =head1 DESCRIPTION
  
  Bash allows completion to come from various sources. The simplest is from a list
  of words (C<-W>):
  
   % complete -W "one two three four" somecmd
   % somecmd t<Tab>
   two  three
  
  Another source is from a bash function (C<-F>). The function will receive input
  in two variables: C<COMP_WORDS> (array, command-line chopped into words) and
  C<COMP_CWORD> (integer, index to the array of words indicating the cursor
  position). It must set an array variable C<COMPREPLY> that contains the list of
  possible completion:
  
   % _foo()
   {
     local cur
     COMPREPLY=()
     cur=${COMP_WORDS[COMP_CWORD]}
     COMPREPLY=($( compgen -W '--help --verbose --version' -- $cur ) )
   }
   % complete -F _foo foo
   % foo <Tab>
   --help  --verbose  --version
  
  And yet another source is an external command (including, a Perl script). The
  command receives two environment variables: C<COMP_LINE> (string, raw
  command-line) and C<COMP_POINT> (integer, cursor location). Program must split
  C<COMP_LINE> into words, find the word to be completed, complete that, and
  return the list of words one per-line to STDOUT. An example:
  
   % cat foo-complete
   #!/usr/bin/perl
   use Complete::Bash qw(parse_cmdline format_completion);
   use Complete::Util qw(complete_array_elem);
   my ($words, $cword) = @{ parse_cmdline() };
   my $res = complete_array_elem(array=>[qw/--help --verbose --version/], word=>$words->[$cword]);
   print format_completion($res);
  
   % complete -C foo-complete foo
   % foo --v<Tab>
   --verbose --version
  
  This module provides routines for you to be doing the above.
  
  =head1 FUNCTIONS
  
  
  =head2 format_completion($completion, $opts) -> str|array
  
  Format completion for output (for shell).
  
  Bash accepts completion reply in the form of one entry per line to STDOUT. Some
  characters will need to be escaped. This function helps you do the formatting,
  with some options.
  
  This function accepts completion answer structure as described in the C<Complete>
  POD. Aside from C<words>, this function also recognizes these keys:
  
  =over
  
  =item * C<as> (str): Either C<string> (the default) or C<array> (to return array of lines
  instead of the lines joined together). Returning array is useful if you are
  doing completion inside C<Term::ReadLine>, for example, where the library
  expects an array.
  
  =item * C<esc_mode> (str): Escaping mode for entries. Either C<default> (most
  nonalphanumeric characters will be escaped), C<shellvar> (like C<default>, but
  dollar sign C<$> will not be escaped, convenient when completing environment
  variables for example), C<filename> (currently equals to C<default>), C<option>
  (currently equals to C<default>), or C<none> (no escaping will be done).
  
  =item * C<path_sep> (str): If set, will enable "path mode", useful for
  completing/drilling-down path. Below is the description of "path mode".
  
  In shell, when completing filename (e.g. C<foo>) and there is only a single
  possible completion (e.g. C<foo> or C<foo.txt>), the shell will display the
  completion in the buffer and automatically add a space so the user can move to
  the next argument. This is also true when completing other values like
  variables or program names.
  
  However, when completing directory (e.g. C</et> or C<Downloads>) and there is
  solely a single completion possible and it is a directory (e.g. C</etc> or
  C<Downloads>), the shell automatically adds the path separator character
  instead (C</etc/> or C<Downloads/>). The user can press Tab again to complete
  for files/directories inside that directory, and so on. This is obviously more
  convenient compared to when shell adds a space instead.
  
  The C<path_sep> option, when set, will employ a trick to mimic this behaviour.
  The trick is, if you have a completion array of C<['foo/']>, it will be changed
  to C<['foo/', 'foo/ ']> (the second element is the first element with added
  space at the end) to prevent bash from adding a space automatically.
  
  Path mode is not restricted to completing filesystem paths. Anything path-like
  can use it. For example when you are completing Java or Perl module name (e.g.
  C<com.company.product.whatever> or C<File::Spec::Unix>) you can use this mode
  (with C<path_sep> appropriately set to, e.g. C<.> or C<::>).
  
  =back
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<completion>* => I<hash|array>
  
  Completion answer structure.
  
  Either an array or hash. See function description for more details.
  
  =item * B<opts> => I<hash>
  
  =back
  
  Return value: Formatted string (or array, if `as` is set to `array`) (str|array)
  
  
  =head2 parse_cmdline($cmdline, $point) -> array
  
  Parse shell command-line for processing by completion routines.
  
  This function basically converts COMP_LINE (str) and COMP_POINT (int) into
  something like (but not exactly the same as) COMP_WORDS (array) and COMP_CWORD
  (int) that bash supplies to shell functions.
  
  The differences with bash are (these differences are mostly for parsing
  convenience for programs that use this routine):
  
  1) quotes and backslashes are stripped (bash's COMP_WORDS contains all the
  quotes and backslashes);
  
  2) variables are substituted with their values from environment variables except
  for the current word (COMP_WORDS[COMP_CWORD]) (bash does not perform variable
  substitution for COMP_WORDS). However, note that special shell variables that
  are not environment variables like C<$0>, C<$_>, C<$IFS> will not be replaced
  correctly because bash does not export those variables for us.
  
  3) tildes (~) are expanded with user's home directory except for the current
  word (bash does not perform tilde expansion for COMP_WORDS);
  
  4) no word-breaking characters aside from whitespaces and C<=> are currently used
  (bash uses COMP_WORDBREAKS which by default also include C<:>, C<;>, and so on).
  This is done for convenience of parsing of Getopt::Long-based applications. More
  word-breaking characters might be used in the future, e.g. when we want to
  handle complex bash statements like pipes, redirection, etc.
  
  Caveats:
  
  =over
  
  =item * Due to the way bash parses the command line, the two below are equivalent:
  
  % cmd --foo=bar
  % cmd --foo = bar
  
  =back
  
  Because they both expand to C<['--foo', '=', 'bar']>. But obviously
  C<Getopt::Long> does not regard the two as equivalent.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<cmdline> => I<str>
  
  Command-line, defaults to COMP_LINE environment.
  
  =item * B<point> => I<int>
  
  Point/position to complete in command-line, defaults to COMP_POINT.
  
  =back
  
  Return value:  (array)
  
  
  Return a 2-element array: C<[$words, $cword]>. C<$words> is array of str,
  equivalent to C<COMP_WORDS> provided by bash to shell functions. C<$cword> is an
  integer, equivalent to C<COMP_CWORD> provided by bash to shell functions. The
  word to be completed is at C<< $words-E<gt>[$cword] >>.
  
  Note that COMP_LINE includes the command name. If you want the command-line
  arguments only (like in C<@ARGV>), you need to strip the first element from
  C<$words> and reduce C<$cword> by 1.
  
  
  =head2 parse_options(%args) -> [status, msg, result, meta]
  
  Parse command-line for options and arguments, more or less like Getopt::Long.
  
  Parse command-line into words using C<parse_cmdline()> then separate options and
  arguments. Since this routine does not accept C<Getopt::Long> (this routine is
  meant to be a generic option parsing of command-lines), it uses a few simple
  rules to server the common cases:
  
  =over
  
  =item * After C<-->, the rest of the words are arguments (just like Getopt::Long).
  
  =item * If we get something like C<-abc> (a single dash followed by several letters) it
  is assumed to be a bundle of short options.
  
  =item * If we get something like C<-MData::Dump> (a single dash, followed by a letter,
  followed by some letters I<and> non-letters/numbers) it is assumed to be an
  option (C<-M>) followed by a value.
  
  =item * If we get something like C<--foo> it is a long option. If the next word is an
  option (starts with a C<->) then it is assumed that this option does not have
  argument. Otherwise, the next word is assumed to be this option's value.
  
  =item * Otherwise, it is an argument (that is, permute is assumed).
  
  =back
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<cmdline> => I<str>
  
  Command-line, defaults to COMP_LINE environment.
  
  =item * B<cword> => I<array[str]>
  
  Alternative to passing `cmdline` and `point`.
  
  If you already did a C<parse_cmdline()>, you can pass the cword result (the
  second element) here to avoid calling C<parse_cmdline()> twice.
  
  =item * B<point> => I<int>
  
  Point/position to complete in command-line, defaults to COMP_POINT.
  
  =item * B<words> => I<array[str]>
  
  Alternative to passing `cmdline` and `point`.
  
  If you already did a C<parse_cmdline()>, you can pass the words result (the first
  element) here to avoid calling C<parse_cmdline()> twice.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (hash)
  
  =head1 SEE ALSO
  
  
  L<Complete>
  
  =head1 SEE ALSO (2)
  
  Other modules related to bash shell tab completion: L<Bash::Completion>,
  L<Getopt::Complete>. L<Term::Bash::Completion::Generator>
  
  Programmable Completion section in Bash manual:
  L<https://www.gnu.org/software/bash/manual/html_node/Programmable-Completion.html>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Complete-Bash>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Complete-Bash>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Bash>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
COMPLETE_BASH

$fatpacked{"Complete/Fish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'COMPLETE_FISH';
  package Complete::Fish;
  
  our $DATE = '2014-11-29'; # DATE
  our $VERSION = '0.03'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         format_completion
                 );
  
  require Complete::Bash;
  
  our %SPEC;
  
  $SPEC{parse_cmdline} = {
      v => 1.1,
      summary => 'Parse shell command-line for processing by completion routines',
      description => <<'_',
  
  This function converts COMMAND_LINE (str) given by tcsh to become something like
  COMP_WORDS (array) and COMP_CWORD (int), like what bash supplies to shell
  functions. Currently implemented using `Complete::Bash`'s `parse_cmdline`.
  
  _
      args_as => 'array',
      args => {
          cmdline => {
              summary => 'Command-line, defaults to COMMAND_LINE environment',
              schema => 'str*',
              pos => 0,
          },
      },
      result => {
          schema => ['array*', len=>2],
          description => <<'_',
  
  Return a 2-element array: `[$words, $cword]`. `$words` is array of str,
  equivalent to `COMP_WORDS` provided by bash to shell functions. `$cword` is an
  integer, equivalent to `COMP_CWORD` provided by bash to shell functions. The
  word to be completed is at `$words->[$cword]`.
  
  Note that COMP_LINE includes the command name. If you want the command-line
  arguments only (like in `@ARGV`), you need to strip the first element from
  `$words` and reduce `$cword` by 1.
  
  _
      },
      result_naked => 1,
  };
  sub parse_cmdline {
      my ($line) = @_;
  
      $line //= $ENV{COMMAND_LINE};
      Complete::Bash::parse_cmdline($line, length($line));
  }
  
  $SPEC{format_completion} = {
      v => 1.1,
      summary => 'Format completion for output (for shell)',
      description => <<'_',
  
  fish accepts completion reply in the form of one entry per line to STDOUT.
  Description can be added to each entry, prefixed by tab character.
  
  _
      args_as => 'array',
      args => {
          completion => {
              summary => 'Completion answer structure',
              description => <<'_',
  
  Either an array or hash, as described in `Complete`.
  
  _
              schema=>['any*' => of => ['hash*', 'array*']],
              req=>1,
              pos=>0,
          },
      },
      result => {
          summary => 'Formatted string (or array, if `as` key is set to `array`)',
          schema => ['any*' => of => ['str*', 'array*']],
      },
      result_naked => 1,
  };
  sub format_completion {
      my $comp = shift;
  
      my $as;
      my $entries;
  
      # we currently use Complete::Bash's rule because i haven't done a read up on
      # how exactly fish escaping rules are.
      if (ref($comp) eq 'HASH') {
          $as = $comp->{as} // 'string';
          $entries = Complete::Bash::format_completion({%$comp, as=>'array'});
      } else {
          $as = 'string';
          $entries = Complete::Bash::format_completion({
              words=>$comp, as=>'array',
          });
      }
  
      # insert description
      {
          my $compary = ref($comp) eq 'HASH' ? $comp->{words} : $comp;
          for (my $i=0; $i<@$compary; $i++) {
  
              my $desc = (ref($compary->[$i]) eq 'HASH' ?
                              $compary->[$i]{description} : '' ) // '';
              $desc =~ s/\R/ /g;
              $entries->[$i] .= "\t$desc";
          }
      }
  
      # turn back to string if that's what the user wants
      if ($as eq 'string') {
          $entries = join("", map{"$_\n"} @$entries);
      }
      $entries;
  }
  
  1;
  #ABSTRACT: Completion module for fish shell
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Complete::Fish - Completion module for fish shell
  
  =head1 VERSION
  
  This document describes version 0.03 of Complete::Fish (from Perl distribution Complete-Fish), released on 2014-11-29.
  
  =head1 DESCRIPTION
  
  fish allows completion of option arguments to come from an external command,
  e.g.:
  
   % complete -c deluser -l user -d Username -a "(cat /etc/passwd|cut -d : -f 1)"
  
  The command is supposed to return completion entries one in a separate line.
  Description for each entry can be added, prefixed with a tab character. The
  provided function C<format_completion()> accept a completion answer structure
  and format it for fish. Example:
  
   format_completion(["a", "b", {word=>"c", description=>"Another letter"}])
  
  will result in:
  
   a
   b
   c       Another letter
  
  =head1 FUNCTIONS
  
  
  =head2 format_completion($completion) -> array|str
  
  Format completion for output (for shell).
  
  fish accepts completion reply in the form of one entry per line to STDOUT.
  Description can be added to each entry, prefixed by tab character.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<completion>* => I<array|hash>
  
  Completion answer structure.
  
  Either an array or hash, as described in C<Complete>.
  
  =back
  
  Return value:
  
  Formatted string (or array, if `as` key is set to `array`) (any)
  
  
  =head2 parse_cmdline($cmdline) -> array
  
  Parse shell command-line for processing by completion routines.
  
  This function converts COMMAND_LINE (str) given by tcsh to become something like
  COMP_WORDS (array) and COMP_CWORD (int), like what bash supplies to shell
  functions. Currently implemented using C<Complete::Bash>'s C<parse_cmdline>.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<cmdline> => I<str>
  
  Command-line, defaults to COMMAND_LINE environment.
  
  =back
  
  Return value:
  
   (array)
  
  Return a 2-element array: C<[$words, $cword]>. C<$words> is array of str,
  equivalent to C<COMP_WORDS> provided by bash to shell functions. C<$cword> is an
  integer, equivalent to C<COMP_CWORD> provided by bash to shell functions. The
  word to be completed is at C<< $words-E<gt>[$cword] >>.
  
  Note that COMP_LINE includes the command name. If you want the command-line
  arguments only (like in C<@ARGV>), you need to strip the first element from
  C<$words> and reduce C<$cword> by 1.
  
  =head1 TODOS
  
  =head1 SEE ALSO
  
  L<Complete>
  
  L<Complete::Bash>
  
  Fish manual.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Complete-Fish>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Complete-Fish>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Fish>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
COMPLETE_FISH

$fatpacked{"Complete/Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'COMPLETE_GETOPT_LONG';
  package Complete::Getopt::Long;
  
  our $DATE = '2015-04-09'; # DATE
  our $VERSION = '0.31'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  use Log::Any::IfLOG '$log';
  
  #use Complete;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         complete_cli_arg
                 );
  
  our %SPEC;
  
  sub _default_completion {
      my %args = @_;
      my $word = $args{word} // '';
  
      my $fres;
      $log->tracef('[comp][compgl] entering default completion routine');
  
      # try completing '$...' with shell variables
      if ($word =~ /\A\$/) {
          $log->tracef('[comp][compgl] completing shell variable');
          require Complete::Util;
          {
              my $compres = Complete::Util::complete_env(
                  word=>$word);
              last unless @$compres;
              $fres = {words=>$compres, esc_mode=>'shellvar'};
              goto RETURN_RES;
          }
          # if empty, fallback to searching file
      }
  
      # try completing '~foo' with user dir (appending / if user's home exists)
      if ($word =~ m!\A~([^/]*)\z!) {
          $log->tracef("[comp][compgl] completing userdir, user=%s", $1);
          {
              eval { require Unix::Passwd::File };
              last if $@;
              my $res = Unix::Passwd::File::list_users(detail=>1);
              last unless $res->[0] == 200;
              my $compres = Complete::Util::complete_array(
                  array=>[map {"~" . $_->{user} . ((-d $_->{home}) ? "/":"")}
                              @{ $res->[2] }],
                  word=>$word,
              );
              last unless @$compres;
              $fres = {words=>$compres, path_sep=>'/'};
              goto RETURN_RES;
          }
          # if empty, fallback to searching file
      }
  
      # try completing '~/blah' or '~foo/blah' as if completing file, but do not
      # expand ~foo (this is supported by complete_file(), so we just give it off
      # to the routine)
      if ($word =~ m!\A(~[^/]*)/!) {
          $log->tracef("[comp][compgl] completing file, path=<%s>", $word);
          $fres = {words=>Complete::Util::complete_file(word=>$word),
                   path_sep=>'/'};
          goto RETURN_RES;
      }
  
      # try completing something that contains wildcard with glob. for
      # convenience, we add '*' at the end so that when user type [AB] it is
      # treated like [AB]*.
      require String::Wildcard::Bash;
      if (String::Wildcard::Bash::contains_wildcard($word)) {
          $log->tracef("[comp][compgl] completing with wildcard glob, glob=<%s>", "$word*");
          {
              my $compres = [glob("$word*")];
              last unless @$compres;
              for (@$compres) {
                  $_ .= "/" if (-d $_);
              }
              $fres = {words=>$compres, path_sep=>'/'};
              goto RETURN_RES;
          }
          # if empty, fallback to searching file
      }
      $log->tracef("[comp][compgl] completing with file, file=<%s>", $word);
      $fres = {words=>Complete::Util::complete_file(word=>$word),
               path_sep=>'/'};
    RETURN_RES:
      $log->tracef("[comp][compgl] leaving default completion routine, result=%s", $fres);
      $fres;
  }
  
  # return the key/element if $opt matches exactly a key/element in $opts (which
  # can be an array/hash) OR expands unambiguously to exactly one key/element in
  # $opts, otherwise return undef. e.g. _expand1('--fo', [qw/--foo --bar --baz
  # --fee --feet/]) and _expand('--fee', ...) will respectively return '--foo' and
  # '--fee' because it expands/is unambiguous in the list, but _expand1('--ba',
  # ...) or _expand1('--qux', ...) will both return undef because '--ba' expands
  # ambiguously (--bar/--baz) while '--qux' cannot be expanded.
  sub _expand1 {
      my ($opt, $opts) = @_;
      my @candidates;
      my $is_hash = ref($opts) eq 'HASH';
      for ($is_hash ? (sort {length($a)<=>length($b)} keys %$opts) : @$opts) {
          next unless index($_, $opt) == 0;
          push @candidates, $is_hash ? $opts->{$_} : $_;
          last if $opt eq $_;
      }
      return @candidates == 1 ? $candidates[0] : undef;
  }
  
  # mark an option (and all its aliases) as seen
  sub _mark_seen {
      my ($seen_opts, $opt, $opts) = @_;
      my $opthash = $opts->{$opt};
      return unless $opthash;
      my $ospec = $opthash->{ospec};
      for (keys %$opts) {
          my $v = $opts->{$_};
          $seen_opts->{$_}++ if $v->{ospec} eq $ospec;
      }
  }
  
  $SPEC{complete_cli_arg} = {
      v => 1.1,
      summary => 'Complete command-line argument using '.
          'Getopt::Long specification',
      description => <<'_',
  
  This routine can complete option names, where the option names are retrieved
  from `Getopt::Long` specification. If you provide completion routine in
  `completion`, you can also complete _option values_ and _arguments_.
  
  Note that this routine does not use `Getopt::Long` (it does its own parsing) and
  currently is not affected by Getopt::Long's configuration. Its behavior mimics
  Getopt::Long under these configuration: `no_ignore_case`, `bundling` (or
  `no_bundling` if the `bundling` option is turned off). Which I think is the
  sensible default. This routine also does not currently support `auto_help` and
  `auto_version`, so you'll need to add those options specifically if you want to
  recognize `--help/-?` and `--version`, respectively.
  
  _
      args => {
          getopt_spec => {
              summary => 'Getopt::Long specification',
              schema  => 'hash*',
              req     => 1,
          },
          completion => {
              summary     =>
                  'Completion routine to complete option value/argument',
              schema      => 'code*',
              description => <<'_',
  
  Completion code will receive a hash of arguments (`%args`) containing these
  keys:
  
  * `type` (str, what is being completed, either `optval`, or `arg`)
  * `word` (str, word to be completed)
  * `cword` (int, position of words in the words array, starts from 0)
  * `opt` (str, option name, e.g. `--str`; undef if we're completing argument)
  * `ospec` (str, Getopt::Long option spec, e.g. `str|S=s`; undef when completing
    argument)
  * `argpos` (int, argument position, zero-based; undef if type='optval')
  * `nth` (int, the number of times this option has seen before, starts from 0
    that means this is the first time this option has been seen; undef when
    type='arg')
  * `seen_opts` (hash, all the options seen in `words`)
  * `parsed_opts` (hash, options parsed the standard/raw way)
  
  as well as all keys from `extras` (but these won't override the above keys).
  
  and is expected to return a completion answer structure as described in
  `Complete` which is either a hash or an array. The simplest form of answer is
  just to return an array of strings. The various `complete_*` function like those
  in `Complete::Util` or the other `Complete::*` modules are suitable to use here.
  
  Completion routine can also return undef to express declination, in which case
  the default completion routine will then be consulted. The default routine
  completes from shell environment variables (`$FOO`), Unix usernames (`~foo`),
  and files/directories.
  
  Example:
  
      use Complete::Unix qw(complete_user);
      use Complete::Util qw(complete_array_elem);
      complete_cli_arg(
          getopt_spec => {
              'help|h'   => sub{...},
              'format=s' => \$format,
              'user=s'   => \$user,
          },
          completion  => sub {
              my %args  = @_;
              my $word  = $args{word};
              my $ospec = $args{ospec};
              if ($ospec && $ospec eq 'format=s') {
                  complete_array(array=>[qw/json text xml yaml/], word=>$word);
              } else {
                  complete_user(word=>$word);
              }
          },
      );
  
  _
          },
          words => {
              summary     => 'Command line arguments, like @ARGV',
              description => <<'_',
  
  See function `parse_cmdline` in `Complete::Bash` on how to produce this (if
  you're using bash).
  
  _
              schema      => 'array*',
              req         => 1,
          },
          cword => {
              summary     =>
                  "Index in words of the word we're trying to complete",
              description => <<'_',
  
  See function `parse_cmdline` in `Complete::Bash` on how to produce this (if
  you're using bash).
  
  _
              schema      => 'int*',
              req         => 1,
          },
          extras => {
              summary => 'Add extra arguments to completion routine',
              schema  => 'hash',
              description => <<'_',
  
  The keys from this `extras` hash will be merged into the final `%args` passed to
  completion routines. Note that standard keys like `type`, `word`, and so on as
  described in the function description will not be overwritten by this.
  
  _
          },
          bundling => {
              schema  => 'bool*',
              default => 1,
              'summary.alt.bool.not' => 'Turn off bundling',
              description => <<'_',
  
  If you turn off bundling, completion of short-letter options won't support
  bundling (e.g. `-b<tab>` won't add more single-letter options), but single-dash
  multiletter options can be recognized. Currently only those specified with a
  single dash will be completed. For example if you have `-foo=s` in your option
  specification, `-f<tab>` can complete it.
  
  This can be used to complete old-style programs, e.g. emacs which has options
  like `-nw`, `-nbc` etc (but also have double-dash options like
  `--no-window-system` or `--no-blinking-cursor`).
  
  _
          },
      },
      result_naked => 1,
      result => {
          schema => ['any*' => of => ['hash*', 'array*']],
          description => <<'_',
  
  You can use `format_completion` function in `Complete::Bash` module to format
  the result of this function for bash.
  
  _
      },
  };
  sub complete_cli_arg {
      require Complete::Util;
      require Getopt::Long::Util;
      require List::MoreUtils;
  
      my %args = @_;
  
      my $fname = __PACKAGE__ . "::complete_cli_arg"; # XXX use __SUB__
      my $fres;
  
      $args{words} or die "Please specify words";
      my @words = @{ $args{words} };
      defined(my $cword = $args{cword}) or die "Please specify cword";
      my $gospec = $args{getopt_spec} or die "Please specify getopt_spec";
      my $comp = $args{completion};
      my $extras = $args{extras} // {};
      my $bundling = $args{bundling} // 1;
      my %parsed_opts;
  
      $log->tracef('[comp][compgl] entering %s(), words=%s, cword=%d, word=<%s>',
                   $fname, \@words, $cword, $words[$cword]);
  
      # parse all options first & supply default completion routine
      my %opts;
      for my $ospec (keys %$gospec) {
          my $res = Getopt::Long::Util::parse_getopt_long_opt_spec($ospec)
              or die "Can't parse option spec '$ospec'";
          $res->{min_vals} //= $res->{type} ? 1 : 0;
          $res->{max_vals} //= $res->{type} || $res->{opttype} ? 1:0;
          for my $o0 (@{ $res->{opts} }) {
              my @o = $res->{is_neg} && length($o0) > 1 ?
                  ($o0, "no$o0", "no-$o0") : ($o0);
              for my $o (@o) {
                  my $k = length($o)==1 ||
                      (!$bundling && $res->{dash_prefix} eq '-') ?
                          "-$o" : "--$o";
                  $opts{$k} = {
                      name => $k,
                      ospec => $ospec, # key to getopt specification
                      parsed => $res,
                  };
              }
          }
      }
      my @optnames = sort keys %opts;
  
      my %seen_opts;
  
      # for each word, we try to find out whether it's supposed to complete option
      # name, or option value, or argument, or separator (or more than one of
      # them). plus some other information.
      my @expects;
  
      my $i = -1;
      my $argpos = 0;
  
    WORD:
      while (1) {
          last WORD if ++$i >= @words;
          my $word = $words[$i];
          #say "D:i=$i, word=$word, ~~@words=",~~@words;
  
          if ($word eq '--' && $i != $cword) {
              $expects[$i] = {separator=>1};
              while (1) {
                  $i++;
                  last WORD if $i >= @words;
                  $expects[$i] = {arg=>1, argpos=>$argpos++};
              }
          }
  
          if ($word =~ /\A-/) {
  
              # split bundled short options
            SPLIT_BUNDLED:
              {
                  last unless $bundling;
                  my $shorts = $word;
                  if ($shorts =~ s/\A-([^-])(.*)/$2/) {
                      my $opt = "-$1";
                      my $opthash = $opts{$opt};
                      if (!$opthash || $opthash->{parsed}{max_vals}) {
                          last SPLIT_BUNDLED;
                      }
                      $words[$i] = $word = "-$1";
                      $expects[$i]{prefix} = $word;
                      $expects[$i]{word} = '';
                      $expects[$i]{short_only} = 1;
                      my $len_before_split = @words;
                      my $j = $i+1;
                    SHORTOPT:
                      while ($shorts =~ s/(.)//) {
                          $opt = "-$1";
                          $opthash = $opts{$opt};
                          if (!$opthash || $opthash->{parsed}{max_vals}) {
                              # end after unknown short option or short option
                              # expects value, and don't complete this optname
                              # later
                              $expects[$i]{do_complete_optname} = 0;
                              if (length $shorts) {
                                  splice @words, $j, 0, $opt, '=', $shorts;
                                  $j += 3;
                              } else {
                                  splice @words, $j, 0, $opt;
                                  $j++;
                              }
                              last SHORTOPT;
                          } else {
                              splice @words, $j, 0, $opt;
                              $j++;
                              # continue splitting
                          }
                      }
                      $cword += @words-$len_before_split if $cword > $i;
                      #say "D:words increases ", @words-$len_before_split;
                  }
              }
  
              # split --foo=val -> --foo, =, val
            SPLIT_EQUAL:
              {
                  if ($word =~ /\A(--?[^=]+)(=)(.*)/) {
                      splice @words, $i, 1, $1, $2, $3;
                      $word = $1;
                      $cword += 2 if $cword >= $i;
                  }
              }
  
              my $opt = $word;
              my $opthash = _expand1($opt, \%opts);
  
              if ($opthash) {
                  $opt = $opthash->{name};
                  $expects[$i]{optname} = $opt;
                  my $nth = $seen_opts{$opt} // 0;
                  $expects[$i]{nth} = $nth;
                  _mark_seen(\%seen_opts, $opt, \%opts);
  
                  my $min_vals = $opthash->{parsed}{min_vals};
                  my $max_vals = $opthash->{parsed}{max_vals};
                  #say "D:min_vals=$min_vals, max_vals=$max_vals";
  
                  # detect = after --opt
                  if ($i+1 < @words && $words[$i+1] eq '=') {
                      $i++;
                      $expects[$i] = {separator=>1, optval=>$opt, word=>'', nth=>$nth};
                      # force a value due to =
                      if (!$max_vals) { $min_vals = $max_vals = 1 }
                  }
  
                  push @{ $parsed_opts{$opt} }, $words[$i+1];
                  for (1 .. $min_vals) {
                      $i++;
                      last WORD if $i >= @words;
                      $expects[$i]{optval} = $opt;
                      $expects[$i]{nth} = $nth;
                  }
                  for (1 .. $max_vals-$min_vals) {
                      last if $i+$_ >= @words;
                      last if $words[$i+$_] =~ /\A-/; # a new option
                      $expects[$i+$_]{optval} = $opt; # but can also be optname
                      $expects[$i]{nth} = $nth;
                  }
              } else {
                  # an unknown option, assume it doesn't require argument, unless
                  # it's --opt= or --opt=foo
                  $opt = undef;
                  $expects[$i]{optname} = $opt;
  
                  # detect = after --opt
                  if ($i+1 < @words && $words[$i+1] eq '=') {
                      $i++;
                      $expects[$i] = {separator=>1, optval=>undef, word=>''};
                      if ($i+1 < @words) {
                          $i++;
                          $expects[$i]{optval} = $opt;
                      }
                  }
              }
          } else {
              $expects[$i]{optname} = '';
              $expects[$i]{arg} = 1;
              $expects[$i]{argpos} = $argpos++;
          }
      }
  
      #use DD; print "D:words: "; dd \@words;
      #say "D:cword: $cword";
      #use DD; print "D:expects: "; dd \@expects;
      #use DD; print "D:seen_opts: "; dd \%seen_opts;
      #use DD; print "D:parsed_opts: "; dd \%parsed_opts;
  
      my $exp = $expects[$cword];
      my $word = $exp->{word} // $words[$cword];
      my @res;
  
      # complete option names
      {
          last unless exists $exp->{optname};
          last if defined($exp->{do_complete_optname}) &&
              !$exp->{do_complete_optname};
          my $opt = $exp->{optname};
          my @o;
          for (@optnames) {
              #say "D:$_";
              my $repeatable = 0;
              next if $exp->{short_only} && /\A--/;
              if ($seen_opts{$_}) {
                  my $opthash = $opts{$_};
                  my $ospecval = $gospec->{$opthash->{ospec}};
                  my $parsed = $opthash->{parsed};
                  if (ref($ospecval) eq 'ARRAY') {
                      $repeatable = 1;
                  } elsif ($parsed->{desttype} || $parsed->{is_inc}) {
                      $repeatable = 1;
                  }
              }
              # skip options that have been specified and not repeatable
              #use DD; dd {'$_'=>$_, seen=>$seen_opts{$_}, repeatable=>$repeatable, opt=>$opt};
              next if $seen_opts{$_} && !$repeatable && (
                  # long option has been specified
                  (!$opt || $opt ne $_) ||
                       # short option (in a bundle) has been specified
                      (defined($exp->{prefix}) &&
                           index($exp->{prefix}, substr($opt, 1, 1)) >= 0));
              if (defined $exp->{prefix}) {
                  my $o = $_; $o =~ s/\A-//;
                  push @o, "$exp->{prefix}$o";
              } else {
                  push @o, $_;
              }
          }
          #use DD; dd \@o;
          my $compres = Complete::Util::complete_array_elem(
              array => \@o, word => $word);
          $log->tracef('[comp][compgl] adding result from option names, '.
                           'matching options=%s', $compres);
          push @res, @$compres;
          if (!exists($exp->{optval}) && !exists($exp->{arg})) {
              $fres = {words=>\@res, esc_mode=>'option'};
              goto RETURN_RES;
          }
      }
  
      # complete option value
      {
          last unless exists($exp->{optval});
          my $opt = $exp->{optval};
          my $opthash = $opts{$opt} if $opt;
          my %compargs = (
              %$extras,
              type=>'optval', words=>\@words, cword=>$args{cword},
              word=>$word, opt=>$opt, ospec=>$opthash->{ospec},
              argpos=>undef, nth=>$exp->{nth}, seen_opts=>\%seen_opts,
              parsed_opts=>\%parsed_opts,
          );
          my $compres;
          if ($comp) {
              $log->tracef("[comp][compgl] invoking routine supplied from 'completion' argument to complete option value, option=<%s>", $opt);
              $compres = $comp->(%compargs);
              $log->tracef('[comp][compgl] adding result from routine: %s', $compres);
          }
          if (!$compres || !$comp) {
              $compres = _default_completion(%compargs);
              $log->tracef('[comp][compgl] adding result from default '.
                               'completion routine');
          }
          if (ref($compres) eq 'ARRAY') {
              push @res, @$compres;
          } elsif (ref($compres) eq 'HASH') {
              unless (@res) {
                  $fres = $compres;
                  goto RETURN_RES;
              }
              push @res, @{ $compres->{words} // [] };
          }
      }
  
      # complete argument
      {
          last unless exists($exp->{arg});
          my %compargs = (
              %$extras,
              type=>'arg', words=>\@words, cword=>$args{cword},
              word=>$word, opt=>undef, ospec=>undef,
              argpos=>$exp->{argpos}, seen_opts=>\%seen_opts,
              parsed_opts=>\%parsed_opts,
          );
          $log->tracef('[comp][compgl] invoking \'completion\' routine '.
                           'to complete argument');
          my $compres = $comp->(%compargs);
          if (!defined $compres) {
              $compres = _default_completion(%compargs);
              $log->tracef('[comp][compgl] adding result from default '.
                               'completion routine: %s', $compres);
          }
          if (ref($compres) eq 'ARRAY') {
              push @res, @$compres;
          } elsif (ref($compres) eq 'HASH') {
              unless (@res) {
                  $fres = $compres;
                  goto RETURN_RES;
              }
              push @res, @{ $compres->{words} // [] };
          }
      }
  
      $fres = [sort(List::MoreUtils::uniq(@res))];
    RETURN_RES:
      $log->tracef("[comp][compgl] leaving %s(), result=%s", $fname, $fres);
      $fres;
  }
  
  1;
  # ABSTRACT: Complete command-line argument using Getopt::Long specification
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Complete::Getopt::Long - Complete command-line argument using Getopt::Long specification
  
  =head1 VERSION
  
  This document describes version 0.31 of Complete::Getopt::Long (from Perl distribution Complete-Getopt-Long), released on 2015-04-09.
  
  =head1 SYNOPSIS
  
  See L<Getopt::Long::Complete> for an easy way to use this module.
  
  =head1 DESCRIPTION
  
  Note that I deliberately do not support C<ci> (case-insensitive) option here.
  Options that differ only in case often are often and they mean different things.
  
  =head1 FUNCTIONS
  
  
  =head2 complete_cli_arg(%args) -> hash|array
  
  Complete command-line argument using Getopt::Long specification.
  
  This routine can complete option names, where the option names are retrieved
  from C<Getopt::Long> specification. If you provide completion routine in
  C<completion>, you can also complete I<option values> and I<arguments>.
  
  Note that this routine does not use C<Getopt::Long> (it does its own parsing) and
  currently is not affected by Getopt::Long's configuration. Its behavior mimics
  Getopt::Long under these configuration: C<no_ignore_case>, C<bundling> (or
  C<no_bundling> if the C<bundling> option is turned off). Which I think is the
  sensible default. This routine also does not currently support C<auto_help> and
  C<auto_version>, so you'll need to add those options specifically if you want to
  recognize C<--help/-?> and C<--version>, respectively.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<bundling> => I<bool> (default: 1)
  
  If you turn off bundling, completion of short-letter options won't support
  bundling (e.g. C<< -bE<lt>tabE<gt> >> won't add more single-letter options), but single-dash
  multiletter options can be recognized. Currently only those specified with a
  single dash will be completed. For example if you have C<-foo=s> in your option
  specification, C<< -fE<lt>tabE<gt> >> can complete it.
  
  This can be used to complete old-style programs, e.g. emacs which has options
  like C<-nw>, C<-nbc> etc (but also have double-dash options like
  C<--no-window-system> or C<--no-blinking-cursor>).
  
  =item * B<completion> => I<code>
  
  Completion routine to complete option value/argument.
  
  Completion code will receive a hash of arguments (C<%args>) containing these
  keys:
  
  =over
  
  =item * C<type> (str, what is being completed, either C<optval>, or C<arg>)
  
  =item * C<word> (str, word to be completed)
  
  =item * C<cword> (int, position of words in the words array, starts from 0)
  
  =item * C<opt> (str, option name, e.g. C<--str>; undef if we're completing argument)
  
  =item * C<ospec> (str, Getopt::Long option spec, e.g. C<str|S=s>; undef when completing
  argument)
  
  =item * C<argpos> (int, argument position, zero-based; undef if type='optval')
  
  =item * C<nth> (int, the number of times this option has seen before, starts from 0
  that means this is the first time this option has been seen; undef when
  type='arg')
  
  =item * C<seen_opts> (hash, all the options seen in C<words>)
  
  =item * C<parsed_opts> (hash, options parsed the standard/raw way)
  
  =back
  
  as well as all keys from C<extras> (but these won't override the above keys).
  
  and is expected to return a completion answer structure as described in
  C<Complete> which is either a hash or an array. The simplest form of answer is
  just to return an array of strings. The various C<complete_*> function like those
  in C<Complete::Util> or the other C<Complete::*> modules are suitable to use here.
  
  Completion routine can also return undef to express declination, in which case
  the default completion routine will then be consulted. The default routine
  completes from shell environment variables (C<$FOO>), Unix usernames (C<~foo>),
  and files/directories.
  
  Example:
  
   use Complete::Unix qw(complete_user);
   use Complete::Util qw(complete_array_elem);
   complete_cli_arg(
       getopt_spec => {
           'help|h'   => sub{...},
           'format=s' => \$format,
           'user=s'   => \$user,
       },
       completion  => sub {
           my %args  = @_;
           my $word  = $args{word};
           my $ospec = $args{ospec};
           if ($ospec && $ospec eq 'format=s') {
               complete_array(array=>[qw/json text xml yaml/], word=>$word);
           } else {
               complete_user(word=>$word);
           }
       },
   );
  
  =item * B<cword>* => I<int>
  
  Index in words of the word we're trying to complete.
  
  See function C<parse_cmdline> in C<Complete::Bash> on how to produce this (if
  you're using bash).
  
  =item * B<extras> => I<hash>
  
  Add extra arguments to completion routine.
  
  The keys from this C<extras> hash will be merged into the final C<%args> passed to
  completion routines. Note that standard keys like C<type>, C<word>, and so on as
  described in the function description will not be overwritten by this.
  
  =item * B<getopt_spec>* => I<hash>
  
  Getopt::Long specification.
  
  =item * B<words>* => I<array>
  
  Command line arguments, like @ARGV.
  
  See function C<parse_cmdline> in C<Complete::Bash> on how to produce this (if
  you're using bash).
  
  =back
  
  Return value:  (hash|array)
  
  
  You can use C<format_completion> function in C<Complete::Bash> module to format
  the result of this function for bash.
  
  =head1 SEE ALSO
  
  L<Getopt::Long::Complete>
  
  L<Complete>
  
  L<Complete::Bash>
  
  Other modules related to bash shell tab completion: L<Bash::Completion>,
  L<Getopt::Complete>.
  
  L<Perinci::CmdLine> - an alternative way to easily create command-line
  applications with completion feature.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Complete-Getopt-Long>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Complete-Getopt-Long>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Getopt-Long>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
COMPLETE_GETOPT_LONG

$fatpacked{"Complete/Path.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'COMPLETE_PATH';
  package Complete::Path;
  
  our $DATE = '2015-01-09'; # DATE
  our $VERSION = '0.12'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Complete;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         complete_path
                 );
  
  sub _dig_leaf {
      my ($p, $list_func, $is_dir_func, $path_sep) = @_;
      my $num_dirs;
      my $listres = $list_func->($p, '', 0);
      return $p unless @$listres == 1;
      my $e = $listres->[0];
      my $p2 = $p =~ m!\Q$path_sep\E\z! ? "$p$e" : "$p$path_sep$e";
      my $is_dir;
      if ($e =~ m!\Q$path_sep\E\z!) {
          $is_dir++;
      } else {
          $is_dir = $is_dir_func && $is_dir_func->($p2);
      }
      return _dig_leaf($p2, $list_func, $is_dir_func, $path_sep) if $is_dir;
      $p2;
  }
  
  our %SPEC;
  
  $SPEC{complete_path} = {
      v => 1.1,
      summary => 'Complete path',
      description => <<'_',
  
  Complete path, for anything path-like. Meant to be used as backend for other
  functions like `Complete::Util::complete_file` or
  `Complete::Module::complete_module`. Provides features like case-insensitive
  matching, expanding intermediate paths, and case mapping.
  
  Algorithm is to split path into path elements, then list items (using the
  supplied `list_func`) and perform filtering (using the supplied `filter_func`)
  at every level.
  
  _
      args => {
          word => {
              schema  => [str=>{default=>''}],
              pos     => 0,
          },
          list_func => {
              summary => 'Function to list the content of intermediate "dirs"',
              schema => 'code*',
              req => 1,
              description => <<'_',
  
  Code will be called with arguments: ($path, $cur_path_elem, $is_intermediate).
  Code should return an arrayref containing list of elements. "Directories" can be
  marked by ending the name with the path separator (see `path_sep`). Or, you can
  also provide an `is_dir_func` function that will be consulted after filtering.
  If an item is a "directory" then its name will be suffixed with a path
  separator by `complete_path()`.
  
  _
          },
          is_dir_func => {
              summary => 'Function to check whether a path is a "dir"',
              schema  => 'code*',
              description => <<'_',
  
  Optional. You can provide this function to determine if an item is a "directory"
  (so its name can be suffixed with path separator). You do not need to do this if
  you already suffix names of "directories" with path separator in `list_func`.
  
  One reason you might want to provide this and not mark "directories" in
  `list_func` is when you want to do extra filtering with `filter_func`. Sometimes
  you do not want to suffix the names first (example: see `complete_file` in
  `Complete::Util`).
  
  _
          },
          starting_path => {
              schema => 'str*',
              req => 1,
              default => '',
          },
          filter_func => {
              schema  => 'code*',
              description => <<'_',
  
  Provide extra filtering. Code will be given path and should return 1 if the item
  should be included in the final result or 0 if the item should be excluded.
  
  _
          },
  
          path_sep => {
              schema  => 'str*',
              default => '/',
          },
          ci => {
              summary => 'Case-insensitive matching',
              schema  => 'bool',
          },
          map_case => {
              summary => 'Treat _ (underscore) and - (dash) as the same',
              schema  => 'bool',
              description => <<'_',
  
  This is another convenience option like `ci`, where you can type `-` (without
  pressing Shift, at least in US keyboard) and can still complete `_` (underscore,
  which is typed by pressing Shift, at least in US keyboard).
  
  This option mimics similar option in bash/readline: `completion-map-case`.
  
  _
          },
          exp_im_path => {
              summary => 'Expand intermediate paths',
              schema  => 'bool',
              description => <<'_',
  
  This option mimics feature in zsh where when you type something like `cd
  /h/u/b/myscript` and get `cd /home/ujang/bin/myscript` as a completion answer.
  
  _
          },
          dig_leaf => {
              summary => 'Dig leafs',
              schema => 'bool',
              description => <<'_',
  
  This feature mimics what's seen on GitHub. If a directory entry only contains a
  single entry, it will directly show the subentry (and subsubentry and so on) to
  save a number of tab presses.
  
  _
          },
          #result_prefix => {
          #    summary => 'Prefix each result with this string',
          #    schema  => 'str*',
          #},
      },
      result_naked => 1,
      result => {
          schema => 'array',
      },
  };
  sub complete_path {
      my %args   = @_;
      my $word   = $args{word} // "";
      my $path_sep = $args{path_sep} // '/';
      my $list_func   = $args{list_func};
      my $is_dir_func = $args{is_dir_func};
      my $filter_func = $args{filter_func};
      my $ci          = $args{ci} // $Complete::OPT_CI;
      my $map_case    = $args{map_case} // $Complete::OPT_MAP_CASE;
      my $exp_im_path = $args{exp_im_path} // $Complete::OPT_EXP_IM_PATH;
      my $dig_leaf    = $args{dig_leaf} // $Complete::OPT_DIG_LEAF;
      my $result_prefix = $args{result_prefix};
      my $starting_path = $args{starting_path} // '';
  
      my $exp_im_path_max_len = $Complete::OPT_EXP_IM_PATH_MAX_LEN;
  
      my $re_ends_with_path_sep = qr!\A\z|\Q$path_sep\E\z!;
  
      # split word by into path elements, as we want to dig level by level (needed
      # when doing case-insensitive search on a case-sensitive tree).
      my @intermediate_dirs;
      {
          @intermediate_dirs = split qr/\Q$path_sep/, $word;
          @intermediate_dirs = ('') if !@intermediate_dirs;
          push @intermediate_dirs, '' if $word =~ $re_ends_with_path_sep;
      }
  
      # extract leaf path, because this one is treated differently
      my $leaf = pop @intermediate_dirs;
      @intermediate_dirs = ('') if !@intermediate_dirs;
  
      #say "D:starting_path=<$starting_path>";
      #say "D:intermediate_dirs=[",join(", ", map{"<$_>"} @intermediate_dirs),"]";
      #say "D:leaf=<$leaf>";
  
      # candidate for intermediate paths. when doing case-insensitive search,
      # there maybe multiple candidate paths for each dir, for example if
      # word='../foo/s' and there is '../foo/Surya', '../Foo/sri', '../FOO/SUPER'
      # then candidate paths would be ['../foo', '../Foo', '../FOO'] and the
      # filename should be searched inside all those dirs. everytime we drill down
      # to deeper subdirectories, we adjust this list by removing
      # no-longer-eligible candidates.
      my @candidate_paths;
  
      for my $i (0..$#intermediate_dirs) {
          my $intdir = $intermediate_dirs[$i];
          my @dirs;
          if ($i == 0) {
              # first path elem, we search starting_path first since
              # candidate_paths is still empty.
              @dirs = ($starting_path);
          } else {
              # subsequent path elem, we search all candidate_paths
              @dirs = @candidate_paths;
          }
  
          if ($i == $#intermediate_dirs && $intdir eq '') {
              @candidate_paths = @dirs;
              last;
          }
  
          my @new_candidate_paths;
          for my $dir (@dirs) {
              #say "D:  intdir list($dir)";
              my $listres = $list_func->($dir, $intdir, 1);
              next unless $listres && @$listres;
              # check if the deeper level is a candidate
              my $re = do {
                  my $s = $intdir;
                  $s =~ s/_/-/g if $map_case;
                  $exp_im_path && length($s) <= $exp_im_path_max_len ?
                      ($ci ? qr/\A\Q$s/i : qr/\A\Q$s/) :
                          ($ci ? qr/\A\Q$s\E(?:\Q$path_sep\E)?\z/i :
                               qr/\A\Q$s\E(?:\Q$path_sep\E)?\z/);
              };
              #say "D:  re=$re";
              for (@$listres) {
                  #say "D:  $_";
                  my $s = $_; $s =~ s/_/-/g if $map_case;
                  #say "D: <$s> =~ $re";
                  next unless $s =~ $re;
                  my $p = $dir =~ $re_ends_with_path_sep ?
                      "$dir$_" : "$dir$path_sep$_";
                  push @new_candidate_paths, $p;
              }
          }
          #say "D:  candidate_paths=[",join(", ", map{"<$_>"} @new_candidate_paths),"]";
          return [] unless @new_candidate_paths;
          @candidate_paths = @new_candidate_paths;
      }
  
      my $cut_chars = 0;
      if (length($starting_path)) {
          $cut_chars += length($starting_path);
          unless ($starting_path =~ /\Q$path_sep\E\z/) {
              $cut_chars += length($path_sep);
          }
      }
  
      my @res;
      for my $dir (@candidate_paths) {
          #say "D:opendir($dir)";
          my $listres = $list_func->($dir, $leaf, 0);
          next unless $listres && @$listres;
          my $re = do {
              my $s = $leaf;
              $s =~ s/_/-/g if $map_case;
              $ci ? qr/\A\Q$s/i : qr/\A\Q$s/;
          };
          #say "D:re=$re";
        L1:
          for my $e (@$listres) {
              my $s = $e; $s =~ s/_/-/g if $map_case;
              next unless $s =~ $re;
              my $p = $dir =~ $re_ends_with_path_sep ?
                  "$dir$e" : "$dir$path_sep$e";
              {
                  local $_ = $p; # convenience for filter func
                  next L1 if $filter_func && !$filter_func->($p);
              }
  
              my $is_dir;
              if ($e =~ $re_ends_with_path_sep) {
                  $is_dir = 1;
              } else {
                  local $_ = $p; # convenience for is_dir_func
                  $is_dir = $is_dir_func->($p);
              }
  
              if ($is_dir && $dig_leaf) {
                  $p = _dig_leaf($p, $list_func, $is_dir_func, $path_sep);
                  # check again
                  if ($p =~ $re_ends_with_path_sep) {
                      $is_dir = 1;
                  } else {
                      local $_ = $p; # convenience for is_dir_func
                      $is_dir = $is_dir_func->($p);
                  }
              }
  
              # process into final result
              my $p0 = $p;
              substr($p, 0, $cut_chars) = '' if $cut_chars;
              $p = "$result_prefix$p" if length($result_prefix);
              unless ($p =~ /\Q$path_sep\E\z/) {
                  $p .= $path_sep if $is_dir;
              }
              push @res, $p;
          }
      }
  
      \@res;
  }
  1;
  # ABSTRACT: Complete path
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Complete::Path - Complete path
  
  =head1 VERSION
  
  This document describes version 0.12 of Complete::Path (from Perl distribution Complete-Path), released on 2015-01-09.
  
  =head1 DESCRIPTION
  
  =head1 FUNCTIONS
  
  
  =head2 complete_path(%args) -> array
  
  {en_US Complete path}.
  
  {en_US 
  Complete path, for anything path-like. Meant to be used as backend for other
  functions like C<Complete::Util::complete_file> or
  C<Complete::Module::complete_module>. Provides features like case-insensitive
  matching, expanding intermediate paths, and case mapping.
  
  Algorithm is to split path into path elements, then list items (using the
  supplied C<list_func>) and perform filtering (using the supplied C<filter_func>)
  at every level.
  }
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<ci> => I<bool>
  
  {en_US Case-insensitive matching}.
  
  =item * B<dig_leaf> => I<bool>
  
  {en_US Dig leafs}.
  
  {en_US 
  This feature mimics what's seen on GitHub. If a directory entry only contains a
  single entry, it will directly show the subentry (and subsubentry and so on) to
  save a number of tab presses.
  }
  
  =item * B<exp_im_path> => I<bool>
  
  {en_US Expand intermediate paths}.
  
  {en_US 
  This option mimics feature in zsh where when you type something like C<cd
  /h/u/b/myscript> and get C<cd /home/ujang/bin/myscript> as a completion answer.
  }
  
  =item * B<filter_func> => I<code>
  
  {en_US 
  Provide extra filtering. Code will be given path and should return 1 if the item
  should be included in the final result or 0 if the item should be excluded.
  }
  
  =item * B<is_dir_func> => I<code>
  
  {en_US Function to check whether a path is a "dir"}.
  
  {en_US 
  Optional. You can provide this function to determine if an item is a "directory"
  (so its name can be suffixed with path separator). You do not need to do this if
  you already suffix names of "directories" with path separator in C<list_func>.
  
  One reason you might want to provide this and not mark "directories" in
  C<list_func> is when you want to do extra filtering with C<filter_func>. Sometimes
  you do not want to suffix the names first (example: see C<complete_file> in
  C<Complete::Util>).
  }
  
  =item * B<list_func>* => I<code>
  
  {en_US Function to list the content of intermediate "dirs"}.
  
  {en_US 
  Code will be called with arguments: ($path, $cur_path_elem, $is_intermediate).
  Code should return an arrayref containing list of elements. "Directories" can be
  marked by ending the name with the path separator (see C<path_sep>). Or, you can
  also provide an C<is_dir_func> function that will be consulted after filtering.
  If an item is a "directory" then its name will be suffixed with a path
  separator by C<complete_path()>.
  }
  
  =item * B<map_case> => I<bool>
  
  {en_US Treat _ (underscore) and - (dash) as the same}.
  
  {en_US 
  This is another convenience option like C<ci>, where you can type C<-> (without
  pressing Shift, at least in US keyboard) and can still complete C<_> (underscore,
  which is typed by pressing Shift, at least in US keyboard).
  
  This option mimics similar option in bash/readline: C<completion-map-case>.
  }
  
  =item * B<path_sep> => I<str> (default: "/")
  
  =item * B<starting_path>* => I<str> (default: "")
  
  =item * B<word> => I<str> (default: "")
  
  =back
  
  Return value:  (array)
  
  =head1 SEE ALSO
  
  L<Complete>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Complete-Path>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Complete-Path>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Path>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
COMPLETE_PATH

$fatpacked{"Complete/Tcsh.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'COMPLETE_TCSH';
  package Complete::Tcsh;
  
  our $DATE = '2014-11-23'; # DATE
  our $VERSION = '0.01'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         parse_cmdline
                         format_completion
                 );
  
  require Complete::Bash;
  
  our %SPEC;
  
  $SPEC{parse_cmdline} = {
      v => 1.1,
      summary => 'Parse shell command-line for processing by completion routines',
      description => <<'_',
  
  This function converts COMMAND_LINE (str) given by tcsh to become something like
  COMP_WORDS (array) and COMP_CWORD (int), like what bash supplies to shell
  functions. Currently implemented using `Complete::Bash`'s `parse_cmdline`.
  
  _
      args_as => 'array',
      args => {
          cmdline => {
              summary => 'Command-line, defaults to COMMAND_LINE environment',
              schema => 'str*',
              pos => 0,
          },
      },
      result => {
          schema => ['array*', len=>2],
          description => <<'_',
  
  Return a 2-element array: `[$words, $cword]`. `$words` is array of str,
  equivalent to `COMP_WORDS` provided by bash to shell functions. `$cword` is an
  integer, equivalent to `COMP_CWORD` provided by bash to shell functions. The
  word to be completed is at `$words->[$cword]`.
  
  Note that COMP_LINE includes the command name. If you want the command-line
  arguments only (like in `@ARGV`), you need to strip the first element from
  `$words` and reduce `$cword` by 1.
  
  _
      },
      result_naked => 1,
  };
  sub parse_cmdline {
      my ($line) = @_;
  
      $line //= $ENV{COMMAND_LINE};
      Complete::Bash::parse_cmdline($line, length($line));
  }
  
  $SPEC{format_completion} = {
      v => 1.1,
      summary => 'Format completion for output (for shell)',
      description => <<'_',
  
  tcsh accepts completion reply in the form of one entry per line to STDOUT.
  Currently the formatting is done using `Complete::Bash`'s `format_completion`
  because escaping rule and so on are not yet well defined in tcsh.
  
  _
      args_as => 'array',
      args => {
          shell_completion => {
              summary => 'Result of shell completion',
              description => <<'_',
  
  Either an array or hash.
  
  _
              schema=>['any*' => of => ['hash*', 'array*']],
              req=>1,
              pos=>0,
          },
          as => {
              schema => ['str*', in=>['string', 'array']],
              default => 'string',
          },
      },
      result => {
          summary => 'Formatted string (or array, if `as` is set to `array`)',
          schema => ['any*' => of => ['str*', 'array*']],
      },
      result_naked => 1,
  };
  sub format_completion {
      Complete::Bash::format_completion(@_);
  }
  
  1;
  #ABSTRACT: Completion module for tcsh shell
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Complete::Tcsh - Completion module for tcsh shell
  
  =head1 VERSION
  
  This document describes version 0.01 of Complete::Tcsh (from Perl distribution Complete-Tcsh), released on 2014-11-23.
  
  =head1 DESCRIPTION
  
  tcsh allows completion to come from various sources. One of the simplest is from
  a list of words:
  
   % complete CMDNAME 'p/*/(one two three)/'
  
  Another source is from an external command:
  
   % complete CMDNAME 'p/*/`mycompleter --somearg`/'
  
  The command receives one environment variables C<COMMAND_LINE> (string, raw
  command-line). Unlike bash, tcsh does not (yet) provide something akin to
  C<COMP_POINT> in bash. Command is expected to print completion entries, one line
  at a time.
  
   % cat mycompleter
   #!/usr/bin/perl
   use Complete::Tcsh qw(parse_cmdline format_completion);
   use Complete::Util qw(complete_array_elem);
   my ($words, $cword) = parse_cmdline();
   my $res = complete_array_elem(array=>[qw/--help --verbose --version/], word=>$words->[$cword]);
   print format_completion($res);
  
   % complete -C foo-complete foo
   % foo --v<Tab>
   --verbose --version
  
  This module provides routines for you to be doing the above.
  
  Also, unlike bash, currently tcsh does not allow delegating completion to a
  shell function.
  
  =head1 FUNCTIONS
  
  
  =head2 format_completion($shell_completion, $as) -> array|str
  
  Format completion for output (for shell).
  
  tcsh accepts completion reply in the form of one entry per line to STDOUT.
  Currently the formatting is done using C<Complete::Bash>'s C<format_completion>
  because escaping rule and so on are not yet well defined in tcsh.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<as> => I<str> (default: "string")
  
  =item * B<shell_completion>* => I<array|hash>
  
  Result of shell completion.
  
  Either an array or hash.
  
  =back
  
  Return value:
  
  Formatted string (or array, if `as` is set to `array`) (any)
  
  
  =head2 parse_cmdline($cmdline) -> array
  
  Parse shell command-line for processing by completion routines.
  
  This function converts COMMAND_LINE (str) given by tcsh to become something like
  COMP_WORDS (array) and COMP_CWORD (int), like what bash supplies to shell
  functions. Currently implemented using C<Complete::Bash>'s C<parse_cmdline>.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<cmdline> => I<str>
  
  Command-line, defaults to COMMAND_LINE environment.
  
  =back
  
  Return value:
  
   (array)
  
  Return a 2-element array: `[$words, $cword]`. `$words` is array of str,
  equivalent to `COMP_WORDS` provided by bash to shell functions. `$cword` is an
  integer, equivalent to `COMP_CWORD` provided by bash to shell functions. The
  word to be completed is at `$words->[$cword]`.
  
  Note that COMP_LINE includes the command name. If you want the command-line
  arguments only (like in `@ARGV`), you need to strip the first element from
  `$words` and reduce `$cword` by 1.
  
  =head1 TODOS
  
  =head1 SEE ALSO
  
  L<Complete>
  
  L<Complete::Bash>
  
  tcsh manual.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Complete-Tcsh>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Complete-Tcsh>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Tcsh>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
COMPLETE_TCSH

$fatpacked{"Complete/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'COMPLETE_UTIL';
  package Complete::Util;
  
  our $DATE = '2015-04-02'; # DATE
  our $VERSION = '0.27'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Complete;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         hashify_answer
                         arrayify_answer
                         combine_answers
                         complete_array_elem
                         complete_hash_key
                         complete_env
                         complete_file
                         complete_program
                 );
  
  our %SPEC;
  
  $SPEC{':package'} = {
      v => 1.1,
      summary => 'General completion routine',
  };
  
  $SPEC{hashify_answer} = {
      v => 1.1,
      summary => 'Make sure we return completion answer in hash form',
      description => <<'_',
  
  This function accepts a hash or an array. If it receives an array, will convert
  the array into `{words=>$ary}' first to make sure the completion answer is in
  hash form.
  
  Then will add keys from `meta` to the hash.
  
  _
      args => {
          arg => {
              summary => '',
              schema  => ['any*' => of => ['array*','hash*']],
              req => 1,
              pos => 0,
          },
          meta => {
              summary => 'Metadata (extra keys) for the hash',
              schema  => 'hash*',
              pos => 1,
          },
      },
      result_naked => 1,
      result => {
          schema => 'hash*',
      },
  };
  sub hashify_answer {
      my $ans = shift;
      if (ref($ans) ne 'HASH') {
          $ans = {words=>$ans};
      }
      if (@_) {
          my $meta = shift;
          for (keys %$meta) {
              $ans->{$_} = $meta->{$_};
          }
      }
      $ans;
  }
  
  $SPEC{arrayify_answer} = {
      v => 1.1,
      summary => 'Make sure we return completion answer in array form',
      description => <<'_',
  
  This is the reverse of `hashify_answer`. It accepts a hash or an array. If it
  receives a hash, will return its `words` key.
  
  _
      args => {
          arg => {
              summary => '',
              schema  => ['any*' => of => ['array*','hash*']],
              req => 1,
              pos => 0,
          },
      },
      result_naked => 1,
      result => {
          schema => 'array*',
      },
  };
  sub arrayify_answer {
      my $ans = shift;
      if (ref($ans) eq 'HASH') {
          $ans = $ans->{words};
      }
      $ans;
  }
  
  $SPEC{complete_array_elem} = {
      v => 1.1,
      summary => 'Complete from array',
      description => <<'_',
  
  Will sort the resulting completion list, so you don't have to presort the array.
  
  _
      args => {
          word    => { schema=>[str=>{default=>''}], pos=>0, req=>1 },
          array   => { schema=>['array*'=>{of=>'str*'}], req=>1 },
          ci      => { schema=>['bool'] },
          exclude => { schema=>['array*'] },
      },
      result_naked => 1,
      result => {
          schema => 'array',
      },
  };
  sub complete_array_elem {
      use experimental 'smartmatch';
  
      my %args  = @_;
      my $array = $args{array} or die "Please specify array";
      my $word  = $args{word} // "";
      my $ci    = $args{ci} // $Complete::OPT_CI;
  
      my $has_exclude = $args{exclude};
      my $exclude;
      if ($ci) {
          $exclude = [map {uc} @{ $args{exclude} // [] }];
      } else {
          $exclude = $args{exclude} // [];
      }
  
      my $wordu = uc($word);
      my @words;
      for (@$array) {
          my $uc = uc($_) if $ci;
          next unless 0==($ci ? index($uc, $wordu) : index($_, $word));
          if ($has_exclude) {
              next if ($ci ? $uc : $_) ~~ @$exclude;
          }
          push @words, $_;
      }
      $ci ? [sort {lc($a) cmp lc($b)} @words] : [sort @words];
  }
  
  *complete_array = \&complete_array_elem;
  
  $SPEC{complete_hash_key} = {
      v => 1.1,
      summary => 'Complete from hash keys',
      args => {
          word  => { schema=>[str=>{default=>''}], pos=>0, req=>1 },
          hash  => { schema=>['hash*'=>{}], req=>1 },
          ci    => { schema=>['bool'] },
      },
      result_naked => 1,
      result => {
          schema => 'array',
      },
  };
  sub complete_hash_key {
      my %args  = @_;
      my $hash  = $args{hash} or die "Please specify hash";
      my $word  = $args{word} // "";
      my $ci    = $args{ci} // $Complete::OPT_CI;
  
      complete_array_elem(word=>$word, array=>[keys %$hash], ci=>$ci);
  }
  
  $SPEC{complete_env} = {
      v => 1.1,
      summary => 'Complete from environment variables',
      description => <<'_',
  
  On Windows, environment variable names are all converted to uppercase. You can
  use case-insensitive option (`ci`) to match against original casing.
  
  _
      args => {
          word  => { schema=>[str=>{default=>''}], pos=>0, req=>1 },
          ci    => { schema=>['bool'] },
      },
      result_naked => 1,
      result => {
          schema => 'array',
      },
  };
  sub complete_env {
      my %args  = @_;
      my $word  = $args{word} // "";
      my $ci    = $args{ci} // $Complete::OPT_CI;
      if ($word =~ /^\$/) {
          complete_array_elem(word=>$word, array=>[map {"\$$_"} keys %ENV],
                              ci=>$ci);
      } else {
          complete_array_elem(word=>$word, array=>[keys %ENV], ci=>$ci);
      }
  }
  
  $SPEC{complete_program} = {
      v => 1.1,
      summary => 'Complete program name found in PATH',
      description => <<'_',
  
  Windows is supported, on Windows PATH will be split using /;/ instead of /:/.
  
  _
      args => {
          word  => { schema=>[str=>{default=>''}], pos=>0, req=>1 },
          ci    => { schema=>'bool' },
      },
      result_naked => 1,
      result => {
          schema => 'array',
      },
  };
  sub complete_program {
      require List::MoreUtils;
  
      my %args = @_;
      my $word = $args{word} // "";
      my $ci   = $args{ci} // $Complete::OPT_CI;
  
      my $word_re = $ci ? qr/\A\Q$word/i : qr/\A\Q$word/;
  
      my @res;
      my @dirs = split(($^O =~ /Win32/ ? qr/;/ : qr/:/), $ENV{PATH});
      for my $dir (@dirs) {
          opendir my($dh), $dir or next;
          for (readdir($dh)) {
              push @res, $_ if $_ =~ $word_re && !(-d "$dir/$_") && (-x _);
          };
      }
  
      [sort(List::MoreUtils::uniq(@res))];
  }
  
  $SPEC{complete_file} = {
      v => 1.1,
      summary => 'Complete file and directory from local filesystem',
      args_groups => [
          {rel=>'one_of', args=>[qw/filter file_regex_filter/]},
      ],
      args => {
          word => {
              schema  => [str=>{default=>''}],
              req     => 1,
              pos     => 0,
          },
          ci => {
              summary => 'Case-insensitive matching',
              schema  => 'bool',
          },
          map_case => {
              schema  => 'bool',
          },
          exp_im_path => {
              schema  => 'bool',
          },
          dig_leaf => {
              schema  => 'bool',
          },
          filter => {
              summary => 'Only return items matching this filter',
              description => <<'_',
  
  Filter can either be a string or a code.
  
  For string filter, you can specify a pipe-separated groups of sequences of these
  characters: f, d, r, w, x. Dash can appear anywhere in the sequence to mean
  not/negate. An example: `f` means to only show regular files, `-f` means only
  show non-regular files, `drwx` means to show only directories which are
  readable, writable, and executable (cd-able). `wf|wd` means writable regular
  files or writable directories.
  
  For code filter, you supply a coderef. The coderef will be called for each item
  with these arguments: `$name`. It should return true if it wants the item to be
  included.
  
  _
              schema  => ['any*' => {of => ['str*', 'code*']}],
          },
          file_regex_filter => {
              summary => 'Filter shortcut for file regex',
              description => <<'_',
  
  This is a shortcut for constructing a filter. So instead of using `filter`, you
  use this option. This will construct a filter of including only directories or
  regular files, and the file must match a regex pattern. This use-case is common.
  
  _
              schema => 're*',
          },
          starting_path => {
              schema  => 'str*',
              default => '.',
          },
          handle_tilde => {
              schema  => 'bool',
              default => 1,
          },
          allow_dot => {
              summary => 'If turned off, will not allow "." or ".." in path',
              description => <<'_',
  
  This is most useful when combined with `starting_path` option to prevent user
  going up/outside the starting path.
  
  _
              schema  => 'bool',
              default => 1,
          },
      },
      result_naked => 1,
      result => {
          schema => 'array',
      },
  };
  sub complete_file {
      require Complete::Path;
      require File::Glob;
  
      my %args   = @_;
      my $word   = $args{word} // "";
      my $ci          = $args{ci} // $Complete::OPT_CI;
      my $map_case    = $args{map_case} // $Complete::OPT_MAP_CASE;
      my $exp_im_path = $args{exp_im_path} // $Complete::OPT_EXP_IM_PATH;
      my $dig_leaf    = $args{dig_leaf} // $Complete::OPT_DIG_LEAF;
      my $handle_tilde = $args{handle_tilde} // 1;
      my $allow_dot   = $args{allow_dot} // 1;
      my $filter = $args{filter};
  
      # if word is starts with "~/" or "~foo/" replace it temporarily with user's
      # name (so we can restore it back at the end). this is to mimic bash
      # support. note that bash does not support case-insensitivity for "foo".
      my $result_prefix;
      my $starting_path = $args{starting_path} // '.';
      if ($handle_tilde && $word =~ s!\A(~[^/]*)/!!) {
          $result_prefix = "$1/";
          my @dir = File::Glob::glob($1); # glob will expand ~foo to /home/foo
          return [] unless @dir;
          $starting_path = $dir[0];
      } elsif ($allow_dot && $word =~ s!\A((?:\.\.?/+)+|/+)!!) {
          # just an optimization to skip sequences of '../'
          $starting_path = $1;
          $result_prefix = $1;
          $starting_path =~ s#/+\z## unless $starting_path =~ m!\A/!;
      }
  
      # bail if we don't allow dot and the path contains dot
      return [] if !$allow_dot &&
          $word =~ m!(?:\A|/)\.\.?(?:\z|/)!;
  
      # prepare list_func
      my $list = sub {
          my ($path, $intdir, $isint) = @_;
          opendir my($dh), $path or return undef;
          my @res;
          for (sort readdir $dh) {
              # skip . and .. if leaf is empty, like in bash
              next if ($_ eq '.' || $_ eq '..') && $intdir eq '';
              next if $isint && !(-d "$path/$_");
              push @res, $_;
          }
          \@res;
      };
  
      # prepare filter_func
      if ($filter && !ref($filter)) {
          my @seqs = split /\s*\|\s*/, $filter;
          $filter = sub {
              my $name = shift;
              my @st = stat($name) or return 0;
              my $mode = $st[2];
              my $pass;
            SEQ:
              for my $seq (@seqs) {
                  my $neg = sub { $_[0] };
                  for my $c (split //, $seq) {
                      if    ($c eq '-') { $neg = sub { $_[0] ? 0 : 1 } }
                      elsif ($c eq 'r') { next SEQ unless $neg->($mode & 0400) }
                      elsif ($c eq 'w') { next SEQ unless $neg->($mode & 0200) }
                      elsif ($c eq 'x') { next SEQ unless $neg->($mode & 0100) }
                      elsif ($c eq 'f') { next SEQ unless $neg->($mode & 0100000)}
                      elsif ($c eq 'd') { next SEQ unless $neg->($mode & 0040000)}
                      else {
                          die "Unknown character in filter: $c (in $seq)";
                      }
                  }
                  $pass = 1; last SEQ;
              }
              $pass;
          };
      } elsif (!$filter && $args{file_regex_filter}) {
          $filter = sub {
              my $name = shift;
              return 1 if -d $name;
              return 0 unless -f _;
              return 1 if $name =~ $args{file_regex_filter};
              0;
          };
      }
  
      Complete::Path::complete_path(
          word => $word,
  
          ci => $ci,
          map_case => $map_case,
          exp_im_path => $exp_im_path,
          dig_leaf => $dig_leaf,
  
          list_func => $list,
          is_dir_func => sub { -d $_[0] },
          filter_func => $filter,
          starting_path => $starting_path,
          result_prefix => $result_prefix,
      );
  }
  
  $SPEC{combine_answers} = {
      v => 1.1,
      summary => 'Given two or more answers, combine them into one',
      description => <<'_',
  
  This function is useful if you want to provide a completion answer that is
  gathered from multiple sources. For example, say you are providing completion
  for the Perl tool `cpanm`, which accepts a filename (a tarball like `*.tar.gz`),
  a directory, or a module name. You can do something like this:
  
      combine_answers(
          complete_file(word=>$word, ci=>1),
          complete_module(word=>$word, ci=>1),
      );
  
  _
      args => {
          answers => {
              schema => [
                  'array*' => {
                      of => ['any*', of=>['hash*','array*']], # XXX answer_t
                      min_len => 1,
                  },
              ],
              req => 1,
              pos => 0,
              greedy => 1,
          },
      },
      args_as => 'array',
      result_naked => 1,
      result => {
          schema => 'hash*',
          description => <<'_',
  
  Return a combined completion answer. Words from each input answer will be
  combined, order preserved and duplicates removed. The other keys from each
  answer will be merged.
  
  _
      },
  };
  sub combine_answers {
      require List::Util;
  
      return undef unless @_;
      return $_[0] if @_ < 2;
  
      my $final = {words=>[]};
      my $encounter_hash;
      my $add_words = sub {
          my $words = shift;
          for my $entry (@$words) {
              push @{ $final->{words} }, $entry
                  unless List::Util::first(
                      sub {
                          (ref($entry) ? $entry->{word} : $entry)
                              eq
                                  (ref($_) ? $_->{word} : $_)
                              }, @{ $final->{words} }
                          );
          }
      };
  
      for my $ans (@_) {
          if (ref($ans) eq 'ARRAY') {
              $add_words->($ans);
          } elsif (ref($ans) eq 'HASH') {
              $encounter_hash++;
              $add_words->($ans->{words} // []);
              for (keys %$ans) {
                  if ($_ eq 'words') {
                      next;
                  } elsif ($_ eq 'static') {
                      if (exists $final->{$_}) {
                          $final->{$_} &&= $ans->{$_};
                      } else {
                          $final->{$_} = $ans->{$_};
                      }
                  } else {
                      $final->{$_} = $ans->{$_};
                  }
              }
          }
      }
      $encounter_hash ? $final : $final->{words};
  }
  
  # TODO: complete_filesystem (probably in a separate module)
  # TODO: complete_hostname (/etc/hosts, ~/ssh/.known_hosts, ...)
  # TODO: complete_package (deb, rpm, ...)
  
  1;
  # ABSTRACT: General completion routine
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Complete::Util - General completion routine
  
  =head1 VERSION
  
  This document describes version 0.27 of Complete::Util (from Perl distribution Complete-Util), released on 2015-04-02.
  
  =head1 DESCRIPTION
  
  =head1 FUNCTIONS
  
  
  =head2 arrayify_answer(%args) -> array
  
  Make sure we return completion answer in array form.
  
  This is the reverse of C<hashify_answer>. It accepts a hash or an array. If it
  receives a hash, will return its C<words> key.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<arg>* => I<array|hash>
  
  =back
  
  Return value:  (array)
  
  
  =head2 combine_answers($answers, ...) -> hash
  
  Given two or more answers, combine them into one.
  
  This function is useful if you want to provide a completion answer that is
  gathered from multiple sources. For example, say you are providing completion
  for the Perl tool C<cpanm>, which accepts a filename (a tarball like C<*.tar.gz>),
  a directory, or a module name. You can do something like this:
  
   combine_answers(
       complete_file(word=>$word, ci=>1),
       complete_module(word=>$word, ci=>1),
   );
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<answers>* => I<array[hash|array]>
  
  =back
  
  Return value:  (hash)
  
  
  Return a combined completion answer. Words from each input answer will be
  combined, order preserved and duplicates removed. The other keys from each
  answer will be merged.
  
  
  =head2 complete_array_elem(%args) -> array
  
  Complete from array.
  
  Will sort the resulting completion list, so you don't have to presort the array.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<array>* => I<array[str]>
  
  =item * B<ci> => I<bool>
  
  =item * B<exclude> => I<array>
  
  =item * B<word>* => I<str> (default: "")
  
  =back
  
  Return value:  (array)
  
  
  =head2 complete_env(%args) -> array
  
  Complete from environment variables.
  
  On Windows, environment variable names are all converted to uppercase. You can
  use case-insensitive option (C<ci>) to match against original casing.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<ci> => I<bool>
  
  =item * B<word>* => I<str> (default: "")
  
  =back
  
  Return value:  (array)
  
  
  =head2 complete_file(%args) -> array
  
  Complete file and directory from local filesystem.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<allow_dot> => I<bool> (default: 1)
  
  If turned off, will not allow "." or ".." in path.
  
  This is most useful when combined with C<starting_path> option to prevent user
  going up/outside the starting path.
  
  =item * B<ci> => I<bool>
  
  Case-insensitive matching.
  
  =item * B<dig_leaf> => I<bool>
  
  =item * B<exp_im_path> => I<bool>
  
  =item * B<file_regex_filter> => I<re>
  
  Filter shortcut for file regex.
  
  This is a shortcut for constructing a filter. So instead of using C<filter>, you
  use this option. This will construct a filter of including only directories or
  regular files, and the file must match a regex pattern. This use-case is common.
  
  =item * B<filter> => I<str|code>
  
  Only return items matching this filter.
  
  Filter can either be a string or a code.
  
  For string filter, you can specify a pipe-separated groups of sequences of these
  characters: f, d, r, w, x. Dash can appear anywhere in the sequence to mean
  not/negate. An example: C<f> means to only show regular files, C<-f> means only
  show non-regular files, C<drwx> means to show only directories which are
  readable, writable, and executable (cd-able). C<wf|wd> means writable regular
  files or writable directories.
  
  For code filter, you supply a coderef. The coderef will be called for each item
  with these arguments: C<$name>. It should return true if it wants the item to be
  included.
  
  =item * B<handle_tilde> => I<bool> (default: 1)
  
  =item * B<map_case> => I<bool>
  
  =item * B<starting_path> => I<str> (default: ".")
  
  =item * B<word>* => I<str> (default: "")
  
  =back
  
  Return value:  (array)
  
  
  =head2 complete_hash_key(%args) -> array
  
  Complete from hash keys.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<ci> => I<bool>
  
  =item * B<hash>* => I<hash>
  
  =item * B<word>* => I<str> (default: "")
  
  =back
  
  Return value:  (array)
  
  
  =head2 complete_program(%args) -> array
  
  Complete program name found in PATH.
  
  Windows is supported, on Windows PATH will be split using /;/ instead of /:/.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<ci> => I<bool>
  
  =item * B<word>* => I<str> (default: "")
  
  =back
  
  Return value:  (array)
  
  
  =head2 hashify_answer(%args) -> hash
  
  Make sure we return completion answer in hash form.
  
  This function accepts a hash or an array. If it receives an array, will convert
  the array into `{words=>$ary}' first to make sure the completion answer is in
  hash form.
  
  Then will add keys from C<meta> to the hash.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<arg>* => I<array|hash>
  
  =item * B<meta> => I<hash>
  
  Metadata (extra keys) for the hash.
  
  =back
  
  Return value:  (hash)
  
  =for Pod::Coverage ^(complete_array)$
  
  =head1 SEE ALSO
  
  L<Complete>
  
  If you want to do bash tab completion with Perl, take a look at
  L<Complete::Bash> or L<Getopt::Long::Complete> or L<Perinci::CmdLine>.
  
  Other C<Complete::*> modules.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Complete-Util>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Complete-Util>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Util>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
COMPLETE_UTIL

$fatpacked{"Complete/Zsh.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'COMPLETE_ZSH';
  package Complete::Zsh;
  
  our $DATE = '2014-11-29'; # DATE
  our $VERSION = '0.01'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         parse_cmdline
                         format_completion
                 );
  
  require Complete::Bash;
  
  our %SPEC;
  
  $SPEC{parse_cmdline} = {
      v => 1.1,
      summary => 'Parse shell command-line for processing by completion routines',
      description => <<'_',
  
  This function converts COMP_LINE (str) (which can be supplied by zsh from `read
  -l`) and COMP_POINT (int) (which can be supplied by zsh from `read -ln`) into
  COMP_WORDS (array) and COMP_CWORD (int), like what bash supplies to shell
  functions. Currently implemented using `Complete::Bash`'s `parse_cmdline`.
  
  _
      args_as => 'array',
      args => {
          cmdline => {
              summary => 'Command-line, defaults to COMP_LINE environment',
              schema => 'str*',
              pos => 0,
          },
      },
      result => {
          schema => ['array*', len=>2],
          description => <<'_',
  
  Return a 2-element array: `[$words, $cword]`. `$words` is array of str,
  equivalent to `COMP_WORDS` provided by bash to shell functions. `$cword` is an
  integer, equivalent to `COMP_CWORD` provided by bash to shell functions. The
  word to be completed is at `$words->[$cword]`.
  
  Note that COMP_LINE includes the command name. If you want the command-line
  arguments only (like in `@ARGV`), you need to strip the first element from
  `$words` and reduce `$cword` by 1.
  
  _
      },
      result_naked => 1,
  };
  sub parse_cmdline {
      my ($line) = @_;
  
      $line //= $ENV{COMP_LINE};
      Complete::Bash::parse_cmdline($line, length($line));
  }
  
  $SPEC{format_completion} = {
      v => 1.1,
      summary => 'Format completion for output (for shell)',
      description => <<'_',
  
  zsh accepts completion reply in the form of one entry per line to STDOUT.
  Currently the formatting is done using `Complete::Bash`'s `format_completion`.
  
  _
      args_as => 'array',
      args => {
          completion => {
              summary => 'Completion answer structure',
              description => <<'_',
  
  Either an array or hash, as described in `Complete`.
  
  _
              schema=>['any*' => of => ['hash*', 'array*']],
              req=>1,
              pos=>0,
          },
      },
      result => {
          summary => 'Formatted string (or array, if `as` key is set to `array`)',
          schema => ['any*' => of => ['str*', 'array*']],
      },
      result_naked => 1,
  };
  sub format_completion {
      Complete::Bash::format_completion(@_);
  }
  
  1;
  #ABSTRACT: Completion module for zsh shell
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Complete::Zsh - Completion module for zsh shell
  
  =head1 VERSION
  
  This document describes version 0.01 of Complete::Zsh (from Perl distribution Complete-Zsh), released on 2014-11-29.
  
  =head1 DESCRIPTION
  
  This module provides routines related to doing completion in zsh.
  
  =head1 FUNCTIONS
  
  
  =head2 format_completion($completion) -> array|str
  
  Format completion for output (for shell).
  
  zsh accepts completion reply in the form of one entry per line to STDOUT.
  Currently the formatting is done using C<Complete::Bash>'s C<format_completion>.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<completion>* => I<array|hash>
  
  Completion answer structure.
  
  Either an array or hash, as described in C<Complete>.
  
  =back
  
  Return value:
  
  Formatted string (or array, if `as` key is set to `array`) (any)
  
  
  =head2 parse_cmdline($cmdline) -> array
  
  Parse shell command-line for processing by completion routines.
  
  This function converts COMP_LINE (str) (which can be supplied by zsh from C<read
  -l>) and COMP_POINT (int) (which can be supplied by zsh from C<read -ln>) into
  COMP_WORDS (array) and COMP_CWORD (int), like what bash supplies to shell
  functions. Currently implemented using C<Complete::Bash>'s C<parse_cmdline>.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<cmdline> => I<str>
  
  Command-line, defaults to COMP_LINE environment.
  
  =back
  
  Return value:
  
   (array)
  
  Return a 2-element array: C<[$words, $cword]>. C<$words> is array of str,
  equivalent to C<COMP_WORDS> provided by bash to shell functions. C<$cword> is an
  integer, equivalent to C<COMP_CWORD> provided by bash to shell functions. The
  word to be completed is at C<< $words-E<gt>[$cword] >>.
  
  Note that COMP_LINE includes the command name. If you want the command-line
  arguments only (like in C<@ARGV>), you need to strip the first element from
  C<$words> and reduce C<$cword> by 1.
  
  =head1 TODOS
  
  =head1 SEE ALSO
  
  L<Complete>
  
  L<Complete::Bash>, L<Complete::Fish>, L<Complete::Tcsh>.
  
  zshcompctl manual page.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Complete-Zsh>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Complete-Zsh>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Zsh>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
COMPLETE_ZSH

$fatpacked{"Config/IOD/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CONFIG_IOD_BASE';
  package Config::IOD::Base;
  
  our $DATE = '2015-03-27'; # DATE
  our $VERSION = '0.15'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  use Carp;
  
  use constant +{
      COL_V_ENCODING => 0, # either "!j" or '"', '[', '{'
      COL_V_WS1 => 1,
      COL_V_VALUE => 2,
      COL_V_WS2 => 3,
      COL_V_COMMENT_CHAR => 4,
      COL_V_COMMENT => 5,
  };
  
  sub new {
      my ($class, %attrs) = @_;
      $attrs{default_section} //= 'GLOBAL';
      $attrs{allow_bang_only} //= 1;
      $attrs{allow_duplicate_key} //= 1;
      $attrs{enable_encoding} //= 1;
      $attrs{enable_quoting}  //= 1;
      $attrs{enable_bracket}  //= 1;
      $attrs{enable_brace}    //= 1;
      $attrs{enable_expr}     //= 0;
      $attrs{ignore_unknown_directive} //= 0;
      # allow_encodings
      # disallow_encodings
      # allow_directives
      # disallow_directives
      bless \%attrs, $class;
  }
  
  # borrowed from Parse::CommandLine. differences: returns arrayref. return undef
  # on error (instead of dying).
  sub _parse_command_line {
      my ($self, $str) = @_;
  
      $str =~ s/\A\s+//ms;
      $str =~ s/\s+\z//ms;
  
      my @argv;
      my $buf;
      my $escaped;
      my $double_quoted;
      my $single_quoted;
  
      for my $char (split //, $str) {
          if ($escaped) {
              $buf .= $char;
              $escaped = undef;
              next;
          }
  
          if ($char eq '\\') {
              if ($single_quoted) {
                  $buf .= $char;
              }
              else {
                  $escaped = 1;
              }
              next;
          }
  
          if ($char =~ /\s/) {
              if ($single_quoted || $double_quoted) {
                  $buf .= $char;
              }
              else {
                  push @argv, $buf if defined $buf;
                  undef $buf;
              }
              next;
          }
  
          if ($char eq '"') {
              if ($single_quoted) {
                  $buf .= $char;
                  next;
              }
              $double_quoted = !$double_quoted;
              next;
          }
  
          if ($char eq "'") {
              if ($double_quoted) {
                  $buf .= $char;
                  next;
              }
              $single_quoted = !$single_quoted;
              next;
          }
  
          $buf .= $char;
      }
      push @argv, $buf if defined $buf;
  
      if ($escaped || $single_quoted || $double_quoted) {
          return undef;
      }
  
      \@argv;
  }
  
  # return ($err, $res, $decoded_val)
  sub _parse_raw_value {
      use experimental 'smartmatch';
  
      my ($self, $val, $needs_res) = @_;
  
      if ($val =~ /\A!/ && $self->{enable_encoding}) {
  
          $val =~ s/!(\w+)(\s+)// or return ("Invalid syntax in encoded value");
          my ($enc, $ws1) = ($1, $2);
  
          # canonicalize shorthands
          $enc = "json" if $enc eq 'j';
          $enc = "hex"  if $enc eq 'h';
          $enc = "expr" if $enc eq 'e';
  
          if ($self->{allow_encodings}) {
              return ("Encoding '$enc' is not in ".
                          "allow_encodings list")
                  unless $enc ~~ @{$self->{allow_encodings}};
          }
          if ($self->{disallow_encodings}) {
              return ("Encoding '$enc' is in ".
                          "disallow_encodings list")
                  if $enc ~~ @{$self->{disallow_encodings}};
          }
  
          if ($enc eq 'json') {
              # XXX imperfect regex for simplicity, comment should not contain
              # "]", '"', or '}' or it will be gobbled up as value by greedy regex
              # quantifier
              $val =~ /\A
                       (".*"|\[.*\]|\{.*\}|\S+)
                       (\s*)
                       (?: ([;#])(.*) )?
                       \z/x or return ("Invalid syntax in JSON-encoded value");
              my $res = [
                  "!$enc", # COL_V_ENCODING
                  $ws1, # COL_V_WS1
                  $1, # COL_V_VALUE
                  $2, # COL_V_WS2
                  $3, # COL_V_COMMENT_CHAR
                  $4, # COL_V_COMMENT
              ] if $needs_res;
              my $decode_res = $self->_decode_json($val);
              return ($decode_res->[1]) unless $decode_res->[0] == 200;
              return (undef, $res, $decode_res->[2]);
          } elsif ($enc eq 'hex') {
              $val =~ /\A
                       ([0-9A-Fa-f]*)
                       (\s*)
                       (?: ([;#])(.*) )?
                       \z/x or return ("Invalid syntax in hex-encoded value");
              my $res = [
                  "!$enc", # COL_V_ENCODING
                  $ws1, # COL_V_WS1
                  $1, # COL_V_VALUE
                  $2, # COL_V_WS2
                  $3, # COL_V_COMMENT_CHAR
                  $4, # COL_V_COMMENT
              ] if $needs_res;
              my $decode_res = $self->_decode_hex($1);
              return ($decode_res->[1]) unless $decode_res->[0] == 200;
              return (undef, $res, $decode_res->[2]);
          } elsif ($enc eq 'base64') {
              $val =~ m!\A
                        ([A-Za-z0-9+/]*=*)
                        (\s*)
                        (?: ([;#])(.*) )?
                        \z!x or return ("Invalid syntax in base64-encoded value");
              my $res = [
                  "!$enc", # COL_V_ENCODING
                  $ws1, # COL_V_WS1
                  $1, # COL_V_VALUE
                  $2, # COL_V_WS2
                  $3, # COL_V_COMMENT_CHAR
                  $4, # COL_V_COMMENT
              ] if $needs_res;
              my $decode_res = $self->_decode_base64($1);
              return ($decode_res->[1]) unless $decode_res->[0] == 200;
              return (undef, $res, $decode_res->[2]);
          } elsif ($enc eq 'expr') {
              return ("expr is not allowed (enable_expr=0)")
                  unless $self->{enable_expr};
              # XXX imperfect regex, expression can't contain # and ; because it
              # will be assumed as comment
              $val =~ m!\A
                        ((?:[^#;])+?)
                        (\s*)
                        (?: ([;#])(.*) )?
                        \z!x or return ("Invalid syntax in expr-encoded value");
              my $res = [
                  "!$enc", # COL_V_ENCODING
                  $ws1, # COL_V_WS1
                  $1, # COL_V_VALUE
                  $2, # COL_V_WS2
                  $3, # COL_V_COMMENT_CHAR
                  $4, # COL_V_COMMENT
              ] if $needs_res;
              my $decode_res = $self->_decode_expr($1);
              return ($decode_res->[1]) unless $decode_res->[0] == 200;
              return (undef, $res, $decode_res->[2]);
          } else {
              return ("unknown encoding '$enc'");
          }
  
      } elsif ($val =~ /\A"/ && $self->{enable_quoting}) {
  
          $val =~ /\A
                   "( (?:
                           \\\\ | # backslash
                           \\.  | # escaped something
                           [^"\\]+ # non-doublequote or non-backslash
                       )* )"
                   (\s*)
                   (?: ([;#])(.*) )?
                   \z/x or return ("Invalid syntax in quoted string value");
          my $res = [
              '"', # COL_V_ENCODING
              '', # COL_V_WS1
              $1, # VOL_V_VALUE
              $2, # COL_V_WS2
              $3, # COL_V_COMMENT_CHAR
              $4, # COL_V_COMMENT
          ] if $needs_res;
          my $decode_res = $self->_decode_json(qq("$1"));
          return ($decode_res->[1]) unless $decode_res->[0] == 200;
          return (undef, $res, $decode_res->[2]);
  
      } elsif ($val =~ /\A\[/ && $self->{enable_bracket}) {
  
          # XXX imperfect regex for simplicity, comment should not contain "]" or
          # it will be gobbled up as value by greedy regex quantifier
          $val =~ /\A
                   \[(.*)\]
                   (?:
                       (\s*)
                       ([#;])(.*)
                   )?
                   \z/x or return ("Invalid syntax in bracketed array value");
          my $res = [
              '[', # COL_V_ENCODING
              '', # COL_V_WS1
              $1, # VOL_V_VALUE
              $2, # COL_V_WS2
              $3, # COL_V_COMMENT_CHAR
              $4, # COL_V_COMMENT
          ] if $needs_res;
          my $decode_res = $self->_decode_json("[$1]");
          return ($decode_res->[1]) unless $decode_res->[0] == 200;
          return (undef, $res, $decode_res->[2]);
  
      } elsif ($val =~ /\A\{/ && $self->{enable_brace}) {
  
          # XXX imperfect regex for simplicity, comment should not contain "}" or
          # it will be gobbled up as value by greedy regex quantifier
          $val =~ /\A
                   \{(.*)\}
                   (?:
                       (\s*)
                       ([#;])(.*)
                   )?
                   \z/x or return ("Invalid syntax in braced hash value");
          my $res = [
              '{', # COL_V_ENCODING
              '', # COL_V_WS1
              $1, # VOL_V_VALUE
              $2, # COL_V_WS2
              $3, # COL_V_COMMENT_CHAR
              $4, # COL_V_COMMENT
          ] if $needs_res;
          my $decode_res = $self->_decode_json("{$1}");
          return ($decode_res->[1]) unless $decode_res->[0] == 200;
          return (undef, $res, $decode_res->[2]);
  
      } else {
  
          $val =~ /\A
                   (.*?)
                   (\s*)
                   (?: ([#;])(.*) )?
                   \z/x or return ("Invalid syntax in value"); # shouldn't happen, regex should match any string
          my $res = [
              '', # COL_V_ENCODING
              '', # COL_V_WS1
              $1, # VOL_V_VALUE
              $2, # COL_V_WS2
              $3, # COL_V_COMMENT_CHAR
              $4, # COL_V_COMMENT
          ] if $needs_res;
          return (undef, $res, $1);
  
      }
      # should not be reached
  }
  
  sub _decode_json {
      my ($self, $val) = @_;
      state $json = do {
          require JSON;
          JSON->new->allow_nonref;
      };
      my $res;
      eval { $res = $json->decode($val) };
      if ($@) {
          return [500, "Invalid JSON: $@"];
      } else {
          return [200, "OK", $res];
      }
  }
  
  sub _decode_hex {
      my ($self, $val) = @_;
      [200, "OK", pack("H*", $val)];
  }
  
  sub _decode_base64 {
      my ($self, $val) = @_;
      require MIME::Base64;
      [200, "OK", MIME::Base64::decode_base64($val)];
  }
  
  sub _decode_expr {
      require Config::IOD::Expr;
  
      my ($self, $val) = @_;
      no strict 'refs';
      local *{"Config::IOD::Expr::val"} = sub {
          my $arg = shift;
          if ($arg =~ /(.+)\.(.+)/) {
              return $self->{_res}{$1}{$2};
          } else {
              return $self->{_res}{ $self->{_cur_section} }{$arg};
          }
      };
      Config::IOD::Expr::_parse_expr($val);
  }
  
  sub _err {
      my ($self, $msg) = @_;
      croak join(
          "",
          @{ $self->{_include_stack} } ? "$self->{_include_stack}[0] " : "",
          "line $self->{_linum}: ",
          $msg
      );
  }
  
  sub _push_include_stack {
      require Cwd;
  
      my ($self, $path) = @_;
  
      # included file's path is based on the main (topmost) file
      if (@{ $self->{_include_stack} }) {
          require File::Spec;
          my (undef, $dir, $file) =
              File::Spec->splitpath($self->{_include_stack}[-1]);
          $path = File::Spec->rel2abs($path, $dir);
      }
  
      my $abs_path = Cwd::abs_path($path) or return [400, "Invalid path name"];
      return [409, "Recursive", $abs_path]
          if grep { $_ eq $abs_path } @{ $self->{_include_stack} };
      push @{ $self->{_include_stack} }, $abs_path;
      return [200, "OK", $abs_path];
  }
  
  sub _pop_include_stack {
      my $self = shift;
  
      croak "BUG: Overpopped _pop_include_stack"
          unless @{$self->{_include_stack}};
      pop @{ $self->{_include_stack} };
  }
  
  sub _init_read {
      my $self = shift;
  
      $self->{_include_stack} = [];
  }
  
  sub _read_file {
      my ($self, $filename) = @_;
      open my $fh, "<", $filename
          or croak "Can't open file '$filename': $!";
      binmode($fh, ":utf8");
      local $/;
      return ~~<$fh>;
  }
  
  sub read_file {
      my ($self, $filename) = @_;
      $self->_init_read;
      my $res = $self->_push_include_stack($filename);
      croak "Can't read '$filename': $res->[1]" unless $res->[0] == 200;
      $res =
          $self->_read_string($self->_read_file($filename));
      $self->_pop_include_stack;
      $res;
  }
  
  sub read_string {
      my ($self, $str) = @_;
      $self->_init_read;
      $self->_read_string($str);
  }
  
  1;
  # ABSTRACT: Base class for Config::IOD and Config::IOD::Reader
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Config::IOD::Base - Base class for Config::IOD and Config::IOD::Reader
  
  =head1 VERSION
  
  This document describes version 0.15 of Config::IOD::Base (from Perl distribution Config-IOD-Reader), released on 2015-03-27.
  
  =head1 ATTRIBUTES
  
  =for BEGIN_BLOCK: attributes
  
  =head2 default_section => str (default: C<GLOBAL>)
  
  If a key line is specified before any section line, this is the section that the
  key will be put in.
  
  =head2 enable_encoding => bool (default: 1)
  
  If set to false, then encoding notation will be ignored and key value will be
  parsed as verbatim. Example:
  
   name = !json null
  
  With C<enable_encoding> turned off, value will not be undef but will be string
  with the value of (as Perl literal) C<"!json null">.
  
  =head2 enable_quoting => bool (default: 1)
  
  If set to false, then quotes on key value will be ignored and key value will be
  parsed as verbatim. Example:
  
   name = "line 1\nline2"
  
  With C<enable_quoting> turned off, value will not be a two-line string, but will
  be a one line string with the value of (as Perl literal) C<"line 1\\nline2">.
  
  =head2 enable_bracket => bool (default: 1)
  
  If set to false, then JSON literal array will be parsed as verbatim. Example:
  
   name = [1,2,3]
  
  With C<enable_bracket> turned off, value will not be a three-element array, but
  will be a string with the value of (as Perl literal) C<"[1,2,3]">.
  
  =head2 enable_brace => bool (default: 1)
  
  If set to false, then JSON literal object (hash) will be parsed as verbatim.
  Example:
  
   name = {"a":1,"b":2}
  
  With C<enable_brace> turned off, value will not be a hash with two pairs, but
  will be a string with the value of (as Perl literal) C<'{"a":1,"b":2}'>.
  
  =head2 allow_encodings => array
  
  If defined, set list of allowed encodings. Note that if C<disallow_encodings> is
  also set, an encoding must also not be in that list.
  
  Also note that, for safety reason, if you want to enable C<expr> encoding,
  you'll also need to set C<enable_expr> to 1.
  
  =head2 disallow_encodings => array
  
  If defined, set list of disallowed encodings. Note that if C<allow_encodings> is
  also set, an encoding must also be in that list.
  
  Also note that, for safety reason, if you want to enable C<expr> encoding,
  you'll also need to set C<enable_expr> to 1.
  
  =head2 enable_expr => bool (default: 0)
  
  Whether to enable C<expr> encoding. By default this is turned on, for safety.
  Please see L</"EXPRESSION"> for more details.
  
  =head2 allow_directives => array
  
  If defined, only directives listed here are allowed. Note that if
  C<disallow_directives> is also set, a directive must also not be in that list.
  
  =head2 disallow_directives => array
  
  If defined, directives listed here are not allowed. Note that if
  C<allow_directives> is also set, a directive must also be in that list.
  
  =head2 allow_bang_only => bool (default: 1)
  
  Since the mistake of specifying a directive like this:
  
   !foo
  
  instead of the correct:
  
   ;!foo
  
  is very common, the spec allows it. This reader, however, can be configured to
  be more strict.
  
  =head2 allow_duplicate_key => bool (default: 1)
  
  If set to 0, you can forbid duplicate key, e.g.:
  
   [section]
   a=1
   a=2
  
  or:
  
   [section]
   a=1
   b=2
   c=3
   a=10
  
  In traditional INI file, to specify an array you specify multiple keys. But when
  there is only a single key, it is unclear if the value is a single-element array
  or a scalar. You can use this setting to avoid this array/scalar ambiguity in
  config file and force user to use JSON encoding or bracket to specify array:
  
   [section]
   a=[1,2]
  
  =head2 ignore_unknown_directive => bool (default: 0)
  
  If set to true, will not die if an unknown directive is encountered. It will
  simply be ignored as a regular comment.
  
  =for END_BLOCK: attributes
  
  =head1 EXPRESSION
  
  =for BEGIN_BLOCK: expression
  
  Expression allows you to do things like:
  
   [section1]
   foo=1
   bar="monkey"
  
   [section2]
   baz =!e 1+1
   qux =!e "grease" . val("section1.bar")
   quux=!e val("qux") . " " . val('baz')
  
  And the result will be:
  
   {
       section1 => {foo=>1, bar=>"monkey"},
       section2 => {baz=>2, qux=>"greasemonkey", quux=>"greasemonkey 2"},
   }
  
  For safety, you'll need to set C<enable_expr> attribute to 1 first to enable
  this feature.
  
  The syntax of the expression (the C<expr> encoding) is not officially specified
  yet in the L<IOD> specification. It will probably be Expr (see
  L<Language::Expr::Manual::Syntax>). At the moment, this module implements a very
  limited subset that is compatible (lowest common denominator) with Perl syntax
  and uses C<eval()> to evaluate the expression. However, only the limited subset
  is allowed (checked by Perl 5.10 regular expression).
  
  The supported terms:
  
   number
   string (double-quoted and single-quoted)
   undef literal
   function call (only the 'val' function is supported)
   grouping (parenthesis)
  
  The supported operators are:
  
   + - .
   * / % x
   **
   unary -, unary +, !, ~
  
  The C<val()> function refers to the configuration key. If the argument contains
  ".", it will be assumed as C<SECTIONNAME.KEYNAME>, otherwise it will access the
  current section's key. Since parsing is done in a single pass, you can only
  refer to the already mentioned key.
  
  =for END_BLOCK: expression
  
  =head1 METHODS
  
  =for BEGIN_BLOCK: methods
  
  =head2 new(%attrs) => obj
  
  =head2 $reader->read_file($filename)
  
  Read IOD configuration from a file. Die on errors.
  
  =head2 $reader->read_string($str)
  
  Read IOD configuration from a string. Die on errors.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Config-IOD-Reader>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Config-IOD-Reader>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Config-IOD-Reader>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
CONFIG_IOD_BASE

$fatpacked{"Config/IOD/Expr.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CONFIG_IOD_EXPR';
  package Config::IOD::Expr;
  
  our $DATE = '2015-03-27'; # DATE
  our $VERSION = '0.15'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  my $EXPR_RE = qr{
  
  (?&ANSWER)
  
  (?(DEFINE)
  
  (?<ANSWER>    (?&ADD))
  (?<ADD>       (?&MULT)   | (?&MULT)  (?: \s* ([+.-]) \s* (?&MULT)  )+)
  (?<MULT>      (?&UNARY)  | (?&UNARY) (?: \s* ([*/x%]) \s* (?&UNARY))+)
  (?<UNARY>     (?&POWER)  | [!~+-] (?&POWER))
  (?<POWER>     (?&TERM)   | (?&TERM) (?: \s* \*\* \s* (?&TERM))+)
  
  (?<TERM>
      (?&NUM)
    | (?&STR_SINGLE)
    | (?&STR_DOUBLE)
    | undef
    | (?&FUNC)
    | \( \s* ((?&ANSWER)) \s* \)
  )
  
  (?<FUNC> val \s* \( (?&TERM) \))
  
  (?<NUM>
      (
       -?
       (?: 0 | [1-9]\d* )
       (?: \. \d+ )?
       (?: [eE] [-+]? \d+ )?
      )
  )
  
  (?<STR_SINGLE>
      (
       '
       (?:
           [^\\']+
         |
           \\ ['\\]
         |
           \\
       )*
       '
      )
  )
  
  (?<STR_DOUBLE>
      (
       "
       (?:
           [^\\"]+
         |
           \\ ["'\\\$tnrfbae]
  # octal, hex, wide hex
       )*
       "
      )
  )
  
  ) # DEFINE
  
  }msx;
  
  sub _parse_expr {
      my $str = shift;
  
      return [400, 'Not a valid expr'] unless $str =~ m{\A$EXPR_RE\z}o;
      my $res = eval $str;
      return [500, "Died when evaluating expr: $@"] if $@;
      [200, "OK", $res];
  }
  
  1;
  # ABSTRACT: Parse expression
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Config::IOD::Expr - Parse expression
  
  =head1 VERSION
  
  This document describes version 0.15 of Config::IOD::Expr (from Perl distribution Config-IOD-Reader), released on 2015-03-27.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Config-IOD-Reader>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Config-IOD-Reader>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Config-IOD-Reader>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
CONFIG_IOD_EXPR

$fatpacked{"Config/IOD/Reader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CONFIG_IOD_READER';
  package Config::IOD::Reader;
  
  our $DATE = '2015-03-27'; # DATE
  our $VERSION = '0.15'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use parent qw(Config::IOD::Base);
  
  sub _merge {
      my ($self, $section) = @_;
  
      my $res = $self->{_res};
      for my $msect (@{ $self->{_merge} }) {
          if ($msect eq $section) {
              # ignore merging self
              next;
              #local $self->{_linum} = $self->{_linum}-1;
              #$self->_err("Can't merge section '$msect' to '$section': ".
              #                "Same section");
          }
          if (!exists($res->{$msect})) {
              local $self->{_linum} = $self->{_linum}-1;
              $self->_err("Can't merge section '$msect' to '$section': ".
                              "Section '$msect' not seen yet");
          }
          for my $k (keys %{ $res->{$msect} }) {
              $res->{$section}{$k} //= $res->{$msect}{$k};
          }
      }
  }
  
  sub _init_read {
      my $self = shift;
  
      $self->SUPER::_init_read;
      $self->{_res} = {};
      $self->{_merge} = undef;
      $self->{_num_seen_section_lines} = 0;
      $self->{_cur_section} = $self->{default_section};
      $self->{_arrayified} = {};
  }
  
  sub _read_string {
      my ($self, $str) = @_;
  
      my $res = $self->{_res};
      my $cur_section = $self->{_cur_section};
  
      my $directive_re = $self->{allow_bang_only} ?
          qr/^;?\s*!\s*(\w+)\s*/ :
          qr/^;\s*!\s*(\w+)\s*/;
  
      my @lines = split /^/, $str;
      local $self->{_linum} = 0;
    LINE:
      for my $line (@lines) {
          $self->{_linum}++;
  
          # blank line
          if ($line !~ /\S/) {
              next LINE;
          }
  
          # directive line
          if ($line =~ s/$directive_re//) {
              my $directive = $1;
              if ($self->{allow_directives}) {
                  $self->_err("Directive '$directive' is not in ".
                                  "allow_directives list")
                      unless grep { $_ eq $directive }
                          @{$self->{allow_directives}};
              }
              if ($self->{disallow_directives}) {
                  $self->_err("Directive '$directive' is in ".
                                  "disallow_directives list")
                      if grep { $_ eq $directive }
                          @{$self->{disallow_directives}};
              }
              my $args = $self->_parse_command_line($line);
              if (!defined($args)) {
                  $self->_err("Invalid arguments syntax '$line'");
              }
              if ($directive eq 'include') {
                  my $path;
                  if (! @$args) {
                      $self->_err("Missing filename to include");
                  } elsif (@$args > 1) {
                      $self->_err("Extraneous arguments");
                  } else {
                      $path = $args->[0];
                  }
                  my $res = $self->_push_include_stack($path);
                  if ($res->[0] != 200) {
                      $self->_err("Can't include '$path': $res->[1]");
                  }
                  $path = $res->[2];
                  $self->_read_string($self->_read_file($path));
                  $self->_pop_include_stack;
              } elsif ($directive eq 'merge') {
                  $self->{_merge} = @$args ? $args : undef;
              } elsif ($directive eq 'noop') {
              } else {
                  if ($self->{ignore_unknown_directive}) {
                      # assume a regular comment
                      next LINE;
                  } else {
                      $self->_err("Unknown directive '$directive'");
                  }
              }
              next LINE;
          }
  
          # comment line
          if ($line =~ /^\s*[;#]/) {
              next LINE;
          }
  
          # section line
          if ($line =~ /^\s*\[\s*(.+?)\s*\](?: \s*[;#].*)?/) {
              my $prev_section = $self->{_cur_section};
              $self->{_cur_section} = $cur_section = $1;
              $res->{$cur_section} //= {};
              $self->{_num_seen_section_lines}++;
  
              # previous section exists? do merging for previous section
              if ($self->{_merge} && $self->{_num_seen_section_lines} > 1) {
                  $self->_merge($prev_section);
              }
  
              next LINE;
          }
  
          # key line
          if ($line =~ /^\s*([^=]+?)\s*=\s*(.*)/) {
              my $key = $1;
              my $val = $2;
  
              # the common case is that value are not decoded or
              # quoted/bracketed/braced, so we avoid calling _parse_raw_value here
              # to avoid overhead
              if ($val =~ /\A["!\\[\{]/) {
                  my ($err, $parse_res, $decoded_val) = $self->_parse_raw_value($val);
                  $self->_err("Invalid value: " . $err) if $err;
                  $val = $decoded_val;
              } else {
                  $val =~ s/\s*[#;].*//; # strip comment
              }
  
              if (exists $res->{$cur_section}{$key}) {
                  if (!$self->{allow_duplicate_key}) {
                      $self->_err("Duplicate key: $key (section $cur_section)");
                  } elsif ($self->{_arrayified}{$cur_section}{$key}++) {
                      push @{ $res->{$cur_section}{$key} }, $val;
                  } else {
                      $res->{$cur_section}{$key} = [
                          $res->{$cur_section}{$key}, $val];
                  }
              } else {
                  $res->{$cur_section}{$key} = $val;
              }
  
              next LINE;
          }
  
          $self->_err("Invalid syntax");
      }
  
      if ($self->{_merge} && $self->{_num_seen_section_lines} > 1) {
          $self->_merge($cur_section);
      }
  
      $res;
  }
  
  1;
  # ABSTRACT: Read IOD configuration files
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Config::IOD::Reader - Read IOD configuration files
  
  =head1 VERSION
  
  This document describes version 0.15 of Config::IOD::Reader (from Perl distribution Config-IOD-Reader), released on 2015-03-27.
  
  =head1 SYNOPSIS
  
   use Config::IOD::Reader;
   my $reader = Config::IOD::Reader->new(
       # list of known attributes, with their default values
       # default_section     => 'GLOBAL',
       # enable_encoding     => 1,
       # enable_quoting      => 1,
       # enable_backet       => 1,
       # enable_brace        => 1,
       # allow_encodings     => undef, # or ['base64','json',...]
       # disallow_encodings  => undef, # or ['base64','json',...]
       # allow_directives    => undef, # or ['include','merge',...]
       # disallow_directives => undef, # or ['include','merge',...]
       # allow_bang_only     => 1,
       # enable_expr         => 0,
   );
   my $config_hash = $reader->read_file('config.iod');
  
  =head1 DESCRIPTION
  
  This module reads L<IOD> configuration files. It is a minimalist alternative to
  the more fully-featured L<Config::IOD>. It cannot write IOD files and is
  optimized for low startup overhead.
  
  =head1 EXPRESSION
  
  Expression allows you to do things like:
  
   [section1]
   foo=1
   bar="monkey"
  
   [section2]
   baz =!e 1+1
   qux =!e "grease" . val("section1.bar")
   quux=!e val("qux") . " " . val('baz')
  
  And the result will be:
  
   {
       section1 => {foo=>1, bar=>"monkey"},
       section2 => {baz=>2, qux=>"greasemonkey", quux=>"greasemonkey 2"},
   }
  
  For safety, you'll need to set C<enable_expr> attribute to 1 first to enable
  this feature.
  
  The syntax of the expression (the C<expr> encoding) is not officially specified
  yet in the L<IOD> specification. It will probably be Expr (see
  L<Language::Expr::Manual::Syntax>). At the moment, this module implements a very
  limited subset that is compatible (lowest common denominator) with Perl syntax
  and uses C<eval()> to evaluate the expression. However, only the limited subset
  is allowed (checked by Perl 5.10 regular expression).
  
  The supported terms:
  
   number
   string (double-quoted and single-quoted)
   undef literal
   function call (only the 'val' function is supported)
   grouping (parenthesis)
  
  The supported operators are:
  
   + - .
   * / % x
   **
   unary -, unary +, !, ~
  
  The C<val()> function refers to the configuration key. If the argument contains
  ".", it will be assumed as C<SECTIONNAME.KEYNAME>, otherwise it will access the
  current section's key. Since parsing is done in a single pass, you can only
  refer to the already mentioned key.
  
  =head1 ATTRIBUTES
  
  =head2 default_section => str (default: C<GLOBAL>)
  
  If a key line is specified before any section line, this is the section that the
  key will be put in.
  
  =head2 enable_encoding => bool (default: 1)
  
  If set to false, then encoding notation will be ignored and key value will be
  parsed as verbatim. Example:
  
   name = !json null
  
  With C<enable_encoding> turned off, value will not be undef but will be string
  with the value of (as Perl literal) C<"!json null">.
  
  =head2 enable_quoting => bool (default: 1)
  
  If set to false, then quotes on key value will be ignored and key value will be
  parsed as verbatim. Example:
  
   name = "line 1\nline2"
  
  With C<enable_quoting> turned off, value will not be a two-line string, but will
  be a one line string with the value of (as Perl literal) C<"line 1\\nline2">.
  
  =head2 enable_bracket => bool (default: 1)
  
  If set to false, then JSON literal array will be parsed as verbatim. Example:
  
   name = [1,2,3]
  
  With C<enable_bracket> turned off, value will not be a three-element array, but
  will be a string with the value of (as Perl literal) C<"[1,2,3]">.
  
  =head2 enable_brace => bool (default: 1)
  
  If set to false, then JSON literal object (hash) will be parsed as verbatim.
  Example:
  
   name = {"a":1,"b":2}
  
  With C<enable_brace> turned off, value will not be a hash with two pairs, but
  will be a string with the value of (as Perl literal) C<'{"a":1,"b":2}'>.
  
  =head2 allow_encodings => array
  
  If defined, set list of allowed encodings. Note that if C<disallow_encodings> is
  also set, an encoding must also not be in that list.
  
  Also note that, for safety reason, if you want to enable C<expr> encoding,
  you'll also need to set C<enable_expr> to 1.
  
  =head2 disallow_encodings => array
  
  If defined, set list of disallowed encodings. Note that if C<allow_encodings> is
  also set, an encoding must also be in that list.
  
  Also note that, for safety reason, if you want to enable C<expr> encoding,
  you'll also need to set C<enable_expr> to 1.
  
  =head2 enable_expr => bool (default: 0)
  
  Whether to enable C<expr> encoding. By default this is turned on, for safety.
  Please see L</"EXPRESSION"> for more details.
  
  =head2 allow_directives => array
  
  If defined, only directives listed here are allowed. Note that if
  C<disallow_directives> is also set, a directive must also not be in that list.
  
  =head2 disallow_directives => array
  
  If defined, directives listed here are not allowed. Note that if
  C<allow_directives> is also set, a directive must also be in that list.
  
  =head2 allow_bang_only => bool (default: 1)
  
  Since the mistake of specifying a directive like this:
  
   !foo
  
  instead of the correct:
  
   ;!foo
  
  is very common, the spec allows it. This reader, however, can be configured to
  be more strict.
  
  =head2 allow_duplicate_key => bool (default: 1)
  
  If set to 0, you can forbid duplicate key, e.g.:
  
   [section]
   a=1
   a=2
  
  or:
  
   [section]
   a=1
   b=2
   c=3
   a=10
  
  In traditional INI file, to specify an array you specify multiple keys. But when
  there is only a single key, it is unclear if the value is a single-element array
  or a scalar. You can use this setting to avoid this array/scalar ambiguity in
  config file and force user to use JSON encoding or bracket to specify array:
  
   [section]
   a=[1,2]
  
  =head2 ignore_unknown_directive => bool (default: 0)
  
  If set to true, will not die if an unknown directive is encountered. It will
  simply be ignored as a regular comment.
  
  =head1 METHODS
  
  =head2 new(%attrs) => obj
  
  =head2 $reader->read_file($filename) => hash
  
  Read IOD configuration from a file. Die on errors.
  
  =head2 $reader->read_string($str) => hash
  
  Read IOD configuration from a string. Die on errors.
  
  =head1 SEE ALSO
  
  L<IOD> - specification
  
  L<Config::IOD> - round-trip parser for reading as well as writing IOD documents
  
  L<IOD::Examples> - sample documents
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Config-IOD-Reader>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Config-IOD-Reader>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Config-IOD-Reader>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
CONFIG_IOD_READER

$fatpacked{"Data/Check/Structure.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_CHECK_STRUCTURE';
  package Data::Check::Structure;
  
  our $DATE = '2014-07-14'; # DATE
  our $VERSION = '0.03'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         is_aoa
                         is_aoaos
                         is_aoh
                         is_aohos
                         is_aos
                         is_hoa
                         is_hoaos
                         is_hoh
                         is_hohos
                         is_hos
                 );
  
  sub is_aos {
      my ($data, $opts) = @_;
      $opts //= {};
      my $max = $opts->{max};
  
      return 0 unless ref($data) eq 'ARRAY';
      for my $i (0..@$data-1) {
          last if defined($max) && $i >= $max;
          return 0 if ref($data->[$i]);
      }
      1;
  }
  
  sub is_aoa {
      my ($data, $opts) = @_;
      $opts //= {};
      my $max = $opts->{max};
  
      return 0 unless ref($data) eq 'ARRAY';
      for my $i (0..@$data-1) {
          last if defined($max) && $i >= $max;
          return 0 unless ref($data->[$i]) eq 'ARRAY';
      }
      1;
  }
  
  sub is_aoaos {
      my ($data, $opts) = @_;
      $opts //= {};
      my $max = $opts->{max};
  
      return 0 unless ref($data) eq 'ARRAY';
      my $aos_opts = {max=>$max};
      for my $i (0..@$data-1) {
          last if defined($max) && $i >= $max;
          return 0 unless is_aos($data->[$i], $aos_opts);
      }
      1;
  }
  
  sub is_aoh {
      my ($data, $opts) = @_;
      $opts //= {};
      my $max = $opts->{max};
  
      return 0 unless ref($data) eq 'ARRAY';
      for my $i (0..@$data-1) {
          last if defined($max) && $i >= $max;
          return 0 unless ref($data->[$i]) eq 'HASH';
      }
      1;
  }
  
  sub is_aohos {
      my ($data, $opts) = @_;
      $opts //= {};
      my $max = $opts->{max};
  
      return 0 unless ref($data) eq 'ARRAY';
      my $hos_opts = {max=>$max};
      for my $i (0..@$data-1) {
          last if defined($max) && $i >= $max;
          return 0 unless is_hos($data->[$i], $hos_opts);
      }
      1;
  }
  
  sub is_hos {
      my ($data, $opts) = @_;
      $opts //= {};
      my $max = $opts->{max};
  
      return 0 unless ref($data) eq 'HASH';
      my $i = 0;
      for my $k (keys %$data) {
          last if defined($max) && ++$i >= $max;
          return 0 if ref($data->{$k});
      }
      1;
  }
  
  sub is_hoa {
      my ($data, $opts) = @_;
      $opts //= {};
      my $max = $opts->{max};
  
      return 0 unless ref($data) eq 'HASH';
      my $i = 0;
      for my $k (keys %$data) {
          last if defined($max) && ++$i >= $max;
          return 0 unless ref($data->{$k}) eq 'ARRAY';
      }
      1;
  }
  
  sub is_hoaos {
      my ($data, $opts) = @_;
      $opts //= {};
      my $max = $opts->{max};
  
      return 0 unless ref($data) eq 'HASH';
      my $i = 0;
      for my $k (keys %$data) {
          last if defined($max) && ++$i >= $max;
          return 0 unless is_aos($data->{$k});
      }
      1;
  }
  
  sub is_hoh {
      my ($data, $opts) = @_;
      $opts //= {};
      my $max = $opts->{max};
  
      return 0 unless ref($data) eq 'HASH';
      my $i = 0;
      for my $k (keys %$data) {
          last if defined($max) && ++$i >= $max;
          return 0 unless ref($data->{$k}) eq 'HASH';
      }
      1;
  }
  
  sub is_hohos {
      my ($data, $opts) = @_;
      $opts //= {};
      my $max = $opts->{max};
  
      return 0 unless ref($data) eq 'HASH';
      my $i = 0;
      for my $k (keys %$data) {
          last if defined($max) && ++$i >= $max;
          return 0 unless is_hos($data->{$k});
      }
      1;
  }
  
  1;
  # ABSTRACT: Check structure of data
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Check::Structure - Check structure of data
  
  =head1 VERSION
  
  This document describes version 0.03 of Data::Check::Structure (from Perl distribution Data-Check-Structure), released on 2014-07-14.
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  This small module provides several simple routines to check the structure of
  data, e.g. whether data is an array of arrays ("aoa"), array of scalars ("aos"),
  and so on.
  
  =head1 FUNCTIONS
  
  =head2 is_aos($data, \%opts) => bool
  
  Check that data is an array of scalars. Examples:
  
   is_aos([]);                     # true
   is_aos(['a', 'b']);             # true
   is_aos(['a', []]);              # false
   is_aos([1,2,3, []], {max=>3});  # true
  
  Known options: C<max> (maximum number of items to check, undef means check all
  items).
  
  =head2 is_aoa($data, \%opts) => bool
  
  Check that data is an array of arrays. Examples:
  
   is_aoa([]);                          # true
   is_aoa([[1], [2]]);                  # true
   is_aoa([[1], 'a']);                  # false
   is_aoa([[1],[],[], 'a'], {max=>3});  # true
  
  Known options: C<max> (maximum number of items to check, undef means check all
  items).
  
  =head2 is_aoaos($data, \%opts) => bool
  
  Check that data is an array of arrays of scalars. Examples:
  
   is_aoaos([]);                           # true
   is_aoaos([[1], [2]]);                   # true
   is_aoaos([[1], [{}]]);                  # false
   is_aoaos([[1],[],[], [{}]], {max=>3});  # true
  
  Known options: C<max> (maximum number of items to check, undef means check all
  items).
  
  =head2 is_aoh($data, \%opts) => bool
  
  Check that data is an array of hashes. Examples:
  
   is_aoh([]);                             # true
   is_aoh([{}, {a=>1}]);                   # true
   is_aoh([{}, 'a']);                      # false
   is_aoh([{},{},{a=>1}, 'a'], {max=>3});  # true
  
  Known options: C<max> (maximum number of items to check, undef means check all
  items).
  
  =head2 is_aohos($data, \%opts) => bool
  
  Check that data is an array of hashes of scalars. Examples:
  
   is_aohos([]);                                 # true
   is_aohos([{a=>1}, {}]);                       # true
   is_aohos([{a=>1}, {b=>[]}]);                  # false
   is_aohos([{a=>1},{},{}, {b=>[]}], {max=>3});  # true
  
  Known options: C<max> (maximum number of items to check, undef means check all
  items).
  
  =head2 is_hos($data, \%opts) => bool
  
  Check that data is a hash of scalars. Examples:
  
   is_hos({});                                   # true
   is_hos({a=>1, b=>2});                         # true
   is_hos({a=>1, b=>[]});                        # false
   is_hos({a=>1, b=>2, c=>3, d=>[]}, {max=>3});  # true (or false, depending on random hash key ordering)
  
  Known options: C<max> (maximum number of items to check, undef means check all
  items).
  
  =head2 is_hoa($data, \%opts) => bool
  
  Check that data is a hash of arrays. Examples:
  
   is_hoa({}) );       # true
   is_hoa({a=>[]}) );  # true
   is_hoa({a=>1}) );   # false
  
  Known options: C<max> (maximum number of items to check, undef means check all
  items).
  
  =head2 is_hoaos($data, \%opts) => bool
  
  Check that data is a hash of arrays of scalars. Examples:
  
   is_hoaos({}) );         # true
   is_hoaos({a=>[]}) );    # true
   is_hoaos({a=>[1]}) );   # true
   is_hoaos({a=>1}) );     # false
   is_hoaos({a=>[{}]}) );  # false
  
  Known options: C<max> (maximum number of items to check, undef means check all
  items).
  
  =head2 is_hoh($data, \%opts) => bool
  
  Check that data is a hash of hashes. Examples:
  
   is_hoh({}) );       # true
   is_hoh({a=>{}}) );  # true
   is_hoh({a=>1}) );   # false
  
  Known options: C<max> (maximum number of items to check, undef means check all
  items).
  
  =head2 is_hohos($data, \%opts) => bool
  
  Check that data is a hash of hashes of scalrs. Examples:
  
   is_hohos({}) );            # true
   is_hohos({a=>{}}) );       # true
   is_hohos({a=>{b=>1}}) );   # true
   is_hohos({a=>1}) );        # false
   is_hohos({a=>{b=>[]}}) );  # false
  
  Known options: C<max> (maximum number of items to check, undef means check all
  items).
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Check-Structure>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-Check-Structure>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Check-Structure>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  Steven Haryanto <stevenharyanto@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Steven Haryanto.
  
  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
DATA_CHECK_STRUCTURE

$fatpacked{"Data/Clean/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_CLEAN_BASE';
  package Data::Clean::Base;
  
  our $DATE = '2015-03-26'; # DATE
  our $VERSION = '0.24'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Log::Any::IfLOG '$log';
  
  use Function::Fallback::CoreOrPP qw(clone);
  use Scalar::Util qw(blessed);
  
  sub new {
      my ($class, %opts) = @_;
      my $self = bless {opts=>\%opts}, $class;
      $log->tracef("Cleanser options: %s", \%opts);
      $self->_generate_cleanser_code;
      $self;
  }
  
  sub command_call_method {
      my ($self, $args) = @_;
      my $mn = $args->[0];
      die "Invalid method name syntax" unless $mn =~ /\A\w+\z/;
      return "{{var}} = {{var}}->$mn; \$ref = ref({{var}})";
  }
  
  sub command_call_func {
      my ($self, $args) = @_;
      my $fn = $args->[0];
      die "Invalid func name syntax" unless $fn =~ /\A\w+(::\w+)*\z/;
      return "{{var}} = $fn({{var}}); \$ref = ref({{var}})";
  }
  
  sub command_one_or_zero {
      my ($self, $args) = @_;
      return "{{var}} = {{var}} ? 1:0; \$ref = ''";
  }
  
  sub command_deref_scalar {
      my ($self, $args) = @_;
      return '{{var}} = ${ {{var}} }; $ref = ref({{var}})';
  }
  
  sub command_stringify {
      my ($self, $args) = @_;
      return '{{var}} = "{{var}}"';
  }
  
  sub command_replace_with_ref {
      my ($self, $args) = @_;
      return '{{var}} = $ref; $ref = ""';
  }
  
  sub command_replace_with_str {
      require String::PerlQuote;
  
      my ($self, $args) = @_;
      return "{{var}} = ".String::PerlQuote::double_quote($args->[0]).'; $ref=""';
  }
  
  sub command_unbless {
      my ($self, $args) = @_;
  
      # Data::Clone by default does not clone objects, so Acme::Damn can modify
      # the original object despite the use of clone(), so we need to know whether
      # user runs clone_and_clean() or clean_in_place() and avoid the use of
      # Acme::Damn for the former case. this workaround will be unnecessary when
      # Data::Clone clones objects.
  
      my $acme_damn_available = eval { require Acme::Damn; 1 } ? 1:0;
      return join(
          "",
          "if (!\$Data::Clean::Base::_clone && $acme_damn_available) { ",
          "{{var}} = Acme::Damn::damn({{var}}) ",
          "} else { ",
          "{{var}} = Function::Fallback::CoreOrPP::_unbless_fallback({{var}}) } ",
          "\$ref = ref({{var}})",
      );
  }
  
  sub command_clone {
      my $clone_func;
      eval { require Data::Clone };
      if ($@) {
          require Clone::PP;
          $clone_func = "Clone::PP::clone";
      } else {
          $clone_func = "Data::Clone::clone";
      }
  
      my ($self, $args) = @_;
      my $limit = $args->[0] // 1;
      return join(
          "",
          "if (++\$ctr_circ <= $limit) { ",
          "{{var}} = $clone_func({{var}}); redo ",
          "} else { ",
          "{{var}} = 'CIRCULAR' } ",
          "\$ref = ref({{var}})",
      );
  }
  
  # test
  sub command_die {
      my ($self, $args) = @_;
      return "die";
  }
  
  sub _generate_cleanser_code {
      my $self = shift;
      my $opts = $self->{opts};
  
      my (@code, @stmts_ary, @stmts_hash, @stmts_main);
  
      my $n = 0;
      my $add_stmt = sub {
          my $which = shift;
          if ($which eq 'if' || $which eq 'new_if') {
              my ($cond0, $act0) = @_;
              for ([\@stmts_ary, '$e', 'ary'],
                   [\@stmts_hash, '$h->{$k}', 'hash'],
                   [\@stmts_main, '$_', 'main']) {
                  my $act  = $act0 ; $act  =~ s/\Q{{var}}\E/$_->[1]/g;
                  my $cond = $cond0; $cond =~ s/\Q{{var}}\E/$_->[1]/g;
                  #unless (@{ $_->[0] }) { push @{ $_->[0] }, '    say "D:'.$_->[2].' val=", '.$_->[1].', ", ref=$ref"; # DEBUG'."\n" }
                  push @{ $_->[0] }, "    ".($n && $which ne 'new_if' ? "els":"")."if ($cond) { $act }\n";
              }
              $n++;
          } else {
              my ($stmt0) = @_;
              for ([\@stmts_ary, '$e', 'ary'],
                   [\@stmts_hash, '$h->{$k}', 'hash'],
                   [\@stmts_main, '$_', 'main']) {
                  my $stmt = $stmt0; $stmt =~ s/\Q{{var}}\E/$_->[1]/g;
                  push @{ $_->[0] }, "    $stmt;\n";
              }
          }
      };
      my $add_if = sub {
          $add_stmt->('if', @_);
      };
      my $add_new_if = sub {
          $add_stmt->('new_if', @_);
      };
      my $add_if_ref = sub {
          my ($ref, $act0) = @_;
          $add_if->("\$ref eq '$ref'", $act0);
      };
      my $add_new_if_ref = sub {
          my ($ref, $act0) = @_;
          $add_new_if->("\$ref eq '$ref'", $act0);
      };
  
      # catch object of specified classes (e.g. DateTime, etc)
      for my $on (grep {/\A\w*(::\w+)*\z/} sort keys %$opts) {
          my $o = $opts->{$on};
          next unless $o;
          my $meth = "command_$o->[0]";
          die "Can't handle command $o->[0] for option '$on'" unless $self->can($meth);
          my @args = @$o; shift @args;
          my $act = $self->$meth(\@args);
          $add_if_ref->($on, $act);
      }
  
      # catch general object not caught by previous
      for my $p ([-obj => 'blessed({{var}})']) {
          my $o = $opts->{$p->[0]};
          next unless $o;
          my $meth = "command_$o->[0]";
          die "Can't handle command $o->[0] for option '$p->[0]'" unless $self->can($meth);
          my @args = @$o; shift @args;
          $add_if->($p->[1], $self->$meth(\@args));
      }
  
      # catch circular references
      my $circ = $opts->{-circular};
      if ($circ) {
          my $meth = "command_$circ->[0]";
          die "Can't handle command $circ->[0] for option '-circular'" unless $self->can($meth);
          my @args = @$circ; shift @args;
          my $act = $self->$meth(\@args);
          #$add_stmt->('stmt', 'say "ref=$ref, " . {{var}}'); # DEBUG
          $add_new_if->('$ref && $refs{ {{var}} }++', $act);
      }
  
      # recurse array and hash
      $add_new_if_ref->("ARRAY", '$process_array->({{var}})');
      $add_if_ref->("HASH" , '$process_hash->({{var}})');
  
      # lastly, catch any reference left
      for my $p ([-ref => '$ref']) {
          my $o = $opts->{$p->[0]};
          next unless $o;
          my $meth = "command_$o->[0]";
          die "Can't handle command $o->[0] for option '$p->[0]'" unless $self->can($meth);
          my @args = @$o; shift @args;
          $add_if->($p->[1], $self->$meth(\@args));
      }
  
      push @code, 'sub {'."\n";
      push @code, 'my $data = shift;'."\n";
      push @code, 'state %refs;'."\n" if $circ;
      push @code, 'state $ctr_circ;'."\n" if $circ;
      push @code, 'state $process_array;'."\n";
      push @code, 'state $process_hash;'."\n";
      push @code, 'if (!$process_array) { $process_array = sub { my $a = shift; for my $e (@$a) { my $ref=ref($e);'."\n".join("", @stmts_ary).'} } }'."\n";
      push @code, 'if (!$process_hash) { $process_hash = sub { my $h = shift; for my $k (keys %$h) { my $ref=ref($h->{$k});'."\n".join("", @stmts_hash).'} } }'."\n";
      push @code, '%refs = (); $ctr_circ=0;'."\n" if $circ;
      push @code, 'for ($data) { my $ref=ref($_);'."\n".join("", @stmts_main).'}'."\n";
      push @code, '$data'."\n";
      push @code, '}'."\n";
  
      my $code = join("", @code).";";
      if ($ENV{LOG_CLEANSER_CODE} && $log->is_trace) {
          require String::LineNumber;
          $log->tracef("Cleanser code:\n%s",
                       $ENV{LINENUM} // 1 ?
                           String::LineNumber::linenum($code) : $code);
      }
      eval "\$self->{code} = $code";
      die "Can't generate code: $@" if $@;
  }
  
  sub clean_in_place {
      my ($self, $data) = @_;
  
      $self->{code}->($data);
  }
  
  sub clone_and_clean {
      my ($self, $data) = @_;
      my $clone = clone($data);
      local $Data::Clean::Base::_clone = 1;
      $self->clean_in_place($clone);
  }
  
  1;
  # ABSTRACT: Base class for Data::Clean::*
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Clean::Base - Base class for Data::Clean::*
  
  =head1 VERSION
  
  This document describes version 0.24 of Data::Clean::Base (from Perl distribution Data-Clean-JSON), released on 2015-03-26.
  
  =for Pod::Coverage ^(command_.+)$
  
  =head1 METHODS
  
  =head2 new(%opts) => $obj
  
  Create a new instance.
  
  Options specify what to do with problematic data. Option keys are either
  reference types or class names, or C<-obj> (to refer to objects, a.k.a. blessed
  references), C<-circular> (to refer to circular references), C<-ref> (to refer
  to references, used to process references not handled by other options). Option
  values are arrayrefs, the first element of the array is command name, to specify
  what to do with the reference/class. The rest are command arguments.
  
  Note that arrayrefs and hashrefs are always walked into, so it's not trapped by
  C<-ref>.
  
  Default for C<%opts>: C<< -ref => 'stringify' >>.
  
  Available commands:
  
  =over 4
  
  =item * ['stringify']
  
  This will stringify a reference like C<{}> to something like C<HASH(0x135f998)>.
  
  =item * ['replace_with_ref']
  
  This will replace a reference like C<{}> with C<HASH>.
  
  =item * ['replace_with_str', STR]
  
  This will replace a reference like C<{}> with I<STR>.
  
  =item * ['call_method']
  
  This will call a method and use its return as the replacement. For example:
  DateTime->from_epoch(epoch=>1000) when processed with [call_method => 'epoch']
  will become 1000.
  
  =item * ['call_func', STR]
  
  This will call a function named STR with value as argument and use its return as
  the replacement.
  
  =item * ['one_or_zero', STR]
  
  This will perform C<< $val ? 1:0 >>.
  
  =item * ['deref_scalar']
  
  This will replace a scalar reference like \1 with 1.
  
  =item * ['unbless']
  
  This will perform unblessing using L<Function::Fallback::CoreOrPP::unbless()>.
  Should be done only for objects (C<-obj>).
  
  =item * ['code', STR]
  
  This will replace with STR treated as Perl code.
  
  =item * ['clone', INT]
  
  This command is useful if you have circular references and want to expand/copy
  them. For example:
  
   my $def_opts = { opt1 => 'default', opt2 => 0 };
   my $users    = { alice => $def_opts, bob => $def_opts, charlie => $def_opts };
  
  C<$users> contains three references to the same data structure. With the default
  behaviour of C<< -circular => [replace_with_str => 'CIRCULAR'] >> the cleaned
  data structure will be:
  
   { alice   => { opt1 => 'default', opt2 => 0 },
     bob     => 'CIRCULAR',
     charlie => 'CIRCULAR' }
  
  But with C<< -circular => ['clone'] >> option, the data structure will be
  cleaned to become (the C<$def_opts> is cloned):
  
   { alice   => { opt1 => 'default', opt2 => 0 },
     bob     => { opt1 => 'default', opt2 => 0 },
     charlie => { opt1 => 'default', opt2 => 0 }, }
  
  The command argument specifies the number of references to clone as a limit (the
  default is 50), since a cyclical structure can lead to infinite cloning. Above
  this limit, the circular references will be replaced with a string
  C<"CIRCULAR">. For example:
  
   my $a = [1]; push @$a, $a;
  
  With C<< -circular => ['clone', 2] >> the data will be cleaned as:
  
   [1, [1, [1, "CIRCULAR"]]]
  
  With C<< -circular => ['clone', 3] >> the data will be cleaned as:
  
   [1, [1, [1, [1, "CIRCULAR"]]]]
  
  =back
  
  =head2 $obj->clean_in_place($data) => $cleaned
  
  Clean $data. Modify data in-place.
  
  =head2 $obj->clone_and_clean($data) => $cleaned
  
  Clean $data. Clone $data first.
  
  =head1 ENVIRONMENT
  
  =over
  
  =item * LOG_CLEANSER_CODE => BOOL (default: 0)
  
  Can be enabled if you want to see the generated cleanser code. It is logged at
  level C<trace>.
  
  =item * LINENUM => BOOL (default: 1)
  
  When logging cleanser code, whether to give line numbers.
  
  =back
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Clean-JSON>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Clean-JSON>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Clean-JSON>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_CLEAN_BASE

$fatpacked{"Data/Clean/FromJSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_CLEAN_FROMJSON';
  package Data::Clean::FromJSON;
  
  our $DATE = '2015-03-26'; # DATE
  our $VERSION = '0.24'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use parent qw(Data::Clean::Base);
  
  sub new {
      my ($class, %opts) = @_;
      $opts{"JSON::XS::Boolean"} //= ['one_or_zero'];
      $opts{"JSON::PP::Boolean"} //= ['one_or_zero'];
      $class->SUPER::new(%opts);
  }
  
  sub get_cleanser {
      my $class = shift;
      state $singleton = $class->new;
      $singleton;
  }
  
  1;
  # ABSTRACT: Clean data from JSON decoder
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Clean::FromJSON - Clean data from JSON decoder
  
  =head1 VERSION
  
  This document describes version 0.24 of Data::Clean::FromJSON (from Perl distribution Data-Clean-JSON), released on 2015-03-26.
  
  =head1 SYNOPSIS
  
   use Data::Clean::FromJSON;
   use JSON;
   my $cleanser = Data::Clean::FromJSON->get_cleanser;
   my $data    = JSON->new->decode('[true]'); # -> [bless(do{\(my $o=1)},"JSON::XS::Boolean")]
   my $cleaned = $cleanser->clean_in_place($data); # -> [1]
  
  =head1 DESCRIPTION
  
  This class can convert L<JSON::PP::Boolean> (or C<JSON::XS::Boolean>) objects to
  1/0 values.
  
  =head1 METHODS
  
  =head2 CLASS->get_cleanser => $obj
  
  Return a singleton instance, with default options. Use C<new()> if you want to
  customize options.
  
  =head2 CLASS->new(%opts) => $obj
  
  Create a new instance. For list of known options, see L<Data::Clean::Base>.
  Data::Clean::FromJSON sets some defaults.
  
      "JSON::PP::Boolean" => ['one_or_zero']
      "JSON::XS::Boolean" => ['one_or_zero']
  
  =head2 $obj->clean_in_place($data) => $cleaned
  
  Clean $data. Modify data in-place.
  
  =head2 $obj->clone_and_clean($data) => $cleaned
  
  Clean $data. Clone $data first.
  
  =head1 ENVIRONMENT
  
  LOG_CLEANSER_CODE
  
  =head1 FAQ
  
  =head2 Why am I getting 'Modification of a read-only value attempted at lib/Data/Clean/Base.pm line xxx'?
  
  [2013-10-15 ] This is also from Data::Clone::clone() when it encounters
  JSON::{PP,XS}::Boolean objects. You can use clean_in_place() instead of
  clone_and_clean(), or clone your data using other cloner like L<Sereal>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Clean-JSON>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Clean-JSON>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Clean-JSON>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_CLEAN_FROMJSON

$fatpacked{"Data/Clean/JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_CLEAN_JSON';
  package Data::Clean::JSON;
  
  our $DATE = '2015-03-26'; # DATE
  our $VERSION = '0.24'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use parent qw(Data::Clean::Base);
  
  sub new {
      my ($class, %opts) = @_;
      $opts{DateTime}  //= [call_method => 'epoch'];
      $opts{'Time::Moment'} //= [call_method => 'epoch'];
      $opts{Regexp}    //= ['stringify'];
      $opts{SCALAR}    //= ['deref_scalar'];
      $opts{-ref}      //= ['replace_with_ref'];
      $opts{-circular} //= ['clone'];
      $opts{-obj}      //= ['unbless'];
      $class->SUPER::new(%opts);
  }
  
  sub get_cleanser {
      my $class = shift;
      state $singleton = $class->new;
      $singleton;
  }
  
  1;
  # ABSTRACT: Clean data so it is safe to output to JSON
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Clean::JSON - Clean data so it is safe to output to JSON
  
  =head1 VERSION
  
  This document describes version 0.24 of Data::Clean::JSON (from Perl distribution Data-Clean-JSON), released on 2015-03-26.
  
  =head1 SYNOPSIS
  
   use Data::Clean::JSON;
   my $cleanser = Data::Clean::JSON->get_cleanser;
   my $data     = { code=>sub {}, re=>qr/abc/i };
  
   my $cleaned;
  
   # modifies data in-place
   $cleaned = $cleanser->clean_in_place($data);
  
   # ditto, but deep clone first, return
   $cleaned = $cleanser->clone_and_clean($data);
  
   # now output it
   use JSON;
   print encode_json($cleaned); # prints '{"code":"CODE","re":"(?^i:abc)"}'
  
  =head1 DESCRIPTION
  
  This class cleans data from anything that might be problematic when encoding to
  JSON. This includes coderefs, globs, and so on.
  
  Data that has been cleaned will probably not be convertible back to the
  original, due to information loss (for example, coderefs converted to string
  C<"CODE">).
  
  The design goals are good performance, good defaults, and just enough
  flexibility. The original use-case is for returning JSON response in HTTP API
  service.
  
  This module is significantly faster than modules like L<Data::Rmap> or
  L<Data::Visitor::Callback> because with something like Data::Rmap you repeatedly
  invoke callback for each data item. This module, on the other hand, generates a
  cleanser code using eval(), using native Perl for() loops.
  
  If C<LOG_CLEANSER_CODE> environment is set to true, the generated cleanser code
  will be logged using L<Log::Any> at trace level. You can see it, e.g. using
  L<Log::Any::App>:
  
   % LOG=1 LOG_CLEANSER_CODE=1 TRACE=1 perl -MLog::Any::App -MData::Clean::JSON \
     -e'$c=Data::Clean::JSON->new; ...'
  
  =head1 METHODS
  
  =head2 CLASS->get_cleanser => $obj
  
  Return a singleton instance, with default options. Use C<new()> if you want to
  customize options.
  
  =head2 CLASS->new(%opts) => $obj
  
  Create a new instance. For list of known options, see L<Data::Clean::Base>.
  Data::Clean::JSON sets some defaults.
  
      DateTime  => [call_method => 'epoch']
      Regexp    => ['stringify']
      SCALAR    => ['deref_scalar']
      -ref      => ['replace_with_ref']
      -circular => ['clone']
      -obj      => ['unbless']
  
  =head2 $obj->clean_in_place($data) => $cleaned
  
  Clean $data. Modify data in-place.
  
  =head2 $obj->clone_and_clean($data) => $cleaned
  
  Clean $data. Clone $data first.
  
  =head1 ENVIRONMENT
  
  LOG_CLEANSER_CODE
  
  =head1 FAQ
  
  =head2 Why clone/modify? Why not directly output JSON?
  
  So that the data can be used for other stuffs, like outputting to YAML, etc.
  
  =head2 Why is it slow?
  
  If you use C<new()> instead of C<get_cleanser()>, make sure that you do not
  construct the Data::Clean::JSON object repeatedly, as the constructor generates
  the cleanser code first using eval(). A short benchmark (run on my slow Atom
  netbook):
  
   % bench -MData::Clean::JSON -b'$c=Data::Clean::JSON->new' \
       'Data::Clean::JSON->new->clone_and_clean([1..100])' \
       '$c->clone_and_clean([1..100])'
   Benchmarking sub { Data::Clean::JSON->new->clean_in_place([1..100]) }, sub { $c->clean_in_place([1..100]) } ...
   a: 302 calls (291.3/s), 1.037s (3.433ms/call)
   b: 7043 calls (4996/s), 1.410s (0.200ms/call)
   Fastest is b (17.15x a)
  
  Second, you can turn off some checks if you are sure you will not be getting bad
  data. For example, if you know that your input will not contain circular
  references, you can turn off circular detection:
  
   $cleanser = Data::Clean::JSON->new(-circular => 0);
  
  Benchmark:
  
   $ perl -MData::Clean::JSON -MBench -E '
     $data = [[1],[2],[3],[4],[5]];
     bench {
         circ   => sub { state $c = Data::Clean::JSON->new;               $c->clone_and_clean($data) },
         nocirc => sub { state $c = Data::Clean::JSON->new(-circular=>0); $c->clone_and_clean($data) }
     }, -1'
   circ: 9456 calls (9425/s), 1.003s (0.106ms/call)
   nocirc: 13161 calls (12885/s), 1.021s (0.0776ms/call)
   Fastest is nocirc (1.367x circ)
  
  The less number of checks you do, the faster the cleansing process will be.
  
  =head2 Why am I getting 'Not a CODE reference at lib/Data/Clean/Base.pm line xxx'?
  
  [2013-08-07 ] This error message is from Data::Clone::clone() when it is cloning
  an object. If you are cleaning objects, instead of using clone_and_clean(), try
  using clean_in_place(). Or, clone your data first using something else like
  L<Sereal>.
  
  =head1 SEE ALSO
  
  L<Data::Rmap>
  
  L<Data::Visitor::Callback>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Clean-JSON>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Clean-JSON>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Clean-JSON>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_CLEAN_JSON

$fatpacked{"Data/Dmp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_DMP';
  package Data::Dmp;
  
  our $DATE = '2015-03-24'; # DATE
  our $VERSION = '0.10'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Scalar::Util qw(looks_like_number blessed reftype refaddr);
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT = qw(dd dmp);
  
  # for when dealing with circular refs
  our %_seen_refaddrs;
  our %_subscripts;
  our @_fixups;
  
  our $OPT_PERL_VERSION;
  
  # BEGIN COPY PASTE FROM Data::Dump
  my %esc = (
      "\a" => "\\a",
      "\b" => "\\b",
      "\t" => "\\t",
      "\n" => "\\n",
      "\f" => "\\f",
      "\r" => "\\r",
      "\e" => "\\e",
  );
  
  # put a string value in double quotes
  sub _double_quote {
      local($_) = $_[0];
  
      # If there are many '"' we might want to use qq() instead
      s/([\\\"\@\$])/\\$1/g;
      return qq("$_") unless /[^\040-\176]/;  # fast exit
  
      s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
  
      # no need for 3 digits in escape for these
      s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
  
      s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
      s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
  
      return qq("$_");
  }
  # END COPY PASTE FROM Data::Dump
  
  sub _dump {
      my ($val, $subscript) = @_;
  
      my $ref = ref($val);
      if ($ref eq '') {
          if (!defined($val)) {
              return "undef";
          } elsif (looks_like_number($val)) {
              return $val;
          } else {
              return _double_quote($val);
          }
      }
      my $refaddr = refaddr($val);
      $_subscripts{$refaddr} //= $subscript;
      if ($_seen_refaddrs{$refaddr}++) {
          push @_fixups, "\$a->$subscript=\$a",
              ($_subscripts{$refaddr} ? "->$_subscripts{$refaddr}" : ""), ";";
          return "'fix'";
      }
  
      my $class;
  
      if ($ref eq 'Regexp' || $ref eq 'REGEXP') {
          require Regexp::Stringify;
          return Regexp::Stringify::stringify_regexp(
              regexp=>$val, with_qr=>1, plver=>$OPT_PERL_VERSION);
      }
  
      if (blessed $val) {
          $class = $ref;
          $ref = reftype($val);
      }
  
      my $res;
      if ($ref eq 'ARRAY') {
          $res = "[";
          my $i = 0;
          for (@$val) {
              $res .= "," if $i;
              $res .= _dump($_, "$subscript\[$i]");
              $i++;
          }
          $res .= "]";
      } elsif ($ref eq 'HASH') {
          $res = "{";
          my $i = 0;
          for (sort keys %$val) {
              $res .= "," if $i++;
              my $k = /\W/ ? _double_quote($_) : $_;
              my $v = _dump($val->{$_}, "$subscript\{$k}");
              $res .= "$k=>$v";
          }
          $res .= "}";
      } elsif ($ref eq 'SCALAR') {
          $res = "\\"._dump($$val, $subscript);
      } elsif ($ref eq 'REF') {
          $res = "\\"._dump($$val, $subscript);
      } elsif ($ref eq 'CODE') {
          $res = "sub{'DUMMY'}";
      } else {
          die "Sorry, I can't dump $val (ref=$ref) yet";
      }
  
      $res = "bless($res,"._double_quote($class).")" if defined($class);
      $res;
  }
  
  our $_is_dd;
  sub _dd_or_dmp {
      local %_seen_refaddrs;
      local %_subscripts;
      local @_fixups;
  
      my $res;
      if (@_ > 1) {
          $res = "(" . join(",", map {_dump($_, '')} @_) . ")";
      } else {
          $res = _dump($_[0], '');
      }
      if (@_fixups) {
          $res = "do{my\$a=$res;" . join("", @_fixups) . "\$a}";
      }
  
      if ($_is_dd) {
          say $res;
          return @_;
      } else {
          return $res;
      }
  }
  
  sub dd { local $_is_dd=1; _dd_or_dmp(@_) }
  sub dmp { goto &_dd_or_dmp }
  
  1;
  # ABSTRACT: Dump Perl data structures as Perl code
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Dmp - Dump Perl data structures as Perl code
  
  =head1 VERSION
  
  This document describes version 0.10 of Data::Dmp (from Perl distribution Data-Dmp), released on 2015-03-24.
  
  =head1 SYNOPSIS
  
   use Data::Dmp; # exports dd() and dmp()
   dd [1, 2, 3]; # prints "[1,2,3]"
   $a = dmp({a => 1}); # -> "{a=>1}"
  
  =head1 DESCRIPTION
  
  Data::Dmp is a Perl dumper like L<Data::Dumper>. It's compact (only about 120
  lines of code long), starts fast and does not use other module except
  L<Regexp::Stringify> when dumping regexes. It produces compact output (similar
  to L<Data::Dumper::Concise>. It's faster than Data::Dumper, but does not offer
  the various formatting options. It supports dumping objects, regexes, circular
  objects. Its code is based on L<Data::Dump>.
  
  It currently does not support "deparse" like Data::Dumper and dumps coderefs as
  C<< sub{'DUMMY'} >>. Unlike Data::Dump, it currently does not support
  identifying tied data or globs.
  
  =head1 FUNCTIONS
  
  =head2 dd($data, ...) => $data ...
  
  Exported by default. Like C<Data::Dump>'s C<dd> (a.k.a. C<dump>), print one or
  more data to STDOUT. Unlike C<Data::Dump>'s C<dd>, it I<always> prints and
  return I<the original data> (like L<XXX>), making it convenient to insert into
  expressions. This also removes ambiguity and saves one C<wantarray()> call.
  
  =head2 dmp($data, ...) => $str
  
  Exported by default. Return dump result as string. Unlike C<Data::Dump>'s C<dd>
  (a.k.a. C<dump>), it I<never> prints and only return the data.
  
  =head1 SETTINGS
  
  =head2 $Data::Dmp::OPT_PERL_VERSION => str
  
  Set target Perl version. Currently this is used when passing to
  L<Regexp::Stringify>. If you set this to, say C<5.010>, then the dumped code
  will keep compatibility with Perl 5.10.0.
  
  =head1 FAQ
  
  =head2 When to use Data::Dmp? How does it compare to other dumper modules?
  
  Data::Dmp might be suitable for you if you want a relatively fast pure-Perl data
  structure dumper to eval-able Perl code. It produces compact, single-line Perl
  code but offers little/no formatting options. Data::Dmp and Data::Dump module
  family usually produce Perl code that is "more eval-able", e.g. it can recreate
  circular structure.
  
  L<Data::Dump> produces nicer output (some alignment, use of range operator to
  shorten lists, use of base64 for binary data, etc) but no built-in option to
  produce compact/single-line output. It's also relatively slow. I usually use its
  variant, L<Data::Dump::Color>, for console debugging.
  
  L<Data::Dumper> is core module, offers a lot of formatting options (like
  disabling hash key sorting, setting verboseness/indent level, and so on) but you
  usually have to configure it quite a bit before it does exactly like you want
  (that's why there are modules on CPAN that are just wrapping Data::Dumper with
  some configuration, like L<Data::Dumper::Concise> et al). It does not support
  dumping Perl code that can recreate circular structures.
  
  Of course, dumping to eval-able Perl code is slow (not to mention the cost of
  re-loading the code back to in-memory data, via eval-ing) compared to dumping to
  JSON, YAML, Sereal, or other format. So you need to decide first whether this is
  the appropriate route you want to take.
  
  =head1 SEE ALSO
  
  L<Data::Dump> and other variations/derivate works in Data::Dump::*.
  
  L<Data::Dumper> and its variants.
  
  L<Data::Printer>.
  
  L<YAML>, L<JSON>, L<Storable>, L<Sereal>, and other serialization formats.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Dmp>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Dmp>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Dmp>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_DMP

$fatpacked{"Data/ModeMerge.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_MODEMERGE';
  package Data::ModeMerge;
  
  our $DATE = '2015-02-21'; # DATE
  our $VERSION = '0.32'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Mo qw(build default);
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT = qw(mode_merge);
  
  sub mode_merge {
      my ($l, $r, $config_vars) = @_;
      my $mm = __PACKAGE__->new(config => $config_vars);
      $mm->merge($l, $r);
  }
  
  has config => (is => "rw");
  
  # hash of modename => handler
  has modes => (is => 'rw', default => sub { {} });
  
  has combine_rules => (is => 'rw');
  
  # merging process state
  has path => (is => "rw", default => sub { [] });
  has errors => (is => "rw", default => sub { [] });
  has mem => (is => "rw", default => sub { {} }); # for handling circular refs. {key=>{res=>[...], todo=>[sub1, ...]}, ...}
  has cur_mem_key => (is => "rw"); # for handling circular refs. instead of passing around this as argument, we put it here.
  
  sub _dump {
      require Data::Dumper;
  
      my ($self, $var) = @_;
      Data::Dumper->new([$var])->Indent(0)->Terse(1)->Sortkeys(1)->Dump;
  }
  
  sub _in($$) {
      my ($self, $needle, $haystack) = @_;
      return 0 unless defined($needle);
      my $r1 = ref($needle);
      my $f1 = $r1 ? $self->_dump($needle) : undef;
      for (@$haystack) {
          my $r2 = ref($_);
          next if $r1 xor $r2;
          return 1 if  $r2 && $f1 eq $self->_dump($_);
          return 1 if !$r2 && $needle eq $_;
      }
      0;
  }
  
  sub BUILD {
      require Data::ModeMerge::Config;
  
      my ($self, $args) = @_;
  
      if ($self->config) {
          # some sanity checks
          my $is_hashref = ref($self->config) eq 'HASH';
          die "config must be a hashref or a Data::ModeMerge::Config" unless
              $is_hashref || UNIVERSAL::isa($self->config, "Data::ModeMerge::Config");
          $self->config(Data::ModeMerge::Config->new(%{ $self->config })) if $is_hashref;
      } else {
          $self->config(Data::ModeMerge::Config->new);
      }
  
      for (qw(NORMAL KEEP ADD CONCAT SUBTRACT DELETE)) {
  	$self->register_mode($_);
      }
  
      if (!$self->combine_rules) {
          $self->combine_rules({
              # "left + right" => [which mode to use, which mode after merge]
              'ADD+ADD'            => ['ADD'     , 'ADD'   ],
              #'ADD+CONCAT'         => undef,
              'ADD+DELETE'         => ['DELETE'  , 'DELETE'],
              #'ADD+KEEP'           => undef,
              'ADD+NORMAL'         => ['NORMAL'  , 'NORMAL'],
              'ADD+SUBTRACT'       => ['SUBTRACT', 'ADD'   ],
  
              #'CONCAT+ADD'         => undef,
              'CONCAT+CONCAT'      => ['CONCAT'  , 'CONCAT'],
              'CONCAT+DELETE'      => ['DELETE'  , 'DELETE'],
              #'CONCAT+KEEP'        => undef,
              'CONCAT+NORMAL'      => ['NORMAL'  , 'NORMAL'],
              #'CONCAT+SUBTRACT'    => undef,
  
              'DELETE+ADD'         => ['NORMAL'  , 'ADD'     ],
              'DELETE+CONCAT'      => ['NORMAL'  , 'CONCAT'  ],
              'DELETE+DELETE'      => ['DELETE'  , 'DELETE'  ],
              'DELETE+KEEP'        => ['NORMAL'  , 'KEEP'    ],
              'DELETE+NORMAL'      => ['NORMAL'  , 'NORMAL'  ],
              'DELETE+SUBTRACT'    => ['NORMAL'  , 'SUBTRACT'],
  
              'KEEP+ADD'          => ['KEEP', 'KEEP'],
              'KEEP+CONCAT'       => ['KEEP', 'KEEP'],
              'KEEP+DELETE'       => ['KEEP', 'KEEP'],
              'KEEP+KEEP'         => ['KEEP', 'KEEP'],
              'KEEP+NORMAL'       => ['KEEP', 'KEEP'],
              'KEEP+SUBTRACT'     => ['KEEP', 'KEEP'],
  
              'NORMAL+ADD'        => ['ADD'     , 'NORMAL'],
              'NORMAL+CONCAT'     => ['CONCAT'  , 'NORMAL'],
              'NORMAL+DELETE'     => ['DELETE'  , 'NORMAL'],
              'NORMAL+KEEP'       => ['NORMAL'  , 'KEEP'  ],
              'NORMAL+NORMAL'     => ['NORMAL'  , 'NORMAL'],
              'NORMAL+SUBTRACT'   => ['SUBTRACT', 'NORMAL'],
  
              'SUBTRACT+ADD'      => ['SUBTRACT', 'SUBTRACT'],
              #'SUBTRACT+CONCAT'   => undef,
              'SUBTRACT+DELETE'   => ['DELETE'  , 'DELETE'  ],
              #'SUBTRACT+KEEP'     => undef,
              'SUBTRACT+NORMAL'   => ['NORMAL'  , 'NORMAL'  ],
              'SUBTRACT+SUBTRACT' => ['ADD'     , 'SUBTRACT'],
          });
      }
  }
  
  sub push_error {
      my ($self, $errmsg) = @_;
      push @{ $self->errors }, [[@{ $self->path }], $errmsg];
      return;
  }
  
  sub register_mode {
      my ($self, $name0) = @_;
      my $obj;
      if (ref($name0)) {
          my $obj = $name0;
      } elsif ($name0 =~ /^\w+(::\w+)+$/) {
          eval "require $name0; \$obj = $name0->new";
          die "Can't load module $name0: $@" if $@;
      } elsif ($name0 =~ /^\w+$/) {
          my $modname = "Data::ModeMerge::Mode::$name0";
          eval "require $modname; \$obj = $modname->new";
          die "Can't load module $modname: $@" if $@;
      } else {
          die "Invalid mode name $name0";
      }
      my $name = $obj->name;
      die "Mode $name already registered" if $self->modes->{$name};
      $obj->merger($self);
      $self->modes->{$name} = $obj;
  }
  
  sub check_prefix {
      my ($self, $hash_key) = @_;
      die "Hash key not a string" if ref($hash_key);
      my $dis = $self->config->disable_modes;
      if (defined($dis) && ref($dis) ne 'ARRAY') {
          $self->push_error("Invalid config value `disable_modes`: must be an array");
          return;
      }
      for my $mh (sort { $b->precedence_level <=> $a->precedence_level }
                  grep { !$dis || !$self->_in($_->name, $dis) }
                  values %{ $self->modes }) {
          if ($mh->check_prefix($hash_key)) {
              return $mh->name;
          }
      }
      return;
  }
  
  sub check_prefix_on_hash {
      my ($self, $hash) = @_;
      die "Not a hash" unless ref($hash) eq 'HASH';
      my $res = 0;
      for (keys %$hash) {
  	do { $res++; last } if $self->check_prefix($_);
      }
      $res;
  }
  
  sub add_prefix {
      my ($self, $hash_key, $mode) = @_;
      die "Hash key not a string" if ref($hash_key);
      my $dis = $self->config->disable_modes;
      if (defined($dis) && ref($dis) ne 'ARRAY') {
          die "Invalid config value `disable_modes`: must be an array";
      }
      if ($dis && $self->_in($mode, $dis)) {
          $self->push_error("Can't add prefix for currently disabled mode `$mode`");
          return $hash_key;
      }
      my $mh = $self->modes->{$mode} or die "Unknown mode: $mode";
      $mh->add_prefix($hash_key);
  }
  
  sub remove_prefix {
      my ($self, $hash_key) = @_;
      die "Hash key not a string" if ref($hash_key);
      my $dis = $self->config->disable_modes;
      if (defined($dis) && ref($dis) ne 'ARRAY') {
          die "Invalid config value `disable_modes`: must be an array";
      }
      for my $mh (sort { $b->precedence_level <=> $a->precedence_level }
                  grep { !$dis || !$self->_in($_->name, $dis) }
                  values %{ $self->modes }) {
          if ($mh->check_prefix($hash_key)) {
              my $r = $mh->remove_prefix($hash_key);
              if (wantarray) { return ($r, $mh->name) }
              else           { return $r }
          }
      }
      if (wantarray) { return ($hash_key, $self->config->default_mode) }
      else           { return $hash_key }
  }
  
  sub remove_prefix_on_hash {
      my ($self, $hash) = @_;
      die "Not a hash" unless ref($hash) eq 'HASH';
      for (keys %$hash) {
  	my $old = $_;
  	$_ = $self->remove_prefix($_);
  	next unless $old ne $_;
  	die "Conflict when removing prefix on hash: $old -> $_ but $_ already exists"
  	    if exists $hash->{$_};
  	$hash->{$_} = $hash->{$old};
  	delete $hash->{$old};
      }
      $hash;
  }
  
  sub merge {
      my ($self, $l, $r) = @_;
      $self->path([]);
      $self->errors([]);
      $self->mem({});
      $self->cur_mem_key(undef);
      my ($key, $res, $backup) = $self->_merge(undef, $l, $r);
      {
          success => !@{ $self->errors },
          error   => (@{ $self->errors } ?
                      join(", ",
                           map { sprintf("/%s: %s", join("/", @{ $_->[0] }), $_->[1]) }
                               @{ $self->errors }) : ''),
          result  => $res,
          backup  => $backup,
      };
  }
  
  # handle circular refs: process todo's
  sub _process_todo {
      my ($self) = @_;
      if ($self->cur_mem_key) {
          for my $mk (keys %{ $self->mem }) {
              my $res = $self->mem->{$mk}{res};
              if (defined($res) && @{ $self->mem->{$mk}{todo} }) {
                  #print "DEBUG: processing todo for mem<$mk>\n";
                  for (@{  $self->mem->{$mk}{todo} }) {
                      $_->(@$res);
                      return if @{ $self->errors };
                  }
                  $self->mem->{$mk}{todo} = [];
              }
          }
      }
  }
  
  sub _merge {
      my ($self, $key, $l, $r, $mode) = @_;
      my $c = $self->config;
      $mode //= $c->default_mode;
  
      my $mh = $self->modes->{$mode};
      die "Can't find handler for mode $mode" unless $mh;
  
      # determine which merge method we will call
      my $rl = ref($l);
      my $rr = ref($r);
      my $tl = $rl eq 'HASH' ? 'HASH' : $rl eq 'ARRAY' ? 'ARRAY' : $rl eq 'CODE' ? 'CODE' : !$rl ? 'SCALAR' : '';
      my $tr = $rr eq 'HASH' ? 'HASH' : $rr eq 'ARRAY' ? 'ARRAY' : $rr eq 'CODE' ? 'CODE' : !$rr ? 'SCALAR' : '';
      if (!$tl) { $self->push_error("Unknown type in left side: $rl"); return }
      if (!$tr) { $self->push_error("Unknown type in right side: $rr"); return }
      if (!$c->allow_create_array && $tl ne 'ARRAY' && $tr eq 'ARRAY') {
          $self->push_error("Not allowed to create array"); return;
      }
      if (!$c->allow_create_hash && $tl ne 'HASH' && $tr eq 'HASH') {
          $self->push_error("Not allowed to create hash"); return;
      }
      if (!$c->allow_destroy_array && $tl eq 'ARRAY' && $tr ne 'ARRAY') {
          $self->push_error("Not allowed to destroy array"); return;
      }
      if (!$c->allow_destroy_hash && $tl eq 'HASH' && $tr ne 'HASH') {
          $self->push_error("Not allowed to destroy hash"); return;
      }
      my $meth = "merge_${tl}_${tr}";
      if (!$mh->can($meth)) { $self->push_error("No merge method found for $tl + $tr (mode $mode)"); return }
  
      #$self->_process_todo;
      # handle circular refs: add to todo if necessary
      my $memkey;
      if ($rl || $rr) {
          $memkey = sprintf "%s%s %s%s %s %s",
              (defined($l) ? ($rl ? 2 : 1) : 0),
              (defined($l) ? "$l" : ''),
              (defined($r) ? ($rr ? 2 : 1) : 0),
              (defined($r) ? "$r" : ''),
              $mode,
              $self->config;
          #print "DEBUG: number of keys in mem = ".scalar(keys %{ $self->mem })."\n";
          #print "DEBUG: mem keys = \n".join("", map { "  $_\n" } keys %{ $self->mem }) if keys %{ $self->mem };
          #print "DEBUG: calculating memkey = <$memkey>\n";
      }
      if ($memkey) {
          if (exists $self->mem->{$memkey}) {
              $self->_process_todo;
              if (defined $self->mem->{$memkey}{res}) {
                  #print "DEBUG: already calculated, using cached result\n";
                  return @{ $self->mem->{$memkey}{res} };
              } else {
                  #print "DEBUG: detecting circular\n";
                  return ($key, undef, undef, 1);
              }
          } else {
              $self->mem->{$memkey} = {res=>undef, todo=>[]};
              $self->cur_mem_key($memkey);
              #print "DEBUG: invoking ".$mh->name."'s $meth(".$self->_dump($key).", ".$self->_dump($l).", ".$self->_dump($r).")\n";
              my ($newkey, $res, $backup) = $mh->$meth($key, $l, $r);
              #print "DEBUG: setting res for mem<$memkey>\n";
              $self->mem->{$memkey}{res} = [$newkey, $res, $backup];
              $self->_process_todo;
              return ($newkey, $res, $backup);
          }
      } else {
          $self->_process_todo;
          #print "DEBUG: invoking ".$mh->name."'s $meth(".$self->_dump($key).", ".$self->_dump($l).", ".$self->_dump($r).")\n";
          return $mh->$meth($key, $l, $r);
      }
  }
  
  # returns 1 if a is included in b (e.g. [user => "jajang"] in included in [user
  # => jajang => "quota"], but [user => "paijo"] is not)
  sub _path_is_included {
      my ($self, $p1, $p2) = @_;
      my $res = 1;
      for my $i (0..@$p1-1) {
          do { $res = 0; last } if !defined($p2->[$i]) || $p1->[$i] ne $p2->[$i];
      }
      #print "_path_is_included([".join(", ", @$p1)."], [".join(", ", @$p2)."])? $res\n";
      $res;
  }
  
  1;
  # ABSTRACT: Merge two nested data structures, with merging modes and options
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::ModeMerge - Merge two nested data structures, with merging modes and options
  
  =head1 VERSION
  
  This document describes version 0.32 of Data::ModeMerge (from Perl distribution Data-ModeMerge), released on 2015-02-21.
  
  =head1 SYNOPSIS
  
      use Data::ModeMerge;
  
      my $hash1 = { a=>1,    c=>1, d=>{  da =>[1]} };
      my $hash2 = { a=>2, "-c"=>2, d=>{"+da"=>[2]} };
  
  
      # if you want Data::ModeMerge to behave like many other merging
      # modules (e.g. Hash::Merge or Data::Merger), turn off modes
      # (prefix) parsing and options key parsing.
  
      my $mm = Data::ModeMerge->new(config => {parse_prefix=>0, options_key=>undef});
      my $res = $mm->merge($hash1, $hash2);
      die $res->{error} if $res->{error};
      # $res->{result} -> { a=>2, c=>1, "-c"=>2, d=>{da=>[1], "+da"=>[2]} }
  
  
      # otherwise Data::ModeMerge will parse prefix as well as options
      # key
  
      my $res = $mm->merge($hash1, $hash2);
      die $res->{error} if $res->{error};
      # $res->{result} -> { a=>2, c=>-1, d=>{da=>[1,2]} }
  
      $res = $merge({  a =>1, {  a2 =>1, ""=>{parse_prefix=>0}},
                    {".a"=>2, {".a2"=>2                       }});
      # $res->{result} -> { a=>12, {a2=>1, ".a2"=>2} }, parse_prefix is turned off in just the subhash
  
  
      # procedural interface
  
      my $res = mode_merge($hash1, $hash2, {allow_destroy_hash=>0});
  
  =head1 DESCRIPTION
  
  There are already several modules on CPAN to do recursive data
  structure merging, like L<Data::Merger> and
  L<Hash::Merge>. C<Data::ModeMerge> differs in that it offers merging
  "modes" and "options". It provides greater flexibility on what the
  result of a merge between two data should/can be. This module may or
  may not be what you need.
  
  One application of this module is in handling configuration. Often
  there are multiple levels of configuration, e.g. in your typical Unix
  command-line program there are system-wide config file in /etc,
  per-user config file under ~/, and command-line options. It's
  convenient programatically to load each of those in a hash and then
  merge system-wide hash with the per-user hash, and then merge the
  result with the command-line hash to get the a single hash as the
  final configuration. Your program can from there on deal with this
  just one hash instead of three.
  
  In a typical merging process between two hashes (left-side and
  right-side), when there is a conflicting key, then the right-side key
  will override the left-side. This is usually the desired behaviour in
  our said program as the system-wide config is there to provide
  defaults, and the per-user config (and the command-line arguments)
  allow a user to override those defaults.
  
  But suppose that the user wants to I<unset> a certain configuration
  setting that is defined by the system-wide config? She can't do that
  unless she edits the system-wide config (in which she might need admin
  rights), or the program allows the user to disregard the system-wide
  config. The latter is usually what's implemented by many Unix
  programs, e.g. the C<-noconfig> command-line option in C<mplayer>. But
  this has two drawbacks: a slightly added complexity in the program
  (need to provide a special, extra comand-line option) and the user
  loses all the default settings in the system-wide config. What she
  needed in the first place was to just unset I<a single setting> (a
  single key-value pair of the hash).
  
  L<Data::ModeMerge> comes to the rescue. It provides a so-called
  C<DELETE mode>.
  
   mode_merge({foo=>1, bar=>2}, {"!foo"=>undef, bar=>3, baz=>1});
  
  will result ini:
  
   {bar=>3, baz=>1}
  
  The C<!> prefix tells Data::ModeMerge to do a DELETE mode merging. So
  the final result will lack the C<foo> key.
  
  On the other hand, what if the system admin wants to I<protect> a
  certain configuration setting from being overriden by the user or the
  command-line? This is useful in a hosting or other retrictive
  environment where we want to limit users' freedom to some levels. This
  is possible via the KEEP mode merging.
  
   mode_merge({"^bar"=>2, "^baz"=>1}, {bar=>3, "!baz"=>0, qux=>7});
  
  will result in:
  
   {"^bar"=>2, "^baz"=>1, qux=>7}
  
  effectively protecting C<bar> and C<baz> from being
  overriden/deleted/etc.
  
  Aside from the two mentioned modes, there are also a few others
  available by default: ADD (prefix C<+>), CONCAT (prefix C<.>),
  SUBTRACT (prefix C<->), as well as the plain ol' NORMAL/override
  (optional prefix C<*>).
  
  You can add other modes by writing a mode handler module.
  
  You can change the default prefixes for each mode if you want. You can
  disable each mode individually.
  
  You can default to always using a certain mode, like the NORMAL mode,
  and ignore all the prefixes, in which case Data::ModeMerge will behave
  like most other merge modules.
  
  There are a few other options like whether or not the right side is
  allowed a "change the structure" of the left side (e.g. replacing a
  scalar with an array/hash, destroying an existing array/hash with
  scalar), maximum length of scalar/array/hash, etc.
  
  You can change default mode, prefixes, disable/enable modes, etc on a
  per-hash basis using the so-called B<options key>. See the B<OPTIONS
  KEY> section for more details.
  
  This module can handle (though not all possible cases)
  circular/recursive references.
  
  =for Pod::Coverage ^(BUILD)$
  
  =head1 MERGING PREFIXES AND YOUR DATA
  
  Merging with this module means you need to be careful when your hash
  keys might contain one of the mode prefixes characters by accident,
  because it will trigger the wrong merge mode and moreover the prefix
  characters will be B<stripped> from the final result (unless you
  configure the module not to do so).
  
  A rather common case is when you have regexes in your hash
  keys. Regexes often begins with C<^>, which coincidentally is a prefix
  for the KEEP mode. Or perhaps you have dot filenames as hash keys,
  where it clashes with the CONCAT mode. Or perhaps shell wildcards,
  where C<*> is also used as the prefix for NORMAL mode.
  
  To avoid clashes, you can either:
  
  =over 4
  
  =item * exclude the keys using
  C<exclude_merge>/C<include_merge>/C<exclude_parse>/C<include_parse>
  config settings
  
  =item * turn off some modes which you don't want via the
  C<disable_modes> config
  
  =item * change the prefix for that mode so that it doesn't clash with
  your data via the C<set_prefix> config
  
  =item * disable prefix parsing altogether via setting C<parse_prefix>
  config to 0
  
  =back
  
  You can do this via the configuration, or on a per-hash basis, using
  the options key.
  
  See L<Data::ModeMerge::Config> for more details on configuration.
  
  =head1 OPTIONS KEY
  
  Aside from merging mode prefixes, you also need to watch out if your
  hash contains a "" (empty string) key, because by default this is the
  key used for options key.
  
  Options key are used to specify configuration on a per-hash basis.
  
  If your hash keys might contain "" keys which are not meant to be an
  options key, you can either:
  
  =over 4
  
  =item * change the name of the key for options key, via setting
  C<options_key> config to another string.
  
  =item * turn off options key mechanism,
  by setting C<options_key> config to undef.
  
  =back
  
  See L<Data::ModeMerge::Config> for more details about options key.
  
  =head1 MERGING MODES
  
  =head2 NORMAL (optional '*' prefix on left/right side)
  
   mode_merge({  a =>11, b=>12}, {  b =>22, c=>23}); # {a=>11, b=>22, c=>23}
   mode_merge({"*a"=>11, b=>12}, {"*b"=>22, c=>23}); # {a=>11, b=>22, c=>23}
  
  =head2 ADD ('+' prefix on the right side)
  
   mode_merge({i=>3}, {"+i"=>4, "+j"=>1}); # {i=>7, j=>1}
   mode_merge({a=>[1]}, {"+a"=>[2, 3]}); # {a=>[1, 2, 3]}
  
  Additive merge on hashes will be treated like a normal merge.
  
  =head2 CONCAT ('.' prefix on the right side)
  
   mode_merge({i=>3}, {".i"=>4, ".j"=>1}); # {i=>34, j=>1}
  
  Concative merge on arrays will be treated like additive merge.
  
  =head2 SUBTRACT ('-' prefix on the right side)
  
   mode_merge({i=>3}, {"-i"=>4}); # {i=>-1}
   mode_merge({a=>["a","b","c"]}, {"-a"=>["b"]}); # {a=>["a","c"]}
  
  Subtractive merge on hashes behaves like a normal merge, except that
  each key on the right-side hash without any prefix will be assumed to
  have a DELETE prefix, i.e.:
  
   mode_merge({h=>{a=>1, b=>1}}, {-h=>{a=>2, "+b"=>2, c=>2}})
  
  is equivalent to:
  
   mode_merge({h=>{a=>1, b=>1}}, {h=>{"!a"=>2, "+b"=>2, "!c"=>2}})
  
  and will merge to become:
  
   {h=>{b=>3}}
  
  =head2 DELETE ('!' prefix on the right side)
  
   mode_merge({x=>WHATEVER}, {"!x"=>WHATEVER}); # {}
  
  =head2 KEEP ('^' prefix on the left/right side)
  
  If you add '^' prefix on the left side, it will be protected from
  being replaced/deleted/etc.
  
   mode_merge({'^x'=>WHATEVER1}, {"x"=>WHATEVER2}); # {x=>WHATEVER1}
  
  For hashes, KEEP mode means that all keys on the left side will not be
  replaced/modified/deleted, *but* you can still add more keys from the
  right side hash.
  
   mode_merge({a=>1, b=>2, c=>3},
              {a=>4, '^c'=>1, d=>5},
              {default_mode=>'KEEP'});
              # {a=>1, b=>2, c=>3, d=>5}
  
  Multiple prefixes on the right side is allowed, where the merging will
  be done by precedence level (highest first):
  
   mode_merge({a=>[1,2]}, {'-a'=>[1], '+a'=>[10]}); # {a=>[2,10]}
  
  but not on the left side:
  
   mode_merge({a=>1, '^a'=>2}, {a=>3}); # error!
  
  Precedence levels (from highest to lowest):
  
   KEEP
   NORMAL
   SUBTRACT
   CONCAT ADD
   DELETE
  
  =head1 FUNCTIONS
  
  =head2 mode_merge($l, $r[, $config_vars])
  
  A non-OO wrapper for merge() method. Exported by default. See C<merge>
  method for more details.
  
  =head1 ATTRIBUTES
  
  =head2 config
  
  A hashref for config. See L<Data::ModeMerge::Config>.
  
  =head2 modes
  
  =head2 combine_rules
  
  =head2 path
  
  =head2 errors
  
  =head2 mem
  
  =head2 cur_mem_key
  
  =head1 METHODS
  
  For typical usage, you only need merge().
  
  =head2 push_error($errmsg)
  
  Used by mode handlers to push error when doing merge. End users
  normally should not need this.
  
  =head2 register_mode($name_or_package_or_obj)
  
  Register a mode. Will die if mode with the same name already exists.
  
  =head2 check_prefix($hash_key)
  
  Check whether hash key has prefix for certain mode. Return the name of
  the mode, or undef if no prefix is detected.
  
  =head2 check_prefix_on_hash($hash)
  
  This is like C<check_prefix> but performed on every key of the
  specified hash. Return true if any of the key contain a merge prefix.
  
  =head2 add_prefix($hash_key, $mode)
  
  Return hash key with added prefix with specified mode. Log merge error
  if mode is unknown or is disabled.
  
  =head2 remove_prefix($hash_key)
  
  Return hash key will any prefix removed.
  
  =head2 remove_prefix_on_hash($hash)
  
  This is like C<remove_prefix> but performed on every key of the
  specified hash. Return the same hash but with prefixes removed.
  
  =head2 merge($l, $r)
  
  Merge two nested data structures. Returns the result hash: {
  success=>0|1, error=>'...', result=>..., backup=>... }. The 'error'
  key is set to contain an error message if there is an error. The merge
  result is in the 'result' key. The 'backup' key contains replaced
  elements from the original hash/array.
  
  =head1 CREATING AND USING YOUR OWN MODE
  
  Let's say you want to add a mode named C<FOO>. It will have the prefix
  '?'.
  
  Create the mode handler class,
  e.g. C<Data::ModeMerge::Mode::FOO>. It's probably best to subclass
  from L<Data::ModeMerge::Mode::Base>. The class must implement name(),
  precedence_level(), default_prefix(), default_prefix_re(), and
  merge_{SCALAR,ARRAY,HASH}_{SCALAR,ARRAY,HASH}(). For more details, see
  the source code of Base.pm and one of the mode handlers
  (e.g. NORMAL.pm).
  
  To use the mode, register it:
  
   my $mm = Data::ModeMerge->new;
   $mm->register_mode('FOO');
  
  This will require C<Data::ModeMerge::Mode::FOO>. After that, define
  the operations against other modes:
  
   # if there's FOO on the left and NORMAL on the right, what mode
   # should the merge be done in (FOO), and what the mode should be
   # after the merge? (NORMAL)
   $mm->combine_rules->{"FOO+NORMAL"} = ["FOO", "NORMAL"];
  
   # we don't define FOO+ADD
  
   $mm->combine_rules->{"FOO+KEEP"} = ["KEEP", "KEEP"];
  
   # and so on
  
  =head1 FAQ
  
  =head2 What is this module good for? Why would I want to use this module instead of the other hash merge modules?
  
  If you just need to (deeply) merge two hashes, chances are you do not
  need this module. Use, for example, L<Hash::Merge>, which is also
  flexible enough because it allows you to set merging behaviour for
  merging different types (e.g. SCALAR vs ARRAY).
  
  You might need this module if your data is recursive/self-referencing
  (which, last time I checked, is not handled well by Hash::Merge), or
  if you want to be able to merge differently (i.e. apply different
  merging B<modes>) according to different prefixes on the key, or
  through special key. In other words, you specify merging modes from
  inside the hash itself.
  
  I originally wrote Data::ModeMerge this for L<Data::Schema> and
  L<Config::Tree>. I want to reuse the "parent" schema (or
  configuration) in more ways other than just override conflicting
  keys. I also want to be able to allow the parent to protect certain
  keys from being overriden. I found these two features lacking in all
  merging modules that I've evaluated prior to writing Data::ModeMerge.
  
  =head1 SEE ALSO
  
  L<Data::ModeMerge::Config>
  
  Other merging modules on CPAN: L<Data::Merger> (from Data-Utilities),
  L<Hash::Merge>, L<Hash::Merge::Simple>
  
  L<Data::Schema> and L<Config::Tree> (among others, two modules which
  use Data::ModeMerge)
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-ModeMerge>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_MODEMERGE

$fatpacked{"Data/ModeMerge/Config.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_MODEMERGE_CONFIG';
  package Data::ModeMerge::Config;
  
  our $DATE = '2015-02-21'; # DATE
  our $VERSION = '0.32'; # VERSION
  
  use 5.010;
  use Mo qw(build default);
  
  has recurse_hash          => (is => 'rw', default => sub{1});
  has recurse_array         => (is => 'rw', default => sub{0});
  has parse_prefix          => (is => 'rw', default => sub{1});
  has wanted_path           => (is => 'rw');
  has default_mode          => (is => 'rw', default => sub{'NORMAL'});
  has disable_modes         => (is => 'rw');
  has allow_create_array    => (is => 'rw', default => sub{1});
  has allow_create_hash     => (is => 'rw', default => sub{1});
  has allow_destroy_array   => (is => 'rw', default => sub{1});
  has allow_destroy_hash    => (is => 'rw', default => sub{1});
  has exclude_parse         => (is => 'rw');
  has exclude_parse_regex   => (is => 'rw');
  has include_parse         => (is => 'rw');
  has include_parse_regex   => (is => 'rw');
  has exclude_merge         => (is => 'rw');
  has exclude_merge_regex   => (is => 'rw');
  has include_merge         => (is => 'rw');
  has include_merge_regex   => (is => 'rw');
  has set_prefix            => (is => 'rw');
  has readd_prefix          => (is => 'rw', default => sub{1});
  has premerge_pair_filter  => (is => 'rw');
  has options_key           => (is => 'rw', default => sub{''});
  has allow_override        => (is => 'rw');
  has disallow_override     => (is => 'rw');
  
  # list of config settings only available in merger-object's config
  # (not in options key)
  sub _config_config {
      state $a = [qw/
          wanted_path
          options_key
          allow_override
          disallow_override
                    /];
  }
  
  # list of config settings available in options key
  sub _config_ok {
      state $a = [qw/
          recurse_hash
          recurse_array
          parse_prefix
          default_mode
          disable_modes
          allow_create_array
          allow_create_hash
          allow_destroy_array
          allow_destroy_hash
          exclude_parse
          exclude_parse_regex
          include_parse
          include_parse_regex
          exclude_merge
          exclude_merge_regex
          include_merge
          include_merge_regex
          set_prefix
          readd_prefix
          premerge_pair_filter
                    /];
  }
  
  1;
  # ABSTRACT: Data::ModeMerge configuration
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::ModeMerge::Config - Data::ModeMerge configuration
  
  =head1 VERSION
  
  This document describes version 0.32 of Data::ModeMerge::Config (from Perl distribution Data-ModeMerge), released on 2015-02-21.
  
  =head1 SYNOPSIS
  
   # getting configuration
   if ($mm->config->allow_extra_hash_keys) { ... }
  
   # setting configuration
   $mm->config->max_warnings(100);
  
  =head1 DESCRIPTION
  
  Configuration variables for Data::ModeMerge.
  
  =head1 ATTRIBUTES
  
  =head2 recurse_hash => BOOL
  
  Context: config, options key
  
  Default: 1
  
  Whether to recursively merge hash. When 1, each key-value pair between
  2 hashes will be recursively merged. Otherwise, the right-side hash
  will just replace the left-side.
  
  Options key will not be parsed under recurse_hash=0.
  
  Example:
  
   mode_merge({h=>{a=>1}}, {h=>{b=>1}}                   ); # {h=>{a=>1, b=>1}}
   mode_merge({h=>{a=>1}}, {h=>{b=>1}}, {recurse_hash=>0}); # {h=>{b=>1}}
  
  =head2 recurse_array => BOOL
  
  Context: config, options key
  
  Default: 0
  
  Whether to recursively merge array. When 1, each element is
  recursively merged. Otherwise, the right-side array will just replace
  the left-side.
  
  Example:
  
   mode_merge([1, 1], [4]                    ); # [4, 1]
   mode_merge([1, 1], [4], {recurse_array=>0}); # [2]
  
  =head2 parse_prefix => BOOL
  
  Context: config, options key
  
  Default: 1
  
  Whether to parse merge prefix in hash keys. If set to 0, merging
  behaviour is similar to most other nested merge modules.
  
   mode_merge({a=>1}, {"+a"=>2}                   ); # {a=>3}
   mode_merge({a=>1}, {"+a"=>2}, {parse_prefix=>0}); # {a=>1, "+a"=>2}
  
  =head2 wanted_path => ARRAYREF
  
  Context: config, options key
  
  Default: undef
  
  If set, merging is only done to the specified "branch". Useful to save
  time/storage when merging large hash "trees" while you only want a
  certain branch of the trees (e.g. resolving just a config variable
  from several config hashes).
  
  Example:
  
   mode_merge(
     {
      user => {
        jajang => { quota => 100, admin => 1 },
        paijo  => { quota =>  50, admin => 0 },
        kuya   => { quota => 150, admin => 0 },
      },
      groups => [qw/admin staff/],
     },
     {
      user => {
        jajang => { quota => 1000 },
      }
     }
   );
  
  With wanted_path unset, the result would be:
  
     {
      user => {
        jajang => { quota => 1000, admin => 1 },
        paijo  => { quota =>   50, admin => 0 },
        kuya   => { quota =>  150, admin => 0 },
      }
      groups => [qw/admin staff/],
     }
  
  With wanted_path set to ["user", "jajang", "quota"] (in other words,
  you're saying that you'll be disregarding other branches), the result
  would be:
  
     {
      user => {
        jajang => { quota => 1000, admin => undef },
      }
     }
  
  =head2 default_mode => 'NORMAL' | 'ADD' | 'CONCAT' | 'SUBTRACT' | 'DELETE' | 'KEEP' | ...
  
  Context: config, options key
  
  Default: NORMAL
  
  Example:
  
   mode_merge(3, 4                         ); # 4
   mode_merge(3, 4, {default_mode => "ADD"}); # 7
  
  =head2 disable_modes => ARRAYREF
  
  Context: config, options key
  
  Default: []
  
  List of modes to ignore the prefixes of.
  
  Example:
  
   mode_merge({add=>1, del=>2, concat=>3},
              {add=>2, "!del"=>0, .concat=>4},
              {disable_modes=>[qw/CONCAT/]});
   #          {add=>3,         concat=>3, .concat=>4}
  
  See also: C<parse_prefix> which if set to 0 will in effect disable all
  modes except the default mode.
  
  =head2 allow_create_array => BOOL
  
  Context: config, options key
  
  Default: 1
  
  If enabled, then array creation will be allowed (from something
  non-array, like a hash/scalar). Setting to 0 is useful if you want to
  avoid the merge to "change the structure" of the left side.
  
  Example:
  
   mode_merge(1, [1,2]                         ); # success, result=[1,2]
   mode_merge(1, [1,2], {allow_create_array=>0}); # failed, can't create array
  
  =head2 allow_create_hash => BOOL
  
  Context: config, options key
  
  Default: 1
  
  If enabled, then hash creation will be allowed (from something
  non-hash, like array/scalar). Setting to 0 is useful if you want to
  avoid the merge to "change the structure" of the left side.
  
  Example:
  
   mode_merge(1, {a=>1}                        ); # success, result={a=>1}
   mode_merge(1, {a=>1}, {allow_create_hash=>0}); # failed, can't create hash
  
  =head2 allow_destroy_array => BOOL
  
  Context: config, options key
  
  Default: 1
  
  If enabled, then replacing array on the left side with non-array
  (e.g. hash/scalar) on the right side is allowed. Setting to 0 is
  useful if you want to avoid the merge to "change the structure" of the
  left side.
  
  Example:
  
   mode_merge([1,2], {}                          ); # success, result={}
   mode_merge([1,2], {}, {allow_destroy_array=>0}); # failed, can't destroy array
  
  =head2 allow_destroy_hash => BOOL
  
  Context: config, options key
  
  Default: 1
  
  If enabled, then replacing hash on the left side with non-hash
  (e.g. array/scalar) on the right side is allowed. Setting to 0 is
  useful if you want to avoid the merge to "change the structure" of the
  left side.
  
  Example:
  
   mode_merge({a=>1}, []                         ); # success, result=[]
   mode_merge({a=>1}, [], {allow_destroy_hash=>0}); # failed, can't destroy hash
  
  =head2 exclude_parse => ARRAYREF
  
  Context: config, options key
  
  Default: undef
  
  The list of hash keys that should not be parsed for prefix and merged
  as-is using the default mode.
  
  If C<include_parse> is also mentioned then only keys in
  C<include_parse> and not in C<exclude_parse> will be parsed for
  prefix.
  
  Example:
  
   mode_merge({a=>1, b=>2}, {"+a"=>3, "+b"=>4}, {exclude_parse=>["+b"]}); # {a=>4, b=>2, "+b"=>4}
  
  =head2 exclude_parse_regex => REGEX
  
  Context: config, options key
  
  Default: undef
  
  Just like C<exclude_parse> but using regex instead of list.
  
  =head2 include_parse => ARRAYREF
  
  Context: config, options key
  
  Default: undef
  
  If specified, then only hash keys listed by this setting will be
  parsed for prefix. The rest of the keys will not be parsed and merged
  as-is using the default mode.
  
  If C<exclude_parse> is also mentioned then only keys in
  C<include_parse> and not in C<exclude_parse> will be parsed for
  prefix.
  
  Example:
  
   mode_merge({a=>1, b=>2, c=>3}, {"+a"=>4, "+b"=>5, "+c"=>6},
              {include_parse=>["+a"]}); # {a=>1, "+a"=>4, b=>7, c=>3, "+c"=>6}
  
  =head2 include_parse_regex => REGEX
  
  Context: config, options key
  
  Default: undef
  
  Just like C<include_parse> but using regex instead of list.
  
  =head2 exclude_merge => ARRAYREF
  
  Context: config, options key
  
  Default: undef
  
  The list of hash keys on the left side that should not be merged and
  instead copied directly to the result. All merging keys on the right
  side will be ignored.
  
  If C<include_merge> is also mentioned then only keys in
  C<include_merge> and not in C<exclude_merge> will be merged.
  
  Example:
  
   mode_merge({a=>1}, {"+a"=>20, "-a"=>30}, {exclude_merge=>["a"]}); # {a=>1}
  
  =head2 exclude_merge_regex => REGEX
  
  Context: config, options key
  
  Default: undef
  
  Just like C<exclude_merge> but using regex instead of list.
  
  =head2 include_merge => ARRAYREF
  
  Context: config, options key
  
  Default: undef
  
  If specified, then only hash keys listed by this setting will be
  merged.
  
  If C<exclude_merge> is also mentioned then only keys in
  C<include_merge> and not in C<exclude_merge> will be merged.
  
  Example:
  
   mode_merge({a=>1, b=>2, c=>3}, {"+a"=>40, "+b"=>50, "+c"=>60, "!c"=>70},
              {include_merge=>["a"]}); # {a=>41, b=>2, c=>3}
  
  =head2 include_merge_regex => ARRAYREF
  
  Context: config, options key
  
  Default: undef
  
  Just like C<include_merge> but using regex instead of list.
  
  =head2 set_prefix => HASHREF
  
  Context: config, options key
  
  Default: undef
  
  Temporarily change the prefix character for each mode. Value is
  hashref where each hash key is mode and the value is a new prefix
  string.
  
   mode_merge({a=>1, c=>2}, {'+a'=>10, '.c'=>20});                                        # {a=>11, c=>220}
   mode_merge({a=>1, c=>2}, {'+a'=>10, '.c'=>20}, {set_prefix=>{ADD=>'.', CONCAT=>'+'}}); # {a=>110, c=>22}
  
  =head2 readd_prefix => BOOL
  
  Context: config, options key
  
  Default: 1
  
  When merging two hashes, the prefixes are first stripped before
  merging. After merging is done, the prefixes by default will be
  re-added. This is done so that modes which are "sticky" (like KEEP)
  can propagate their mode). Setting C<readd_prefix> to 0 will prevent
  their stickiness.
  
   mode_merge({"^a"=>1}, {a=>2});                    # {"^a"=>1}
   mode_merge({"^a"=>1}, {a=>2}, {readd_prefix=>0}); # { "a"=>1}
  
  =head2 premerge_pair_filter => CODEREF
  
  Context: config, options key
  
  Default: undef
  
  Pass the key and value of each hash pair to a subroutine before
  merging (and before the keys are stripped for mode prefixes). Will
  push error if there is conflicting key in the hash.
  
  The subroutine should return a list of new key(s) and value(s). If key
  is undef then it means the pair should be discarded. This way, the
  filter is able to add or remove pairs from the hash.
  
   mode_merge({a=>1}, {"+amok"=>2},
              {premerge_pair_filter=>sub{ uc(substr($_[0],0,2)), $_[1]*2 }});
   # {"A"=>6}
  
  =head2 options_key => STR
  
  Context: config
  
  Default: '' (empty string)
  
  If defined, then when merging two hashes, this key will be searched
  first on the left-side and right-side hash. The values will then be
  merged and override (many of) the configuration.
  
  Options key is analogous to Apache's C<.htaccess> mechanism, which
  allows setting configuration on a per-directory (per-hash)
  basis. There's even an C<allow_override> config similar to Apache
  directive of the same name.
  
  If you want to disable processing of options key, set this to undef.
  
  Example:
  
   mode_merge({a=>1, {x=>3}},
              {a=>2, {x=>4}},
              {default_mode=>'ADD'}); # {a=>3, {x=>7}}
   mode_merge({a=>1, {x=>3}},
              {a=>2, {x=>4, ''=>{default_mode=>'CONCAT'}}},
              {default_mode=>'ADD'}); # {a=>3, {x=>34}}
  
  On the above example, C<default_mode> is set to ADD. But in the
  {x=>...} subhash, C<default_mode> is changed to CONCAT by the options
  key.
  
  =head2 allow_override => REGEX
  
  Context: config
  
  Default: undef
  
  If defined, then only config names matching regex will be able to be
  set in options key.
  
  If C<disallow_override> is also set, then only config names matching
  C<allow_override> and not matching C<disallow_override> will be able
  to be set in options key.
  
  =head2 disallow_override => REGEX
  
  Context: config
  
  Default: undef
  
  If defined, then config names matching regex will not be able to be
  set in options key.
  
  For example, if you want to restrict "structural changes" in merging
  while still allowing options key, you can set C<allow_create_hash>,
  C<allow_destroy_hash>, C<allow_create_array>, and
  C<allow_destroy_array> all to 0 and C<disallow_override> to
  C<allow_create|allow_destroy> to forbid overriding via options key.
  
  If C<disallow_override> is also set, then only config names matching
  C<allow_override> and not matching C<disallow_override> will be able
  to be set in options key.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-ModeMerge>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_MODEMERGE_CONFIG

$fatpacked{"Data/ModeMerge/Mode/ADD.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_MODEMERGE_MODE_ADD';
  package Data::ModeMerge::Mode::ADD;
  
  our $DATE = '2015-02-21'; # DATE
  our $VERSION = '0.32'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Mo qw(build default);
  extends 'Data::ModeMerge::Mode::NORMAL';
  
  sub name { 'ADD' }
  
  sub precedence_level { 3 }
  
  sub default_prefix { '+' }
  
  sub default_prefix_re { qr/^\+/ }
  
  sub merge_SCALAR_SCALAR {
      my ($self, $key, $l, $r) = @_;
      ($key, ( $l // 0 ) + $r);
  }
  
  sub merge_SCALAR_ARRAY {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't add scalar and array");
      return;
  }
  
  sub merge_SCALAR_HASH {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't add scalar and hash");
      return;
  }
  
  sub merge_ARRAY_SCALAR {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't add array and scalar");
      return;
  }
  
  sub merge_ARRAY_ARRAY {
      my ($self, $key, $l, $r) = @_;
      ($key, [ @$l, @$r ]);
  }
  
  sub merge_ARRAY_HASH {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't add array and hash");
      return;
  }
  
  sub merge_HASH_SCALAR {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't add hash and scalar");
      return;
  }
  
  sub merge_HASH_ARRAY {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't add hash and array");
      return;
  }
  
  1;
  # ABSTRACT: Handler for Data::ModeMerge ADD merge mode
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::ModeMerge::Mode::ADD - Handler for Data::ModeMerge ADD merge mode
  
  =head1 VERSION
  
  This document describes version 0.32 of Data::ModeMerge::Mode::ADD (from Perl distribution Data-ModeMerge), released on 2015-02-21.
  
  =head1 SYNOPSIS
  
   use Data::ModeMerge;
  
  =head1 DESCRIPTION
  
  This is the class to handle ADD merge mode.
  
  =for Pod::Coverage ^merge_.*
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-ModeMerge>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_MODEMERGE_MODE_ADD

$fatpacked{"Data/ModeMerge/Mode/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_MODEMERGE_MODE_BASE';
  package Data::ModeMerge::Mode::Base;
  
  our $DATE = '2015-02-21'; # DATE
  our $VERSION = '0.32'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  #use Log::Any '$log';
  use Mo qw(build default);
  
  #use Data::Clone qw/clone/;
  
  has merger => (is => 'rw');
  has prefix => (is => 'rw');
  has prefix_re => (is => 'rw');
  has check_prefix_sub => (is => 'rw');
  has add_prefix_sub => (is => 'rw');
  has remove_prefix_sub => (is => 'rw');
  
  sub name {
      die "Subclass must provide name()";
  }
  
  sub precedence_level {
      die "Subclass must provide precedence_level()";
  }
  
  sub default_prefix {
      die "Subclass must provide default_prefix()";
  }
  
  sub default_prefix_re {
      die "Subclass must provide default_prefix_re()";
  }
  
  sub BUILD {
      my ($self) = @_;
      $self->prefix($self->default_prefix);
      $self->prefix_re($self->default_prefix_re);
  }
  
  sub check_prefix {
      my ($self, $hash_key) = @_;
      if ($self->check_prefix_sub) {
          $self->check_prefix_sub->($hash_key);
      } else {
          $hash_key =~ $self->prefix_re;
      }
  }
  
  sub add_prefix {
      my ($self, $hash_key) = @_;
      if ($self->add_prefix_sub) {
          $self->add_prefix_sub->($hash_key);
      } else {
          $self->prefix . $hash_key;
      }
  }
  
  sub remove_prefix {
      my ($self, $hash_key) = @_;
      if ($self->remove_prefix_sub) {
          $self->remove_prefix_sub->($hash_key);
      } else {
          my $re = $self->prefix_re;
          $hash_key =~ s/$re//;
          $hash_key;
      }
  }
  
  sub merge_ARRAY_ARRAY {
      my ($self, $key, $l, $r) = @_;
      my $mm = $self->merger;
      my $c = $mm->config;
      return $self->merge_SCALAR_SCALAR($key, $l, $r) unless $c->recurse_array;
      return if $c->wanted_path && !$mm->_path_is_included($mm->path, $c->wanted_path);
  
      my @res;
      my @backup;
      my $la = @$l;
      my $lb = @$r;
      push @{ $mm->path }, -1;
      for my $i (0..($la > $lb ? $la : $lb)-1) {
          #print "DEBUG: merge_A_A: #$i: a->[$i]=".Data::Dumper->new([$l->[$i]])->Indent(0)->Terse(1)->Dump.", b->[$i]=".Data::Dumper->new([$r->[$i]])->Indent(0)->Terse(1)->Dump."\n";
          $mm->path->[-1] = $i;
          if ($i < $la && $i < $lb) {
              push @backup, $l->[$i];
              my ($subnewkey, $subres, $subbackup, $is_circular) = $mm->_merge($i, $l->[$i], $r->[$i], $c->default_mode);
              last if @{ $mm->errors };
              if ($is_circular) {
                  push @res, undef;
                  #print "DEBUG: pushing todo to mem<".$mm->cur_mem_key.">\n";
                  push @{ $mm->mem->{ $mm->cur_mem_key }{todo} }, sub {
                      my ($subnewkey, $subres, $subbackup) = @_;
                      #print "DEBUG: Entering todo subroutine (i=$i)\n";
                      $res[$i] = $subres;
                  }
              } else {
                  push @res, $subres;# if defined($newkey); = we allow DELETE on array?
              }
          } elsif ($i < $la) {
              push @res, $l->[$i];
          } else {
              push @res, $r->[$i];
          }
      }
      pop @{ $mm->path };
      ($key, \@res, \@backup);
  }
  
  sub _prefilter_hash {
      my ($self, $h, $desc, $sub) = @_;
      my $mm = $self->merger;
  
      if (ref($sub) ne 'CODE') {
          $mm->push_error("$desc failed: filter must be a coderef");
          return;
      }
  
      my $res = {};
      for (keys %$h) {
          my @r = $sub->($_, $h->{$_});
          while (my ($k, $v) = splice @r, 0, 2) {
              next unless defined $k;
              if (exists $res->{$k}) {
                  $mm->push_error("$desc failed; key conflict: ".
                                  "$_ -> $k, but key $k already exists");
                  return;
              }
              $res->{$k} = $v;
          }
      }
  
      $res;
  }
  
  # turn {[prefix]key => val, ...} into { key => [MODE, val], ...}, push
  # error if there's conflicting key
  sub _gen_left {
      my ($self, $l, $mode, $esub, $ep, $ip, $epr, $ipr) = @_;
      my $mm = $self->merger;
      my $c = $mm->config;
  
      #print "DEBUG: Entering _gen_left(".$mm->_dump($l).", $mode, ...)\n";
  
      if ($c->premerge_pair_filter) {
          $l = $self->_prefilter_hash($l, "premerge filter left hash",
                                      $c->premerge_pair_filter);
          return if @{ $mm->errors };
      }
  
      my $hl = {};
      if ($c->parse_prefix) {
          for (keys %$l) {
              my $do_parse = 1;
              $do_parse = 0 if $do_parse && $ep  &&  $mm->_in($_, $ep);
              $do_parse = 0 if $do_parse && $ip  && !$mm->_in($_, $ip);
              $do_parse = 0 if $do_parse && $epr &&  /$epr/;
              $do_parse = 0 if $do_parse && $ipr && !/$ipr/;
  
              if ($do_parse) {
                  my $old = $_;
                  my $m2;
                  ($_, $m2) = $mm->remove_prefix($_);
                  next if $esub && !$esub->($_);
                  if ($old ne $_ && exists($l->{$_})) {
                      $mm->push_error("Conflict when removing prefix on left-side ".
                                      "hash key: $old -> $_ but $_ already exists");
                      return;
                  }
                  $hl->{$_} = [$m2, $l->{$old}];
              } else {
                  next if $esub && !$esub->($_);
                  $hl->{$_} = [$mode, $l->{$_}];
              }
          }
      } else {
          for (keys %$l) {
              next if $esub && !$esub->($_);
              $hl->{$_} = [$mode, $l->{$_}];
          }
      }
  
      #print "DEBUG: Leaving _gen_left, result = ".$mm->_dump($hl)."\n";
      $hl;
  }
  
  # turn {[prefix]key => val, ...} into { key => {MODE=>val, ...}, ...},
  # push error if there's conflicting key+MODE
  sub _gen_right {
      my ($self, $r, $mode, $esub, $ep, $ip, $epr, $ipr) = @_;
      my $mm = $self->merger;
      my $c = $mm->config;
  
      #print "DEBUG: Entering _gen_right(".$mm->_dump($r).", $mode, ...)\n";
  
      if ($c->premerge_pair_filter) {
          $r = $self->_prefilter_hash($r, "premerge filter right hash",
                                      $c->premerge_pair_filter);
          return if @{ $mm->errors };
      }
  
      my $hr = {};
      if ($c->parse_prefix) {
          for (keys %$r) {
              my $do_parse = 1;
              $do_parse = 0 if $do_parse && $ep  &&  $mm->_in($_, $ep);
              $do_parse = 0 if $do_parse && $ip  && !$mm->_in($_, $ip);
              $do_parse = 0 if $do_parse && $epr &&  /$epr/;
              $do_parse = 0 if $do_parse && $ipr && !/$ipr/;
  
              if ($do_parse) {
                  my $old = $_;
                  my $m2;
                  ($_, $m2) = $mm->remove_prefix($_);
                  next if $esub && !$esub->($_);
                  if (exists $hr->{$_}{$m2}) {
                      $mm->push_error("Conflict when removing prefix on right-side ".
                                      "hash key: $old($m2) -> $_ ($m2) but $_ ($m2) ".
                                      "already exists");
                      return;
                  }
                  $hr->{$_}{$m2} = $r->{$old};
              } else {
                  next if $esub && !$esub->($_);
                  $hr->{$_} = {$mode => $r->{$_}};
              }
          }
      } else {
          for (keys %$r) {
              next if $esub && !$esub->($_);
              $hr->{$_} = {$mode => $r->{$_}}
          }
      }
      #print "DEBUG: Leaving _gen_right, result = ".$mm->_dump($hr)."\n";
      $hr;
  }
  
  # merge two hashes which have been prepared by _gen_left and
  # _gen_right, will result in { key => [final_mode, val], ... }
  sub _merge_gen {
      my ($self, $hl, $hr, $mode, $em, $im, $emr, $imr) = @_;
      my $mm = $self->merger;
      my $c = $mm->config;
  
      #print "DEBUG: Entering _merge_gen(".$mm->_dump($hl).", ".$mm->_dump($hr).", $mode, ...)\n";
  
      my $res = {};
      my $backup = {};
  
      my %k = map {$_=>1} keys(%$hl), keys(%$hr);
      push @{ $mm->path }, "";
    K:
      for my $k (keys %k) {
          my @o;
          $mm->path->[-1] = $k;
          my $do_merge = 1;
          $do_merge = 0 if $do_merge && $em  &&  $mm->_in($k, $em);
          $do_merge = 0 if $do_merge && $im  && !$mm->_in($k, $im);
          $do_merge = 0 if $do_merge && $emr && $k =~ /$emr/;
          $do_merge = 0 if $do_merge && $imr && $k !~ /$imr/;
  
          if (!$do_merge) {
              $res->{$k} = $hl->{$k} if $hl->{$k};
              next K;
          }
  
          $backup->{$k} = $hl->{$k}[1] if $hl->{$k} && $hr->{$k};
          if ($hl->{$k}) {
              push @o, $hl->{$k};
          }
          if ($hr->{$k}) {
              my %m = map {$_=>$mm->modes->{$_}->precedence_level} keys %{ $hr->{$k} };
              #print "DEBUG: \\%m=".Data::Dumper->new([\%m])->Indent(0)->Terse(1)->Dump."\n";
              push @o, map { [$_, $hr->{$k}{$_}] } sort { $m{$b} <=> $m{$a} } keys %m;
          }
          my $final_mode;
          my $is_circular;
          my $v;
          #print "DEBUG: k=$k, o=".Data::Dumper->new([\@o])->Indent(0)->Terse(1)->Dump."\n";
          for my $i (0..$#o) {
              if ($i == 0) {
                  my $mh = $mm->modes->{$o[$i][0]};
                  if (@o == 1 &&
                          (($hl->{$k} && $mh->can("merge_left_only")) ||
                           ($hr->{$k} && $mh->can("merge_right_only")))) {
                      # there's only left-side or right-side
                      my $meth = $hl->{$k} ? "merge_left_only" : "merge_right_only";
                      my ($subnewkey, $v, $subbackup, $is_circular, $newmode) = $mh->$meth($k, $o[$i][1]); # XXX handle circular?
                      next K unless defined($subnewkey);
                      $final_mode = $newmode;
                      $v = $res;
                  } else {
                      $final_mode = $o[$i][0];
                      $v = $o[$i][1];
                  }
              } else {
                  my $m = $mm->combine_rules->{"$final_mode+$o[$i][0]"}
                      or do {
                          $mm->push_error("Can't merge $final_mode + $o[$i][0]");
                          return;
                      };
                  #print "DEBUG: merge $final_mode+$o[$i][0] = $m->[0], $m->[1]\n";
                  my ($subnewkey, $subbackup);
                  ($subnewkey, $v, $subbackup, $is_circular) = $mm->_merge($k, $v, $o[$i][1], $m->[0]);
                  return if @{ $mm->errors };
                  if ($is_circular) {
                      if ($i < $#o) {
                          $mm->push_error("Can't handle circular at $i of $#o merges (mode $m->[0]): not the last merge");
                          return;
                      }
                      #print "DEBUG: pushing todo to mem<".$mm->cur_mem_key.">\n";
                      push @{ $mm->mem->{ $mm->cur_mem_key }{todo} }, sub {
                          my ($subnewkey, $subres, $subbackup) = @_;
                          #print "DEBUG: Entering todo subroutine (k=$k)\n";
                          my $final_mode = $m->[1];
                          #XXX return unless defined($subnewkey);
                          $res->{$k} = [$m->[1], $subres];
                          if ($c->readd_prefix) {
                              # XXX if there is a conflict error in
                              # _readd_prefix, how to adjust path?
                              $self->_readd_prefix($res, $k, $c->default_mode);
                          } else {
                              $res->{$k} = $res->{$k}[1];
                          }
                      };
                      delete $res->{$k};
                  }
                  next K unless defined $subnewkey;
                  $final_mode = $m->[1];
              }
          }
          $res->{$k} = [$final_mode, $v] unless $is_circular;
      }
      pop @{ $mm->path };
      #print "DEBUG: Leaving _merge_gen, res = ".$mm->_dump($res)."\n";
      ($res, $backup);
  }
  
  # hh is {key=>[MODE, val], ...} which is the format returned by _merge_gen
  sub _readd_prefix {
      my ($self, $hh, $k, $defmode) = @_;
      my $mm = $self->merger;
      my $c = $mm->config;
  
      my $m = $hh->{$k}[0];
      if ($m eq $defmode) {
          $hh->{$k} = $hh->{$k}[1];
      } else {
          my $kp = $mm->modes->{$m}->add_prefix($k);
          if (exists $hh->{$kp}) {
              $mm->push_error("BUG: conflict when re-adding prefix after merge: $kp");
              return;
          }
          $hh->{$kp} = $hh->{$k}[1];
          delete $hh->{$k};
      }
  }
  
  sub merge_HASH_HASH {
      my ($self, $key, $l, $r, $mode) = @_;
      my $mm = $self->merger;
      my $c = $mm->config;
      $mode //= $c->default_mode;
      #print "DEBUG: entering merge_H_H(".$mm->_dump($l).", ".$mm->_dump($r).", $mode), config=($c)=",$mm->_dump($c),"\n";
      #$log->trace("using config($c)");
  
      return $self->merge_SCALAR_SCALAR($key, $l, $r) unless $c->recurse_hash;
      return if $c->wanted_path && !$mm->_path_is_included($mm->path, $c->wanted_path);
  
      # STEP 1. MERGE LEFT & RIGHT OPTIONS KEY
      my $config_replaced;
      my $orig_c = $c;
      my $ok = $c->options_key;
      {
          last unless defined $ok;
  
          my $okl = $self->_gen_left ($l, $mode, sub {$_[0] eq $ok});
          return if @{ $mm->errors };
  
          my $okr = $self->_gen_right($r, $mode, sub {$_[0] eq $ok});
          return if @{ $mm->errors };
  
          push @{ $mm->path }, $ok;
          my ($res, $backup);
          {
              local $c->{readd_prefix} = 0;
              ($res, $backup) = $self->_merge_gen($okl, $okr, $mode);
          }
          pop @{ $mm->path };
          return if @{ $mm->errors };
  
          #print "DEBUG: merge options key (".$mm->_dump($okl).", ".$mm->_dump($okr).") = ".$mm->_dump($res)."\n";
  
          $res = $res->{$ok} ? $res->{$ok}[1] : undef;
          if (defined($res) && ref($res) ne 'HASH') {
              $mm->push_error("Invalid options key after merge: value must be hash");
              return;
          }
          last unless keys %$res;
          #$log->tracef("cloning config ...");
          # Data::Clone by default does *not* deep-copy object
          #my $c2 = clone($c);
          my $c2 = bless({ %$c }, ref($c));
  
          for (keys %$res) {
              if ($c->allow_override) {
                  my $re = $c->allow_override;
                  if (!/$re/) {
                      $mm->push_error("Configuration in options key `$_` not allowed by allow_override $re");
                      return;
                  }
              }
              if ($c->disallow_override) {
                  my $re = $c->disallow_override;
                  if (/$re/) {
                      $mm->push_error("Configuration in options key `$_` not allowed by disallow_override $re");
                      return;
                  }
              }
              if ($mm->_in($_, $c->_config_config)) {
                  $mm->push_error("Configuration not allowed in options key: $_");
                  return;
              }
              if ($_ ne $ok && !$mm->_in($_, $c->_config_ok)) {
                  $mm->push_error("Unknown configuration in options key: $_");
                  return;
              }
              $c2->$_($res->{$_}) unless $_ eq $ok;
          }
          $mm->config($c2);
          $config_replaced++;
          $c = $c2;
          #$log->trace("config now changed to $c2");
      }
  
      my $sp = $c->set_prefix;
      my $saved_prefixes;
      if (defined($sp)) {
          if (ref($sp) ne 'HASH') {
              $mm->push_error("Invalid config value `set_prefix`: must be a hash");
              return;
          }
          $saved_prefixes = {};
          for my $mh (values %{ $mm->modes }) {
              my $n = $mh->name;
              if ($sp->{$n}) {
                  $saved_prefixes->{$n} = {
                      prefix => $mh->prefix,
                      prefix_re => $mh->prefix_re,
                      check_prefix_sub => $mh->check_prefix_sub,
                      add_prefix_sub => $mh->add_prefix_sub,
                      remove_prefix_sub => $mh->remove_prefix_sub,
                  };
                  $mh->prefix($sp->{$n});
                  my $re = quotemeta($sp->{$n});
                  $mh->prefix_re(qr/^$re/);
                  $mh->check_prefix_sub(undef);
                  $mh->add_prefix_sub(undef);
                  $mh->remove_prefix_sub(undef);
              }
          }
      }
  
      my $ep = $c->exclude_parse;
      my $ip = $c->include_parse;
      if (defined($ep) && ref($ep) ne 'ARRAY') {
          $mm->push_error("Invalid config value `exclude_parse`: must be an array");
          return;
      }
      if (defined($ip) && ref($ip) ne 'ARRAY') {
          $mm->push_error("Invalid config value `include_parse`: must be an array");
          return;
      }
  
      my $epr = $c->exclude_parse_regex;
      my $ipr = $c->include_parse_regex;
      if (defined($epr)) {
          eval { $epr = qr/$epr/ };
          if ($@) {
              $mm->push_error("Invalid config value `exclude_parse_regex`: invalid regex: $@");
              return;
          }
      }
      if (defined($ipr)) {
          eval { $ipr = qr/$ipr/ };
          if ($@) {
              $mm->push_error("Invalid config value `include_parse_regex`: invalid regex: $@");
              return;
          }
      }
  
      # STEP 2. PREPARE LEFT HASH
      my $hl = $self->_gen_left ($l, $mode, sub {defined($ok) ? $_[0] ne $ok : 1}, $ep, $ip, $epr, $ipr);
      return if @{ $mm->errors };
  
      # STEP 3. PREPARE RIGHT HASH
      my $hr = $self->_gen_right($r, $mode, sub {defined($ok) ? $_[0] ne $ok : 1}, $ep, $ip, $epr, $ipr);
      return if @{ $mm->errors };
  
      #print "DEBUG: hl=".Data::Dumper->new([$hl])->Indent(0)->Terse(1)->Dump."\n";
      #print "DEBUG: hr=".Data::Dumper->new([$hr])->Indent(0)->Terse(1)->Dump."\n";
  
      my $em = $c->exclude_merge;
      my $im = $c->include_merge;
      if (defined($em) && ref($em) ne 'ARRAY') {
          $mm->push_error("Invalid config value `exclude_marge`: must be an array");
          return;
      }
      if (defined($im) && ref($im) ne 'ARRAY') {
          $mm->push_error("Invalid config value `include_merge`: must be an array");
          return;
      }
  
      my $emr = $c->exclude_merge_regex;
      my $imr = $c->include_merge_regex;
      if (defined($emr)) {
          eval { $emr = qr/$emr/ };
          if ($@) {
              $mm->push_error("Invalid config value `exclude_merge_regex`: invalid regex: $@");
              return;
          }
      }
      if (defined($imr)) {
          eval { $imr = qr/$imr/ };
          if ($@) {
              $mm->push_error("Invalid config value `include_merge_regex`: invalid regex: $@");
              return;
          }
      }
  
      # STEP 4. MERGE LEFT & RIGHT
      my ($res, $backup) = $self->_merge_gen($hl, $hr, $mode, $em, $im, $emr, $imr);
      return if @{ $mm->errors };
  
      #print "DEBUG: intermediate res(5) = ".Data::Dumper->new([$res])->Indent(0)->Terse(1)->Dump."\n";
  
      # STEP 5. TURN BACK {key=>[MODE=>val]}, ...} INTO {(prefix)key => val, ...}
      if ($c->readd_prefix) {
          for my $k (keys %$res) {
              $self->_readd_prefix($res, $k, $c->default_mode);
          }
      } else {
          $res->{$_} = $res->{$_}[1] for keys %$res;
      }
  
      if ($saved_prefixes) {
          for (keys %$saved_prefixes) {
              my $mh = $mm->modes->{$_};
              my $s = $saved_prefixes->{$_};
              $mh->prefix($s->{prefix});
              $mh->prefix_re($s->{prefix_re});
              $mh->check_prefix_sub($s->{check_prefix_sub});
              $mh->add_prefix_sub($s->{add_prefix_sub});
              $mh->remove_prefix_sub($s->{remove_prefix_sub});
          }
      }
  
      # restore config
      if ($config_replaced) {
          $mm->config($orig_c);
          #print "DEBUG: Restored config, config=", $mm->_dump($mm->config), "\n";
      }
  
      #print "DEBUG: backup = ".Data::Dumper->new([$backup])->Indent(0)->Terse(1)->Dump."\n";
      #print "DEBUG: leaving merge_H_H, result = ".$mm->_dump($res)."\n";
      ($key, $res, $backup);
  }
  
  1;
  # ABSTRACT: Base class for Data::ModeMerge mode handler
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::ModeMerge::Mode::Base - Base class for Data::ModeMerge mode handler
  
  =head1 VERSION
  
  This document describes version 0.32 of Data::ModeMerge::Mode::Base (from Perl distribution Data-ModeMerge), released on 2015-02-21.
  
  =head1 SYNOPSIS
  
   use Data::ModeMerge;
  
  =head1 DESCRIPTION
  
  This is the base class for mode type handlers.
  
  =for Pod::Coverage ^(BUILD|merge_.+)$
  
  =head1 ATTRIBUTES
  
  =head2 merger
  
  =head2 prefix
  
  =head2 prefix_re
  
  =head2 check_prefix_sub
  
  =head2 add_prefix_sub
  
  =head2 remove_prefix_sub
  
  =head1 METHODS
  
  =head2 name
  
  Return name of mode. Subclass must override this method.
  
  =head2 precedence_level
  
  Return precedence level, which is a number. The greater the number,
  the higher the precedence. Subclass must override this method.
  
  =head2 default_prefix
  
  Return default prefix. Subclass must override this method.
  
  =head2 default_prefix_re
  
  Return default prefix regex. Subclass must override this method.
  
  =head2 check_prefix($hash_key)
  
  Return true if hash key has prefix for this mode.
  
  =head2 add_prefix($hash_key)
  
  Return hash key with added prefix of this mode.
  
  =head2 remove_prefix($hash_key)
  
  Return hash key with prefix of this mode prefix removed.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-ModeMerge>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_MODEMERGE_MODE_BASE

$fatpacked{"Data/ModeMerge/Mode/CONCAT.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_MODEMERGE_MODE_CONCAT';
  package Data::ModeMerge::Mode::CONCAT;
  
  our $DATE = '2015-02-21'; # DATE
  our $VERSION = '0.32'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Mo qw(build default);
  extends 'Data::ModeMerge::Mode::ADD';
  
  sub name { 'CONCAT' }
  
  sub precedence_level { 2 }
  
  sub default_prefix { '.' }
  
  sub default_prefix_re { qr/^\./ }
  
  sub merge_SCALAR_SCALAR {
      my ($self, $key, $l, $r) = @_;
      ($key, ($l // "") . $r);
  }
  
  1;
  # ABSTRACT: Handler for Data::ModeMerge CONCAT merge mode
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::ModeMerge::Mode::CONCAT - Handler for Data::ModeMerge CONCAT merge mode
  
  =head1 VERSION
  
  This document describes version 0.32 of Data::ModeMerge::Mode::CONCAT (from Perl distribution Data-ModeMerge), released on 2015-02-21.
  
  =head1 SYNOPSIS
  
   use Data::ModeMerge;
  
  =head1 DESCRIPTION
  
  This is the class to handle CONCAT merge mode.
  
  =for Pod::Coverage ^merge_.*
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-ModeMerge>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_MODEMERGE_MODE_CONCAT

$fatpacked{"Data/ModeMerge/Mode/DELETE.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_MODEMERGE_MODE_DELETE';
  package Data::ModeMerge::Mode::DELETE;
  
  our $DATE = '2015-02-21'; # DATE
  our $VERSION = '0.32'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Mo qw(build default);
  extends 'Data::ModeMerge::Mode::Base';
  
  sub name { 'DELETE' }
  
  sub precedence_level { 1 }
  
  sub default_prefix { '!' }
  
  sub default_prefix_re { qr/^!/ }
  
  # merge_left_only and merge_right_only are a bit different: they are
  # called with $l only or $r only instead of both, and should return an
  # extra argument $mode, i.e. ($key, $result, $backup, $is_circular,
  # $mode)
  sub merge_left_only {
      my ($self, $key, $l) = @_;
      return;
  }
  
  sub merge_right_only {
      my ($self, $key, $r) = @_;
      return;
  }
  
  sub merge_SCALAR_SCALAR {
      return;
  }
  
  sub merge_SCALAR_ARRAY {
      return;
  }
  
  sub merge_SCALAR_HASH {
      return;
  }
  
  sub merge_ARRAY_SCALAR {
      return;
  }
  
  sub merge_ARRAY_ARRAY {
      my ($self, $key, $l, $r) = @_;
      $self->merger->config->allow_destroy_array or
          $self->merger->push_error("Now allowed to destroy array via DELETE mode");
      return;
  }
  
  sub merge_ARRAY_HASH {
      return;
  }
  
  sub merge_HASH_SCALAR {
      return;
  }
  
  sub merge_HASH_ARRAY {
      return;
  }
  
  sub merge_HASH_HASH {
      my ($self, $key, $l, $r) = @_;
      $self->merger->config->allow_destroy_hash or
          $self->merger->push_error("Now allowed to destroy hash via DELETE mode");
      return;
  }
  
  1;
  # ABSTRACT: Handler for Data::ModeMerge DELETE merge mode
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::ModeMerge::Mode::DELETE - Handler for Data::ModeMerge DELETE merge mode
  
  =head1 VERSION
  
  This document describes version 0.32 of Data::ModeMerge::Mode::DELETE (from Perl distribution Data-ModeMerge), released on 2015-02-21.
  
  =head1 SYNOPSIS
  
   use Data::ModeMerge;
  
  =head1 DESCRIPTION
  
  This is the class to handle DELETE merge mode.
  
  =for Pod::Coverage ^merge_.*
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-ModeMerge>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_MODEMERGE_MODE_DELETE

$fatpacked{"Data/ModeMerge/Mode/KEEP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_MODEMERGE_MODE_KEEP';
  package Data::ModeMerge::Mode::KEEP;
  
  our $DATE = '2015-02-21'; # DATE
  our $VERSION = '0.32'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Mo qw(build default);
  extends 'Data::ModeMerge::Mode::Base';
  
  sub name { 'KEEP' }
  
  sub precedence_level { 6 }
  
  sub default_prefix { '^' }
  
  sub default_prefix_re { qr/^\^/ }
  
  sub merge_SCALAR_SCALAR {
      my ($self, $key, $l, $r) = @_;
      ($key, $l);
  }
  
  sub merge_SCALAR_ARRAY {
      my ($self, $key, $l, $r) = @_;
      ($key, $l);
  }
  
  sub merge_SCALAR_HASH {
      my ($self, $key, $l, $r) = @_;
      ($key, $l);
  }
  
  sub merge_ARRAY_SCALAR {
      my ($self, $key, $l, $r) = @_;
      ($key, $l);
  }
  
  sub merge_ARRAY_ARRAY {
      my ($self, $key, $l, $r) = @_;
      $self->SUPER::merge_ARRAY_ARRAY($key, $l, $r, 'KEEP');
  };
  
  sub merge_ARRAY_HASH {
      my ($self, $key, $l, $r) = @_;
      ($key, $l);
  }
  
  sub merge_HASH_SCALAR {
      my ($self, $key, $l, $r) = @_;
      ($key, $l);
  }
  
  sub merge_HASH_ARRAY {
      my ($self, $key, $l, $r) = @_;
      ($key, $l);
  }
  
  sub merge_HASH_HASH {
      my ($self, $key, $l, $r) = @_;
      $self->SUPER::merge_HASH_HASH($key, $l, $r, 'KEEP');
  };
  
  1;
  # ABSTRACT: Handler for Data::ModeMerge KEEP merge mode
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::ModeMerge::Mode::KEEP - Handler for Data::ModeMerge KEEP merge mode
  
  =head1 VERSION
  
  This document describes version 0.32 of Data::ModeMerge::Mode::KEEP (from Perl distribution Data-ModeMerge), released on 2015-02-21.
  
  =head1 SYNOPSIS
  
   use Data::ModeMerge;
  
  =head1 DESCRIPTION
  
  This is the class to handle KEEP merge mode.
  
  =for Pod::Coverage ^merge_.*
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-ModeMerge>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_MODEMERGE_MODE_KEEP

$fatpacked{"Data/ModeMerge/Mode/NORMAL.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_MODEMERGE_MODE_NORMAL';
  package Data::ModeMerge::Mode::NORMAL;
  
  our $DATE = '2015-02-21'; # DATE
  our $VERSION = '0.32'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Mo qw(build default);
  extends 'Data::ModeMerge::Mode::Base';
  
  sub name { 'NORMAL' }
  
  sub precedence_level { 5 }
  
  sub default_prefix { '*' }
  
  sub default_prefix_re { qr/^\*/ }
  
  sub merge_SCALAR_SCALAR {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_SCALAR_ARRAY {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_SCALAR_HASH {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_SCALAR_CODE {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_ARRAY_SCALAR {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_ARRAY_HASH {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_ARRAY_CODE {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_HASH_SCALAR {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_HASH_ARRAY {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_HASH_CODE {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_CODE_SCALAR {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_CODE_ARRAY {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_CODE_HASH {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  sub merge_CODE_CODE {
      my ($self, $key, $l, $r) = @_;
      ($key, $r);
  }
  
  1;
  # ABSTRACT: Handler for Data::ModeMerge NORMAL merge mode
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::ModeMerge::Mode::NORMAL - Handler for Data::ModeMerge NORMAL merge mode
  
  =head1 VERSION
  
  This document describes version 0.32 of Data::ModeMerge::Mode::NORMAL (from Perl distribution Data-ModeMerge), released on 2015-02-21.
  
  =head1 SYNOPSIS
  
   use Data::ModeMerge;
  
  =head1 DESCRIPTION
  
  This is the class to handle NORMAL merge mode.
  
  =for Pod::Coverage ^merge_.*
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-ModeMerge>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_MODEMERGE_MODE_NORMAL

$fatpacked{"Data/ModeMerge/Mode/SUBTRACT.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_MODEMERGE_MODE_SUBTRACT';
  package Data::ModeMerge::Mode::SUBTRACT;
  
  our $DATE = '2015-02-21'; # DATE
  our $VERSION = '0.32'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Mo qw(build default);
  extends 'Data::ModeMerge::Mode::NORMAL';
  
  sub name { 'SUBTRACT' }
  
  sub precedence_level { 4 }
  
  sub default_prefix { '-' }
  
  sub default_prefix_re { qr/^-/ }
  
  sub merge_SCALAR_SCALAR {
      my ($self, $key, $l, $r) = @_;
      ($key, $l - $r);
  }
  
  sub merge_SCALAR_ARRAY {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't subtract scalar and array");
      return;
  }
  
  sub merge_SCALAR_HASH {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't subtract scalar and hash");
      return;
  }
  
  sub merge_ARRAY_SCALAR {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't subtract array and scalar");
      return;
  }
  
  sub merge_ARRAY_ARRAY {
      my ($self, $key, $l, $r) = @_;
      my @res;
      my $mm = $self->merger;
      for (@$l) {
          push @res, $_ unless $mm->_in($_, $r);
      }
      ($key, \@res);
  }
  
  sub merge_ARRAY_HASH {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't subtract array and hash");
      return;
  }
  
  sub merge_HASH_SCALAR {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't subtract hash and scalar");
      return;
  }
  
  sub merge_HASH_ARRAY {
      my ($self, $key, $l, $r) = @_;
      $self->merger->push_error("Can't subtract hash and array");
      return;
  }
  
  sub merge_HASH_HASH {
      my ($self, $key, $l, $r) = @_;
      my $mm = $self->merger;
  
      my %res;
      my $r2 = {};
      for (keys %$r) {
          my $k = $mm->check_prefix($_) ? $_ : $mm->add_prefix($_, 'DELETE');
          if ($k ne $_ && exists($r->{$k})) {
              $mm->push_error("Conflict when adding DELETE prefix on right-side hash key $_ ".
                              "for SUBTRACT merge: key $k already exists");
              return;
          }
          $r2->{$k} = $r->{$_};
      }
      $mm->_merge($key, $l, $r2, 'NORMAL');
  }
  
  1;
  # ABSTRACT: Handler for Data::ModeMerge SUBTRACT merge mode
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::ModeMerge::Mode::SUBTRACT - Handler for Data::ModeMerge SUBTRACT merge mode
  
  =head1 VERSION
  
  This document describes version 0.32 of Data::ModeMerge::Mode::SUBTRACT (from Perl distribution Data-ModeMerge), released on 2015-02-21.
  
  =head1 SYNOPSIS
  
   use Data::ModeMerge;
  
  =head1 DESCRIPTION
  
  This is the class to handle SUBTRACT merge mode.
  
  =for Pod::Coverage ^merge_.*
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-ModeMerge>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_MODEMERGE_MODE_SUBTRACT

$fatpacked{"Data/Sah.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH';
  package Data::Sah;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  #use Log::Any qw($log);
  
  use Mo qw(build default);
  
  our $Log_Validator_Code = $ENV{LOG_SAH_VALIDATOR_CODE} // 0;
  
  use Data::Sah::Normalize qw(
                         $type_re
                         $clause_name_re
                         $clause_re
                         $attr_re
                         $funcset_re
                         $compiler_re
                         );
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(normalize_schema gen_validator);
  
  # store Data::Sah::Compiler::* instances
  has compilers    => (is => 'rw', default => sub { {} });
  
  has _merger      => (
      is      => 'rw',
      lazy    => 1,
      default => sub {
          require Data::ModeMerge;
          my $mm = Data::ModeMerge->new(config => {
              recurse_array => 1,
          });
          $mm->modes->{NORMAL}  ->prefix   ('merge.normal.');
          $mm->modes->{NORMAL}  ->prefix_re(qr/\Amerge\.normal\./);
          $mm->modes->{ADD}     ->prefix   ('merge.add.');
          $mm->modes->{ADD}     ->prefix_re(qr/\Amerge\.add\./);
          $mm->modes->{CONCAT}  ->prefix   ('merge.concat.');
          $mm->modes->{CONCAT}  ->prefix_re(qr/\Amerge\.concat\./);
          $mm->modes->{SUBTRACT}->prefix   ('merge.subtract.');
          $mm->modes->{SUBTRACT}->prefix_re(qr/\Amerge\.subtract\./);
          $mm->modes->{DELETE}  ->prefix   ('merge.delete.');
          $mm->modes->{DELETE}  ->prefix_re(qr/\Amerge\.delete\./);
          $mm->modes->{KEEP}    ->prefix   ('merge.keep.');
          $mm->modes->{KEEP}    ->prefix_re(qr/\Amerge\.keep\./);
          $mm;
      },
  );
  
  has _var_enumer  => (
      is      => 'rw',
      lazy    => 1,
      default => sub {
          require Language::Expr::Interpreter::VarEnumer;
          Language::Expr::Interpreter::VarEnumer->new;
      },
  );
  
  sub normalize_clset {
      require Scalar::Util;
  
      my $self;
      if (Scalar::Util::blessed($_[0])) {
          $self = shift;
      } else {
          $self = __PACKAGE__->new;
      }
  
      Data::Sah::Normalize::normalize_clset(@_);
  }
  
  sub normalize_schema {
      require Scalar::Util;
  
      my $self;
      if (Scalar::Util::blessed($_[0])) {
          $self = shift;
      } else {
          $self = __PACKAGE__->new;
      }
      my ($s) = @_;
  
      Data::Sah::Normalize::normalize_schema(@_);
  }
  
  sub gen_validator {
      require Scalar::Util;
  
      my $self;
      if (Scalar::Util::blessed($_[0])) {
          $self = shift;
      } else {
          $self = __PACKAGE__->new;
      }
      my ($schema, $opts) = @_;
      my %args = (schema => $schema, %{$opts // {}});
      my $opt_source = delete $args{source};
  
      $args{log_result} = 1 if $Log_Validator_Code;
  
      my $pl = $self->get_compiler("perl");
      my $code = $pl->expr_validator_sub(%args);
      return $code if $opt_source;
  
      my $res = eval $code;
      die "Can't compile validator: $@" if $@;
      $res;
  }
  
  sub _merge_clause_sets {
      my ($self, @clause_sets) = @_;
      my @merged;
  
      my $mm = $self->_merger;
  
      my @c;
      for (@clause_sets) {
          push @c, {cs=>$_, has_prefix=>$mm->check_prefix_on_hash($_)};
      }
      for (reverse @c) {
          if ($_->{has_prefix}) { $_->{last_with_prefix} = 1; last }
      }
  
      my $i = -1;
      for my $c (@c) {
          $i++;
          if (!$i || !$c->{has_prefix} && !$c[$i-1]{has_prefix}) {
              push @merged, $c->{cs};
              next;
          }
          $mm->config->readd_prefix(
              ($c->{last_with_prefix} || $c[$i-1]{last_with_prefix}) ? 0 : 1);
          my $mres = $mm->merge($merged[-1], $c->{cs});
          die "Can't merge clause sets: $mres->{error}" unless $mres->{success};
          $merged[-1] = $mres->{result};
      }
      \@merged;
  }
  
  sub get_compiler {
      my ($self, $name) = @_;
      return $self->compilers->{$name} if $self->compilers->{$name};
  
      die "Invalid compiler name `$name`" unless $name =~ $compiler_re;
      my $module = "Data::Sah::Compiler::$name";
      if (!eval "require $module; 1") {
          die "Can't load compiler module $module".($@ ? ": $@" : "");
      }
  
      my $obj = $module->new(main => $self);
      $self->compilers->{$name} = $obj;
  
      return $obj;
  }
  
  sub normalize_var {
      my ($self, $var, $curpath) = @_;
      die "Not yet implemented";
  }
  
  1;
  # ABSTRACT: Fast and featureful data structure validation
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah - Fast and featureful data structure validation
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 SYNOPSIS
  
  Non-OO interface:
  
   use Data::Sah qw(
       normalize_schema
       gen_validator
   );
  
   # generate a validator for schema
   my $v = gen_validator(["int*", min=>1, max=>10]);
  
   # validate your data using the generated validator
   say "valid" if $v->(5);     # valid
   say "valid" if $v->(11);    # invalid
   say "valid" if $v->(undef); # invalid
   say "valid" if $v->("x");   # invalid
  
   # generate validator which reports error message string, in Indonesian
   my $v = gen_validator(["int*", min=>1, max=>10],
                         {return_type=>'str', lang=>'id_ID'});
   say $v->(5);  # ''
   say $v->(12); # 'Data tidak boleh lebih besar dari 10'
                 # (in English: 'Data must not be larger than 10')
  
   # normalize a schema
   my $nschema = normalize_schema("int*"); # => ["int", {req=>1}, {}]
   normalize_schema(["int*", min=>0]); # => ["int", {min=>0, req=>1}, {}]
  
  OO interface (more advanced usage):
  
   use Data::Sah;
   my $sah = Data::Sah->new;
  
   # get perl compiler
   my $pl = $sah->get_compiler("perl");
  
   # compile schema into Perl code
   my $cd = $pl->compile(schema => ["int*", min=>0]);
   say $cd->{result};
  
  will print something like:
  
   # req #0
   (defined($data))
   &&
   # check type 'int'
   (Scalar::Util::Numeric::isint($data))
   &&
   (# clause: min
   ($data >= 0))
  
  To see the full validator code (with C<sub {}> and all), you can do something
  like:
  
   % LOG=1 LOG_SAH_VALIDATOR_CODE=1 TRACE=1 perl -MLog::Any::App -MData::Sah=gen_validator -E'gen_validator(["int*", min=>0])'
  
  which will print log message like:
  
   normalized schema=['int',{min => 0,req => 1},{}]
   validator code:
      1|do {
      2|    require Scalar::Util::Numeric;
      3|    sub {
      4|        my ($data) = @_;
      5|        my $_sahv_res =
       |
      7|            # req #0
      8|            (defined($data))
       |
     10|            &&
       |
     12|            # check type 'int'
     13|            (Scalar::Util::Numeric::isint($data))
       |
     15|            &&
       |
     17|            (# clause: min
     18|            ($data >= 0));
       |
     20|        return($_sahv_res);
     21|    }}
  
  =head1 DESCRIPTION
  
  This module, L<Data::Sah>, implements compilers for producing Perl and
  JavaScript validators, as well as translatable human description text from
  L<Sah> schemas. Compiler approach is used instead of interpreter for faster
  speed.
  
  The generated validator code can run without this module.
  
  =head1 STATUS
  
  Some features are not implemented yet:
  
  =over
  
  =item * def/subschema
  
  =item * expression
  
  =item * buf type
  
  =item * date/datetime type
  
  =item * obj: meths, attrs properties
  
  =item * .prio, .err_msg, .ok_err_msg attributes
  
  =item * .result_var attribute
  
  =item * BaseType: if, prefilters, postfilters, check, prop, check_prop clauses
  
  =item * HasElems: each_elem, each_index, check_each_elem, check_each_index, exists clauses
  
  =item * HasElems: len, elems, indices properties
  
  =item * hash: check_each_key, check_each_value, allowed_keys_re, forbidden_keys_re clauses
  
  =item * array: uniq clauses
  
  =item * human compiler: markdown output
  
  =item * markdown output
  
  =back
  
  =head1 EXPORTS
  
  None exported by default.
  
  =head2 normalize_schema($schema) => ARRAY
  
  Normalize C<$schema>.
  
  Can also be used as a method.
  
  =head2 gen_validator($schema, \%opts) => CODE (or STR)
  
  Generate validator code for C<$schema>. Can also be used as a method. Known
  options (unknown options will be passed to Perl schema compiler):
  
  =over
  
  =item * accept_ref => BOOL (default: 0)
  
  Normally the generated validator accepts data, as in:
  
   $res = $vdr->($data);
   $res = $vdr->(42);
  
  If this option is set to true, validator accepts reference to data instead, as
  in:
  
   $res = $vdr->(\$data);
  
  This allows $data to be modified by the validator (mainly, to set default value
  specified in schema). For example:
  
   my $data;
   my $vdr = gen_validator([int => {min=>0, max=>10, default=>5}],
                           {accept_ref=>1});
   my $res = $vdr->(\$data);
   say $res;  # => 1 (success)
   say $data; # => 5
  
  =item * source => BOOL (default: 0)
  
  If set to 1, return source code string instead of compiled subroutine. Usually
  only needed for debugging (but see also C<$Log_Validator_Code> and
  C<LOG_SAH_VALIDATOR_CODE> if you want to log validator source code).
  
  =back
  
  =head1 ATTRIBUTES
  
  =head2 compilers => HASH
  
  A mapping of compiler name and compiler (Data::Sah::Compiler::*) objects.
  
  =head1 VARIABLES
  
  =head2 C<$Log_Validator_Code> (bool, default: 0)
  
  =head1 ENVIRONMENT
  
  L<LOG_SAH_VALIDATOR_CODE>
  
  =head1 METHODS
  
  =head2 new() => OBJ
  
  Create a new Data::Sah instance.
  
  =head2 $sah->get_compiler($name) => OBJ
  
  Get compiler object. C<Data::Sah::Compiler::$name> will be loaded first and
  instantiated if not already so. After that, the compiler object is cached.
  
  Example:
  
   my $plc = $sah->get_compiler("perl"); # loads Data::Sah::Compiler::perl
  
  =head2 $sah->normalize_schema($schema) => HASH
  
  Normalize a schema, e.g. change C<int*> into C<< [int => {req=>1}] >>, as well
  as do some sanity checks on it. Returns the normalized schema if succeeds, or
  dies on error.
  
  Can also be used as a function.
  
  Note: this functionality is implemented in L<Data::Sah::Normalize> (distributed
  separately in Data-Sah-Normalize). Use that module instead if you just need
  normalizing schemas, to reduce dependencies.
  
  =head2 $sah->normalize_clset($clset[, \%opts]) => HASH
  
  Normalize a clause set, e.g. change C<< {"!match"=>"abc"} >> into C<<
  {"match"=>"abc", "match.op"=>"not"} >>. Produce a shallow copy of the input
  clause set hash.
  
  Can also be used as a function.
  
  =head2 $sah->normalize_var($var) => STR
  
  Normalize a variable name in expression into its fully qualified/absolute form.
  
  Not yet implemented (pending specification).
  
  For example:
  
   [int => {min => 10, 'max=' => '2*$min'}]
  
  $min in the above expression will be normalized as C<schema:clauses.min>.
  
  =head2 $sah->gen_validator($schema, \%opts) => CODE
  
  Use the Perl compiler to generate validator code. Can also be used as a
  function. See the documentation as a function for list of known options.
  
  =head1 MODULE ORGANIZATION
  
  B<Data::Sah::Type::*> roles specify Sah types, e.g. C<Data::Sah::Type::bool>
  specifies the bool type. It can also be used to name distributions that
  introduce new types, e.g. C<Data-Sah-Type-complex> which introduces complex
  number type.
  
  B<Data::Sah::FuncSet::*> roles specify bundles of functions, e.g.
  <Data::Sah::FuncSet::Core> specifies the core/standard functions.
  
  B<Data::Sah::Compiler::$LANG::> namespace is for compilers. Each compiler might
  further contain <::TH::*> and <::FSH::*> subnamespaces to implement appropriate
  functionalities, e.g. C<Data::Sah::Compiler::perl::TH::bool> is the bool type
  handler for the Perl compiler and C<Data::Sah::Compiler::perl::FSH::Core> is the
  Core funcset handler for Perl compiler.
  
  B<Data::Sah::TypeX::$TYPENAME::$CLAUSENAME> namespace can be used to name
  distributions that extend an existing Sah type by introducing a new clause for
  it. See L<Data::Sah::Manual::Extending> for an example.
  
  B<Data::Sah::Lang::$LANGCODE> namespaces are for modules that contain
  translations. They are further organized according to the organization of other
  Data::Sah modules, e.g. L<Data::Sah::Lang::en_US::Type::int> or
  C<Data::Sah::Lang::en_US::TypeX::str::is_palindrome>.
  
  B<Sah::Schema::> namespace is reserved for modules that contain bundles of
  schemas. For example, C<Sah::Schema::CPANMeta> contains the schema to validate
  CPAN META.yml. L<Sah::Schema::Int> contains various schemas for integers such as
  C<pos_int>, C<int8>, C<uint32>. L<Sah::Schema::Sah> contains the schema for Sah
  schema itself.
  
  =head1 FAQ
  
  See also L<Sah::FAQ>.
  
  =head2 Relation to Data::Schema?
  
  L<Data::Schema> is the old incarnation of this module, deprecated since 2011.
  
  There are enough incompatibilities between the two (some different syntaxes,
  renamed clauses). Also, some terminology have been changed, e.g. "attribute"
  become "clauses", "suffix" becomes "attributes". This warrants a new name.
  
  Compared to Data::Schema, Sah always compiles schemas and there is much greater
  flexibility in code generation (can customize data term, code can return boolean
  or error message string or detailed hash, can generate code to validate multiple
  schemas, etc). There is no longer hash form, schema is either a string or an
  array. Some clauses have been renamed (mostly, commonly used clauses are
  abbreviated, Huffman encoding thingy), some removed (usually because they are
  replaced by a more general solution), and new ones have been added.
  
  If you use Data::Schema, I recommend you migrate to Data::Sah as I will not be
  developing Data::Schema anymore. Sorry, there's currently no tool to convert
  your Data::Schema schemas to Sah, but it should be relatively straightforward.
  
  =head2 Comparison to {JSON::Schema, Data::Rx, Data::FormValidator, ...}?
  
  See L<Sah::FAQ>.
  
  =head2 Why is it so slow?
  
  You probably do not reuse the compiled schema, e.g. you continually destroy and
  recreate Data::Sah object, or repeatedly recompile the same schema. To gain the
  benefit of compilation, you need to keep the compiled result and use the
  generated Perl code repeatedly.
  
  =head2 Can I generate another schema dynamically from within the schema?
  
  For example:
  
   // if first element is an integer, require the array to contain only integers,
   // otherwise require the array to contain only strings.
   ["array", {"min_len": 1, "of=": "[is_int($_[0]) ? 'int':'str']"}]
  
  Currently no, Data::Sah does not support expression on clauses that contain
  other schemas. In other words, dynamically generated schemas are not supported.
  To support this, if the generated code needs to run independent of Data::Sah, it
  needs to contain the compiler code itself (or an interpreter) to compile or
  evaluate the generated schema.
  
  However, an C<eval_schema()> Sah function which uses Data::Sah can be trivially
  declared and target the Perl compiler.
  
  =head2 How to display the validator code being generated?
  
  Use the C<< source => 1 >> option in C<gen_validator()>.
  
  If you use the OO interface, e.g.:
  
   # generate perl code
   my $cd = $plc->compile(schema=>..., ...);
  
  then the generated code is in C<< $cd->{result} >> and you can just print it.
  
  If you generate validator using C<gen_validator()>, you can set environment
  LOG_SAH_VALIDATOR_CODE or package variable C<$Log_Validator_Code> to true and
  the generated code will be logged at trace level using L<Log::Any>. The log can
  be displayed using, e.g., L<Log::Any::App>:
  
   % LOG_SAH_VALIDATOR_CODE=1 TRACE=1 \
     perl -MLog::Any::App -MData::Sah=gen_validator \
     -e '$sub = gen_validator([int => min=>1, max=>10])'
  
  Sample output:
  
   normalized schema=['int',{max => 10,min => 1},{}]
   schema already normalized, skipped normalization
   validator code:
      1|do {
      2|    require Scalar::Util::Numeric;
      3|    sub {
      4|        my ($data) = @_;
      5|        my $_sahv_res =
       |
      7|            # skip if undef
      8|            (!defined($data) ? 1 :
       |
     10|            (# check type 'int'
     11|            (Scalar::Util::Numeric::isint($data))
       |
     13|            &&
       |
     15|            (# clause: min
     16|            ($data >= 1))
       |
     18|            &&
       |
     20|            (# clause: max
     21|            ($data <= 10))));
       |
     23|        return($_sahv_res);
     24|    }}
  
  Lastly, you can also use L<validate-with-sah> CLI utility from the
  L<App::SahUtils> distribution (use the C<--show-code> option).
  
  =head2 How to show the validation error message? The validator only returns true/false!
  
  Pass the C<< return_type=>"str" >> to get an error message string on error, or
  C<< return_type=>"full" >> to get a hash of detailed error messages. Note also
  that the error messages are translateable (e.g. use C<LANG> or C<< lang=>... >>
  option. For example:
  
   my $v = gen_validator([int => between => [1,10]], {return_type=>"str"});
   say "$_: ", $v->($_) for 1, "x", 12;
  
  will output:
  
   1:
   "x": Input is not of type integer
   12: Must be between 1 and 10
  
  =head2 What does the C<@...> prefix that is sometimes shown on the error message mean?
  
  It shows the path to data item that fails the validation, e.g.:
  
   my $v = gen_validator([array => of => [int=>min=>5], {return_type=>"str"});
   say $v->([10, 5, "x"]);
  
  prints:
  
   @2: Input is not of type integer
  
  which means that the third element (subscript 2) of the array fails the
  validation. Another example:
  
   my $v = gen_validator([array => of => [hash=>keys=>{a=>"int"}]]);
   say $v->([{}, {a=>1.1}]);
  
  prints:
  
   @1/a: Input is not of type integer
  
  =head2 How to show the process of validation by the compiled code?
  
  If you are generating Perl code from schema, you can pass C<< debug=>1 >> option
  so the code contains logging (L<Log::Any>-based) and other debugging
  information, which you can display. For example:
  
   % TRACE=1 perl -MLog::Any::App -MData::Sah=gen_validator -E'
     $v = gen_validator([array => of => [hash => {req_keys=>["a"]}]],
                        {return_type=>"str", debug=>1});
     say "Validation result: ", $v->([{a=>1}, "x"]);'
  
  will output:
  
   ...
   [spath=[]]skip if undef ...
   [spath=[]]check type 'array' ...
   [spath=['of']]clause: {"of":["hash",{"req_keys":["a"]}]} ...
   [spath=['of']]skip if undef ...
   [spath=['of']]check type 'hash' ...
   [spath=['of','req_keys']]clause: {"req_keys":["a"]} ...
   [spath=['of']]skip if undef ...
   [spath=['of']]check type 'hash' ...
   Validation result: [spath=of]@1: Input is not of type hash
  
  =head2 What else can I do with the compiled code?
  
  Data::Sah offers some options in code generation. Beside compiling the validator
  code into a subroutine, there are also some other options. Examples:
  
  =over
  
  =item * L<Dist::Zilla::Plugin::Rinci::Validate>
  
  This plugin inserts the generated code (without the C<sub { ... }> wrapper) to
  validate the content of C<%args> right before C<# VALIDATE_ARG> or C<#
  VALIDATE_ARGS> like below:
  
   $SPEC{foo} = {
       args => {
           arg1 => { schema => ..., req=>1 },
           arg2 => { schema => ... },
       },
       ...
   };
   sub foo {
       my %args = @_; # VALIDATE_ARGS
   }
  
  The schemas will be retrieved from the Rinci metadata (C<$SPEC{foo}> above).
  This means, subroutines in your built distribution will do argument validation.
  
  =item * L<Perinci::Sub::Wrapper>
  
  This module is part of the L<Perinci> family. What the module does is basically
  wrap your subroutine with a wrapper code that can include validation code (among
  others). This is a convenient way to add argument validation to an existing
  subroutine/code.
  
  =back
  
  =head1 SEE ALSO
  
  =head3 Other compiled validators
  
  =head3 Other interpreted validators
  
  L<Params::Validate> is very fast, although minimal. L<Data::Rx>, L<Kwalify>,
  L<Data::Verifier>, L<Data::Validator>, L<JSON::Schema>, L<Validation::Class>.
  
  For Moo/Mouse/Moose stuffs: L<Moose> type system, L<MooseX::Params::Validate>,
  L<Type::Tiny>, among others.
  
  Form-oriented: L<Data::FormValidator>, L<FormValidator::Lite>, among others.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH

$fatpacked{"Data/Sah/Compiler.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER';
  package Data::Sah::Compiler;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  #use Carp;
  use Mo qw(default);
  use Role::Tiny::With;
  use Log::Any::IfLOG qw($log);
  
  with 'Data::Sah::Compiler::TextResultRole';
  
  use Scalar::Util qw(blessed);
  
  has main => (is => 'rw');
  
  # instance to Language::Expr instance
  has expr_compiler => (
      is => 'rw',
      lazy => 1,
      default => sub {
          require Language::Expr;
          Language::Expr->new;
      },
  );
  
  sub name {
      die "BUG: Please override name()";
  }
  
  # literal representation in target language
  sub literal {
      die "BUG: Please override literal()";
  }
  
  # compile expression to target language
  sub expr {
      die "BUG: Please override expr()";
  }
  
  sub _die {
      my ($self, $cd, $msg) = @_;
      die join(
          "",
          "Sah ". $self->name . " compiler: ",
          "at schema:/", join("/", @{$cd->{spath} // []}), ": ",
          # XXX show (snippet of) current schema
          $msg,
      );
  }
  
  # form dependency list from which clauses are mentioned in expressions NEED TO
  # BE UPDATED: NEED TO CHECK EXPR IN ALL ATTRS FOR THE WHOLE SCHEMA/SUBSCHEMAS
  # (NOT IN THE CURRENT CLSET ONLY), THERE IS NO LONGER A ctbl, THE WAY EXPR IS
  # STORED IS NOW DIFFERENT. PLAN: NORMALIZE ALL SUBSCHEMAS, GATHER ALL EXPR VARS
  # AND STORE IN $cd->{all_expr_vars} (SKIP DOING THIS IS
  # $cd->{outer_cd}{all_expr_vars} is already defined).
  sub _form_deps {
      require Algorithm::Dependency::Ordered;
      require Algorithm::Dependency::Source::HoA;
      require Language::Expr::Interpreter::VarEnumer;
  
      my ($self, $cd, $ctbl) = @_;
      my $main = $self->main;
  
      my %depends;
      for my $crec (values %$ctbl) {
          my $cn = $crec->{name};
          my $expr = defined($crec->{expr}) ? $crec->{value} :
              $crec->{attrs}{expr};
          if (defined $expr) {
              my $vars = $main->_var_enumer->eval($expr);
              for (@$vars) {
                  /^\w+$/ or $self->_die($cd,
                      "Invalid variable syntax '$_', ".
                          "currently only the form \$abc is supported");
                  $ctbl->{$_} or $self->_die($cd,
                      "Unhandled clause specified in variable '$_'");
              }
              $depends{$cn} = $vars;
              for (@$vars) {
                  push @{ $ctbl->{$_}{depended_by} }, $cn;
              }
          } else {
              $depends{$cn} = [];
          }
      }
      #$log->tracef("deps: %s", \%depends);
      my $ds = Algorithm::Dependency::Source::HoA->new(\%depends);
      my $ad = Algorithm::Dependency::Ordered->new(source => $ds)
          or die "Failed to set up dependency algorithm";
      my $sched = $ad->schedule_all
          or die "Can't resolve dependencies, please check your expressions";
      #$log->tracef("sched: %s", $sched);
      my %rsched = map
          {@{ $depends{$sched->[$_]} } ? ($sched->[$_] => $_) : ()}
              0..@$sched-1;
      #$log->tracef("deps: %s", \%rsched);
      \%rsched;
  }
  
  # since a schema can be based on another schema, we need to resolve to get the
  # "base" type's handler (and collect clause sets in the process). for example:
  # if pos_int is [int => {min=>0}], and pos_even is [pos_int, {div_by=>2}] then
  # resolving pos_even will result in: ["int", [{min=>0}, {div_by=>2}], []]. The
  # first element is the base type, the second is merged clause sets, the third is
  # merged extras.
  sub _resolve_base_type {
      require Scalar::Util;
  
      my ($self, %args) = @_;
      my $ns   = $args{schema};
      my $t    = $ns->[0];
      my $cd   = $args{cd};
      my $th   = $self->get_th(name=>$t, cd=>$cd);
      my $seen = $args{seen} // {};
      my $res  = $args{res} // [$t, [], []];
  
      $self->_die($cd, "Recursive dependency on type '$t'") if $seen->{$t}++;
  
      $res->[0] = $t;
      unshift @{$res->[1]}, $ns->[1] if keys(%{$ns->[1]});
      unshift @{$res->[2]}, $ns->[2] if $ns->[2];
      if (Scalar::Util::blessed $th) {
          $res->[1] = $self->main->_merge_clause_sets(@{$res->[1]}) if @{$res->[1]} > 1;
          $res->[2] = $self->main->_merge_clause_sets(@{$res->[2]}) if @{$res->[2]} > 1;
      } else {
          $self->_resolve_base_type(schema=>$th, cd=>$cd, seen=>$seen, res=>$res);
      }
      $res;
  }
  
  # generate a list of clauses in clsets, in order of evaluation. clauses are
  # sorted based on expression dependencies and priority. result is array of
  # [CLSET_NUM, CLAUSE] pairs, e.g. ([0, 'default'], [1, 'default'], [0, 'min'],
  # [0, 'max']).
  sub _get_clauses_from_clsets {
      my ($self, $cd, $clsets) = @_;
      my $tn = $cd->{type};
      my $th = $cd->{th};
  
      my $deps;
      ## temporarily disabled, expr needs to be sorted globally
      #if ($self->_clset_has_expr($clset)) {
      #    $deps = $self->_form_deps($ctbl);
      #} else {
      #    $deps = {};
      #}
      #$deps = {};
  
      my $sorter = sub {
          my ($ia, $ca) = @$a;
          my ($ib, $cb) = @$b;
          my $res;
  
          # dependency
          #$res = ($deps->{"$ca.$ia"} // -1) <=> ($deps->{"$cb.$ib"} // -1);
          #return $res if $res;
  
          # prio from clause definition
          my ($metaa, $metab);
          eval {
              $metaa = "Data::Sah::Type::$tn"->${\("clausemeta_$ca")};
          };
          if ($@) {
              for ($cd->{args}{on_unhandled_clause}) {
                  my $msg = "Unhandled clause for type $tn: $ca ($@)";
                  next if $_ eq 'ignore';
                  next if $_ eq 'warn'; # don't produce multiple warnings
                  $self->_die($cd, $msg);
              }
          }
          $metaa //= {prio=>50};
          eval {
              $metab = "Data::Sah::Type::$tn"->${\("clausemeta_$cb")};
          };
          if ($@) {
              for ($cd->{args}{on_unhandled_clause}) {
                  my $msg = "Unhandled clause for type $tn: $cb";
                  next if $_ eq 'ignore';
                  next if $_ eq 'warn'; # don't produce multiple warnings
                  $self->_die($cd, $msg);
              }
          }
          $metab //= {prio=>50};
  
          {
              $res = $metaa->{prio} <=> $metab->{prio};
              #$log->errorf("TMP:   sort1");
              last if $res;
  
              # prio from schema
              my $sprioa = $clsets->[$ia]{"$ca.prio"} // 50;
              my $spriob = $clsets->[$ib]{"$cb.prio"} // 50;
              $res = $sprioa <=> $spriob;
              #$log->errorf("TMP:   sort2");
              last if $res;
  
              # alphabetical order of clause name
              $res = $ca cmp $cb;
              #$log->errorf("TMP:   sort3");
              last if $res;
  
              # clause set order
              $res = $ia <=> $ib;
              #$log->errorf("TMP:   sort4");
              last if $res;
  
              $res = 0;
          }
  
          #$log->errorf("TMP:   sort [%s,%s] vs [%s,%s] = %s", $ia, $ca, $ib, $cb, $res);
          $res;
      };
  
      my @clauses;
      for my $i (0..@$clsets-1) {
          push @clauses, map {[$i, $_]}
              grep {!/\A_/ && !/\./} keys %{$clsets->[$i]};
      }
  
      my $res = [sort $sorter @clauses];
      #$log->errorf("TMP: sorted clauses: %s", $res);
      $res;
  }
  
  sub get_th {
      my ($self, %args) = @_;
      my $cd    = $args{cd};
      my $name  = $args{name};
  
      my $th_map = $cd->{th_map};
      return $th_map->{$name} if $th_map->{$name};
  
      if ($args{load} // 1) {
          no warnings;
          $self->_die($cd, "Invalid syntax for type name '$name', please use ".
                          "letters/numbers/underscores only")
              unless $name =~ $Data::Sah::type_re;
          my $main = $self->main;
          my $module = ref($self) . "::TH::$name";
          if (!eval "require $module; 1") {
              $self->_die($cd, "Can't load type handler $module".
                              ($@ ? ": $@" : ""));
          }
  
          my $obj = $module->new(compiler=>$self);
          $th_map->{$name} = $obj;
      }
      use experimental 'smartmatch';
  
      return $th_map->{$name};
  }
  
  sub get_fsh {
      my ($self, %args) = @_;
      my $cd    = $args{cd};
      my $name  = $args{name};
  
      my $fsh_table = $cd->{fsh_table};
      return $fsh_table->{$name} if $fsh_table->{$name};
  
      if ($args{load} // 1) {
          no warnings;
          $self->_die($cd, "Invalid syntax for func set name '$name', ".
                          "please use letters/numbers/underscores")
              unless $name =~ $Data::Sah::funcset_re;
          my $module = ref($self) . "::FSH::$name";
          if (!eval "require $module; 1") {
              $self->_die($cd, "Can't load func set handler $module".
                              ($@ ? ": $@" : ""));
          }
  
          my $obj = $module->new();
          $fsh_table->{$name} = $obj;
      }
      use experimental 'smartmatch';
  
      return $fsh_table->{$name};
  }
  
  sub init_cd {
      require Time::HiRes;
  
      my ($self, %args) = @_;
  
      my $cd = {};
      $cd->{args} = \%args;
  
      if (my $ocd = $args{outer_cd}) {
          # for checking later, because outer_cd might be autovivified to hash
          # later
          $cd->{_inner}       = 1;
  
          $cd->{outer_cd}     = $ocd;
          $cd->{indent_level} = $ocd->{indent_level};
          $cd->{th_map}       = { %{ $ocd->{th_map}  } };
          $cd->{fsh_map}      = { %{ $ocd->{fsh_map} } };
          $cd->{default_lang} = $ocd->{default_lang};
          $cd->{spath}        = [@{ $ocd->{spath} }];
      } else {
          $cd->{indent_level} = $cd->{args}{indent_level} // 0;
          $cd->{th_map}       = {};
          $cd->{fsh_map}      = {};
          # we use || here because in some env, LANG/LANGUAGE is set to ''
          $cd->{default_lang} = $ENV{LANG} || "en_US";
          $cd->{default_lang} =~ s/\..+//; # en_US.UTF-8 -> en_US
          $cd->{spath}        = [];
      }
      $cd->{_id} = Time::HiRes::gettimeofday(); # compilation id
      $cd->{ccls} = [];
  
      $cd;
  }
  
  sub check_compile_args {
      my ($self, $args) = @_;
  
      return if $args->{_args_checked}++;
  
      $args->{data_name} //= 'data';
      $args->{data_name} =~ /\A[A-Za-z_]\w*\z/ or $self->_die(
          {}, "Invalid syntax in data_name '$args->{data_name}', ".
              "please use letters/nums only");
      $args->{allow_expr} //= 1;
      $args->{on_unhandled_attr}   //= 'die';
      $args->{on_unhandled_clause} //= 'die';
      $args->{skip_clause}         //= [];
      $args->{mark_missing_translation} //= 1;
      for ($args->{lang}) {
          $_ //= $ENV{LANG} || $ENV{LANGUAGE} || "en_US";
          s/\W.*//; # LANG=en_US.UTF-8, LANGUAGE=en_US:en
      }
      # locale, no default
  }
  
  sub _process_clause {
      use experimental 'smartmatch';
  
      my ($self, $cd, $clset_num, $clause) = @_;
  
      my $th = $cd->{th};
      my $tn = $cd->{type};
      my $clsets = $cd->{clsets};
  
      my $clset = $clsets->[$clset_num];
      local $cd->{spath}       = [@{$cd->{spath}}, $clause];
      local $cd->{clset}       = $clset;
      local $cd->{clset_num}   = $clset_num;
      local $cd->{uclset}      = $cd->{uclsets}[$clset_num];
      local $cd->{clset_dlang} = $cd->{_clset_dlangs}[$clset_num];
      #$log->tracef("Processing clause %s", $clause);
  
      delete $cd->{uclset}{$clause};
      delete $cd->{uclset}{"$clause.prio"};
  
      if ($clause ~~ @{ $cd->{args}{skip_clause} }) {
          delete $cd->{uclset}{$_}
              for grep /^\Q$clause\E(\.|\z)/, keys(%{$cd->{uclset}});
          return;
      }
  
      my $meth  = "clause_$clause";
      my $mmeth = "clausemeta_$clause";
      unless ($th->can($meth)) {
          for ($cd->{args}{on_unhandled_clause}) {
              next if $_ eq 'ignore';
              do { warn "Can't handle clause $clause"; next }
                  if $_ eq 'warn';
              $self->_die($cd, "Can't handle clause $clause");
          }
      }
  
      # put information about the clause to $cd
  
      my $meta;
      if ($th->can($mmeth)) {
          $meta = $th->$mmeth;
      } else {
          $meta = {};
      }
      local $cd->{cl_meta} = $meta;
      $self->_die($cd, "Clause $clause doesn't allow expression")
          if $clset->{"$clause.is_expr"} && !$meta->{allow_expr};
      for my $a (keys %{ $meta->{attrs} }) {
          my $av = $meta->{attrs}{$a};
          $self->_die($cd, "Attribute $clause.$a doesn't allow ".
                          "expression")
              if $clset->{"$clause.$a.is_expr"} && !$av->{allow_expr};
      }
      local $cd->{clause} = $clause;
      my $cv = $clset->{$clause};
      my $ie = $clset->{"$clause.is_expr"};
      my $op = $clset->{"$clause.op"};
      local $cd->{cl_value}   = $cv;
      local $cd->{cl_term}    = $ie ? $self->expr($cv) : $self->literal($cv);
      local $cd->{cl_is_expr} = $ie;
      local $cd->{cl_op}      = $op;
      delete $cd->{uclset}{"$clause.is_expr"};
      delete $cd->{uclset}{"$clause.op"};
  
      if ($self->can("before_clause")) {
          $self->before_clause($cd);
      }
      if ($th->can("before_clause")) {
          $th->before_clause($cd);
      }
      my $tmpnam = "before_clause_$clause";
      if ($th->can($tmpnam)) {
          $th->$tmpnam($cd);
      }
  
      my $is_multi;
      if (defined($op) && !$ie) {
          if ($op =~ /\A(and|or|none)\z/) {
              $is_multi = 1;
          } elsif ($op eq 'not') {
              $is_multi = 0;
          } else {
              $self->_die($cd, "Invalid value for $clause.op, ".
                              "must be one of and/or/not/none");
          }
      }
      $self->_die($cd, "'$clause.op' attribute set to $op, ".
                      "but value of '$clause' clause not an array")
          if $is_multi && ref($cv) ne 'ARRAY';
      if (!$th->can($meth)) {
          # skip
      } elsif ($cd->{CLAUSE_DO_MULTI} || !$is_multi) {
          local $cd->{cl_is_multi} = 1 if $is_multi;
          $th->$meth($cd);
      } else {
          my $i = 0;
          for my $cv2 (@$cv) {
              local $cd->{spath} = [@{ $cd->{spath} }, $i];
              local $cd->{cl_value} = $cv2;
              local $cd->{cl_term}  = $self->literal($cv2);
              local $cd->{_debug_ccl_note} = "" if $i;
              $i++;
              $th->$meth($cd);
          }
      }
  
      $tmpnam = "after_clause_$clause";
      if ($th->can($tmpnam)) {
          $th->$tmpnam($cd);
      }
      if ($th->can("after_clause")) {
          $th->after_clause($cd);
      }
      if ($self->can("after_clause")) {
          $self->after_clause($cd);
      }
  
      delete $cd->{uclset}{"$clause.err_msg"};
      delete $cd->{uclset}{"$clause.err_level"};
      delete $cd->{uclset}{$_} for
          grep /\A\Q$clause\E\.human(\..+)?\z/, keys(%{$cd->{uclset}});
  }
  
  sub _process_clsets {
      my ($self, $cd, $which) = @_;
  
      # $which can be left undef/false if called from compile(), or set to 'from
      # clause_clset' if called from within clause_clset(), in which case
      # before_handle_type, handle_type, before_all_clauses, and after_all_clauses
      # won't be called.
  
      my $th = $cd->{th};
      my $tn = $cd->{type};
      my $clsets = $cd->{clsets};
  
      my $cname = $self->name;
      local $cd->{uclsets} = [];
      $cd->{_clset_dlangs} = []; # default lang for each clset
      for my $clset (@$clsets) {
          for (keys %$clset) {
              if (!$cd->{args}{allow_expr} && /\.is_expr\z/ && $clset->{$_}) {
                  $self->_die($cd, "Expression not allowed: $_");
              }
          }
          push @{ $cd->{uclsets} }, {
              map {$_=>$clset->{$_}}
                  grep {
                      !/\A_|\._/ && (!/\Ac\./ || /\Ac\.\Q$cname\E\./)
                  } keys %$clset
          };
          my $dl = $clset->{default_lang} // $cd->{outer_cd}{clset_dlang} //
              "en_US";
          push @{ $cd->{_clset_dlangs} }, $dl;
      }
  
      my $clauses = $self->_get_clauses_from_clsets($cd, $clsets);
  
      if ($which) {
          # {before,after}_clause_sets is currently internal/undocumented, created
          # only for clause_clset
          if ($self->can("before_clause_sets")) {
              $self->before_clause_sets($cd);
          }
          if ($th->can("before_clause_sets")) {
              $th->before_clause_sets($cd);
          }
      } else {
          if ($self->can("before_handle_type")) {
              $self->before_handle_type($cd);
          }
  
          $th->handle_type($cd);
  
          if ($self->can("before_all_clauses")) {
              $self->before_all_clauses($cd);
          }
          if ($th->can("before_all_clauses")) {
              $th->before_all_clauses($cd);
          }
      }
  
      for my $clause0 (@$clauses) {
          my ($clset_num, $clause) = @$clause0;
          $self->_process_clause($cd, $clset_num, $clause);
      } # for clause
  
      for my $uclset (@{ $cd->{uclsets} }) {
          if (keys %$uclset) {
              for ($cd->{args}{on_unhandled_attr}) {
                  my $msg = "Unhandled attribute(s) for type $tn: ".
                      join(", ", keys %$uclset);
                  next if $_ eq 'ignore';
                  do { warn $msg; next } if $_ eq 'warn';
                  $self->_die($cd, $msg);
              }
          }
      }
  
      if ($which) {
          # {before,after}_clause_sets is currently internal/undocumented, created
          # only for clause_clset
          if ($th->can("after_clause_sets")) {
              $th->after_clause_sets($cd);
          }
          if ($self->can("after_clause_sets")) {
              $self->after_clause_sets($cd);
          }
      } else {
          if ($th->can("after_all_clauses")) {
              $th->after_all_clauses($cd);
          }
          if ($self->can("after_all_clauses")) {
              $self->after_all_clauses($cd);
          }
      }
  }
  
  sub compile {
      my ($self, %args) = @_;
  
      # XXX schema
      $self->check_compile_args(\%args);
  
      my $main   = $self->main;
      my $cd     = $self->init_cd(%args);
  
      if ($self->can("before_compile")) {
          $self->before_compile($cd);
      }
  
      # normalize schema
      my $schema0 = $args{schema} or $self->_die($cd, "No schema");
      my $nschema;
      if ($args{schema_is_normalized}) {
          $nschema = $schema0;
          #$log->tracef("schema already normalized, skipped normalization");
      } else {
          $nschema = $main->normalize_schema($schema0);
          #$log->tracef("normalized schema=%s", $nschema);
      }
      $cd->{nschema} = $nschema;
      local $cd->{schema} = $nschema;
  
      {
          my $defs = $nschema->[2]{def};
          if ($defs) {
              for my $name (sort keys %$defs) {
                  my $def = $defs->{$name};
                  my $opt = $name =~ s/[?]\z//;
                  local $cd->{def_optional} = $opt;
                  local $cd->{def_name}     = $name;
                  $self->_die($cd, "Invalid name syntax in def: '$name'")
                      unless $name =~ $Data::Sah::type_re;
                  local $cd->{def_def}      = $def;
                  $self->def($cd);
                  #$log->tracef("=> def() name=%s, def=>%s, optional=%s)",
                  #             $name, $def, $opt);
              }
          }
      }
  
      my $res       = $self->_resolve_base_type(schema=>$nschema, cd=>$cd);
      my $tn        = $res->[0];
      my $th        = $self->get_th(name=>$tn, cd=>$cd);
      my $clsets    = $res->[1];
      $cd->{th}     = $th;
      $cd->{type}   = $tn;
      $cd->{clsets} = $clsets;
  
      $self->_process_clsets($cd);
  
      if ($self->can("after_compile")) {
          $self->after_compile($cd);
      }
  
      if ($args{log_result}) {# && $log->is_trace) {
          require String::LineNumber;
          $log->tracef(
              "Schema compilation result:\n%s",
              !ref($cd->{result}) && ($ENV{LINENUM} // 1) ?
                  String::LineNumber::linenum($cd->{result}) :
                        $cd->{result}
                    );
      }
      return $cd;
  }
  
  sub def {
      my ($self, $cd) = @_;
      my $name = $cd->{def_name};
      my $def  = $cd->{def_def};
      my $opt  = $cd->{def_optional};
  
      my $th = $self->get_th(cd=>$cd, name=>$name, load=>0);
      if ($th) {
          if ($opt) {
              #$log->tracef("Not redefining already-defined schema/type '$name'");
              return;
          }
          $self->_die($cd, "Redefining existing type ($name) not allowed");
      }
  
      my $nschema = $self->main->normalize_schema($def);
      $cd->{th_map}{$name} = $nschema;
  }
  
  sub _ignore_clause {
      my ($self, $cd) = @_;
      my $cl = $cd->{clause};
      delete $cd->{uclset}{$cl};
  }
  
  sub _ignore_clause_and_attrs {
      my ($self, $cd) = @_;
      my $cl = $cd->{clause};
      delete $cd->{uclset}{$cl};
      delete $cd->{uclset}{$_} for grep /\A\Q$cl\E\./, keys %{$cd->{uclset}};
  }
  
  sub _die_unimplemented_clause {
      my ($self, $cd, $note) = @_;
  
      $self->_die($cd, "Clause '$cd->{clause}' for type '$cd->{type}' ".
                      ($note ? "($note) " : "") .
                          "is currently unimplemented");
  }
  
  1;
  # ABSTRACT: Base class for Sah compilers (Data::Sah::Compiler::*)
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler - Base class for Sah compilers (Data::Sah::Compiler::*)
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(check_compile_args|def|expr|init_cd|literal|name)$
  
  =head1 ATTRIBUTES
  
  =head2 main => OBJ
  
  Reference to the main Data::Sah object.
  
  =head2 expr_compiler => OBJ
  
  Reference to expression compiler object. In the perl compiler, for example, this
  will be an instance of L<Language::Expr::Compiler::Perl> object.
  
  =head1 METHODS
  
  =head2 new() => OBJ
  
  =head2 $c->compile(%args) => HASH
  
  Compile schema into target language.
  
  Arguments (C<*> denotes required arguments, subclass may introduce others):
  
  =over 4
  
  =item * data_name => STR (default: 'data')
  
  A unique name. Will be used as default for variable names, etc. Should only be
  comprised of letters/numbers/underscores.
  
  =item * schema* => STR|ARRAY
  
  The schema to use. Will be normalized by compiler, unless
  C<schema_is_normalized> is set to true.
  
  =item * lang => STR (default: from LANG/LANGUAGE or C<en_US>)
  
  Desired output human language. Defaults (and falls back to) C<en_US>.
  
  =item * mark_missing_translation => BOOL (default: 1)
  
  If a piece of text is not found in desired human language, C<en_US> version of
  the text will be used but using this format:
  
   (en_US:the text to be translated)
  
  If you do not want this marker, set the C<mark_missing_translation> option to 0.
  
  =item * locale => STR
  
  Locale name, to be set during generating human text description. This sometimes
  needs to be if setlocale() fails to set locale using only C<lang>.
  
  =item * schema_is_normalized => BOOL (default: 0)
  
  If set to true, instruct the compiler not to normalize the input schema and
  assume it is already normalized.
  
  =item * allow_expr => BOOL (default: 1)
  
  Whether to allow expressions. If false, will die when encountering expression
  during compilation. Usually set to false for security reason, to disallow
  complex expressions when schemas come from untrusted sources.
  
  =item * on_unhandled_attr => STR (default: 'die')
  
  What to do when an attribute can't be handled by compiler (either it is an
  invalid attribute, or the compiler has not implemented it yet). Valid values
  include: C<die>, C<warn>, C<ignore>.
  
  =item * on_unhandled_clause => STR (default: 'die')
  
  What to do when a clause can't be handled by compiler (either it is an invalid
  clause, or the compiler has not implemented it yet). Valid values include:
  C<die>, C<warn>, C<ignore>.
  
  =item * indent_level => INT (default: 0)
  
  Start at a specified indent level. Useful when generated code will be inserted
  into another code (e.g. inside C<sub {}> where it is nice to be able to indent
  the inside code).
  
  =item * skip_clause => ARRAY (default: [])
  
  List of clauses to skip (to assume as if it did not exist). Example when
  compiling with the human compiler:
  
   # schema
   [int => {default=>1, between=>[1, 10]}]
  
   # generated human description in English
   integer, between 1 and 10, default 1
  
   # generated human description, with skip_clause => ['default']
   integer, between 1 and 10
  
  =back
  
  =head3 Compilation data
  
  During compilation, compile() will call various hooks (listed below). The hooks
  will be passed compilation data (C<$cd>) which is a hashref containing various
  compilation state and result. Compilation data is written to this hashref
  instead of on the object's attributes to make it easy to do recursive
  compilation (compilation of subschemas).
  
  Subclasses may add more data (see their documentation).
  
  Keys which contain input data, compilation state, and others (many of these keys
  might exist only temporarily during certain phases of compilation and will no
  longer exist at the end of compilation, for example C<clause> will only exist
  during processing of a clause and will be seen by hooks like C<before_clause>
  and C<after_clause>, it will not be seen by C<before_all_clauses> or
  C<after_compile>):
  
  =over 4
  
  =item * B<args> => HASH
  
  Arguments given to C<compile()>.
  
  =item * B<compiler> => OBJ
  
  The compiler object.
  
  =item * B<outer_cd> => HASH
  
  If compilation is called from within another C<compile()>, this will be set to
  the outer compilation's C<$cd>. The inner compilation will inherit some values
  from the outer, like list of types (C<th_map>) and function sets (C<fsh_map>).
  
  =item * B<th_map> => HASH
  
  Mapping of fully-qualified type names like C<int> and its
  C<Data::Sah::Compiler::*::TH::*> type handler object (or array, a normalized
  schema).
  
  =item * B<fsh_map> => HASH
  
  Mapping of function set name like C<core> and its
  C<Data::Sah::Compiler::*::FSH::*> handler object.
  
  =item * B<schema> => ARRAY
  
  The current schema (normalized) being processed. Since schema can contain other
  schemas, there will be subcompilation and this value will not necessarily equal
  to C<< $cd->{args}{schema} >>.
  
  =item * B<spath> = ARRAY
  
  An array of strings, with empty array (C<[]>) as the root. Point to current
  location in schema during compilation. Inner compilation will continue/append
  the path.
  
  Example:
  
   # spath, with pointer to location in the schema
  
   spath: ["elems"] ----
                        \
   schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]}
  
   spath: ["elems", 0] ------------
                                   \
   schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]}
  
   spath: ["elems", 1, "min"] ---------------------
                                                   \
   schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]}
  
   spath: ["elems", 2, "div_by", 1] -------------------------------------------------
                                                                                     \
   schema: ["array", {elems => ["float", [int => {min=>3}], [int => "div_by&" => [2, 3]]]}
  
  Note: aside from C<spath>, there is also the analogous C<dpath> which points to
  the location of I<data> (e.g. array element, hash key). But this is declared and
  maintained by the generated code, not by the compiler.
  
  =item * B<th> => OBJ
  
  Current type handler.
  
  =item * B<type> => STR
  
  Current type name.
  
  =item * B<clsets> => ARRAY
  
  All the clause sets. Each schema might have more than one clause set, due to
  processing base type's clause set.
  
  =item * B<clset> => HASH
  
  Current clause set being processed. Note that clauses are evaluated not strictly
  in clset order, but instead based on expression dependencies and priority.
  
  =item * B<clset_dlang> => HASH
  
  Default language of the current clause set. This value is taken from C<<
  $cd->{clset}{default_lang} >> or C<< $cd->{outer_cd}{default_lang} >> or the
  default C<en_US>.
  
  =item * B<clset_num> => INT
  
  Set to 0 for the first clause set, 1 for the second, and so on. Due to merging,
  we might process more than one clause set during compilation.
  
  =item * B<uclset> => HASH
  
  Short for "unprocessed clause set", a shallow copy of C<clset>, keys will be
  removed from here as they are processed by clause handlers, remaining keys after
  processing the clause set means they are not recognized by hooks and thus
  constitutes an error.
  
  =item * B<uclsets> => ARRAY
  
  All the C<uclset> for each clause set.
  
  =item * B<clause> => STR
  
  Current clause name.
  
  =item * B<cl_meta> => HASH
  
  Metadata information about the clause, from the clause definition. This include
  C<prio> (priority), C<attrs> (list of attributes specific for this clause),
  C<allow_expr> (whether clause allows expression in its value), etc. See
  C<Data::Sah::Type::$TYPENAME> for more information.
  
  =item * B<cl_value> => ANY
  
  Clause value. Note: for putting in generated code, use C<cl_term>.
  
  =item * B<cl_term> => STR
  
  Clause value term. If clause value is a literal (C<.is_expr> is false) then it
  is produced by passing clause value to C<literal()>. Otherwise, it is produced
  by passing clause value to C<expr()>.
  
  =item * B<cl_is_expr> => BOOL
  
  A copy of C<< $cd->{clset}{"${clause}.is_expr"} >>, for convenience.
  
  =item * B<cl_op> => STR
  
  A copy of C<< $cd->{clset}{"${clause}.op"} >>, for convenience.
  
  =item * B<cl_is_multi> => BOOL
  
  Set to true if cl_value contains multiple clause values. This will happen if
  C<.op> is either C<and>, C<or>, or C<none> and C<< $cd->{CLAUSE_DO_MULTI} >> is
  set to true.
  
  =item * B<indent_level> => INT
  
  Current level of indent when printing result using C<< $c->line() >>. 0 means
  unindented.
  
  =item * B<all_expr_vars> => ARRAY
  
  All variables in all expressions in the current schema (and all of its
  subschemas). Used internally by compiler. For example (XXX syntax not not
  finalized):
  
   # schema
   [array => {of=>'str1', min_len=>1, 'max_len=' => '$min_len*3'},
    {def => {
        str1 => [str => {min_len=>6, 'max_len=' => '$min_len*2',
                         check=>'substr($_,0,1) eq "a"'}],
    }}]
  
   all_expr_vars => ['schema:///clsets/0/min_len', # or perhaps .../min_len/value
                     'schema://str1/clsets/0/min_len']
  
  This data can be used to order the compilation of clauses based on dependencies.
  In the above example, C<min_len> needs to be evaluated before C<max_len>
  (especially if C<min_len> is an expression).
  
  =back
  
  Keys which contain compilation result:
  
  =over 4
  
  =item * B<ccls> => [HASH, ...]
  
  Compiled clauses, collected during processing of schema's clauses. Each element
  will contain the compiled code in the target language, error message, and other
  information. At the end of processing, these will be joined together.
  
  =item * B<result>
  
  The final result. For most compilers, it will be string/text.
  
  =back
  
  =head3 Return value
  
  The compilation data will be returned as return value. Main result will be in
  the C<result> key. There is also C<ccls>, and subclasses may put additional
  results in other keys. Final usable result might need to be pieced together from
  these results, depending on your needs.
  
  =head3 Hooks
  
  By default this base compiler does not define any hooks; subclasses can define
  hooks to implement their compilation process. Each hook will be passed
  compilation data, and should modify or set the compilation data as needed. The
  hooks that compile() will call at various points, in calling order, are:
  
  =over 4
  
  =item * $c->before_compile($cd)
  
  Called once at the beginning of compilation.
  
  =item * $c->before_handle_type($cd)
  
  =item * $th->handle_type($cd)
  
  =item * $c->before_all_clauses($cd)
  
  Called before calling handler for any clauses.
  
  =item * $th->before_all_clauses($cd)
  
  Called before calling handler for any clauses, after compiler's
  before_all_clauses().
  
  =item * $c->before_clause($cd)
  
  Called for each clause, before calling the actual clause handler
  ($th->clause_NAME() or $th->clause).
  
  =item * $th->before_clause($cd)
  
  After compiler's before_clause() is called, I<type handler>'s before_clause()
  will also be called if available.
  
  Input and output interpretation is the same as compiler's before_clause().
  
  =item * $th->before_clause_NAME($cd)
  
  Can be used to customize clause.
  
  Introduced in v0.10.
  
  =item * $th->clause_NAME($cd)
  
  Clause handler. Will be called only once (if C<$cd->{CLAUSE_DO_MULTI}> is set to
  by other hooks before this) or once for each value in a multi-value clause (e.g.
  when C<.op> attribute is set to C<and> or C<or>). For example, in this schema:
  
   [int => {"div_by&" => [2, 3, 5]}]
  
  C<clause_div_by()> can be called only once with C<< $cd->{cl_value} >> set to
  [2, 3, 5] or three times, each with C<< $cd->{value} >> set to 2, 3, and 5
  respectively.
  
  =item * $th->after_clause_NAME($cd)
  
  Can be used to customize clause.
  
  Introduced in v0.10.
  
  =item * $th->after_clause($cd)
  
  Called for each clause, after calling the actual clause handler
  ($th->clause_NAME()).
  
  =item * $c->after_clause($cd)
  
  Called for each clause, after calling the actual clause handler
  ($th->clause_NAME()).
  
  Output interpretation is the same as $th->after_clause().
  
  =item * $th->after_all_clauses($cd)
  
  Called after all clauses have been compiled, before compiler's
  after_all_clauses().
  
  =item * $c->after_all_clauses($cd)
  
  Called after all clauses have been compiled.
  
  =item * $c->after_compile($cd)
  
  Called at the very end before compiling process end.
  
  =back
  
  =head2 $c->get_th
  
  =head2 $c->get_fsh
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER

$fatpacked{"Data/Sah/Compiler/Prog.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PROG';
  package Data::Sah::Compiler::Prog;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Log::Any::IfLOG qw($log);
  
  use Mo qw(build default);
  extends 'Data::Sah::Compiler';
  
  #use Digest::MD5 qw(md5_hex);
  
  # human compiler, to produce error messages
  has hc => (is => 'rw');
  
  # subclass should provide a default, choices: 'shell', 'c', 'ini', 'cpp'
  has comment_style => (is => 'rw');
  
  has var_sigil => (is => 'rw');
  
  has concat_op => (is => 'rw');
  
  has logical_and_op => (is => 'rw', default => sub {'&&'});
  
  has logical_not_op => (is => 'rw', default => sub {'!'});
  
  #has logical_or_op => (is => 'rw', default => sub {'||'});
  
  sub init_cd {
      my ($self, %args) = @_;
  
      my $cd = $self->SUPER::init_cd(%args);
      $cd->{vars} = {};
  
      my $hc = $self->hc;
      if (!$hc) {
          $hc = $self->main->get_compiler("human");
          $self->hc($hc);
      }
  
      if (my $ocd = $cd->{outer_cd}) {
          $cd->{vars}    = $ocd->{vars};
          $cd->{modules} = $ocd->{modules};
          $cd->{_hc}     = $ocd->{_hc};
          $cd->{_hcd}    = $ocd->{_hcd};
          $cd->{_subdata_level} = $ocd->{_subdata_level};
      } else {
          $cd->{vars}    = {};
          $cd->{modules} = [];
          $cd->{_hc}     = $hc;
          $cd->{_subdata_level} = 0;
      }
  
      $cd;
  }
  
  sub check_compile_args {
      my ($self, $args) = @_;
  
      return if $args->{_args_checked_Prog}++;
  
      $self->SUPER::check_compile_args($args);
  
      my $ct = ($args->{code_type} //= 'validator');
      if ($ct ne 'validator') {
          $self->_die({}, "code_type currently can only be 'validator'");
      }
      my $rt = ($args->{return_type} //= 'bool');
      if ($rt !~ /\A(bool|str|full)\z/) {
          $self->_die({}, "Invalid value for return_type, ".
                          "use bool|str|full");
      }
      $args->{var_prefix} //= "_sahv_";
      $args->{sub_prefix} //= "_sahs_";
      $args->{data_term}  //= $self->var_sigil . $args->{data_name};
      $args->{data_term_is_lvalue} //= 1;
      $args->{tmp_data_name} //= "tmp_$args->{data_name}";
      $args->{tmp_data_term} //= $self->var_sigil . $args->{tmp_data_name};
      $args->{comment}    //= 1;
      $args->{err_term}   //= $self->var_sigil . "err_$args->{data_name}";
  }
  
  sub comment {
      my ($self, $cd, @args) = @_;
      return '' unless $cd->{args}{comment};
  
      my $content = join("", @args);
      $content =~ s/\n+/ /g;
  
      my $style = $self->comment_style;
      if ($style eq 'shell') {
          return join("", "# ", $content, "\n");
      } elsif ($style eq 'shell2') {
          return join("", "## ", $content, "\n");
      } elsif ($style eq 'cpp') {
          return join("", "// ", $content, "\n");
      } elsif ($style eq 'c') {
          return join("", "/* ", $content, '*/');
      } elsif ($style eq 'ini') {
          return join("", "; ", $content, "\n");
      } else {
          $self->_die($cd, "BUG: Unknown comment style: $style");
      }
  }
  
  # enclose expression with parentheses, unless it already is
  sub enclose_paren {
      my ($self, $expr, $force) = @_;
      if ($expr =~ /\A(\s*)(\(.+\)\s*)\z/os) {
          return $expr if !$force;
          return "$1($2)";
      } else {
          $expr =~ /\A(\s*)(.*)/os;
          return "$1($2)";
      }
  }
  
  sub add_module {
      use experimental 'smartmatch';
  
      my ($self, $cd, $name) = @_;
  
      return 0 if $name ~~ @{ $cd->{modules} };
      push @{ $cd->{modules} }, $name;
      1;
  }
  
  sub add_var {
      my ($self, $cd, $name, $value) = @_;
  
      return if exists $cd->{vars}{$name};
      #$log->tracef("TMP: add_var %s", $name);
      $cd->{vars}{$name} = $value;
  }
  
  # naming convention: expr_NOUN(), stmt_VERB(_NOUN)?()
  
  sub expr_assign {
      my ($self, $v, $t) = @_;
      "$v = $t";
  }
  
  sub _xlt {
      my ($self, $cd, $text) = @_;
  
      my $hc  = $cd->{_hc};
      my $hcd = $cd->{_hcd};
      #$log->tracef("(Prog) Translating text %s ...", $text);
      $hc->_xlt($hcd, $text);
  }
  
  sub expr_concat {
      my ($self, @t) = @_;
      join(" " . $self->concat_op . " ", @t);
  }
  
  sub expr_var {
      my ($self, $v) = @_;
      $self->var_sigil. $v;
  }
  
  sub expr_preinc {
      my ($self, $t) = @_;
      "++$t";
  }
  
  sub expr_preinc_var {
      my ($self, $v) = @_;
      "++" . $self->var_sigil. $v;
  }
  
  # expr_postinc
  # expr_predec
  # expr_postdec
  
  # args: log_result, var_term, err_term. the rest is the same/supplied to
  # compile().
  sub expr_validator_sub {
      my ($self, %args) = @_;
  
      my $log_result = delete $args{log_result};
      my $dt         = $args{data_term};
      my $vt         = delete($args{var_term}) // $dt;
      my $do_log     = $args{debug_log} // $args{debug};
      my $rt         = $args{return_type} // 'bool';
  
      $args{indent_level} = 1;
  
      my $cd = $self->compile(%args);
      my $et = $cd->{args}{err_term};
  
      if ($rt ne 'bool') {
          my ($ev) = $et =~ /(\w+)/; # to remove sigil
          $self->add_var($cd, $ev, $rt eq 'str' ? undef : {});
      }
      my $resv = '_sahv_res';
      my $rest = $self->var_sigil . $resv;
  
      my $needs_expr_block = @{ $cd->{modules} } || $do_log;
  
      my $code = join(
          "",
          ($self->stmt_require_log_module."\n") x !!$do_log,
          (map { $self->stmt_require_module($_, $cd)."\n" } @{ $cd->{modules} }),
          $self->expr_anon_sub(
              [$vt],
              join(
                  "",
                  (map {$self->stmt_declare_local_var(
                      $_, $self->literal($cd->{vars}{$_}))."\n"}
                       sort keys %{ $cd->{vars} }),
                  #$log->tracef('-> (validator)(%s) ...', $dt);\n";
                  $self->stmt_declare_local_var($resv, "\n\n" . $cd->{result})."\n\n",
  
                  # when rt=bool, return true/false result
                  #(";\n\n\$log->tracef('<- validator() = %s', \$res)")
                  #    x !!($do_log && $rt eq 'bool'),
                  ($self->stmt_return($rest)."\n")
                      x !!($rt eq 'bool'),
  
                  # when rt=str, return string error message
                  #($log->tracef('<- validator() = %s', ".
                  #     "\$err_data);\n\n";
                  #    x !!($do_log && $rt eq 'str'),
                  ($self->expr_set_err_str($et, $self->literal('')).";",
                   "\n\n".$self->stmt_return($et)."\n")
                      x !!($rt eq 'str'),
  
                  # when rt=full, return error hash
                  ($self->stmt_return($et)."\n")
                      x !!($rt eq 'full'),
              )
          ),
      );
  
      if ($needs_expr_block) {
          $code = $self->expr_block($code);
      }
  
      if ($log_result && $log->is_trace) {
          require String::LineNumber;
          $log->tracef("validator code:\n%s",
                       ($ENV{LINENUM} // 1) ?
                           String::LineNumber::linenum($code) :
                                 $code);
      }
  
      $code;
  }
  
  # add compiled clause to ccls, along with extra information useful for joining
  # later (like error level, code for adding error message, etc). available
  # options:
  #
  # - err_level (str, the default will be taken from current clause's .err_level
  # if not specified),
  #
  # - err_expr (str, a string expression in the target language that evaluates to
  # an error message, the more general and dynamic alternative to err_msg.
  #
  # - err_msg (str, the default will be produced by human compiler if not
  # supplied, or taken from current clause's .err_msg),
  #
  # - subdata (bool, default false, if set to true then this means we are
  # delving into subdata, e.g. array elements or hash pair values, and appropriate
  # things must be done to adjust for this [e.g. push_dpath/pop_dpath at the end
  # so that error message can show the proper data path].
  #
  # - assert (bool, default false, if set to true means this ccl is an assert ccl,
  # meaning it always returns true and is not translated from an actual clause. it
  # will not affect number of errors nor produce error messages.)
  sub add_ccl {
      my ($self, $cd, $ccl, $opts) = @_;
      $opts //= {};
      my $clause = $cd->{clause} // "";
      my $op     = $cd->{cl_op} // "";
      #$log->errorf("TMP: adding ccl %s, current ccls=%s", $ccl, $cd->{ccls});
  
      my $use_dpath = $cd->{args}{return_type} ne 'bool';
  
      my $el = $opts->{err_level} // $cd->{clset}{"$clause.err_level"} // "error";
      my $err_expr = $opts->{err_expr};
      my $err_msg  = $opts->{err_msg};
  
      if (defined $err_expr) {
          $self->add_var($cd, '_sahv_dpath', []) if $use_dpath;
          $err_expr = $self->expr_prefix_dpath($err_expr) if $use_dpath;
      } else {
          unless (defined $err_msg) { $err_msg = $cd->{clset}{"$clause.err_msg"} }
          unless (defined $err_msg) {
              # XXX how to invert on op='none' or op='not'?
  
              my @msgpath = @{$cd->{spath}};
              my $msgpath;
              my $hc  = $cd->{_hc};
              my $hcd = $cd->{_hcd};
              while (1) {
                  # search error message, use more general one if the more
                  # specific one is not available
                  last unless @msgpath;
                  $msgpath = join("/", @msgpath);
                  my $ccls = $hcd->{result}{$msgpath};
                  pop @msgpath;
                  if ($ccls) {
                      local $hcd->{args}{format} = 'inline_err_text';
                      $err_msg = $hc->format_ccls($hcd, $ccls);
                      # show path when debugging
                      $err_msg = "(msgpath=$msgpath) $err_msg"
                          if $cd->{args}{debug};
                      last;
                  }
              }
              if (!$err_msg) {
                  $err_msg = "ERR (clause=".($cd->{clause} // "").")";
              } else {
                  $err_msg = ucfirst($err_msg);
              }
          }
          if ($err_msg) {
              $self->add_var($cd, '_sahv_dpath', []) if $use_dpath;
              $err_expr = $self->literal($err_msg);
              $err_expr = $self->expr_prefix_dpath($err_expr) if $use_dpath;
          }
      }
  
      my $rt = $cd->{args}{return_type};
      my $et = $cd->{args}{err_term};
      my $err_code;
      if ($rt eq 'full') {
          $self->add_var($cd, '_sahv_dpath', []) if $use_dpath;
          my $k = $el eq 'warn' ? 'warnings' : 'errors';
          $err_code = $self->expr_set_err_full($et, $k, $err_expr) if $err_expr;
      } elsif ($rt eq 'str') {
          if ($el ne 'warn') {
              $err_code = $self->expr_set_err_str($et, $err_expr) if $err_expr;
          }
      }
  
      my $res = {
          ccl             => $ccl,
          err_level       => $el,
          err_code        => $err_code,
          (_debug_ccl_note => $cd->{_debug_ccl_note}) x !!$cd->{_debug_ccl_note},
          subdata         => $opts->{subdata},
      };
      push @{ $cd->{ccls} }, $res;
      delete $cd->{uclset}{"$clause.err_level"};
      delete $cd->{uclset}{"$clause.err_msg"};
  }
  
  # join ccls to handle .op and insert error messages. opts = op
  sub join_ccls {
      my ($self, $cd, $ccls, $opts) = @_;
      $opts //= {};
      my $op = $opts->{op} // "and";
      #$log->errorf("TMP: joining ccl %s", $ccls);
      #warn "join_ccls"; #TMP
  
      my ($min_ok, $max_ok, $min_nok, $max_nok);
      if ($op eq 'and') {
          $max_nok = 0;
      } elsif ($op eq 'or') {
          $min_ok = 1;
      } elsif ($op eq 'none') {
          $max_ok = 0;
      } elsif ($op eq 'not') {
  
      }
      my $dmin_ok  = defined($min_ok);
      my $dmax_ok  = defined($max_ok);
      my $dmin_nok = defined($min_nok);
      my $dmax_nok = defined($max_nok);
  
      return "" unless @$ccls;
  
      my $rt      = $cd->{args}{return_type};
      my $vp      = $cd->{args}{var_prefix};
  
      my $aop = $self->logical_and_op;
      my $nop = $self->logical_not_op;
  
      my $true = $self->true;
  
      # insert comment, error message, and $ok/$nok counting. $which is 0 by
      # default (normal), or 1 (reverse logic, for 'not' or 'none'), or 2 (for
      # $ok/$nok counting), or 3 (like 2, but for the last clause).
      my $_ice = sub {
          my ($ccl, $which) = @_;
  
          return $self->enclose_paren($ccl->{ccl}) if $ccl->{assert};
  
          my $res = "";
  
          if ($ccl->{_debug_ccl_note}) {
              if ($cd->{args}{debug_log} // $cd->{args}{debug}) {
                  $res .= $self->expr_log(
                      $cd, $self->literal($ccl->{_debug_ccl_note})) . " $aop\n";
              } else {
                  $res .= $self->comment($cd, $ccl->{_debug_ccl_note});
              }
          }
  
          $which //= 0;
          # clause code
          my $cc = ($which == 1 ? $nop:"") . $self->enclose_paren($ccl->{ccl});
          my ($ec, $oec);
          my ($ret, $oret);
          if ($which >= 2) {
              my @chk;
              if ($ccl->{err_level} eq 'warn') {
                  $oret = 1;
                  $ret  = 1;
              } elsif ($ccl->{err_level} eq 'fatal') {
                  $oret = 1;
                  $ret  = 0;
              } else {
                  $oret = $self->expr_preinc_var("${vp}ok");
                  $ret  = $self->expr_preinc_var("${vp}nok");
                  push @chk, $self->expr_var("${vp}ok"). " <= $max_ok"
                      if $dmax_ok;
                  push @chk, $self->expr_var("${vp}nok")." <= $max_nok"
                      if $dmax_nok;
                  if ($which == 3) {
                      push @chk, $self->expr_var("${vp}ok"). " >= $min_ok"
                          if $dmin_ok;
                      push @chk, $self->expr_var("${vp}nok")." >= $min_nok"
                          if $dmin_nok;
  
                      # we need to clear the error message previously set
                      if ($rt ne 'bool') {
                          my $et = $cd->{args}{err_term};
                          my $clerrc;
                          if ($rt eq 'full') {
                              $clerrc = $self->expr_reset_err_full($et);
                          } else {
                              $clerrc = $self->expr_reset_err_str($et);
                          }
                          push @chk, $clerrc;
                      }
                  }
              }
              $res .= "($cc ? $oret : $ret)";
              $res .= " $aop " . join(" $aop ", @chk) if @chk;
          } else {
              $ec = $ccl->{err_code};
              $ret =
                  $ccl->{err_level} eq 'fatal' ? 0 :
                      # this must not be done because it messes up ok/nok counting
                      #$rt eq 'full' ? 1 :
                          $ccl->{err_level} eq 'warn' ? 1 : 0;
              if ($rt eq 'bool' && $ret) {
                  $res .= $true;
              } elsif ($rt eq 'bool' || !$ec) {
                  $res .= $self->enclose_paren($cc);
              } else {
                  $res .= $self->enclose_paren(
                      $self->enclose_paren($cc). " ? $true : ($ec,$ret)",
                      "force");
              }
          }
  
          # insert dpath handling
          my $use_dpath = $rt ne 'bool' && $ccl->{subdata};
          $res = $self->expr_push_and_pop_dpath_between_expr($res) if $use_dpath;
          $res;
  
      };
  
      my $j = "\n\n$aop\n\n";
      if ($op eq 'not') {
          return $_ice->($ccls->[0], 1);
      } elsif ($op eq 'and') {
          return join $j, map { $_ice->($_) } @$ccls;
      } elsif ($op eq 'none') {
          return join $j, map { $_ice->($_, 1) } @$ccls;
      } else {
          my $jccl = join $j, map {$_ice->($ccls->[$_], $_ == @$ccls-1 ? 3:2)}
              0..@$ccls-1;
          {
              local $cd->{ccls} = [];
              local $cd->{_debug_ccl_note} = "op=$op";
              $self->add_ccl(
                  $cd,
                  $self->expr_block(
                      join(
                          "",
                          $self->stmt_declare_local_var("${vp}ok" , "0"), "\n",
                          $self->stmt_declare_local_var("${vp}nok", "0"), "\n",
                          "\n",
                          $self->block_uses_sub ?
                              $self->stmt_return($jccl) : $jccl,
                      )
                  ),
              );
              $_ice->($cd->{ccls}[0]);
          }
      }
  }
  
  sub before_compile {
      my ($self, $cd) = @_;
  
      if ($cd->{args}{data_term_is_lvalue}) {
          $cd->{data_term} = $cd->{args}{data_term};
      } else {
          my $v = $cd->{args}{var_prefix} . $cd->{args}{data_name};
          push @{ $cd->{vars} }, $v; # XXX unless already there
          $cd->{data_term} = $self->var_sigil . $v;
          # XXX perl specific!
          push @{ $cd->{ccls} }, ["(local($cd->{data_term} = $cd->{args}{data_term}), 1)"];
      }
  }
  
  sub before_handle_type {
      my ($self, $cd) = @_;
  
      # do a human compilation first to collect all the error messages
  
      unless ($cd->{_inner}) {
          my $hc = $cd->{_hc};
          my %hargs = %{$cd->{args}};
          $hargs{format}               = 'msg_catalog';
          $hargs{schema_is_normalized} = 1;
          $hargs{schema}               = $cd->{nschema};
          $hargs{on_unhandled_clause}  = 'ignore';
          $hargs{on_unhandled_attr}    = 'ignore';
          $cd->{_hcd} = $hc->compile(%hargs);
      }
  }
  
  sub before_all_clauses {
      my ($self, $cd) = @_;
  
      # handle ok/default/prefilters/req/forbidden clauses
  
      my $dt     = $cd->{data_term};
      my $clsets = $cd->{clsets};
  
      # handle ok, this is very high priority because !ok=>1 should fail undef
      # too. we need to handle its .op=not here.
      for my $i (0..@$clsets-1) {
          my $clset  = $clsets->[$i];
          next unless exists $clset->{ok};
          my $op = $clset->{"ok.op"} // "";
          if ($op && $op ne 'not') {
              $self->_die($cd, "ok can only be combined with .op=not");
          }
          if ($op eq 'not') {
              local $cd->{_debug_ccl_note} = "!ok #$i";
              $self->add_ccl($cd, $self->false);
          } else {
              local $cd->{_debug_ccl_note} = "ok #$i";
              $self->add_ccl($cd, $self->true);
          }
          delete $cd->{uclsets}[$i]{"ok"};
          delete $cd->{uclsets}[$i]{"ok.is_expr"};
      }
  
      # handle default
      for my $i (0..@$clsets-1) {
          my $clset  = $clsets->[$i];
          my $def    = $clset->{default};
          my $defie  = $clset->{"default.is_expr"};
          if (defined $def) {
              local $cd->{_debug_ccl_note} = "default #$i";
              my $ct = $defie ?
                  $self->expr($def) : $self->literal($def);
              $self->add_ccl(
                  $cd,
                  "(".$self->expr_setif($dt, $ct).", ".$self->true.")",
                  {err_msg => ""},
              );
          }
          delete $cd->{uclsets}[$i]{"default"};
          delete $cd->{uclsets}[$i]{"default.is_expr"};
      }
  
      # XXX handle prefilters
  
      # handle req
      my $has_req;
      for my $i (0..@$clsets-1) {
          my $clset  = $clsets->[$i];
          my $req    = $clset->{req};
          my $reqie  = $clset->{"req.is_expr"};
          my $req_err_msg = $self->_xlt($cd, "Required but not specified");
          local $cd->{_debug_ccl_note} = "req #$i";
          if ($req && !$reqie) {
              $has_req++;
              $self->add_ccl(
                  $cd, $self->expr_defined($dt),
                  {
                      err_msg   => $req_err_msg,
                      err_level => 'fatal',
                  },
              );
          } elsif ($reqie) {
              $has_req++;
              my $ct = $self->expr($req);
              $self->add_ccl(
                  $cd, "!($ct) || ".$self->expr_defined($dt),
                  {
                      err_msg   => $req_err_msg,
                      err_level => 'fatal',
                  },
              );
          }
          delete $cd->{uclsets}[$i]{"req"};
          delete $cd->{uclsets}[$i]{"req.is_expr"};
      }
  
      # handle forbidden
      my $has_fbd;
      for my $i (0..@$clsets-1) {
          my $clset  = $clsets->[$i];
          my $fbd    = $clset->{forbidden};
          my $fbdie  = $clset->{"forbidden.is_expr"};
          my $fbd_err_msg = $self->_xlt($cd, "Forbidden but specified");
          local $cd->{_debug_ccl_note} = "forbidden #$i";
          if ($fbd && !$fbdie) {
              $has_fbd++;
              $self->add_ccl(
                  $cd, "!".$self->expr_defined($dt),
                  {
                      err_msg   => $fbd_err_msg,
                      err_level => 'fatal',
                  },
              );
          } elsif ($fbdie) {
              $has_fbd++;
              my $ct = $self->expr($fbd);
              $self->add_ccl(
                  $cd, "!($ct) || !".$self->expr_defined($dt),
                  {
                      err_msg   => $fbd_err_msg,
                      err_level => 'fatal',
                  },
              );
          }
          delete $cd->{uclsets}[$i]{"forbidden"};
          delete $cd->{uclsets}[$i]{"forbidden.is_expr"};
      }
  
      if (!$has_req && !$has_fbd) {
          $cd->{_skip_undef} = 1;
          $cd->{_ccls_idx1} = @{$cd->{ccls}};
      }
  
  
      $self->_die($cd, "BUG: type handler did not produce _ccl_check_type")
          unless defined($cd->{_ccl_check_type});
      local $cd->{_debug_ccl_note} = "check type '$cd->{type}'";
      $self->add_ccl(
          $cd, $cd->{_ccl_check_type},
          {
              err_msg   => sprintf(
                  $self->_xlt($cd, "Not of type %s"),
                  $self->_xlt(
                      $cd,
                      $cd->{_hc}->get_th(name=>$cd->{type})->name //
                          $cd->{type}
                      ),
              ),
              err_level => 'fatal',
          },
      );
  }
  
  sub before_clause {
      my ($self, $cd) = @_;
  
      $self->_die($cd, "Sorry, .op + .is_expr not yet supported ".
                      "(found in clause $cd->{clause})")
          if $cd->{cl_is_expr} && $cd->{cl_op};
  
      if ($cd->{args}{debug}) {
          state $json = do {
              require JSON;
              JSON->new->allow_nonref;
          };
          my $clset = $cd->{clset};
          my $cl    = $cd->{clause};
          my $res   = $json->encode({
              map { $_ => $clset->{$_}}
                  grep {/\A\Q$cl\E(?:\.|\z)/}
                      keys %$clset });
          $res =~ s/\n+/ /g;
          # a one-line dump of the clause, suitable for putting in generated
          # code's comment
          $cd->{_debug_ccl_note} = "clause: $res";
      } else {
          $cd->{_debug_ccl_note} = "clause: $cd->{clause}";
      }
  
      # we save ccls to save_ccls and empty ccls for each clause, to let clause
      # join and do stuffs to ccls. at after_clause(), we push the clause's result
      # as a single ccl to the original ccls.
  
      push @{ $cd->{_save_ccls} }, $cd->{ccls};
      $cd->{ccls} = [];
  }
  
  sub after_clause {
      my ($self, $cd) = @_;
  
      if ($cd->{args}{debug}) {
          delete $cd->{_debug_ccl_note};
      }
  
      my $save = pop @{ $cd->{_save_ccls} };
      if (@{ $cd->{ccls} }) {
          push @$save, {
              ccl       => $self->join_ccls($cd, $cd->{ccls}, {op=>$cd->{cl_op}}),
              err_level => $cd->{clset}{"$cd->{clause}.err_level"} // "error",
          }
      }
      $cd->{ccls} = $save;
  }
  
  sub after_clause_sets {
      my ($self, $cd) = @_;
  
      # simply join them together with &&
      $cd->{result} = $self->indent(
          $cd,
          $self->join_ccls($cd, $cd->{ccls}, {err_msg => ''}),
      );
  }
  
  sub after_all_clauses {
      my ($self, $cd) = @_;
  
      if (delete $cd->{_skip_undef}) {
          my $jccl = $self->join_ccls(
              $cd,
              [splice(@{ $cd->{ccls} }, $cd->{_ccls_idx1})],
          );
          local $cd->{_debug_ccl_note} = "skip if undef";
          $self->add_ccl(
              $cd,
              "!".$self->expr_defined($cd->{data_term})." ? ".$self->true." : \n\n".
                  $self->enclose_paren($jccl),
              {err_msg => ''},
          );
      }
  
      # simply join them together with &&
      $cd->{result} = $self->indent(
          $cd,
          $self->join_ccls($cd, $cd->{ccls}, {err_msg => ''}),
      );
  }
  
  1;
  # ABSTRACT: Base class for programming language compilers
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::Prog - Base class for programming language compilers
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::Prog (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  This class is derived from L<Data::Sah::Compiler>. It is used as base class for
  compilers which compile schemas into code (validator) in several programming
  languages, Perl (L<Data::Sah::Compiler::perl>) and JavaScript
  (L<Data::Sah::Compiler::js>) being two of them. (Other similar programming
  languages like PHP and Ruby might also be supported later on if needed).
  
  Compilers using this base class are flexible in the kind of code they produce:
  
  =over 4
  
  =item * configurable validator return type
  
  Can generate validator that returns a simple bool result, str, or full data
  structure (containing errors, warnings, and potentially other information).
  
  =item * configurable data term
  
  For flexibility in combining the validator code with other code, e.g. putting
  inside subroutine wrapper (see L<Perinci::Sub::Wrapper>) or directly embedded to
  your source code (see L<Dist::Zilla::Plugin::Rinci::Validate>).
  
  =back
  
  =for Pod::Coverage ^(after_.+|before_.+|add_module|add_var|add_ccl|join_ccls|check_compile_args|enclose_paren|init_cd|expr|expr_.+|stmt_.+)$
  
  =head1 HOW IT WORKS
  
  The compiler generates code in the following form:
  
   EXPR && EXPR2 && ...
  
  where C<EXPR> can be a single expression or multiple expressions joined by the
  list operator (which Perl and JavaScript support). Each C<EXPR> is typically
  generated out of a single schema clause. Some pseudo-example of generated
  JavaScript code:
  
   (data >= 0)  # from clause: min => 0
   &&
   (data <= 10) # from clause: max => 10
  
  Another example, a fuller translation of schema C<< [int => {min=>0, max=>10}]
  >> to Perl, returning string result (error message) instead of boolean:
  
   # from clause: req => 0
   !defined($data) ? 1 : (
  
       # type check
       ($data =~ /^[+-]?\d+$/ ? 1 : ($err //= "Data is not an integer", 0))
  
       &&
  
       # from clause: min => 0
       ($data >=  0 ? 1 : ($err //= "Must be at least 0", 0))
  
       &&
  
       # from clause: max => 10
       ($data <= 10 ? 1 : ($err //= "Must be at most 10", 0))
  
   )
  
  The final validator code will add enclosing subroutine and variable declaration,
  loading of modules, etc.
  
  Note: Current assumptions/hard-coded things for the supported languages: ternary
  operator (C<? :>), semicolon as statement separator.
  
  =head1 ATTRIBUTES
  
  These usually need not be set/changed by users.
  
  =head2 hc => OBJ
  
  Instance of L<Data::Sah::Compiler::human>, to generate error messages.
  
  =head2 comment_style => STR
  
  Specify how comments are written in the target language. Either 'cpp' (C<//
  comment>), 'shell' (C<# comment>), 'c' (C</* comment */>), or 'ini' (C<;
  comment>). Each programming language subclass will set this, for example, the
  perl compiler sets this to 'shell' while js sets this to 'cpp'.
  
  =head2 var_sigil => STR
  
  =head2 concat_op => STR
  
  =head2 logical_and_op => STR
  
  =head2 logical_not_op => STR
  
  =head1 METHODS
  
  =head2 new() => OBJ
  
  =head2 $c->compile(%args) => RESULT
  
  Aside from base class' arguments, this class supports these arguments (suffix
  C<*> denotes required argument):
  
  =over 4
  
  =item * data_term => STR
  
  A variable name or an expression in the target language that contains the data,
  defaults to I<var_sigil> + C<name> if not specified.
  
  =item * data_term_is_lvalue => BOOL (default: 1)
  
  Whether C<data_term> can be assigned to.
  
  =item * tmp_data_name => STR
  
  Normally need not be set manually, as it will be set to "tmp_" . data_name. Used
  to store temporary data during clause evaluation.
  
  =item * tmp_data_term => STR
  
  Normally need not be set manually, as it will be set to var_sigil .
  tmp_data_name. Used to store temporary data during clause evaluation. For
  example, in JavaScript, the 'int' and 'float' type pass strings in the type
  check. But for further checking with the clauses (like 'min', 'max',
  'divisible_by') the string data needs to be converted to number first. Likewise
  with prefiltering. This variable holds the temporary value. The clauses compare
  against this value. At the end of clauses, the original data_term is restored.
  So the output validator code for schema C<< [int => min => 1] >> will look
  something like:
  
   // type check 'int'
   type(data)=='number' && Math.round(data)==data || parseInt(data)==data)
  
   &&
  
   // convert to number
   (tmp_data = type(data)=='number' ? data : parseFloat(data), true)
  
   &&
  
   // check clause 'min'
   (tmp_data >= 1)
  
  =item * err_term => STR
  
  A variable name or lvalue expression to store error message(s), defaults to
  I<var_sigil> + C<err_NAME> (e.g. C<$err_data> in the Perl compiler).
  
  =item * var_prefix => STR (default: _sahv_)
  
  Prefix for variables declared by generated code.
  
  =item * sub_prefix => STR (default: _sahs_)
  
  Prefix for subroutines declared by generated code.
  
  =item * code_type => STR (default: validator)
  
  The kind of code to generate. For now the only valid (and default) value is
  'validator'. Compiler can perhaps generate other kinds of code in the future.
  
  =item * return_type => STR (default: bool)
  
  Specify what kind of return value the generated code should produce. Either
  C<bool>, C<str>, or C<full>.
  
  C<bool> means generated validator code should just return true/false depending
  on whether validation succeeds/fails.
  
  C<str> means validation should return an error message string (the first one
  encountered) if validation fails and an empty string/undef if validation
  succeeds.
  
  C<full> means validation should return a full data structure. From this
  structure you can check whether validation succeeds, retrieve all the collected
  errors/warnings, etc.
  
  =item * debug => BOOL (default: 0)
  
  This is a general debugging option which should turn on all debugging-related
  options, e.g. produce more comments in the generated code, etc. Each compiler
  might have more specific debugging options.
  
  If turned on, specific debugging options can be explicitly turned off
  afterwards, e.g. C<< debug=>1, debug_log=>0 >> will turn on all debugging
  options but turn off the C<debug_log> setting.
  
  Currently turning on C<debug> means:
  
  =over
  
  =item - Turning on the other debug_* options, like debug_log
  
  =item - Prefixing error message with msgpath
  
  =back
  
  =item * debug_log => BOOL (default: 0)
  
  Whether to add logging to generated code. This aids in debugging generated code
  specially for more complex validation.
  
  =item * comment => BOOL (default: 1)
  
  If set to false, generated code will be devoid of comments.
  
  =back
  
  =head3 Compilation data
  
  This subclass adds the following compilation data (C<$cd>).
  
  Keys which contain compilation state:
  
  =over 4
  
  =item * B<data_term> => ARRAY
  
  Input data term. Set to C<< $cd->{args}{data_term} >> or a temporary variable
  (if C<< $cd->{args}{data_term_is_lvalue} >> is false). Hooks should use this
  instead of C<< $cd->{args}{data_term} >> directly, because aside from the
  aforementioned temporary variable, data term can also change, for example if
  C<default.temp> or C<prefilters.temp> attribute is set, where generated code
  will operate on another temporary variable to avoid modifying the original data.
  Or when C<.input> attribute is set, where generated code will operate on
  variable other than data.
  
  =back
  
  Keys which contain compilation result:
  
  =over 4
  
  =item * B<modules> => ARRAY
  
  List of module names that are required by the code, e.g. C<["Scalar::Utils",
  "List::Util"]>).
  
  =item * B<subs> => ARRAY
  
  Contains pairs of subroutine names and definition code string, e.g. C<< [
  [_sahs_zero => 'sub _sahs_zero { $_[0] == 0 }'], [_sahs_nonzero => 'sub
  _sah_s_nonzero { $_[0] != 0 }'] ] >>. For flexibility, you'll need to do this
  bit of arranging yourself to get the final usable code you can compile in your
  chosen programming language.
  
  =item * B<vars> => HASH
  
  =back
  
  =head2 $c->comment($cd, @args) => STR
  
  Generate a comment. For example, in perl compiler:
  
   $c->comment($cd, "123"); # -> "# 123\n"
  
  Will return an empty string if compile argument C<comment> is set to false.
  
  =head1 INTERNAL VARIABLES IN THE GENERATED CODE
  
  The generated code maintains the following variables. C<_sahv_> prefix stands
  for "Sah validator", it is used to minimize clash with data_term.
  
  =over
  
  =item * _sahv_dpath => ARRAY
  
  Analogous to C<spath> in compilation data, this variable stands for "data path"
  and is used to track location within data. If a clause is checking each element
  of an array (like the 'each_elem' or 'elems' array clause), this variable will
  be adjusted accordingly. Error messages thus can be more informative by pointing
  more exactly where in the data the problem lies.
  
  =item * C<tmp_data_term> => ANY
  
  As explained in the C<compile()> method, this is used to store temporary value
  when checking against clauses.
  
  =item * _sahv_stack => ARRAY
  
  This variable is used to store validation result of subdata. It is only used if
  the validator is returning a string or full structure, not a single boolean
  value. See C<Data::Sah::Compiler::js::TH::hash> for an example.
  
  =item * _sahv_x
  
  Usually used as temporary variable in short, anonymous functions.
  
  =back
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PROG

$fatpacked{"Data/Sah/Compiler/Prog/TH.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PROG_TH';
  package Data::Sah::Compiler::Prog::TH;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  
  extends 'Data::Sah::Compiler::TH';
  
  # handled in compiler's before_all_clauses()
  
  sub clause_default {}
  sub clause_ok {}
  sub clause_req {}
  sub clause_forbidden {}
  sub clause_prefilters {}
  
  # handled in compiler's after_all_clauses()
  
  #sub clause_postfilters {}
  
  sub clause_name {
      my ($self, $cd) = @_;
      $self->compiler->_ignore_clause_and_attrs($cd);
  }
  
  sub clause_summary {
      my ($self, $cd) = @_;
      $self->compiler->_ignore_clause_and_attrs($cd);
  }
  
  sub clause_description {
      my ($self, $cd) = @_;
      $self->compiler->_ignore_clause_and_attrs($cd);
  }
  
  sub clause_comment {
      my ($self, $cd) = @_;
      $self->compiler->_ignore_clause($cd);
  }
  
  sub clause_tags {
      my ($self, $cd) = @_;
      $self->compiler->_ignore_clause($cd);
  }
  
  sub clause_defhash_v {
      my ($self, $cd) = @_;
      $self->compiler->_ignore_clause($cd);
  }
  
  sub clause_v {
      my ($self, $cd) = @_;
      $self->compiler->_ignore_clause($cd);
  }
  
  # temporarily use temporary variable for referring to data (e.g. when converting
  # non-number to number for checking in clauses, or prefiltering)
  sub set_tmp_data_term {
      my ($self, $cd, $expr) = @_;
      my $c = $self->compiler;
      #$log->errorf("TMP: set_tmp_data_term");
  
      my $tdn = $cd->{args}{tmp_data_name};
      my $tdt = $cd->{args}{tmp_data_term};
      my $t = $c->expr_array_subscript($tdt, $cd->{_subdata_level});
      unless ($cd->{_save_data_term}) {
          $c->add_var($cd, $tdn, []);
          $cd->{_save_data_term} = $cd->{data_term};
          $cd->{data_term} = $t;
      }
      local $cd->{_debug_ccl_note} = 'set temporary data term';
      $c->add_ccl($cd, "(".$c->expr_assign($t, $expr). ", ".$c->true.")");
  }
  
  sub restore_data_term {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      #$log->errorf("TMP: restore_data_term");
  
      my $tdt = $cd->{args}{tmp_data_term};
      if ($cd->{_save_data_term}) {
          $cd->{data_term} = delete($cd->{_save_data_term});
          local $cd->{_debug_ccl_note} = 'restore original data term';
          $c->add_ccl($cd, "(".$c->expr_pop($tdt). ", ".$c->true.")");
      }
  }
  
  sub gen_any_or_all_of {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      my $jccl;
      {
          local $cd->{ccls} = [];
          for my $i (0..@$cv-1) {
              local $cd->{spath} = [@{ $cd->{spath} }, $i];
              my $sch  = $cv->[$i];
              my %iargs = %{$cd->{args}};
              $iargs{outer_cd}             = $cd;
              $iargs{schema}               = $sch;
              $iargs{schema_is_normalized} = 0;
              $iargs{indent_level}++;
              my $icd  = $c->compile(%iargs);
              my @code = (
                  $icd->{result},
              );
              $c->add_ccl($cd, join("", @code));
          }
          if ($which eq 'all') {
              $jccl = $c->join_ccls(
                  $cd, $cd->{ccls}, {err_msg=>''});
          } else {
              $jccl = $c->join_ccls(
                  $cd, $cd->{ccls}, {err_msg=>'', op=>'or'});
          }
      }
      $c->add_ccl($cd, $jccl);
  }
  
  1;
  # ABSTRACT: Base class for programming-language emiting compiler's type handlers
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::Prog::TH - Base class for programming-language emiting compiler's type handlers
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::Prog::TH (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(compiler|clause_.+|handle_.+|gen_.+|set_tmp_data_term|restore_data_term)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PROG_TH

$fatpacked{"Data/Sah/Compiler/Prog/TH/all.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PROG_TH_ALL';
  package Data::Sah::Compiler::Prog::TH::all;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::Prog::TH';
  with 'Data::Sah::Type::all';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = $c->true;
  }
  
  sub clause_of {
      my ($self, $cd) = @_;
      $self->gen_any_or_all_of("all", $cd);
  }
  
  1;
  # ABSTRACT: Base class for programming language compiler handler for type "all"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::Prog::TH::all - Base class for programming language compiler handler for type "all"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::Prog::TH::all (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PROG_TH_ALL

$fatpacked{"Data/Sah/Compiler/Prog/TH/any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PROG_TH_ANY';
  package Data::Sah::Compiler::Prog::TH::any;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::any';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = $c->true;
  }
  
  sub clause_of {
      my ($self, $cd) = @_;
      $self->gen_any_or_all_of("any", $cd);
  }
  
  1;
  # ABSTRACT: Base class for programming language compiler handler for type "any"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::Prog::TH::any - Base class for programming language compiler handler for type "any"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::Prog::TH::any (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PROG_TH_ANY

$fatpacked{"Data/Sah/Compiler/TH.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_TH';
  package Data::Sah::Compiler::TH;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Mo qw(build default);
  
  # reference to compiler object
  has compiler => (is => 'rw');
  
  sub clause_v {
      my ($self, $cd) = @_;
      $self->compiler->_ignore_clause($cd);
  }
  
  sub clause_default_lang {
      my ($self, $cd) = @_;
      $self->compiler->_ignore_clause($cd);
  }
  
  sub clause_clause {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      my ($clause, $clv) = @$cv;
      my $meth   = "clause_$clause";
      my $mmeth  = "clausemeta_$clause";
  
      # provide an illusion of a clsets
      my $clsets = [{$clause => $clv}];
      local $cd->{clsets} = $clsets;
  
      $c->_process_clause($cd, 0, $clause);
  }
  
  # clause_clset, like clause_clause, also works by doing what compile() does.
  
  sub clause_clset {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      # provide an illusion of a clsets
      local $cd->{clsets} = [$cv];
      $c->_process_clsets($cd, 'from clause_clset');
  }
  
  1;
  # ABSTRACT: Base class for type handlers
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::TH - Base class for type handlers
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::TH (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(compiler|clause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_TH

$fatpacked{"Data/Sah/Compiler/TextResultRole.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_TEXTRESULTROLE';
  package Data::Sah::Compiler::TextResultRole;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use Mo qw(default);
  use Role::Tiny;
  
  use String::Indent ();
  
  # can be changed to tab, for example
  has indent_character => (is => 'rw', default => sub {''});
  
  sub add_result {
      my ($self, $cd, @args) = @_;
  
      $cd->{result} //= [];
      push @{ $cd->{result} }, $self->indent($cd, join("", @args));
      $self;
  }
  
  sub indent {
      my ($self, $cd, $str) = @_;
      String::Indent::indent(
          $self->indent_character x $cd->{indent_level},
          $str,
      );
  }
  
  sub inc_indent {
      my ($self, $cd) = @_;
      $cd->{indent_level}++;
  }
  
  sub dec_indent {
      my ($self, $cd) = @_;
      $cd->{indent_level}--;
  }
  
  sub indent_str {
      my ($self, $cd) = @_;
      $self->indent_character x $cd->{indent_level};
  }
  
  1;
  # ABSTRACT: Role for compilers that produce text result (array of lines)
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::TextResultRole - Role for compilers that produce text result (array of lines)
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::TextResultRole (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 ATTRIBUTES
  
  =head2 indent_character => STR
  
  =head1 METHODS
  
  =head2 $c->add_result($cd, @arg)
  
  Append result to C<< $cd->{result} >>. Will use C<< $cd->{indent_level} >> to
  indent the line. Used by compiler; users normally do not need this.
  
  =head2 $c->inc_indent($cd)
  
  Increase indent level. This is done by increasing C<< $cd->{indent_level} >> by
  1.
  
  =head2 $c->dec_indent($cd)
  
  Decrease indent level. This is done by decreasing C<< $cd->{indent_level} >> by
  1.
  
  =head2 $c->indent_str($cd)
  
  Shortcut for C<< $c->indent_character x $cd->{indent_level} >>.
  
  =head2 $c->indent($cd, $str) => STR
  
  Indent each line in $str with indent_str and return the result.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_TEXTRESULTROLE

$fatpacked{"Data/Sah/Compiler/human.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN';
  package Data::Sah::Compiler::human;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any::IfLOG qw($log);
  
  use Data::Dmp qw(dmp);
  use Mo qw(build default);
  use POSIX qw(locale_h);
  use Text::sprintfn;
  
  extends 'Data::Sah::Compiler';
  
  # every type extension is registered here
  our %typex; # key = type, val = [clause, ...]
  
  sub name { "human" }
  
  sub _add_msg_catalog {
      my ($self, $cd, $msg) = @_;
      return unless $cd->{args}{format} eq 'msg_catalog';
  
      my $spath = join("/", @{ $cd->{spath} });
      $cd->{_msg_catalog}{$spath} = $msg;
  }
  
  sub check_compile_args {
      use experimental 'smartmatch';
  
      my ($self, $args) = @_;
  
      $self->SUPER::check_compile_args($args);
  
      my @fmts = ('inline_text', 'inline_err_text', 'markdown', 'msg_catalog');
      $args->{format} //= $fmts[0];
      unless ($args->{format} ~~ @fmts) {
          $self->_die({}, "Unsupported format, use one of: ".join(", ", @fmts));
      }
  }
  
  sub init_cd {
      my ($self, %args) = @_;
  
      my $cd = $self->SUPER::init_cd(%args);
      if ($cd->{args}{format} eq 'msg_catalog') {
          $cd->{_msg_catalog} //= $cd->{outer_cd}{_msg_catalog};
          $cd->{_msg_catalog} //= {};
      }
      $cd;
  }
  
  sub expr {
      my ($self, $cd, $expr) = @_;
  
      # for now we dump expression as is. we should probably parse it first to
      # localize number, e.g. "1.1 + 2" should become "1,1 + 2" in id_ID.
  
      # XXX for nicer output, perhaps say "the expression X" instead of just "X",
      # especially if X has a variable or rather complex.
      $expr;
  }
  
  sub literal {
      my ($self, $val) = @_;
  
      return $val unless ref($val);
      dmp($val);
  }
  
  # translate
  sub _xlt {
      my ($self, $cd, $text) = @_;
  
      my $lang = $cd->{args}{lang};
  
      #$log->tracef("translating text '%s' to '%s'", $text, $lang);
  
      return $text if $lang eq 'en_US';
      my $translations;
      {
          no strict 'refs';
          $translations = \%{"Data::Sah::Lang::$lang\::translations"};
      }
      return $translations->{$text} if defined($translations->{$text});
      if ($cd->{args}{mark_missing_translation}) {
          return "(no $lang text:$text)";
      } else {
          return $text;
      }
  }
  
  # ($cd, 3, "element") -> "3rd element"
  sub _ordinate {
      my ($self, $cd, $n, $noun) = @_;
  
      my $lang = $cd->{args}{lang};
  
      # we assume _xlt() has been called (and thus the appropriate
      # Data::Sah::Lang::* has been loaded)
  
      if ($lang eq 'en_US') {
          require Lingua::EN::Numbers::Ordinate;
          return Lingua::EN::Numbers::Ordinate::ordinate($n) . " $noun";
      } else {
          no strict 'refs';
          return "Data::Sah::Lang::$lang\::ordinate"->($n, $noun);
      }
  }
  
  # add a compiled clause (ccl), which will be combined at the end of compilation
  # to be the final result. args is a hashref with these keys:
  #
  # * type* - str (default 'clause'). either 'noun', 'clause', 'list' (bulleted
  #   list, a clause followed by a list of items, each of them is also a ccl)
  #
  # * fmt* - str/2-element array. human text which can be used as the first
  #   argument to sprintf. string. if type=noun, can be a two-element arrayref to
  #   contain singular and plural version of noun.
  #
  # * expr - bool. fmt can handle .is_expr=1. for example, 'len=' => '1+1' can be
  #   compiled into 'length must be 1+1'. other clauses cannot handle expression,
  #   e.g. 'between=' => '[2, 2*2]'. this clause will be using the generic message
  #   'between must [2, 2*2]'
  #
  # * vals - arrayref (default [clause value]). values to fill fmt with.
  #
  # * items - arrayref. required if type=list. a single ccl or a list of ccls.
  #
  # * xlt - bool (default 1). set to 0 if fmt has been translated, and should not
  #   be translated again.
  #
  # add_ccl() is called by clause handlers and handles using .human, translating
  # fmt, sprintf(fmt, vals) into 'text', .err_level (adding 'must be %s', 'should
  # not be %s'), .is_expr, .op.
  sub add_ccl {
      use experimental 'smartmatch';
  
      my ($self, $cd, $ccl) = @_;
      #$log->errorf("TMP: add_ccl %s", $ccl);
  
      $ccl->{xlt} //= 1;
  
      my $clause = $cd->{clause} // "";
      $ccl->{type} //= "clause";
  
      my $do_xlt = 1;
  
      my $hvals = {
          modal_verb     => $self->_xlt($cd, "must"),,
          modal_verb_neg => $self->_xlt($cd, "must not"),
      };
      my $mod="";
  
      # is .human for desired language specified? if yes, use that instead
  
      {
          my $lang   = $cd->{args}{lang};
          my $dlang  = $cd->{clset_dlang} // "en_US"; # undef if not in clause
          my $suffix = $lang eq $dlang ? "" : ".alt.lang.$lang";
          if ($clause) {
              delete $cd->{uclset}{$_} for
                  grep /\A\Q$clause.human\E(\.|\z)/, keys %{$cd->{uclset}};
              if (defined $cd->{clset}{"$clause.human$suffix"}) {
                  $ccl->{type} = 'clause';
                  $ccl->{fmt}  = $cd->{clset}{"$clause.human$suffix"};
                  goto FILL_FORMAT;
              }
          } else {
              delete $cd->{uclset}{$_} for
                  grep /\A\.name(\.|\z)/, keys %{$cd->{uclset}};
              if (defined $cd->{clset}{".name$suffix"}) {
                  $ccl->{type} = 'noun';
                  $ccl->{fmt}  = $cd->{clset}{".name$suffix"};
                  $ccl->{vals} = undef;
                  goto FILL_FORMAT;
              }
          }
      }
  
      goto TRANSLATE unless $clause;
  
      my $ie   = $cd->{cl_is_expr};
      my $im   = $cd->{cl_is_multi};
      my $op   = $cd->{cl_op} // "";
      my $cv   = $cd->{clset}{$clause};
      my $vals = $ccl->{vals} // [$cv];
  
      # handle .is_expr
  
      if ($ie) {
          if (!$ccl->{expr}) {
              $ccl->{fmt} = "($clause -> %s" . ($op ? " op=$op" : "") . ")";
              $do_xlt = 0;
              $vals = [$self->expr($cd, $vals)];
          }
          goto ERR_LEVEL;
      }
  
      # handle .op
  
      if ($op eq 'not') {
          ($hvals->{modal_verb}, $hvals->{modal_verb_neg}) =
              ($hvals->{modal_verb_neg}, $hvals->{modal_verb});
      } elsif ($im && $op eq 'and') {
          if (@$cv == 2) {
              $vals = [sprintf($self->_xlt($cd, "%s and %s"),
                               $self->literal($cv->[0]),
                               $self->literal($cv->[1]))];
          } else {
              $vals = [sprintf($self->_xlt($cd, "all of %s"),
                               $self->literal($cv))];
          }
      } elsif ($im && $op eq 'or') {
          if (@$cv == 2) {
              $vals = [sprintf($self->_xlt($cd, "%s or %s"),
                               $self->literal($cv->[0]),
                               $self->literal($cv->[1]))];
          } else {
              $vals = [sprintf($self->_xlt($cd, "one of %s"),
                               $self->literal($cv))];
          }
      } elsif ($im && $op eq 'none') {
          ($hvals->{modal_verb}, $hvals->{modal_verbneg}) =
              ($hvals->{modal_verb_neg}, $hvals->{modal_verb});
          if (@$cv == 2) {
              $vals = [sprintf($self->_xlt($cd, "%s nor %s"),
                               $self->literal($cv->[0]),
                               $self->literal($cv->[1]))];
          } else {
              $vals = [sprintf($self->_xlt($cd, "any of %s"),
                               $self->literal($cv))];
          }
      } else {
          $vals = [map {$self->literal($_)} @$vals];
      }
  
    ERR_LEVEL:
  
      # handle .err_level
      if ($ccl->{type} eq 'clause' && 'constraint' ~~ $cd->{cl_meta}{tags}) {
          if (($cd->{clset}{"$clause.err_level"}//'error') eq 'warn') {
              if ($op eq 'not') {
                  $hvals->{modal_verb}     = $self->_xlt($cd, "should not");
                  $hvals->{modal_verb_neg} = $self->_xlt($cd, "should");
              } else {
                  $hvals->{modal_verb}     = $self->_xlt($cd, "should");
                  $hvals->{modal_verb_neg} = $self->_xlt($cd, "should not");
              }
          }
      }
      delete $cd->{uclset}{"$clause.err_level"};
  
    TRANSLATE:
  
      if ($ccl->{xlt}) {
          if (ref($ccl->{fmt}) eq 'ARRAY') {
              $ccl->{fmt}  = [map {$self->_xlt($cd, $_)} @{$ccl->{fmt}}];
          } elsif (!ref($ccl->{fmt})) {
              $ccl->{fmt}  = $self->_xlt($cd, $ccl->{fmt});
          }
      }
  
    FILL_FORMAT:
  
      if (ref($ccl->{fmt}) eq 'ARRAY') {
          $ccl->{text} = [map {sprintfn($_, (map {$_//""} ($hvals, @$vals)))}
                              @{$ccl->{fmt}}];
      } elsif (!ref($ccl->{fmt})) {
          $ccl->{text} = sprintfn($ccl->{fmt}, (map {$_//""} ($hvals, @$vals)));
      }
      delete $ccl->{fmt} unless $cd->{args}{debug};
  
      push @{$cd->{ccls}}, $ccl;
  
      $self->_add_msg_catalog($cd, $ccl);
  }
  
  # format ccls to form final result. at the end of compilation, we have a tree of
  # ccls. this method accept a single ccl (of type either noun/clause) or an array
  # of ccls (which it will join together).
  sub format_ccls {
      my ($self, $cd, $ccls) = @_;
  
      # used internally to determine if the result is a single noun, in which case
      # when format is inline_err_text, we add 'Not of type '. XXX: currently this
      # is the wrong way to count? we shouldn't count children? perhaps count from
      # msg_catalog instead?
      local $cd->{_fmt_noun_count} = 0;
      local $cd->{_fmt_etc_count} = 0;
  
      my $f = $cd->{args}{format};
      my $res;
      if ($f eq 'inline_text' || $f eq 'inline_err_text' || $f eq 'msg_catalog') {
          $res = $self->_format_ccls_itext($cd, $ccls);
          if ($f eq 'inline_err_text') {
              #$log->errorf("TMP: noun=%d, etc=%d", $cd->{_fmt_noun_count}, $cd->{_fmt_etc_count});
              if ($cd->{_fmt_noun_count} == 1 && $cd->{_fmt_etc_count} == 0) {
                  # a single noun (type name), we should add some preamble
                  $res = sprintf(
                      $self->_xlt($cd, "Not of type %s"),
                      $res
                  );
              } elsif (!$cd->{_fmt_noun_count}) {
                  # a clause (e.g. "must be >= 10"), already looks like errmsg
              } else {
                  # a noun + clauses (e.g. "integer, must be even"). add preamble
                  $res = sprintf(
                      $self->_xlt(
                          $cd, "Does not satisfy the following schema: %s"),
                      $res
                  );
              }
          }
      } else {
          $res = $self->_format_ccls_markdown($cd, $ccls);
      }
      $res;
  }
  
  sub _format_ccls_itext {
      my ($self, $cd, $ccls) = @_;
  
      local $cd->{args}{mark_missing_translation} = 0;
      my $c_comma = $self->_xlt($cd, ", ");
  
      if (ref($ccls) eq 'HASH' && $ccls->{type} =~ /^(noun|clause)$/) {
          if ($ccls->{type} eq 'noun') {
              $cd->{_fmt_noun_count}++;
          } else {
              $cd->{_fmt_etc_count}++;
          }
          # handle a single noun/clause ccl
          my $ccl = $ccls;
          return ref($ccl->{text}) eq 'ARRAY' ? $ccl->{text}[0] : $ccl->{text};
      } elsif (ref($ccls) eq 'HASH' && $ccls->{type} eq 'list') {
          # handle a single list ccl
          my $c_openpar  = $self->_xlt($cd, "(");
          my $c_closepar = $self->_xlt($cd, ")");
          my $c_colon    = $self->_xlt($cd, ": ");
          my $ccl = $ccls;
  
          my $txt = $ccl->{text}; $txt =~ s/\s+$//;
          my @t = ($txt, $c_colon);
          my $i = 0;
          for (@{ $ccl->{items} }) {
              push @t, $c_comma if $i;
              my $it = $self->_format_ccls_itext($cd, $_);
              if ($it =~ /\Q$c_comma/) {
                  push @t, $c_openpar, $it, $c_closepar;
              } else {
                  push @t, $it;
              }
              $i++;
          }
          return join("", @t);
      } elsif (ref($ccls) eq 'ARRAY') {
          # handle an array of ccls
          return join($c_comma, map {$self->_format_ccls_itext($cd, $_)} @$ccls);
      } else {
          $self->_die($cd, "Can't format $ccls");
      }
  }
  
  sub _format_ccls_markdown {
      my ($self, $cd, $ccls) = @_;
  
      $self->_die($cd, "Sorry, markdown not yet implemented");
  }
  
  sub _load_lang_modules {
      my ($self, $cd) = @_;
  
      my $lang = $cd->{args}{lang};
      die "Invalid language '$lang', please use letters only"
          unless $lang =~ /\A\w+\z/;
  
      my @modp;
      unless ($lang eq 'en_US') {
          push @modp, "Data/Sah/Lang/$lang.pm";
          for my $cl (@{ $typex{$cd->{type}} // []}) {
              my $modp = "Data/Sah/Lang/$lang/TypeX/$cd->{type}/$cl.pm";
              $modp =~ s!::!/!g; # $cd->{type} might still contain '::'
              push @modp, $modp;
          }
      }
      my $i;
      for my $modp (@modp) {
          $i++;
          unless (exists $INC{$modp}) {
              if ($i == 1) {
                  # test to check whether Data::Sah::Lang::$lang exists. if it
                  # does not, we fallback to en_US.
                  require Module::Path::More;
                  my $mod = $modp; $mod =~ s/\.pm$//;
                  if (!Module::Path::More::module_path(module=>$modp)) {
                      #$log->debug("$mod cannot be found, falling back to en_US");
                      $cd->{args}{lang} = 'en_US';
                      last;
                  }
              }
              #$log->trace("Loading $modp ...");
              require $modp;
  
              # negative-cache, so we don't have to try again
              $INC{$modp} = undef;
          }
      }
  }
  
  sub before_compile {
      my ($self, $cd) = @_;
  
      # set locale so that numbers etc are printed according to locale (e.g.
      # sprintf("%s", 1.2) prints '1,2' in id_ID).
      $cd->{_orig_locale} = setlocale(LC_ALL);
  
      # XXX do we need to set everything? LC_ADDRESS, LC_TELEPHONE, LC_PAPER, ...
      my $res = setlocale(LC_ALL, $cd->{args}{locale} // $cd->{args}{lang});
      warn "Unsupported locale $cd->{args}{lang}"
          if $cd->{args}{debug} && !defined($res);
  }
  
  sub before_handle_type {
      my ($self, $cd) = @_;
  
      $self->_load_lang_modules($cd);
  }
  
  sub before_clause {
      my ($self, $cd) = @_;
  
      # by default, human clause handler can handle multiple values (e.g.
      # "div_by&"=>[2, 3] becomes "must be divisible by 2 and 3" instead of having
      # to be ["must be divisible by 2", "must be divisible by 3"]. some clauses
      # that don't can override this value to 0.
      $cd->{CLAUSE_DO_MULTI} = 1;
  }
  
  sub after_clause {
      my ($self, $cd) = @_;
  
      # reset what we set in before_clause()
      delete $cd->{CLAUSE_DO_MULTI};
  }
  
  sub after_all_clauses {
      use experimental 'smartmatch';
  
      my ($self, $cd) = @_;
  
      # quantify NOUN (e.g. integer) into 'required integer', 'optional integer',
      # or 'forbidden integer'.
  
      # my $q;
      # if (!$cd->{clset}{'required.is_expr'} &&
      #         !('required' ~~ $cd->{args}{skip_clause})) {
      #     if ($cd->{clset}{required}) {
      #         $q = 'required %s';
      #     } else {
      #         $q = 'optional %s';
      #     }
      # } elsif ($cd->{clset}{forbidden} && !$cd->{clset}{'forbidden.is_expr'} &&
      #              !('forbidden' ~~ $cd->{args}{skip_clause})) {
      #     $q = 'forbidden %s';
      # }
      # if ($q && @{$cd->{ccls}} && $cd->{ccls}[0]{type} eq 'noun') {
      #     $q = $self->_xlt($cd, $q);
      #     for (ref($cd->{ccls}[0]{text}) eq 'ARRAY' ?
      #              @{ $cd->{ccls}[0]{text} } : $cd->{ccls}[0]{text}) {
      #         $_ = sprintf($q, $_);
      #     }
      # }
  
      $cd->{result} = $self->format_ccls($cd, $cd->{ccls});
  }
  
  sub after_compile {
      my ($self, $cd) = @_;
  
      setlocale(LC_ALL, $cd->{_orig_locale});
  
      if ($cd->{args}{format} eq 'msg_catalog') {
          $cd->{result} = $cd->{_msg_catalog};
      }
  }
  
  1;
  # ABSTRACT: Compile Sah schema to human language
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human - Compile Sah schema to human language
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  This class is derived from L<Data::Sah::Compiler>. It generates human language
  text.
  
  =for Pod::Coverage ^(name|literal|expr|add_ccl|format_ccls|check_compile_args|handle_.+|before_.+|after_.+)$
  
  =head1 ATTRIBUTES
  
  =head1 METHODS
  
  =head2 new() => OBJ
  
  =head2 $c->compile(%args) => RESULT
  
  Aside from base class' arguments, this class supports these arguments (suffix
  C<*> denotes required argument):
  
  =over 4
  
  =item * format => STR (default: C<inline_text>)
  
  Format of text to generate. Either C<inline_text>, C<inline_err_text>, or
  C<markdown>. Note that you can easily convert Markdown to HTML, there are
  libraries in Perl, JavaScript, etc to do that.
  
  Sample C<inline_text> output:
  
   integer, must satisfy all of the following: (divisible by 3, at least 10)
  
  C<inline_err_text> is just like C<inline_text>, except geared towards producing
  an error message. Currently, instead of producing "integer" from schema "int",
  it produces "Not of type integer". The rest is identical.
  
  Sample C<markdown> output:
  
   integer, must satisfy all of the following:
  
   * divisible by 3
   * at least 10
  
  =back
  
  =head3 Compilation data
  
  This subclass adds the following compilation data (C<$cd>).
  
  Keys which contain compilation state:
  
  =over 4
  
  =back
  
  Keys which contain compilation result:
  
  =over 4
  
  =back
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN

$fatpacked{"Data/Sah/Compiler/human/TH.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH';
  package Data::Sah::Compiler::human::TH;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::TH';
  
  sub name { undef }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      # give the class name
      my $pkg = ref($self);
      $pkg =~ s/^Data::Sah::Compiler::human::TH:://;
  
      $c->add_ccl($cd, {type=>'noun', fmt=>$pkg});
  }
  
  # not translated
  
  sub clause_name {}
  sub clause_summary {}
  sub clause_description {}
  sub clause_comment {}
  sub clause_tags {}
  
  sub clause_prefilters {}
  sub clause_postfilters {}
  
  # ignored
  
  sub clause_ok {}
  
  # handled in after_all_clauses
  
  sub clause_req {}
  sub clause_forbidden {}
  
  # default implementation
  
  sub clause_default {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {expr=>1,
                        fmt => 'default value %s'});
  }
  
  sub before_clause_clause {
      my ($self, $cd) = @_;
      $cd->{CLAUSE_DO_MULTI} = 0;
  }
  
  sub before_clause_clset {
      my ($self, $cd) = @_;
      $cd->{CLAUSE_DO_MULTI} = 0;
  }
  
  1;
  # ABSTRACT: Base class for human type handlers
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH - Base class for human type handlers
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|compiler|clause_.+|handle_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH

$fatpacked{"Data/Sah/Compiler/human/TH/Comparable.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_COMPARABLE';
  package Data::Sah::Compiler::human::TH::Comparable;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::Comparable';
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c = $self->compiler;
  
      my $fmt;
      if ($which eq 'is') {
          $c->add_ccl($cd, {expr=>1, multi=>1,
                            fmt => '%(modal_verb)s have the value %s'});
      } elsif ($which eq 'in') {
          $c->add_ccl($cd, {expr=>1, multi=>1,
                            fmt => '%(modal_verb)s be one of %s'});
      }
  }
  1;
  # ABSTRACT: human's type handler for role "Comparable"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::Comparable - human's type handler for role "Comparable"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::Comparable (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_COMPARABLE

$fatpacked{"Data/Sah/Compiler/human/TH/HasElems.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_HASELEMS';
  package Data::Sah::Compiler::human::TH::HasElems;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::HasElems';
  
  sub before_clause {
      my ($self_th, $which, $cd) = @_;
  }
  
  sub before_clause_len_between {
      my ($self, $cd) = @_;
      $cd->{CLAUSE_DO_MULTI} = 0;
  }
  
  sub superclause_has_elems {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
  
      if ($which eq 'len') {
          $c->add_ccl($cd, {
              expr  => 1,
              fmt   => q[length %(modal_verb)s be %s],
          });
      } elsif ($which eq 'min_len') {
          $c->add_ccl($cd, {
              expr  => 1,
              fmt   => q[length %(modal_verb)s be at least %s],
          });
      } elsif ($which eq 'max_len') {
          $c->add_ccl($cd, {
              expr  => 1,
              fmt   => q[length %(modal_verb)s be at most %s],
          });
      } elsif ($which eq 'len_between') {
          $c->add_ccl($cd, {
              fmt   => q[length %(modal_verb)s be between %s and %s],
              vals  => $cv,
          });
      } elsif ($which eq 'has') {
          $c->add_ccl($cd, {
              expr=>1, multi=>1,
              fmt => "%(modal_verb)s have %s in its elements"});
      } elsif ($which eq 'each_index') {
          $self_th->clause_each_index($cd);
      } elsif ($which eq 'each_elem') {
          $self_th->clause_each_elem($cd);
      } elsif ($which eq 'check_each_index') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'check_each_elem') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'uniq') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'exists') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      }
  }
  
  1;
  # ABSTRACT: human's type handler for role "HasElems"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::HasElems - human's type handler for role "HasElems"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::HasElems (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_HASELEMS

$fatpacked{"Data/Sah/Compiler/human/TH/Sortable.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_SORTABLE';
  package Data::Sah::Compiler::human::TH::Sortable;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::Sortable';
  
  sub before_clause_between {
      my ($self, $cd) = @_;
      $cd->{CLAUSE_DO_MULTI} = 0;
  }
  
  sub before_clause_xbetween {
      my ($self, $cd) = @_;
      $cd->{CLAUSE_DO_MULTI} = 0;
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c = $self->compiler;
      my $cv = $cd->{cl_value};
  
      if ($which eq 'min') {
          $c->add_ccl($cd, {
              expr=>1,
              fmt => '%(modal_verb)s be at least %s',
          });
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, {
              expr=>1,
              fmt => '%(modal_verb)s be larger than %s',
          });
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, {
              expr=>1,
              fmt => '%(modal_verb)s be at most %s',
          });
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, {
              expr=>1,
              fmt => '%(modal_verb)s be smaller than %s',
          });
      } elsif ($which eq 'between') {
          $c->add_ccl($cd, {
              fmt => '%(modal_verb)s be between %s and %s',
              vals => $cv,
          });
      } elsif ($which eq 'xbetween') {
          $c->add_ccl($cd, {
              fmt => '%(modal_verb)s be larger than %s and smaller than %s',
              vals => $cv,
          });
      }
  }
  
  1;
  # ABSTRACT: human's type handler for role "Sortable"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::Sortable - human's type handler for role "Sortable"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::Sortable (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_SORTABLE

$fatpacked{"Data/Sah/Compiler/human/TH/all.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_ALL';
  package Data::Sah::Compiler::human::TH::all;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Type::all';
  
  sub handle_type {
  }
  
  sub clause_of {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      my @result;
      my $i = 0;
      for my $cv2 (@$cv) {
          local $cd->{spath} = [@{$cd->{spath}}, $i];
          my %iargs = %{$cd->{args}};
          $iargs{outer_cd}             = $cd;
          $iargs{schema}               = $cv2;
          $iargs{schema_is_normalized} = 0;
          my $icd = $c->compile(%iargs);
          push @result, $icd->{ccls};
          $c->_add_msg_catalog($cd, $icd->{ccls});
          $i++;
      }
  
      # can we say 'NOUN1 as well as NOUN2 as well as NOUN3 ...'?
      my $can = 1;
      for my $r (@result) {
          unless (@$r == 1 && $r->[0]{type} eq 'noun') {
              $can = 0;
              last;
          }
      }
  
      my $vals;
      if ($can) {
          my $c0  = $c->_xlt($cd, '%(modal_verb)s be %s');
          my $awa = $c->_xlt($cd, 'as well as %s');
          my $wb  = $c->_xlt($cd, ' ');
          my $fmt;
          my $i = 0;
          for my $r (@result) {
              $fmt .= $i ? $wb . $awa : $c0;
              push @$vals, ref($r->[0]{text}) eq 'ARRAY' ?
                  $r->[0]{text}[0] : $r->[0]{text};
              $i++;
          }
          $c->add_ccl($cd, {
              fmt  => $fmt,
              vals => $vals,
              xlt  => 0,
              type => 'noun',
          });
      } else {
          $c->add_ccl($cd, {
              type  => 'list',
              fmt   => '%(modal_verb)s be all of the following',
              items => [
                  @result,
              ],
              vals  => [],
          });
      }
  }
  
  1;
  # ABSTRACT: perl's type handler for type "all"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::all - perl's type handler for type "all"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::all (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_ALL

$fatpacked{"Data/Sah/Compiler/human/TH/any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_ANY';
  package Data::Sah::Compiler::human::TH::any;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Type::any';
  
  sub handle_type {
      # does not have a noun
  }
  
  sub clause_of {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      my @result;
      my $i = 0;
      for my $cv2 (@$cv) {
          local $cd->{spath} = [@{$cd->{spath}}, $i];
          my %iargs = %{$cd->{args}};
          $iargs{outer_cd}             = $cd;
          $iargs{schema}               = $cv2;
          $iargs{schema_is_normalized} = 0;
          my $icd = $c->compile(%iargs);
          push @result, $icd->{ccls};
          $i++;
      }
  
      # can we say 'either NOUN1 or NOUN2 or NOUN3 ...'?
      my $can = 1;
      for my $r (@result) {
          unless (@$r == 1 && $r->[0]{type} eq 'noun') {
              $can = 0;
              last;
          }
      }
  
      my $vals;
      if ($can) {
          my $c0  = $c->_xlt($cd, '%(modal_verb)s be either %s');
          my $awa = $c->_xlt($cd, 'or %s');
          my $wb  = $c->_xlt($cd, ' ');
          my $fmt;
          my $i = 0;
          for my $r (@result) {
              $fmt .= $i ? $wb . $awa : $c0;
              push @$vals, ref($r->[0]{text}) eq 'ARRAY' ?
                  $r->[0]{text}[0] : $r->[0]{text};
              $i++;
          }
          $c->add_ccl($cd, {
              fmt  => $fmt,
              vals => $vals,
              xlt  => 0,
              type => 'noun',
          });
      } else {
          $c->add_ccl($cd, {
              type  => 'list',
              fmt   => '%(modal_verb)s be one of the following',
              items => [
                  @result,
              ],
              vals  => [],
          });
      }
  }
  
  1;
  # ABSTRACT: perl's type handler for type "any"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::any - perl's type handler for type "any"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::any (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_ANY

$fatpacked{"Data/Sah/Compiler/human/TH/array.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_ARRAY';
  package Data::Sah::Compiler::human::TH::array;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Compiler::human::TH::Comparable';
  with 'Data::Sah::Compiler::human::TH::HasElems';
  with 'Data::Sah::Type::array';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          fmt   => ["array", "arrays"],
          type  => 'noun',
      });
  }
  
  sub clause_each_index {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      my %iargs = %{$cd->{args}};
      $iargs{outer_cd}             = $cd;
      $iargs{schema}               = $cv;
      $iargs{schema_is_normalized} = 0;
      my $icd = $c->compile(%iargs);
  
      $c->add_ccl($cd, {
          type  => 'list',
          fmt   => 'each array subscript %(modal_verb)s be',
          items => [
              $icd->{ccls},
          ],
          vals  => [],
      });
  }
  
  sub clause_each_elem {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      my %iargs = %{$cd->{args}};
      $iargs{outer_cd}             = $cd;
      $iargs{schema}               = $cv;
      $iargs{schema_is_normalized} = 0;
      my $icd = $c->compile(%iargs);
  
      # can we say 'array of INOUNS', e.g. 'array of integers'?
      if (@{$icd->{ccls}} == 1) {
          my $c0 = $icd->{ccls}[0];
          if ($c0->{type} eq 'noun' && ref($c0->{text}) eq 'ARRAY' &&
                  @{$c0->{text}} > 1 && @{$cd->{ccls}} &&
                      $cd->{ccls}[0]{type} eq 'noun') {
              for (ref($cd->{ccls}[0]{text}) eq 'ARRAY' ?
                       @{$cd->{ccls}[0]{text}} : ($cd->{ccls}[0]{text})) {
                  my $fmt = $c->_xlt($cd, '%s of %s');
                  $_ = sprintf $fmt, $_, $c0->{text}[1];
              }
              return;
          }
      }
  
      # nope, we can't
      $c->add_ccl($cd, {
          type  => 'list',
          fmt   => 'each array element %(modal_verb)s be',
          items => [
              $icd->{ccls},
          ],
          vals  => [],
      });
  }
  
  sub clause_elems {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      for my $i (0..@$cv-1) {
          local $cd->{spath} = [@{$cd->{spath}}, $i];
          my $v = $cv->[$i];
          my %iargs = %{$cd->{args}};
          $iargs{outer_cd}             = $cd;
          $iargs{schema}               = $v;
          $iargs{schema_is_normalized} = 0;
          my $icd = $c->compile(%iargs);
          $c->add_ccl($cd, {
              type  => 'list',
              fmt   => '%s %(modal_verb)s be',
              vals  => [
                  $c->_ordinate($cd, $i+1, $c->_xlt($cd, "element")),
              ],
              items => [ $icd->{ccls} ],
          });
      }
  }
  
  1;
  # ABSTRACT: human's type handler for type "array"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::array - human's type handler for type "array"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::array (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_ARRAY

$fatpacked{"Data/Sah/Compiler/human/TH/bool.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_BOOL';
  package Data::Sah::Compiler::human::TH::bool;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Compiler::human::TH::Comparable';
  with 'Data::Sah::Compiler::human::TH::Sortable';
  with 'Data::Sah::Type::bool';
  
  sub name { "boolean value" }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          fmt   => ["boolean value", "boolean values"],
          type  => 'noun',
      });
  }
  
  sub before_clause_is_true {
      my ($self, $cd) = @_;
      $cd->{CLAUSE_DO_MULTI} = 0;
  }
  
  sub clause_is_true {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      $c->add_ccl($cd, {
          fmt   => $cv ? q[%(modal_verb)s be true] : q[%(modal_verb)s be false],
      });
  }
  
  sub clause_is_re {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      $c->add_ccl($cd, {
          fmt   => q[%(modal_verb)s be a regex pattern],
      });
  }
  
  1;
  # ABSTRACT: perl's type handler for type "bool"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::bool - perl's type handler for type "bool"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::bool (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_BOOL

$fatpacked{"Data/Sah/Compiler/human/TH/buf.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_BUF';
  package Data::Sah::Compiler::human::TH::buf;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH::str';
  
  sub name { "buffer" }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          fmt   => ["buffer", "buffers"],
          type  => 'noun',
      });
  }
  
  1;
  # ABSTRACT: perl's type handler for type "buf"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::buf - perl's type handler for type "buf"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::buf (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_BUF

$fatpacked{"Data/Sah/Compiler/human/TH/cistr.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_CISTR';
  package Data::Sah::Compiler::human::TH::cistr;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH::str';
  
  1;
  # ABSTRACT: perl's type handler for type "cistr"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::cistr - perl's type handler for type "cistr"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::cistr (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_CISTR

$fatpacked{"Data/Sah/Compiler/human/TH/code.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_CODE';
  package Data::Sah::Compiler::human::TH::code;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Type::code';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          fmt   => ["code", "codes"],
          type  => 'noun',
      });
  }
  
  1;
  # ABSTRACT: perl's type handler for type "code"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::code - perl's type handler for type "code"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::code (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_CODE

$fatpacked{"Data/Sah/Compiler/human/TH/date.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_DATE';
  package Data::Sah::Compiler::human::TH::date;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Compiler::human::TH::Comparable';
  with 'Data::Sah::Compiler::human::TH::Sortable';
  with 'Data::Sah::Type::date';
  
  sub name { "date" }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {type=>'noun', fmt => ["date", "dates"]});
  }
  
  1;
  # ABSTRACT: human's type handler for type "date"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::date - human's type handler for type "date"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::date (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_DATE

$fatpacked{"Data/Sah/Compiler/human/TH/float.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_FLOAT';
  package Data::Sah::Compiler::human::TH::float;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Compiler::human::TH::Comparable';
  with 'Data::Sah::Compiler::human::TH::Sortable';
  with 'Data::Sah::Type::float';
  
  sub name { "decimal number" }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          type=>'noun',
          fmt => ["decimal number", "decimal numbers"],
      });
  }
  
  sub clause_is_nan {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $cv = $cd->{cl_value};
      if ($cd->{cl_is_expr}) {
          $c->add_ccl($cd, {});
      } else {
          $c->add_ccl($cd, {
              fmt => $cv ?
                  q[%(modal_verb)s be a NaN] :
                      q[%(modal_verb_neg)s be a NaN],
          });
      }
  }
  
  sub clause_is_inf {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $cv = $cd->{cl_value};
      if ($cd->{cl_is_expr}) {
          $c->add_ccl($cd, {});
      } else {
          $c->add_ccl($cd, {
              fmt => $cv ?
                  q[%(modal_verb)s an infinity] :
                      q[%(modal_verb_neg)s an infinity],
          });
      }
  }
  
  sub clause_is_pos_inf {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $cv = $cd->{cl_value};
      if ($cd->{cl_is_expr}) {
          $c->add_ccl($cd, {});
      } else {
          $c->add_ccl($cd, {
              fmt => $cv ?
                  q[%(modal_verb)s a positive infinity] :
                      q[%(modal_verb_neg)s a positive infinity],
          });
      }
  }
  
  sub clause_is_neg_inf {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $cv = $cd->{cl_value};
      if ($cd->{cl_is_expr}) {
          $c->add_ccl($cd, {});
      } else {
          $c->add_ccl($cd, {
              fmt => $cv ?
                  q[%(modal_verb)s a negative infinity] :
                      q[%(modal_verb_neg)s a negative infinity],
          });
      }
  }
  
  1;
  # ABSTRACT: human's type handler for type "num"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::float - human's type handler for type "num"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::float (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_FLOAT

$fatpacked{"Data/Sah/Compiler/human/TH/hash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_HASH';
  package Data::Sah::Compiler::human::TH::hash;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Compiler::human::TH::Comparable';
  with 'Data::Sah::Compiler::human::TH::HasElems';
  with 'Data::Sah::Type::hash';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          fmt   => ["hash", "hashes"],
          type  => 'noun',
      });
  }
  
  sub clause_has {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
  
      $c->add_ccl($cd, {
          expr=>1, multi=>1,
          fmt => "%(modal_verb)s have %s in its field values"});
  }
  
  sub clause_each_index {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      my %iargs = %{$cd->{args}};
      $iargs{outer_cd}             = $cd;
      $iargs{schema}               = $cv;
      $iargs{schema_is_normalized} = 0;
      my $icd = $c->compile(%iargs);
  
      $c->add_ccl($cd, {
          type  => 'list',
          fmt   => 'field name %(modal_verb)s be',
          items => [
              $icd->{ccls},
          ],
          vals  => [],
      });
  }
  
  sub clause_each_elem {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      my %iargs = %{$cd->{args}};
      $iargs{outer_cd}             = $cd;
      $iargs{schema}               = $cv;
      $iargs{schema_is_normalized} = 0;
      my $icd = $c->compile(%iargs);
  
      $c->add_ccl($cd, {
          type  => 'list',
          fmt   => 'each field %(modal_verb)s be',
          items => [
              $icd->{ccls},
          ],
          vals  => [],
      });
  }
  
  sub clause_keys {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      for my $k (sort keys %$cv) {
          local $cd->{spath} = [@{$cd->{spath}}, $k];
          my $v = $cv->{$k};
          my %iargs = %{$cd->{args}};
          $iargs{outer_cd}             = $cd;
          $iargs{schema}               = $v;
          $iargs{schema_is_normalized} = 0;
          my $icd = $c->compile(%iargs);
          $c->add_ccl($cd, {
              type  => 'list',
              fmt   => 'field %s %(modal_verb)s be',
              vals  => [$k],
              items => [ $icd->{ccls} ],
          });
      }
  }
  
  sub clause_re_keys {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      for my $k (sort keys %$cv) {
          local $cd->{spath} = [@{$cd->{spath}}, $k];
          my $v = $cv->{$k};
          my %iargs = %{$cd->{args}};
          $iargs{outer_cd}             = $cd;
          $iargs{schema}               = $v;
          $iargs{schema_is_normalized} = 0;
          my $icd = $c->compile(%iargs);
          $c->add_ccl($cd, {
              type  => 'list',
              fmt   => 'fields whose names match regex pattern %s %(modal_verb)s be',
              vals  => [$k],
              items => [ $icd->{ccls} ],
          });
      }
  }
  
  sub clause_req_keys {
    my ($self, $cd) = @_;
    my $c  = $self->compiler;
  
    $c->add_ccl($cd, {
      fmt   => q[%(modal_verb)s have required fields %s],
      expr  => 1,
    });
  }
  
  sub clause_allowed_keys {
    my ($self, $cd) = @_;
    my $c  = $self->compiler;
  
    $c->add_ccl($cd, {
      fmt   => q[%(modal_verb)s only have these allowed fields %s],
      expr  => 1,
    });
  }
  
  sub clause_allowed_keys_re {
    my ($self, $cd) = @_;
    my $c  = $self->compiler;
  
    $c->add_ccl($cd, {
      fmt   => q[%(modal_verb)s only have fields matching regex pattern %s],
      expr  => 1,
    });
  }
  
  sub clause_forbidden_keys {
    my ($self, $cd) = @_;
    my $c  = $self->compiler;
  
    $c->add_ccl($cd, {
      fmt   => q[%(modal_verb_neg)s have these forbidden fields %s],
      expr  => 1,
    });
  }
  
  sub clause_forbidden_keys_re {
    my ($self, $cd) = @_;
    my $c  = $self->compiler;
  
    $c->add_ccl($cd, {
      fmt   => q[%(modal_verb_neg)s have fields matching regex pattern %s],
      expr  => 1,
    });
  }
  
  1;
  # ABSTRACT: human's type handler for type "hash"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::hash - human's type handler for type "hash"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::hash (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_HASH

$fatpacked{"Data/Sah/Compiler/human/TH/int.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_INT';
  package Data::Sah::Compiler::human::TH::int;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH::num';
  with 'Data::Sah::Type::int';
  
  sub name { "integer" }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          type  => 'noun',
          fmt   => ["integer", "integers"],
      });
  }
  
  sub clause_div_by {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      if (!$cd->{cl_is_multi} && !$cd->{cl_is_expr} &&
              $cv == 2) {
          $c->add_ccl($cd, {
              fmt   => q[%(modal_verb)s be even],
          });
          return;
      }
  
      $c->add_ccl($cd, {
          fmt   => q[%(modal_verb)s be divisible by %s],
          expr  => 1,
      });
  }
  
  sub clause_mod {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      if (!$cd->{cl_is_multi} && !$cd->{cl_is_expr}) {
          if ($cv->[0] == 2 && $cv->[1] == 0) {
              $c->add_ccl($cd, {
                  fmt   => q[%(modal_verb)s be even],
              });
          } elsif ($cv->[0] == 2 && $cv->[1] == 1) {
              $c->add_ccl($cd, {
                  fmt   => q[%(modal_verb)s be odd],
              });
          }
          return;
      }
  
      $c->add_ccl($cd, {
          type => 'clause',
          fmt  =>
              q[%(modal_verb)s leave a remainder of %2$s when divided by %1$s],
          vals => $cv,
      });
  }
  
  1;
  # ABSTRACT: human's type handler for type "int"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::int - human's type handler for type "int"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::int (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_INT

$fatpacked{"Data/Sah/Compiler/human/TH/num.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_NUM';
  package Data::Sah::Compiler::human::TH::num;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Compiler::human::TH::Comparable';
  with 'Data::Sah::Compiler::human::TH::Sortable';
  with 'Data::Sah::Type::num';
  
  sub name { "number" }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {type=>'noun', fmt => ["number", "numbers"]});
  }
  
  1;
  # ABSTRACT: human's type handler for type "num"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::num - human's type handler for type "num"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::num (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_NUM

$fatpacked{"Data/Sah/Compiler/human/TH/obj.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_OBJ';
  package Data::Sah::Compiler::human::TH::obj;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Type::obj';
  
  sub name { "object" }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          fmt   => ["object", "objects"],
          type  => 'noun',
      });
  }
  
  sub clause_can {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      $c->add_ccl($cd, {
          fmt   => q[%(modal_verb)s have method(s) %s],
          #expr  => 1, # weird
      });
  }
  
  sub clause_isa {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      $c->add_ccl($cd, {
          fmt   => q[%(modal_verb)s be subclass of %s],
      });
  }
  
  1;
  # ABSTRACT: perl's type handler for type "obj"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::obj - perl's type handler for type "obj"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::obj (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_OBJ

$fatpacked{"Data/Sah/Compiler/human/TH/re.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_RE';
  package Data::Sah::Compiler::human::TH::re;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Type::re';
  
  sub name { "regex pattern" }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          fmt   => ["regex pattern", "regex patterns"],
          type  => 'noun',
      });
  }
  
  1;
  # ABSTRACT: perl's type handler for type "re"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::re - perl's type handler for type "re"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::re (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_RE

$fatpacked{"Data/Sah/Compiler/human/TH/str.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_STR';
  package Data::Sah::Compiler::human::TH::str;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Compiler::human::TH::Sortable';
  with 'Data::Sah::Compiler::human::TH::Comparable';
  with 'Data::Sah::Compiler::human::TH::HasElems';
  with 'Data::Sah::Type::str';
  
  sub name { "text" }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          fmt   => ["text", "texts"],
          type  => 'noun',
      });
  }
  
  sub clause_each_index {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      my %iargs = %{$cd->{args}};
      $iargs{outer_cd}             = $cd;
      $iargs{schema}               = $cv;
      $iargs{schema_is_normalized} = 0;
      my $icd = $c->compile(%iargs);
  
      $c->add_ccl($cd, {
          type  => 'list',
          fmt   => 'each subscript of text %(modal_verb)s be',
          items => [
              $icd->{ccls},
          ],
          vals  => [],
      });
  }
  
  sub clause_each_elem {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      my %iargs = %{$cd->{args}};
      $iargs{outer_cd}             = $cd;
      $iargs{schema}               = $cv;
      $iargs{schema_is_normalized} = 0;
      my $icd = $c->compile(%iargs);
  
      $c->add_ccl($cd, {
          type  => 'list',
          fmt   => 'each character of the text %(modal_verb)s be',
          items => [
              $icd->{ccls},
          ],
          vals  => [],
      });
  }
  
  sub clause_encoding {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      $c->_die($cd, "Only 'utf8' encoding is currently supported")
          unless $cv eq 'utf8';
      # currently does nothing
  }
  
  sub clause_match {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      $c->add_ccl($cd, {
          fmt   => q[%(modal_verb)s match regex pattern %s],
          #expr  => 1, # weird
      });
  }
  
  sub clause_is_re {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
  
      $c->add_ccl($cd, {
          fmt   => q[%(modal_verb)s be a regex pattern],
      });
  }
  
  1;
  # ABSTRACT: perl's type handler for type "str"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::str - perl's type handler for type "str"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::str (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_STR

$fatpacked{"Data/Sah/Compiler/human/TH/undef.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_HUMAN_TH_UNDEF';
  package Data::Sah::Compiler::human::TH::undef;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::human::TH';
  with 'Data::Sah::Type::undef';
  
  sub name { "undefined value" }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      $c->add_ccl($cd, {
          fmt   => ["undefined value", "undefined values"],
          type  => 'noun',
      });
  }
  
  1;
  # ABSTRACT: perl's type handler for type "undef"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::human::TH::undef - perl's type handler for type "undef"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::human::TH::undef (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(name|clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_HUMAN_TH_UNDEF

$fatpacked{"Data/Sah/Compiler/js.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS';
  package Data::Sah::Compiler::js;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use String::Indent ();
  
  extends 'Data::Sah::Compiler::Prog';
  
  sub BUILD {
      my ($self, $args) = @_;
  
      $self->comment_style('cpp');
      $self->indent_character(" " x 4);
      $self->var_sigil("");
      $self->concat_op("+");
  }
  
  sub name { "js" }
  
  sub expr {
      my ($self, $expr) = @_;
      $self->expr_compiler->js($expr);
  }
  
  sub literal {
      my ($self, $val) = @_;
  
      state $json = do {
          require JSON;
          JSON->new->allow_nonref;
      };
  
      # we need cleaning since json can't handle qr//, for one.
      state $cleanser = do {
          require Data::Clean::JSON;
          Data::Clean::JSON->get_cleanser;
      };
  
      $json->encode($cleanser->clone_and_clean($val));
  }
  
  sub compile {
      my ($self, %args) = @_;
  
      #$self->expr_compiler->compiler->hook_var(
      # ...
      #);
  
      #$self->expr_compiler->compiler->hook_func(
      # ...
      #);
  
      $self->SUPER::compile(%args);
  }
  
  sub true { "true" }
  
  sub false { "false" }
  
  sub expr_defined {
      my ($self, $t) = @_;
      "!($t === undefined || $t === null)";
  }
  
  sub expr_array_subscript {
      my ($self, $at, $idxt) = @_;
      "$at\[$idxt]";
  }
  
  sub expr_last_elem {
      my ($self, $at, $idxt) = @_;
      "$at\[($at).length-1]";
  }
  
  sub expr_array_0_nmin1 {
      my ($self, $n) = @_;
      "Array($n).join().split(',').map(function(e,i){return i})";
  }
  
  sub expr_array_1_n {
      my ($self, $n) = @_;
      "Array($n).join().split(',').map(function(e,i){return i+1})";
  }
  
  sub expr_push {
      my ($self, $at, $elt) = @_;
      "($at).push($elt)";
  }
  
  sub expr_pop {
      my ($self, $at, $elt) = @_;
      "($at).pop()";
  }
  
  sub expr_push_and_pop_dpath_between_expr {
      my ($self, $et) = @_;
      join(
          "",
          "[",
          $self->expr_push('_sahv_dpath', $self->literal(undef)), ", ", # 0
          $self->enclose_paren($et), ", ", #1
          $self->expr_pop('_sahv_dpath'), # 2
          "][1]",
      );
  }
  
  sub expr_prefix_dpath {
      my ($self, $t) = @_;
      '(_sahv_dpath.length ? "@" + _sahv_dpath.join("/") + ": " : "") + ' . $t;
  }
  
  # $l //= $r
  sub expr_setif {
      my ($self, $l, $r) = @_;
      "$l = " . $self->expr_defined($l) . " ? $l : $r";
  }
  
  sub expr_set_err_str {
      my ($self, $et, $err_expr) = @_;
      $self->expr_setif($et, $err_expr);
  }
  
  sub expr_set_err_full {
      my ($self, $et, $k, $err_expr) = @_;
      join(
          "",
          "(",
          $self->expr_setif("$et\['$k']", "{}"),
          ",",
          $self->expr_setif("$et\['$k'][_sahv_dpath.join('/')]", $err_expr),
          ")",
      );
  }
  
  sub expr_reset_err_str {
      my ($self, $et, $err_expr) = @_;
      "($et = null, true)";
  }
  
  sub expr_reset_err_full {
      my ($self, $et) = @_;
      join(
          "",
          "(",
          $self->expr_setif("$et\['errors']", "{}"),
          ",",
          "delete($et\['errors'][_sahv_dpath.join('/')])",
          ")",
      );
  }
  
  sub expr_log {
      my ($self, $cd, $ccl) = @_;
      # currently not supported
      "";
  }
  
  sub expr_block {
      my ($self, $code) = @_;
      join(
          "",
          "(function() {\n",
          String::Indent::indent(
              $self->indent_character,
              $code,
          ),
          "})()",
      );
  }
  
  # whether block is implemented using function
  sub block_uses_sub { 1 }
  
  sub stmt_declare_local_var {
      my $self = shift;
      my $v = shift;
      if (@_) {
          "var $v = $_[0];";
      } else {
          "var $v;";
      }
  }
  
  sub expr_anon_sub {
      my ($self, $args, $code) = @_;
      join(
          "",
          "function(".join(", ", @$args).") {\n",
          String::Indent::indent(
              $self->indent_character,
              $code,
          ),
          "}"
      );
  }
  
  sub stmt_require_module {
      my ($self, $mod, $cd) = @_;
      # currently loading module is not supported by js?
      #"require $mod;";
      '';
  }
  
  sub stmt_require_log_module {
      my ($self, $mod) = @_;
      # currently logging is not supported by js
      '';
  }
  
  sub stmt_return {
      my $self = shift;
      if (@_) {
          "return($_[0]);";
      } else {
          'return;';
      }
  }
  
  sub expr_validator_sub {
      my ($self, %args) = @_;
  
      $args{data_term} = 'data';
      $self->SUPER::expr_validator_sub(%args);
  }
  
  sub _str2reliteral {
      my ($self, $cd, $str) = @_;
  
      my $re;
      if (ref($str) eq 'Regexp') {
          $re = "$str";
      } else {
          eval { qr/$str/ };
          $self->_die($cd, "Invalid regex $str: $@") if $@;
          $re = $str;
      }
  
      # i don't know if this is safe?
      $re = "$re";
      $re =~ s!/!\\/!g;
      "/$re/";
  }
  
  1;
  # ABSTRACT: Compile Sah schema to JavaScript code
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js - Compile Sah schema to JavaScript code
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 SYNOPSIS
  
   # see Data::Sah
  
  =head1 DESCRIPTION
  
  Derived from L<Data::Sah::Compiler::Prog>.
  
  =for Pod::Coverage BUILD ^(after_.+|before_.+|name|expr|true|false|literal|expr_.+|stmt_.+|block_uses_sub)$
  
  =head1 METHODS
  
  =head2 new() => OBJ
  
  =head2 $c->compile(%args) => RESULT
  
  Aside from Prog's arguments, this class supports these arguments:
  
  =over
  
  =back
  
  =head1 DEVELOPER NOTES
  
  To generate expression code that says "all subexpression must be true", you can
  do:
  
   ARRAY.every(function(x) { return blah(x) })
  
  which shortcuts to false after the first item failure.
  
  To say "at least one subexpression must be true":
  
   !ARRAY.every(function(x) { return !blah(x) })
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS

$fatpacked{"Data/Sah/Compiler/js/TH.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH';
  package Data::Sah::Compiler::js::TH;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  
  extends 'Data::Sah::Compiler::Prog::TH';
  
  sub gen_each {
      my ($self, $cd, $indices_expr, $data_name, $data_term, $code_at_sub_begin) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      local $cd->{_subdata_level} = $cd->{_subdata_level} + 1;
      my $use_dpath = $cd->{args}{return_type} ne 'bool';
  
      my %iargs = %{$cd->{args}};
      $iargs{outer_cd}             = $cd;
      $iargs{data_name}            = $data_name,
      $iargs{data_term}            = $data_term,
      $iargs{schema}               = $cv;
      $iargs{schema_is_normalized} = 0;
      $iargs{indent_level}++;
      my $icd = $c->compile(%iargs);
      my @code = (
          "(", $indices_expr, ").every(function(_sahv_idx){", ($code_at_sub_begin // ''), " return(\n",
          # if ary == [], then set ary[0] = 0, else set ary[-1] = ary[-1]+1
          ($c->indent_str($cd), "(_sahv_dpath[_sahv_dpath.length ? _sahv_dpath.length-1 : 0] = _sahv_idx),\n") x !!$use_dpath,
          $icd->{result}, "\n",
          $c->indent_str($icd), ")})",
      );
      $c->add_ccl($cd, join("", @code), {subdata=>1});
  }
  
  1;
  # ABSTRACT: Base class for js type handlers
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH - Base class for js type handlers
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(compiler|clause_.+|gen_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH

$fatpacked{"Data/Sah/Compiler/js/TH/all.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_ALL';
  package Data::Sah::Compiler::js::TH::all;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  # Mo currently doesn't support multiple classes in 'extends'
  #extends
  #    'Data::Sah::Compiler::js::TH',
  #    'Data::Sah::Compiler::Prog::TH::all';
  
  use parent (
      'Data::Sah::Compiler::js::TH',
      'Data::Sah::Compiler::Prog::TH::all',
  );
  
  1;
  # ABSTRACT: js's type handler for type "all"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::all - js's type handler for type "all"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::all (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_ALL

$fatpacked{"Data/Sah/Compiler/js/TH/any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_ANY';
  package Data::Sah::Compiler::js::TH::any;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  #use Role::Tiny::With;
  
  # Mo currently doesn't support multiple classes in 'extends'
  #extends
  #    'Data::Sah::Compiler::js::TH',
  #    'Data::Sah::Compiler::Prog::TH::any';
  
  use parent (
      'Data::Sah::Compiler::js::TH',
      'Data::Sah::Compiler::Prog::TH::any',
  );
  
  1;
  # ABSTRACT: js's type handler for type "any"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::any - js's type handler for type "any"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::any (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_ANY

$fatpacked{"Data/Sah/Compiler/js/TH/array.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_ARRAY';
  package Data::Sah::Compiler::js::TH::array;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::array';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "$dt instanceof Array";
  }
  
  my $STR = "JSON.stringify";
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "$STR($dt) == $STR($ct)");
      } elsif ($which eq 'in') {
          $c->add_ccl(
              $cd,
              "!($ct).every(function(x){return $STR(x) != $STR($dt) })");
      }
  }
  
  sub superclause_has_elems {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'len') {
          $c->add_ccl($cd, "($dt).length == $ct");
      } elsif ($which eq 'min_len') {
          $c->add_ccl($cd, "($dt).length >= $ct");
      } elsif ($which eq 'max_len') {
          $c->add_ccl($cd, "($dt).length <= $ct");
      } elsif ($which eq 'len_between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl(
                  $cd, "($dt).length >= $ct\->[0] && ($dt).length >= $ct\->[1]");
          } else {
              # simplify code
              $c->add_ccl(
                  $cd, "($dt).length >= $cv->[0] && ($dt).length <= $cv->[1]");
          }
      } elsif ($which eq 'has') {
          $c->add_ccl(
              $cd,
              "($dt).map(function(x){return $STR(x)}).indexOf($STR($ct)) > -1");
      } elsif ($which eq 'each_index') {
          $self_th->gen_each($cd,
                             $c->expr_array_0_nmin1("($dt).length"), '_sahv_idx', '_sahv_idx');
      } elsif ($which eq 'each_elem') {
          $self_th->gen_each($cd,
                             $c->expr_array_0_nmin1("($dt).length"), '_sahv_idx', "$dt\[_sahv_idx]");
      } elsif ($which eq 'check_each_index') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'check_each_elem') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'uniq') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'exists') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      }
  }
  
  sub clause_elems {
      my ($self_th, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      local $cd->{_subdata_level} = $cd->{_subdata_level} + 1;
      my $use_dpath = $cd->{args}{return_type} ne 'bool';
  
      my $jccl;
      {
          local $cd->{ccls} = [];
          #local $cd->{args}{return_type} = 'bool';
  
          my $cdef = $cd->{clset}{"elems.create_default"} // 1;
          delete $cd->{uclset}{"elems.create_default"};
  
          for my $i (0..@$cv-1) {
              local $cd->{spath} = [@{$cd->{spath}}, $i];
              my $sch = $c->main->normalize_schema($cv->[$i]);
              my $edt = "$dt\[$i]";
              my %iargs = %{$cd->{args}};
              $iargs{outer_cd}             = $cd;
              $iargs{data_name}            = "$cd->{args}{data_name}_$i";
              $iargs{data_term}            = $edt;
              $iargs{schema}               = $sch;
              $iargs{schema_is_normalized} = 1;
              $iargs{indent_level}++;
              my $icd = $c->compile(%iargs);
              my @code = (
                  ($c->indent_str($cd), "(_sahv_dpath[-1] = $i),\n") x !!$use_dpath,
                  $icd->{result}, "\n",
              );
              my $ires = join("", @code);
              local $cd->{_debug_ccl_note} = "elem: $i";
              if ($cdef && defined($sch->[1]{default})) {
                  $c->add_ccl($cd, $ires);
              } else {
                  $c->add_ccl($cd, "($dt).length < ".($i+1)." || ($ires)");
              }
          }
          $jccl = $c->join_ccls(
              $cd, $cd->{ccls}, {err_msg => ''});
      }
      $c->add_ccl($cd, $jccl, {subdata=>1});
  }
  
  1;
  # ABSTRACT: js's type handler for type "array"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::array - js's type handler for type "array"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::array (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_ARRAY

$fatpacked{"Data/Sah/Compiler/js/TH/bool.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_BOOL';
  package Data::Sah::Compiler::js::TH::bool;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::bool';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "typeof($dt)=='boolean' || typeof($dt)=='number' || typeof($dt)=='string'";
  }
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "!!($dt) == !!($ct)");
      } elsif ($which eq 'in') {
          $c->add_ccl($cd, "($ct).map(function(x){return !!x}).indexOf(!!($dt)) > -1");
      }
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'min') {
          $c->add_ccl($cd, "!!($dt) >= !!($ct)");
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, "!!($dt) > !!($ct)");
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, "!!($dt) <= !!($ct)");
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, "!!($dt) < !!($ct)");
      } elsif ($which eq 'between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "!!($dt) >= !!($ct\->[0]) && ".
                              "!!($dt) <= !!($ct\->[1])");
          } else {
              # simplify code
              $c->add_ccl($cd, "!!($dt) >= !!($cv->[0]) && ".
                              "!!($dt) <= !!($cv->[1])");
          }
      } elsif ($which eq 'xbetween') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "!!($dt) > !!($ct\->[0]) && ".
                              "!!($dt) < !!($ct\->[1])");
          } else {
              # simplify code
              $c->add_ccl($cd, "!!($dt) > !!($cv->[0]) && ".
                              "!!($dt) < !!($cv->[1])");
          }
      }
  }
  
  sub clause_is_true {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl($cd, "$ct ? !!($dt) : !(".$c->expr_defined($ct).") ? true : !($dt)");
  }
  
  1;
  # ABSTRACT: js's type handler for type "bool"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::bool - js's type handler for type "bool"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::bool (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_BOOL

$fatpacked{"Data/Sah/Compiler/js/TH/buf.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_BUF';
  package Data::Sah::Compiler::js::TH::buf;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH::str';
  with 'Data::Sah::Type::buf';
  
  1;
  # ABSTRACT: js's type handler for type "buf"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::buf - js's type handler for type "buf"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::buf (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+|handle_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_BUF

$fatpacked{"Data/Sah/Compiler/js/TH/cistr.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_CISTR';
  package Data::Sah::Compiler::js::TH::cistr;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH::str';
  with 'Data::Sah::Type::cistr';
  
  sub before_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      # XXX only do this when there are clauses
  
      # convert number to string
      $self->set_tmp_data_term($cd, "typeof($dt)=='number' ? ''+$dt : typeof($dt)=='string' ? ($dt).toLowerCase() : $dt");
  }
  
  sub after_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $self->restore_data_term($cd);
  }
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "$dt == ($ct).toLowerCase()");
      } elsif ($which eq 'in') {
          $c->add_ccl($cd, "($ct).map(function(x) { return x.toLowerCase() }).indexOf($dt) > -1");
      }
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'min') {
          $c->add_ccl($cd, "$dt >= ($ct).toLowerCase()");
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, "$dt > ($ct).toLowerCase()");
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, "$dt <= ($ct).toLowerCase()");
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, "$dt < ($ct).toLowerCase()");
      } elsif ($which eq 'between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt >= (($ct)[0]).toLowerCase() && ".
                              "$dt <= (($ct)[1]).toLowerCase()");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt >= ".$c->literal(lc $cv->[0]).
                              " && $dt <= ".$c->literal(lc $cv->[1]));
          }
      } elsif ($which eq 'xbetween') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt > (($ct)[0]).toLowerCase() && ".
                              "$dt < (($ct)[1]).toLowerCase()");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt > ".$c->literal(lc $cv->[0]).
                              " && $dt < ".$c->literal(lc $cv->[1]));
          }
      }
  }
  
  sub superclause_has_elems {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'has') {
          $c->add_ccl($cd, "($dt).indexOf(($ct).toLowerCase()) > -1");
      } else {
          $self_th->SUPER::superclause_has_elems($which, $cd);
      }
  }
  
  sub clause_match {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      my $re;
      if ($cd->{cl_is_expr}) {
          $re = $ct;
      } else {
          $re = $c->_str2reliteral($cd, $cv);
      }
  
      $c->add_ccl($cd, join(
          "",
          "(function(){ ",
          "var _sahv_match = true; ",
          "try { _sahv_match = ($dt).match(RegExp($re)) } catch(e) { if (e.name=='SyntaxError') _sahv_match = false } ",
          ($cd->{cl_is_expr} ?
               "return _sahv_match == !!($ct);" :
                   "return ".($cv ? '':'!')."!!_sahv_match;"),
          "} )()",
      ));
  }
  
  1;
  # ABSTRACT: js's type handler for type "cistr"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::cistr - js's type handler for type "cistr"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::cistr (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+|handle_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_CISTR

$fatpacked{"Data/Sah/Compiler/js/TH/code.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_CODE';
  package Data::Sah::Compiler::js::TH::code;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::code';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "typeof($dt)=='function'";
  }
  
  1;
  # ABSTRACT: js's type handler for type "code"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::code - js's type handler for type "code"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::code (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_CODE

$fatpacked{"Data/Sah/Compiler/js/TH/date.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_DATE';
  package Data::Sah::Compiler::js::TH::date;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  use Scalar::Util qw(blessed looks_like_number);
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::date';
  
  my $epoch_low  = 10**8;
  my $epoch_high = 2**31;
  
  # Date() accept these arguments:
  # - Date(milliseconds epoch)
  # - Date(year, month, date, hour, minute, sec, millisec) tapi year=114 utk 2014, month=0 utk jan
  # - Date(datestring)
  # - Date(another Date object)
  # if arguments are invalid, Date() will still return a Date object,
  # but if we try to do d.getMonth() or d.getYear() it will return NaN
  #
  # to compare 2 date, we can use d1 > d2, d1 < d2, but for anything
  # involving =, we need to prefix using +: +d1 === +d2.
  
  sub expr_coerce_term {
      my ($self, $cd, $t) = @_;
  
      join(
          '',
          "(",
          "($t instanceof Date) ? $t : ",
          "typeof($t)=='number' ? (new Date($t * 1000)) : ",
          "parseFloat($t)==$t   ? (new Date(parseFloat($t)) * 1000) : ",
          "(new Date($t))",
          ")",
      );
  }
  
  sub expr_coerce_value {
      my ($self, $cd, $v) = @_;
  
      if (blessed($v) && $v->isa('DateTime')) {
          return join(
              '',
              "(new Date(",
              $v->year, ",",
              $v->month, ",",
              $v->day, ",",
              $v->hour, ",",
              $v->minute, ",",
              $v->second, ",",
              $v->millisecond,
              "))",
          );
      } elsif (looks_like_number($v) && $v >= 10**8 && $v <= 2**31) {
          return "(new Date($v*1000))";
      } elsif ($v =~ /\A([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})Z\z/) {
          require DateTime;
          eval { DateTime->new(year=>$1, month=>$2, day=>$3,
                               hour=>$4, minute=>$5, second=>$6,
                               time_zone=>'UTC') ; 1 }
              or die "Invalid date literal '$v': $@";
          return "(new Date(\"$v\"))";
      } elsif ($v =~ /\A([0-9]{4})-([0-9]{2})-([0-9]{2})\z/) {
          require DateTime;
          eval { DateTime->new(year=>$1, month=>$2, day=>$3) ; 1 }
              or die "Invalid date literal '$v': $@";
          return "(new Date(\"$v\"))";
      } else {
          die "Invalid date literal '$v'";
      }
  }
  
  sub handle_type {
      my ($self, $cd) = @_;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = join(
          '',
          "(",
          "typeof($dt)=='number' ? ($dt >= $epoch_low && $dt <= $epoch_high) : ",
          "parseFloat($dt)==$dt ? (parseFloat($dt) >= $epoch_low && parseFloat($dt) <= $epoch_high) : ",
          "!isNaN((new Date($dt)).getYear())",
          ")",
      );
  }
  
  sub before_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      # XXX only do this when there are clauses
  
      # coerce to DateTime object during validation
      $self->set_tmp_data_term($cd, $self->expr_coerce_term($cd, $dt));
  }
  
  sub after_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $self->restore_data_term($cd);
  }
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          if ($cd->{cl_is_expr}) {
              $ct = $self->expr_coerce_term($cd, $ct);
          } else {
              $ct = $self->expr_coerce_value($cd, $cv);
          }
          $c->add_ccl($cd, "+($dt) === +($ct)");
      } elsif ($which eq 'in') {
          $c->add_module('List::Util');
          if ($cd->{cl_is_expr}) {
              # i'm lazy, technical debt
              $c->_die($cd, "date's in clause with expression not yet supported");
          }
          $ct = '['.join(', ', map { "+(".$self->expr_coerce_value($cd, $_).")" } @$ct).']';
          $c->add_ccl($cd, "($ct).indexOf(+($dt)) > -1");
      }
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          # i'm lazy, technical debt
          $c->_die($cd, "date's comparison with expression not yet supported");
      }
  
      if ($which eq 'min') {
          $c->add_ccl($cd, "+($dt) >= +(".$self->expr_coerce_value($cd, $cv).")");
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, "+($dt) > +(".$self->expr_coerce_value($cd, $cv).")");
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, "+($dt) <= +(".$self->expr_coerce_value($cd, $cv).")");
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, "+($dt) < +(".$self->expr_coerce_value($cd, $cv).")");
      } elsif ($which eq 'between') {
          $c->add_ccl($cd, "+($dt) >= +(".$self->expr_coerce_value($cd, $cv->[0]).") && ".
                          "+($dt) <= +(".$self->expr_coerce_value($cd, $cv->[1]).")");
      } elsif ($which eq 'xbetween') {
          $c->add_ccl($cd, "+($dt) > +(".$self->expr_coerce_value($cd, $cv->[0]).") && ".
                          "+($dt) < +(".$self->expr_coerce_value($cd, $cv->[1]).")");
      }
  }
  
  1;
  # ABSTRACT: js's type handler for type "date"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::date - js's type handler for type "date"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::date (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+|handle_.+|before_.+|after_.+|expr_coerce_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_DATE

$fatpacked{"Data/Sah/Compiler/js/TH/float.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_FLOAT';
  package Data::Sah::Compiler::js::TH::float;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH::num';
  with 'Data::Sah::Type::float';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $cd->{_ccl_check_type} = "(typeof($dt)=='number' || parseFloat($dt)==$dt)";
  }
  
  sub clause_is_nan {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl(
              $cd,
              join(
                  "",
                  "$ct ? isNaN($dt) : ",
                  $self->expr_defined($ct), " ? !isNaN($dt) : true",
              )
          );
      } else {
          if ($cd->{cl_value}) {
              $c->add_ccl($cd, "isNaN($dt)");
          } elsif (defined $cd->{cl_value}) {
              $c->add_ccl($cd, "!isNaN($dt)");
          }
      }
  }
  
  sub clause_is_pos_inf {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl(
              $cd,
              join(
                  "",
                  "$ct ? $dt == Infinity : ",
                  $self->expr_defined($ct), " ? $dt != Infinity : true",
              )
          );
      } else {
          if ($cd->{cl_value}) {
              $c->add_ccl($cd, "$dt == Infinity");
          } elsif (defined $cd->{cl_value}) {
              $c->add_ccl($cd, "$dt != Infinity");
          }
      }
  }
  
  sub clause_is_neg_inf {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl(
              $cd,
              join(
                  "",
                  "$ct ? $dt == -Infinity : ",
                  $self->expr_defined($ct), " ? $dt != -Infinity : true",
              )
          );
      } else {
          if ($cd->{cl_value}) {
              $c->add_ccl($cd, "$dt == -Infinity");
          } elsif (defined $cd->{cl_value}) {
              $c->add_ccl($cd, "$dt != -Infinity");
          }
      }
  }
  
  sub clause_is_inf {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl(
              $cd,
              join(
                  "",
                  "$ct ? Math.abs($dt) == Infinity : ",
                  $self->expr_defined($ct), " ? Math.abs($dt) != Infinity : true",
              )
          );
      } else {
          if ($cd->{cl_value}) {
              $c->add_ccl($cd, "Math.abs($dt) == Infinity");
          } elsif (defined $cd->{cl_value}) {
              $c->add_ccl($cd, "Math.abs($dt) != Infinity");
          }
      }
  }
  
  1;
  # ABSTRACT: js's type handler for type "float"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::float - js's type handler for type "float"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::float (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(compiler|clause_.+|handle_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_FLOAT

$fatpacked{"Data/Sah/Compiler/js/TH/hash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_HASH';
  package Data::Sah::Compiler::js::TH::hash;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::hash';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      # XXX also exclude RegExp, ...
      $cd->{_ccl_check_type} = "typeof($dt)=='object' && !($dt instanceof Array)";
  }
  
  my $STR = "JSON.stringify";
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "$STR($dt) == $STR($ct)");
      } elsif ($which eq 'in') {
          $c->add_ccl(
              $cd,
              "!($ct).every(function(x){return $STR(x) != $STR($dt) })");
      }
  }
  
  sub superclause_has_elems {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      # XXX need to optimize, Object.keys(h).length is not efficient
  
      if ($which eq 'len') {
          $c->add_ccl($cd, "Object.keys($dt).length == $ct");
      } elsif ($which eq 'min_len') {
          $c->add_ccl($cd, "Object.keys($dt).length >= $ct");
      } elsif ($which eq 'max_len') {
          $c->add_ccl($cd, "Object.keys($dt).length <= $ct");
      } elsif ($which eq 'len_between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl(
                  $cd, "Object.keys($dt).length >= $ct\->[0] && ".
                      "Object.keys($dt).length >= $ct\->[1]");
          } else {
              # simplify code
              $c->add_ccl(
                  $cd, "Object.keys($dt).length >= $cv->[0] && ".
                      "Object.keys($dt).length <= $cv->[1]");
          }
      } elsif ($which eq 'has') {
          $c->add_ccl(
              $cd,
              "!Object.keys($dt).every(function(x){return $STR(($dt)[x]) != $STR($ct) })");
      } elsif ($which eq 'each_index') {
          $self_th->gen_each($cd, "Object.keys($dt)", '_sahv_idx', '_sahv_idx');
      } elsif ($which eq 'each_elem') {
          $self_th->gen_each($cd, "Object.keys($dt)", '_sahv_idx', "$dt\[_sahv_idx]");
      } elsif ($which eq 'check_each_index') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'check_each_elem') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'uniq') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'exists') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      }
  }
  
  sub _clause_keys_or_re_keys {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      local $cd->{_subdata_level} = $cd->{_subdata_level} + 1;
      my $use_dpath = $cd->{args}{return_type} ne 'bool';
  
      # we handle subdata manually here, because in generated code for
      # keys.restrict, we haven't delved into the keys
  
      my $jccl;
      {
          local $cd->{ccls} = [];
  
          my $chk_x_unknown;
          my $filt_x_unknown;
          if ($which eq 'keys') {
              my $lit_valid_keys = $c->literal([keys %$cv]);
              $chk_x_unknown  = "$lit_valid_keys.indexOf(x) > -1";
              $filt_x_unknown = "$lit_valid_keys.indexOf(x) == -1";
          } else {
              my $lit_regexes = "[".
                  join(",", map { $c->_str2reliteral($cd, $_) }
                           keys %$cv)."]";
              $chk_x_unknown  = "!$lit_regexes.every(function(y) { return !x.match(y) })";
              $filt_x_unknown = "$lit_regexes.every(function(y) { return !x.match(y) })";
          }
  
          if ($cd->{clset}{"$which.restrict"} // 1) {
              local $cd->{_debug_ccl_note} = "$which.restrict";
              $c->add_ccl(
                  $cd,
                  "Object.keys($dt).every(function(x){ return $chk_x_unknown })",
                  {
                      err_msg => 'TMP1',
                      err_expr => join(
                          "",
                          $c->literal($c->_xlt(
                              $cd, "hash contains ".
                                  "unknown field(s) (%s)")),
                          '.replace("%s", ',
                          "Object.keys($dt).filter(function(x){ return $filt_x_unknown }).join(', ')",
                          ')',
                      ),
                  },
              );
          }
          delete $cd->{uclset}{"$which.restrict"};
  
          my $cdef;
          if ($which eq 'keys') {
              $cdef = $cd->{clset}{"keys.create_default"} // 1;
              delete $cd->{uclset}{"keys.create_default"};
          }
  
          #local $cd->{args}{return_type} = 'bool';
          my $nkeys = scalar(keys %$cv);
          my $i = 0;
          for my $k (sort keys %$cv) {
              my $kre = $c->_str2reliteral($cd, $k);
              local $cd->{spath} = [@{ $cd->{spath} }, $k];
              ++$i;
              my $sch = $c->main->normalize_schema($cv->{$k});
              my $kdn = $k; $kdn =~ s/\W+/_/g;
              my $klit = $which eq 're_keys' ? 'x' : $c->literal($k);
              my $kdt = "$dt\[$klit]";
              my %iargs = %{$cd->{args}};
              $iargs{outer_cd}             = $cd;
              $iargs{data_name}            = $kdn;
              $iargs{data_term}            = $kdt;
              $iargs{schema}               = $sch;
              $iargs{schema_is_normalized} = 1;
              $iargs{indent_level}++;
              my $icd = $c->compile(%iargs);
  
              # should we set default for hash value?
              my $sdef = $cdef && defined($sch->[1]{default});
  
              $c->add_var($cd, '_sahv_stack', []) if $use_dpath;
  
              my @code = (
                  ($c->indent_str($cd), "(_sahv_dpath.push(null), _sahv_stack.push(null), _sahv_stack[_sahv_stack.length-1] = \n")
                      x !!($use_dpath && $i == 1),
  
                  # for re_keys, we iterate over all data's keys which match regex
                  ("Object.keys($dt).every(function(x) { return (")
                      x !!($which eq 're_keys'),
  
                  $which eq 're_keys' ? "!x.match($kre) || (" :
                      ($sdef ? "" : "!$dt.hasOwnProperty($klit) || ("),
  
                  ($c->indent_str($cd), "(_sahv_dpath[_sahv_dpath.length-1] = ".
                       ($which eq 're_keys' ? 'x' : $klit)."),\n") x !!$use_dpath,
                  $icd->{result}, "\n",
  
                  $which eq 're_keys' || !$sdef ? ")" : "",
  
                  # close iteration over all data's keys which match regex
                  (") })")
                      x !!($which eq 're_keys'),
  
                  ($c->indent_str($cd), "), _sahv_dpath.pop(), _sahv_stack.pop()\n")
                      x !!($use_dpath && $i == $nkeys),
              );
              my $ires = join("", @code);
              local $cd->{_debug_ccl_note} = "$which: ".$c->literal($k);
              $c->add_ccl($cd, $ires);
          }
          $jccl = $c->join_ccls(
              $cd, $cd->{ccls}, {err_msg => ''});
      }
      $c->add_ccl($cd, $jccl, {});
  }
  
  sub clause_keys {
      my ($self, $cd) = @_;
      $self->_clause_keys_or_re_keys('keys', $cd);
  }
  
  sub clause_re_keys {
      my ($self, $cd) = @_;
      $self->_clause_keys_or_re_keys('re_keys', $cd);
  }
  
  sub clause_req_keys {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl(
        $cd,
        "($ct).every(function(x){ return Object.keys($dt).indexOf(x) > -1 })", # XXX cache Object.keys($dt)
        {
          err_msg => 'TMP',
          err_expr => join(
              "",
              $c->literal($c->_xlt(
                  $cd, "hash has missing required field(s) (%s)")),
              '.replace("%s", ',
              "($ct).filter(function(x){ return Object.keys($dt).indexOf(x) == -1 }).join(', ')",
              ')',
          ),
        }
      );
  }
  
  sub clause_allowed_keys {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl(
        $cd,
        "Object.keys($dt).every(function(x){ return ($ct).indexOf(x) > -1 })", # XXX cache Object.keys($ct)
        {
          err_msg => 'TMP',
          err_expr => join(
              "",
              $c->literal($c->_xlt(
                  $cd, "hash contains non-allowed field(s) (%s)")),
              '.replace("%s", ',
              "Object.keys($dt).filter(function(x){ return ($ct).indexOf(x) == -1 }).join(', ')",
              ')',
          ),
        }
      );
  }
  
  sub clause_allowed_keys_re {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      #my $ct = $cd->{cl_term};
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          # i'm lazy atm and does not need expr yet
          $c->_die_unimplemented_clause($cd, "with expr");
      }
  
      my $re = $c->_str2reliteral($cd, $cv);
      $c->add_ccl(
        $cd,
        "Object.keys($dt).every(function(x){ return x.match(RegExp($re)) })",
        {
          err_msg => 'TMP',
          err_expr => join(
              "",
              $c->literal($c->_xlt(
                  $cd, "hash contains non-allowed field(s) (%s)")),
              '.replace("%s", ',
              "Object.keys($dt).filter(function(x){ return !x.match(RegExp($re)) }).join(', ')",
              ')',
          ),
        }
      );
  }
  
  sub clause_forbidden_keys {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl(
        $cd,
        "Object.keys($dt).every(function(x){ return ($ct).indexOf(x) == -1 })", # XXX cache Object.keys($ct)
        {
          err_msg => 'TMP',
          err_expr => join(
              "",
              $c->literal($c->_xlt(
                  $cd, "hash contains forbidden field(s) (%s)")),
              '.replace("%s", ',
              "Object.keys($dt).filter(function(x){ return ($ct).indexOf(x) > -1 }).join(', ')",
              ')',
          ),
        }
      );
  }
  
  sub clause_forbidden_keys_re {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      #my $ct = $cd->{cl_term};
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          # i'm lazy atm and does not need expr yet
          $c->_die_unimplemented_clause($cd, "with expr");
      }
  
      my $re = $c->_str2reliteral($cd, $cv);
      $c->add_ccl(
        $cd,
        "Object.keys($dt).every(function(x){ return !x.match(RegExp($re)) })",
        {
          err_msg => 'TMP',
          err_expr => join(
              "",
              $c->literal($c->_xlt(
                  $cd, "hash contains forbidden field(s) (%s)")),
              '.replace("%s", ',
              "Object.keys($dt).filter(function(x){ return x.match(RegExp($re)) }).join(', ')",
              ')',
          ),
        }
      );
  }
  
  1;
  # ABSTRACT: js's type handler for type "hash"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::hash - js's type handler for type "hash"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::hash (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_HASH

$fatpacked{"Data/Sah/Compiler/js/TH/int.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_INT';
  package Data::Sah::Compiler::js::TH::int;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH::num';
  with 'Data::Sah::Type::int';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $cd->{_ccl_check_type} = "(typeof($dt)=='number' && Math.round($dt)==$dt || parseInt($dt)==$dt)";
  }
  
  sub clause_div_by {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl($cd, "$dt % $ct == 0");
  }
  
  sub clause_mod {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl($cd, "$dt % $ct\[0] == $ct\[1]");
  }
  
  1;
  # ABSTRACT: js's type handler for type "int"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::int - js's type handler for type "int"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::int (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_INT

$fatpacked{"Data/Sah/Compiler/js/TH/num.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_NUM';
  package Data::Sah::Compiler::js::TH::num;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::num';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $cd->{_ccl_check_type} = "(typeof($dt)=='number' || parseFloat($dt)==$dt)";
  }
  
  sub before_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      # XXX only do this when there are clauses
  
      # convert non-number to number, if we need further testing like <, >=, etc.
      $self->set_tmp_data_term(
          $cd, "typeof($dt)=='number' ? $dt : parseFloat($dt)");
  }
  
  sub after_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $self->restore_data_term($cd);
  }
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "$dt == $ct");
      } elsif ($which eq 'in') {
          $c->add_ccl($cd, "($ct).indexOf($dt) > -1");
      }
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'min') {
          $c->add_ccl($cd, "$dt >= $ct");
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, "$dt > $ct");
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, "$dt <= $ct");
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, "$dt < $ct");
      } elsif ($which eq 'between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt >= $ct\[0] && $dt <= $ct\[1]");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt >= $cv->[0] && $dt <= $cv->[1]");
          }
      } elsif ($which eq 'xbetween') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt > $ct\[0] && $dt < $ct\[1]");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt > $cv->[0] && $dt < $cv->[1]");
          }
      }
  }
  
  1;
  # ABSTRACT: js's type handler for type "num"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::num - js's type handler for type "num"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::num (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_NUM

$fatpacked{"Data/Sah/Compiler/js/TH/obj.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_OBJ';
  package Data::Sah::Compiler::js::TH::obj;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::obj';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $cd->{_ccl_check_type} = "typeof($dt) == 'object'";
  }
  
  sub clause_can {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl($cd, "typeof($dt\[$ct])=='function'");
      # for property: ($dt).hasOwnProperty($ct)
  }
  
  sub clause_isa {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->_die_unimplemented_clause($cd);
      # doesn't work? in nodejs?
      #$c->add_ccl($cd, "$dt instanceOf global($ct)");
  }
  
  1;
  # ABSTRACT: js's type handler for type "obj"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::obj - js's type handler for type "obj"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::obj (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_OBJ

$fatpacked{"Data/Sah/Compiler/js/TH/re.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_RE';
  package Data::Sah::Compiler::js::TH::re;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::re';
  
  # XXX prefilter to convert string to regex object
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "$dt instanceof RegExp";
  }
  
  1;
  # ABSTRACT: js's type handler for type "re"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::re - js's type handler for type "re"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::re (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_RE

$fatpacked{"Data/Sah/Compiler/js/TH/str.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_STR';
  package Data::Sah::Compiler::js::TH::str;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::str';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "typeof($dt)=='string' || typeof($dt)=='number'";
  }
  
  sub before_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      # XXX only do this when there are clauses
  
      # convert number to string
      $self->set_tmp_data_term($cd, "typeof($dt)=='number' ? ''+$dt : $dt");
  }
  
  sub after_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $self->restore_data_term($cd);
  }
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "$dt == $ct");
      } elsif ($which eq 'in') {
          $c->add_ccl($cd, "($ct).indexOf($dt) > -1");
      }
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'min') {
          $c->add_ccl($cd, "$dt >= $ct");
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, "$dt > $ct");
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, "$dt <= $ct");
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, "$dt < $ct");
      } elsif ($which eq 'between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt >= ($ct)[0] && $dt <= ($ct)[1]");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt >= ".$c->literal($cv->[0]).
                              " && $dt <= ".$c->literal($cv->[1]));
          }
      } elsif ($which eq 'xbetween') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt > ($ct)[0] && $dt < ($ct)[1]");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt > ".$c->literal($cv->[0]).
                              " && $dt < ".$c->literal($cv->[1]));
          }
      }
  }
  
  sub superclause_has_elems {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'len') {
          $c->add_ccl($cd, "($dt).length == $ct");
      } elsif ($which eq 'min_len') {
          $c->add_ccl($cd, "($dt).length >= $ct");
      } elsif ($which eq 'max_len') {
          $c->add_ccl($cd, "($dt).length <= $ct");
      } elsif ($which eq 'len_between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl(
                  $cd, "($dt).length >= ($ct)[0] && ".
                      "($dt).length >= ($ct)[1]");
          } else {
              # simplify code
              $c->add_ccl(
                  $cd, "($dt).length >= $cv->[0] && ".
                      "($dt).length <= $cv->[1]");
          }
      } elsif ($which eq 'has') {
          $c->add_ccl($cd, "($dt).indexOf($ct) > -1");
      } elsif ($which eq 'each_index') {
          $self_th->gen_each($cd, $c->expr_array_0_nmin1("($dt).length"), '_sahv_idx', '_sahv_idx');
      } elsif ($which eq 'each_elem') {
          $self_th->gen_each($cd, $c->expr_array_0_nmin1("($dt).length"), '_sahv_idx', "$dt.charAt(_sahv_idx)");
      } elsif ($which eq 'check_each_index') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'check_each_elem') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'uniq') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'exists') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      }
  }
  
  sub clause_encoding {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->_die($cd, "Only 'utf8' encoding is currently supported")
          unless $cv eq 'utf8';
      # currently does nothing
  }
  
  sub clause_match {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      my $re;
      if ($cd->{cl_is_expr}) {
          $re = $ct;
      } else {
          $re = $c->_str2reliteral($cd, $cv);
      }
  
      $c->add_ccl($cd, join(
          "",
          "(function(){ ",
          "var _sahv_match = true; ",
          "try { _sahv_match = ($dt).match(RegExp($re)) } catch(e) { if (e.name=='SyntaxError') _sahv_match = false } ",
          ($cd->{cl_is_expr} ?
               "return _sahv_match == !!($ct);" :
                   "return ".($cv ? '':'!')."!!_sahv_match;"),
          "} )()",
      ));
  }
  
  sub clause_is_re {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl($cd, join(
          "",
          "(function(){ var _sahv_is_re = true; ",
          "try { RegExp($dt) } catch(e) { if (e.name=='SyntaxError') _sahv_is_re = false } ",
          ($cd->{cl_is_expr} ?
              "return _sahv_is_re == !!($ct);" :
                  "return ".($cv ? '':'!')."_sahv_is_re;"),
          "} )()",
      ));
  }
  
  1;
  # ABSTRACT: js's type handler for type "str"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::str - js's type handler for type "str"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::str (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+|handle_.+|before_.+|after_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_STR

$fatpacked{"Data/Sah/Compiler/js/TH/undef.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_JS_TH_UNDEF';
  package Data::Sah::Compiler::js::TH::undef;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::js::TH';
  with 'Data::Sah::Type::undef';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "$dt === undefined || $dt === null";
  }
  
  1;
  # ABSTRACT: js's type handler for type "re"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::js::TH::undef - js's type handler for type "re"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::js::TH::undef (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_JS_TH_UNDEF

$fatpacked{"Data/Sah/Compiler/perl.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL';
  package Data::Sah::Compiler::perl;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any qw($log);
  
  use Data::Dmp qw(dmp);
  use Mo qw(build default);
  use String::Indent ();
  
  extends 'Data::Sah::Compiler::Prog';
  
  sub BUILD {
      my ($self, $args) = @_;
  
      $self->comment_style('shell');
      $self->indent_character(" " x 4);
      $self->var_sigil('$');
      $self->concat_op(".");
  }
  
  sub name { "perl" }
  
  sub literal {
      dmp($_[1]);
  }
  
  sub expr {
      my ($self, $expr) = @_;
      $self->expr_compiler->perl($expr);
  }
  
  sub compile {
      my ($self, %args) = @_;
  
      #$self->expr_compiler->compiler->hook_var(
      #    sub {
      #        $_[0];
      #    }
      #);
  
      #$self->expr_compiler->compiler->hook_func(
      #    sub {
      #        my ($name, @args) = @_;
      #        die "Unknown function $name"
      #            unless $self->main->func_names->{$name};
      #        my $subname = "func_$name";
      #        $self->define_sub_start($subname);
      #        my $meth = "func_$name";
      #        $self->func_handlers->{$name}->$meth;
      #        $self->define_sub_end();
      #        $subname . "(" . join(", ", @args) . ")";
      #    }
      #);
  
      $args{pp} //= $ENV{DATA_SAH_PP};
      $args{pp} //= eval { require Scalar::Util::Numeric; 1 } ? 0 : 1;
  
      $self->SUPER::compile(%args);
  }
  
  sub init_cd {
      my ($self, %args) = @_;
  
      my $cd = $self->SUPER::init_cd(%args);
  
      if (my $ocd = $cd->{outer_cd}) {
          $cd->{module_statements} = $ocd->{module_statements};
      } else {
          $cd->{module_statements} = {};
      }
  
      $self->add_no($cd, 'warnings', ["'void'"]);
  
      $cd;
  }
  
  sub true { "1" }
  
  sub false { "''" }
  
  sub add_use {
      my ($self, $cd, $name, $imports) = @_;
  
      die "BUG: imports must be an arrayref"
          if defined($imports) && ref($imports) ne 'ARRAY';
      $self->add_module($cd, $name);
      $cd->{module_statements}{$name} = ['use', $imports];
  }
  
  sub add_no {
      my ($self, $cd, $name, $imports) = @_;
  
      die "BUG: imports must be an arrayref"
          if defined($imports) && ref($imports) ne 'ARRAY';
      $self->add_module($cd, $name);
      $cd->{module_statements}{$name} = ['no', $imports];
  }
  
  sub add_smartmatch_pragma {
      my ($self, $cd) = @_;
      $self->add_use($cd, 'experimental', ["'smartmatch'"]);
  }
  
  sub add_sun_module {
      my ($self, $cd) = @_;
      if ($cd->{args}{pp}) {
          $cd->{_sun_module} = 'Scalar::Util::Numeric::PP';
      } else {
          $cd->{_sun_module} = 'Scalar::Util::Numeric';
      }
      $self->add_module($cd, $cd->{_sun_module});
  }
  
  sub expr_defined {
      my ($self, $t) = @_;
      "defined($t)";
  }
  
  sub expr_array_subscript {
      my ($self, $at, $idxt) = @_;
      "$at->\[$idxt]";
  }
  
  sub expr_last_elem {
      my ($self, $at, $idxt) = @_;
      "$at->\[-1]";
  }
  
  sub expr_push {
      my ($self, $at, $elt) = @_;
      "push(\@{$at}, $elt)";
  }
  
  sub expr_pop {
      my ($self, $at, $elt) = @_;
      "pop(\@{$at})";
  }
  
  sub expr_push_and_pop_dpath_between_expr {
      my ($self, $et) = @_;
      join(
          "",
          "[",
          $self->expr_push('$_sahv_dpath', $self->literal(undef)), ", ", # 0
          "~~", $self->enclose_paren($et), ", ", #1 (~~ to avoid list flattening)
          $self->expr_pop('$_sahv_dpath'), # 2
          "]->[1]",
      );
  }
  
  sub expr_prefix_dpath {
      my ($self, $t) = @_;
      '(@$_sahv_dpath ? \'@\'.join("/",@$_sahv_dpath).": " : "") . ' . $t;
  }
  
  # $l //= $r
  sub expr_setif {
      my ($self, $l, $r) = @_;
      "($l //= $r)";
  }
  
  sub expr_set_err_str {
      my ($self, $et, $err_expr) = @_;
      "($et //= $err_expr)";
  }
  
  sub expr_set_err_full {
      my ($self, $et, $k, $err_expr) = @_;
      "($et\->{$k}{join('/',\@\$_sahv_dpath)} //= $err_expr)";
  }
  
  sub expr_reset_err_str {
      my ($self, $et, $err_expr) = @_;
      "($et = undef, 1)";
  }
  
  sub expr_reset_err_full {
      my ($self, $et) = @_;
      "(delete($et\->{errors}{join('/',\@\$_sahv_dpath)}), 1)";
  }
  
  sub expr_log {
      my ($self, $cd, @expr) = @_;
  
      "\$log->tracef('[sah validator](spath=%s) %s', " .
          $self->literal($cd->{spath}).", " . join(", ", @expr) . ")";
  }
  
  # wrap statements into an expression
  sub expr_block {
      my ($self, $code) = @_;
      join(
          "",
          "do {\n",
          String::Indent::indent(
              $self->indent_character,
              $code,
          ),
          "}",
      );
  }
  
  # whether block is implemented using function
  sub block_uses_sub { 0 }
  
  sub stmt_declare_local_var {
      my ($self, $v, $vt) = @_;
      if ($vt eq 'undef') {
          "my \$$v;";
      } else {
          "my \$$v = $vt;";
      }
  }
  
  sub expr_anon_sub {
      my ($self, $args, $code) = @_;
      join(
          "",
          "sub {\n",
          String::Indent::indent(
              $self->indent_character,
              join(
                  "",
                  ("my (".join(", ", @$args).") = \@_;\n") x !!@$args,
                  $code,
              ),
          ),
          "}"
      );
  }
  
  sub stmt_require_module {
      my ($self, $mod, $cd) = @_;
      my $ms = $cd->{module_statements};
  
      if (!$ms->{$mod}) {
          "require $mod;";
      } elsif ($ms->{$mod}[0] eq 'use' || $ms->{$mod}[0] eq 'no') {
          my $verb = $ms->{$mod}[0];
          if (!$ms->{$mod}[1]) {
              "$verb $mod;";
          } else {
              "$verb $mod (".join(", ", @{ $ms->{$mod}[1] }).");";
          }
      }
  }
  
  sub stmt_require_log_module {
      my ($self, $mod) = @_;
      'use Log::Any qw($log);';
  }
  
  sub stmt_return {
      my $self = shift;
      if (@_) {
          "return($_[0]);";
      } else {
          'return;';
      }
  }
  
  sub expr_validator_sub {
      my ($self, %args) = @_;
  
      $self->check_compile_args(\%args);
  
      my $aref = delete $args{accept_ref};
      if ($aref) {
          $args{var_term}  = '$ref_'.$args{data_name};
          $args{data_term} = '$$ref_'.$args{data_name};
      } else {
          $args{var_term}  = '$'.$args{data_name};
          $args{data_term} = '$'.$args{data_name};
      }
  
      $self->SUPER::expr_validator_sub(%args);
  }
  
  sub _str2reliteral {
      require Regexp::Stringify;
  
      my ($self, $cd, $str) = @_;
  
      my $re;
      if (ref($str) eq 'Regexp') {
          $re = $str;
      } else {
          eval { $re = qr/$str/ };
          $self->_die($cd, "Invalid regex $str: $@") if $@;
      }
  
      Regexp::Stringify::stringify_regexp(regexp=>$re, plver=>5.010);
  }
  
  1;
  # ABSTRACT: Compile Sah schema to Perl code
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl - Compile Sah schema to Perl code
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 SYNOPSIS
  
   # see Data::Sah
  
  =head1 DESCRIPTION
  
  Derived from L<Data::Sah::Compiler::Prog>.
  
  =for Pod::Coverage BUILD ^(after_.+|before_.+|name|expr|true|false|literal|expr_.+|stmt_.+|block_uses_sub)$
  
  =head1 METHODS
  
  =head2 new() => OBJ
  
  =head3 Compilation data
  
  This subclass adds the following compilation data (C<$cd>).
  
  Keys which contain compilation result:
  
  =over
  
  =item * B<module_statements> => HASH
  
  This hash, keyed by module name, lets the Perl compiler differentiate on the
  different statements to use when loading modules, e.g.:
  
   {
       "Foo"      => undef,    # or does not exist
       "Bar::Baz" => ['use'],
       "Qux"      => ['use', []],
       "Quux"     => ['use', ["'a'", 123]],
       "warnings" => ['no'],
   }
  
  will lead to these codes (in the order specified by C<< $cd->{modules} >>, BTW)
  being generated:
  
   require Foo;
   use Bar::Baz;
   use Qux ();
   use Quux ('a', 123);
   no warnings;
  
  =back
  
  =head2 $c->comment($cd, @args) => STR
  
  Generate a comment. For example, in perl compiler:
  
   $c->comment($cd, "123"); # -> "# 123\n"
  
  Will return an empty string if compile argument C<comment> is set to false.
  
  =head2 $c->compile(%args) => RESULT
  
  Aside from Prog's arguments, this class supports these arguments:
  
  =over
  
  =item * pp => bool (default: 0)
  
  If set to true, will avoid the use of XS modules in the generated code and will
  opt instead to use pure-perl modules.
  
  =back
  
  =head2 $c->add_use($cd, $module, \@imports)
  
  This is like C<add_module()>, but indicate that C<$module> needs to be C<use>-d
  in the generated code (for example, Perl pragmas). Normally if C<add_module()>
  is used, the generated code will use C<require>.
  
  If you use C<< $c->add_use($cd, 'foo') >>, this code will be generated:
  
   use foo;
  
  If you use C<< $c->add_use($cd, 'foo', ["'a'", "'b'", "123"]) >>, this code will
  be generated:
  
   use foo ('a', 'b', 123);
  
  If you use C<< $c->add_use($cd, 'foo', []) >>, this code will be generated:
  
   use foo ();
  
  The generated statement will be added at the top (top-level lexical scope) and
  duplicates are ignored. To generate multiple and lexically-scoped C<use> and
  C<no> statements, e.g. like below, currently you can generate them manually:
  
   if (blah) {
       no warnings;
       ...
   }
  
  =head2 $c->add_no($cd, $module)
  
  This is the counterpart of C<add_use()>, to generate C<<no foo>> statement.
  
  See also: C<add_use()>.
  
  =head2 $c->add_smartmatch_pragma($cd)
  
  Equivalent to:
  
   $c->add_use($cd, 'experimental', ["'smartmatch'"]);
  
  =head2 $c->add_sun_module($cd)
  
  Add L<Scalar::Util::Numeric> module, or L<Scalar::Util::Numeric::PP> when C<pp>
  compile argument is true.
  
  =head1 ENVIRONMENT
  
  =head2 DATA_SAH_PP => bool
  
  Set default for C<pp> compile argument.
  
  =head1 DEVELOPER NOTES
  
  To generate expression code that says "all subexpression must be true", you can
  do:
  
   !defined(List::Util::first(sub { blah($_) }, "value", ...))
  
  This is a bit harder to read than:
  
   !grep { !blah($_) } "value", ...
  
  but has the advantage of the ability to shortcut on the first item that fails.
  
  Similarly, to say "at least one subexpression must be true":
  
   defined(List::Util::first(sub { blah($_) }, "value", ...))
  
  which can shortcut in contrast to:
  
   grep { blah($_) } "value", ...
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL

$fatpacked{"Data/Sah/Compiler/perl/TH.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH';
  package Data::Sah::Compiler::perl::TH;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::Prog::TH';
  
  sub gen_each {
      my ($self, $cd, $indices_expr, $data_name, $data_term, $code_at_sub_begin) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      local $cd->{_subdata_level} = $cd->{_subdata_level} + 1;
      my $use_dpath = $cd->{args}{return_type} ne 'bool';
  
      $c->add_module($cd, 'List::Util');
      my %iargs = %{$cd->{args}};
      $iargs{outer_cd}             = $cd;
      $iargs{data_name}            = $data_name;
      $iargs{data_term}            = $data_term;
      $iargs{schema}               = $cv;
      $iargs{schema_is_normalized} = 0;
      $iargs{indent_level}++;
      my $icd = $c->compile(%iargs);
      my @code = (
          "!defined(List::Util::first(sub {", ($code_at_sub_begin // ''), "!(\n",
          ($c->indent_str($cd),
           "(\$_sahv_dpath->[-1] = \$_),\n") x !!$use_dpath,
           $icd->{result}, "\n",
           $c->indent_str($icd), ")}, ",
           $indices_expr,
           "))",
      );
      $c->add_ccl($cd, join("", @code), {subdata=>1});
  }
  
  1;
  # ABSTRACT: Base class for perl type handlers
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH - Base class for perl type handlers
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(compiler|clause_.+|gen_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH

$fatpacked{"Data/Sah/Compiler/perl/TH/all.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_ALL';
  package Data::Sah::Compiler::perl::TH::all;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  # Mo currently doesn't support multiple classes in 'extends'
  #extends
  #    'Data::Sah::Compiler::perl::TH',
  #    'Data::Sah::Compiler::Prog::TH::all';
  
  use parent (
      'Data::Sah::Compiler::perl::TH',
      'Data::Sah::Compiler::Prog::TH::all',
  );
  
  1;
  # ABSTRACT: perl's type handler for type "all"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::all - perl's type handler for type "all"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::all (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_ALL

$fatpacked{"Data/Sah/Compiler/perl/TH/any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_ANY';
  package Data::Sah::Compiler::perl::TH::any;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  # Mo currently doesn't support multiple classes in 'extends'
  #extends
  #    'Data::Sah::Compiler::perl::TH',
  #    'Data::Sah::Compiler::Prog::TH::any';
  
  use parent (
      'Data::Sah::Compiler::perl::TH',
      'Data::Sah::Compiler::Prog::TH::any',
  );
  
  1;
  # ABSTRACT: perl's type handler for type "any"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::any - perl's type handler for type "any"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::any (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_ANY

$fatpacked{"Data/Sah/Compiler/perl/TH/array.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_ARRAY';
  package Data::Sah::Compiler::perl::TH::array;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH';
  with 'Data::Sah::Type::array';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "ref($dt) eq 'ARRAY'";
  }
  
  my $FRZ = "Storable::freeze";
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      # Storable is chosen because it's core and fast. ~~ is not very
      # specific.
      $c->add_module($cd, 'Storable');
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "$FRZ($dt) eq $FRZ($ct)");
      } elsif ($which eq 'in') {
          $c->add_smartmatch_pragma($cd);
          $c->add_ccl($cd, "$FRZ($dt) ~~ [map {$FRZ(\$_)} \@{ $ct }]");
      }
  }
  
  sub superclause_has_elems {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'len') {
          $c->add_ccl($cd, "\@{$dt} == $ct");
      } elsif ($which eq 'min_len') {
          $c->add_ccl($cd, "\@{$dt} >= $ct");
      } elsif ($which eq 'max_len') {
          $c->add_ccl($cd, "\@{$dt} <= $ct");
      } elsif ($which eq 'len_between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl(
                  $cd, "\@{$dt} >= $ct\->[0] && \@{$dt} >= $ct\->[1]");
          } else {
              # simplify code
              $c->add_ccl(
                  $cd, "\@{$dt} >= $cv->[0] && \@{$dt} <= $cv->[1]");
          }
      } elsif ($which eq 'has') {
          $c->add_smartmatch_pragma($cd);
          #$c->add_ccl($cd, "$FRZ($ct) ~~ [map {$FRZ(\$_)} \@{ $dt }]");
  
          # XXX currently we choose below for speed, but only works for array of
          # scalars
          $c->add_ccl($cd, "$ct ~~ $dt");
      } elsif ($which eq 'each_index') {
          $self_th->gen_each($cd, "0..\@{$dt}-1", '_', '$_');
      } elsif ($which eq 'each_elem') {
          $self_th->gen_each($cd, "0..\@{$dt}-1", '_', "$dt\->[\$_]");
      } elsif ($which eq 'check_each_index') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'check_each_elem') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'uniq') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'exists') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      }
  }
  
  sub clause_elems {
      my ($self_th, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      local $cd->{_subdata_level} = $cd->{_subdata_level} + 1;
      my $use_dpath = $cd->{args}{return_type} ne 'bool';
  
      my $jccl;
      {
          local $cd->{ccls} = [];
          #local $cd->{args}{return_type} = 'bool';
  
          my $cdef = $cd->{clset}{"elems.create_default"} // 1;
          delete $cd->{uclset}{"elems.create_default"};
  
          for my $i (0..@$cv-1) {
              local $cd->{spath} = [@{$cd->{spath}}, $i];
              my $sch = $c->main->normalize_schema($cv->[$i]);
              my $edt = "$dt\->[$i]";
              my %iargs = %{$cd->{args}};
              $iargs{outer_cd}             = $cd;
              $iargs{data_name}            = "$cd->{args}{data_name}_$i";
              $iargs{data_term}            = $edt;
              $iargs{schema}               = $sch;
              $iargs{schema_is_normalized} = 1;
              $iargs{indent_level}++;
              my $icd = $c->compile(%iargs);
              my @code = (
                  ($c->indent_str($cd), "(\$_sahv_dpath->[-1] = $i),\n") x !!$use_dpath,
                  $icd->{result}, "\n",
              );
              my $ires = join("", @code);
              local $cd->{_debug_ccl_note} = "elem: $i";
              if ($cdef && defined($sch->[1]{default})) {
                  $c->add_ccl($cd, $ires);
              } else {
                  $c->add_ccl($cd, "\@{$dt} < ".($i+1)." || ($ires)");
              }
          }
          $jccl = $c->join_ccls(
              $cd, $cd->{ccls}, {err_msg => ''});
      }
      $c->add_ccl($cd, $jccl, {subdata=>1});
  }
  
  1;
  # ABSTRACT: perl's type handler for type "array"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::array - perl's type handler for type "array"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::array (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_ARRAY

$fatpacked{"Data/Sah/Compiler/perl/TH/bool.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_BOOL';
  package Data::Sah::Compiler::perl::TH::bool;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH';
  with 'Data::Sah::Type::bool';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "!ref($dt)";
  }
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "($dt ? 1:0) == ($ct ? 1:0)");
      } elsif ($which eq 'in') {
          $c->add_smartmatch_pragma($cd);
          $c->add_ccl($cd, "($dt ? 1:0) ~~ [map {\$_?1:0} \@{$ct}]");
      }
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'min') {
          $c->add_ccl($cd, "($dt ? 1:0) >= ($ct ? 1:0)");
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, "($dt ? 1:0) > ($ct ? 1:0)");
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, "($dt ? 1:0) <= ($ct ? 1:0)");
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, "($dt ? 1:0) < ($ct ? 1:0)");
      } elsif ($which eq 'between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "($dt ? 1:0) >= ($ct\->[0] ? 1:0) && ".
                              "($dt ? 1:0) <= ($ct\->[1] ? 1:0)");
          } else {
              # simplify code
              $c->add_ccl($cd, "($dt ? 1:0) >= ($cv->[0] ? 1:0) && ".
                              "($dt ? 1:0) <= ($cv->[1] ? 1:0)");
          }
      } elsif ($which eq 'xbetween') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "($dt ? 1:0) > ($ct\->[0] ? 1:0) && ".
                              "($dt ? 1:0) < ($ct\->[1] ? 1:0)");
          } else {
              # simplify code
              $c->add_ccl($cd, "($dt ? 1:0) > ($cv->[0] ? 1:0) && ".
                              "($dt ? 1:0) < ($cv->[1] ? 1:0)");
          }
      }
  }
  
  sub clause_is_true {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl($cd, "($ct) ? $dt : !defined($ct) ? 1 : !$dt");
  }
  
  1;
  # ABSTRACT: perl's type handler for type "bool"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::bool - perl's type handler for type "bool"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::bool (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_BOOL

$fatpacked{"Data/Sah/Compiler/perl/TH/buf.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_BUF';
  package Data::Sah::Compiler::perl::TH::buf;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH::str';
  with 'Data::Sah::Type::buf';
  
  1;
  # ABSTRACT: perl's type handler for type "buf"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::buf - perl's type handler for type "buf"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::buf (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_BUF

$fatpacked{"Data/Sah/Compiler/perl/TH/cistr.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_CISTR';
  package Data::Sah::Compiler::perl::TH::cistr;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH::str';
  with 'Data::Sah::Type::cistr';
  
  sub before_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      # XXX only do this when there are clauses
  
      # convert to lowercase so we don't lc() the data repeatedly
      $self->set_tmp_data_term($cd, "lc($dt)");
  }
  
  sub after_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $self->restore_data_term($cd);
  }
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "$dt eq lc($ct)");
      } elsif ($which eq 'in') {
          $c->add_smartmatch_pragma($cd);
          $c->add_ccl($cd, "$dt ~~ [map {lc} \@{ $ct }]");
      }
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'min') {
          $c->add_ccl($cd, "$dt ge lc($ct)");
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, "$dt gt lc($ct)");
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, "$dt le lc($ct)");
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, "$dt lt lc($ct)");
      } elsif ($which eq 'between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt ge lc($ct\->[0]) && ".
                              "$dt le lc($ct\->[1])");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt ge ".$c->literal(lc $cv->[0]).
                              " && $dt le ".$c->literal(lc $cv->[1]));
          }
      } elsif ($which eq 'xbetween') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt gt lc($ct\->[0]) && ".
                              "$dt lt lc($ct\->[1])");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt gt ".$c->literal(lc $cv->[0]).
                              " && $dt lt ".$c->literal(lc $cv->[1]));
          }
      }
  }
  
  sub superclause_has_elems {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'has') {
          $c->add_ccl($cd, "index($dt, lc($ct)) > -1");
      } else {
          $self_th->SUPER::superclause_has_elems($which, $cd);
      }
  }
  
  # turn "(?-xism:blah)" to "(?i-xsm:blah)"
  sub __change_re_str_switch {
      my $re = shift;
  
      if ($^V ge v5.14.0) {
          state $sub = sub { my $s = shift; $s =~ /i/ ? $s : "i$s" };
          $re =~ s/\A\(\?\^(\w*):/"(?".$sub->($1).":"/e;
      } else {
          state $subl = sub { my $s = shift; $s =~ /i/ ? $s : "i$s" };
          state $subr = sub { my $s = shift; $s =~ s/i//; $s };
          $re =~ s/\A\(\?(\w*)-(\w*):/"(?".$subl->($1)."-".$subr->($2).":"/e;
      }
      return $re;
  }
  
  sub clause_match {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl($cd, join(
              "",
              "ref($ct) eq 'Regexp' ? $dt =~ qr/$ct/i : ",
              "do { my \$re = $ct; eval { \$re = /\$re/i; 1 } && ",
              "$dt =~ \$re }",
          ));
      } else {
          # simplify code and we can check regex at compile time
          my $re = $c->_str2reliteral($cd, $cv);
          $re = __change_re_str_switch($re);
          $c->add_ccl($cd, "$dt =~ /$re/i");
      }
  }
  
  1;
  # ABSTRACT: perl's type handler for type "cistr"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::cistr - perl's type handler for type "cistr"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::cistr (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+|handle_.+|before_.+|after_.+)$
  
  =head1 NOTES
  
  Should probably be reimplemented using special Perl string type, or special Perl
  operators, instead of simulated using C<lc()> on a per-clause basis. The
  implementation as it is now is not "contagious", e.g. C<< [cistr =>
  check_each_elem => '$_ eq "A"'] >> should be true even if data is C<"Aaa">,
  since one would expect C<<$_ eq "A">> is also done case-insensitively, but it is
  currently internally implemented by converting data to lowercase and splitting
  per character to become C<<["a", "a", "a"]>>.
  
  Or, avoid C<cistr> altogether and use C<prefilters> to convert to
  lowercase/uppercase first before processing.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_CISTR

$fatpacked{"Data/Sah/Compiler/perl/TH/code.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_CODE';
  package Data::Sah::Compiler::perl::TH::code;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH';
  with 'Data::Sah::Type::code';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "ref($dt) eq 'CODE'";
  }
  
  1;
  # ABSTRACT: perl's type handler for type "code"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::code - perl's type handler for type "code"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::code (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_CODE

$fatpacked{"Data/Sah/Compiler/perl/TH/date.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_DATE';
  package Data::Sah::Compiler::perl::TH::date;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  use Scalar::Util qw(blessed looks_like_number);
  
  extends 'Data::Sah::Compiler::perl::TH';
  with 'Data::Sah::Type::date';
  
  sub expr_coerce_term {
      my ($self, $cd, $t) = @_;
  
      my $c = $self->compiler;
      $c->add_module($cd, 'DateTime');
      $c->add_module($cd, 'Scalar::Util');
  
      join(
          '',
          "(",
          "(Scalar::Util::blessed($t) && $t->isa('DateTime')) ? $t : ",
          "(Scalar::Util::looks_like_number($t) && $t >= 10**8 && $t <= 2**31) ? (DateTime->from_epoch(epoch=>$t)) : ",
          "$t =~ /\\A([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})Z\\z/ ? DateTime->new(year=>\$1, month=>\$2, day=>\$3, hour=>\$4, minute=>\$5, second=>\$6, time_zone=>'UTC') : ",
          "$t =~ /\\A([0-9]{4})-([0-9]{2})-([0-9]{2})\\z/ ? DateTime->new(year=>\$1, month=>\$2, day=>\$3) : die(\"BUG: can't coerce date\")",
          ")",
      );
  }
  
  sub expr_coerce_value {
      my ($self, $cd, $v) = @_;
  
      my $c = $self->compiler;
      $c->add_module($cd, 'DateTime');
  
      if (blessed($v) && $v->isa('DateTime')) {
          return join(
              '',
              "DateTime->new(",
              "year=>",   $v->year, ",",
              "month=>",  $v->month, ",",
              "day=>",    $v->day, ",",
              "hour=>",   $v->hour, ",",
              "minute=>", $v->minute, ",",
              "second=>", $v->second, ",",
              ")",
          );
      } elsif (looks_like_number($v) && $v >= 10**8 && $v <= 2**31) {
          return "DateTime->from_epoch(epoch=>$v)";
      } elsif ($v =~ /\A([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})Z\z/) {
          require DateTime;
          eval { DateTime->new(year=>$1, month=>$2, day=>$3,
                               hour=>$4, minute=>$5, second=>$6,
                               time_zone=>'UTC') ; 1 }
              or die "Invalid date literal '$v': $@";
          return "DateTime->new(year=>$1, month=>$2, day=>$3, hour=>$4, minute=>$5, second=>$6, time_zone=>'UTC')";
      } elsif ($v =~ /\A([0-9]{4})-([0-9]{2})-([0-9]{2})\z/) {
          require DateTime;
          eval { DateTime->new(year=>$1, month=>$2, day=>$3) ; 1 }
              or die "Invalid date literal '$v': $@";
          return "DateTime->new(year=>$1, month=>$2, day=>$3)";
      } else {
          die "Invalid date literal '$v'";
      }
  }
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $dt = $cd->{data_term};
  
      $c->add_module($cd, 'Scalar::Util');
      $cd->{_ccl_check_type} = join(
          '',
          "(",
          "(Scalar::Util::blessed($dt) && $dt->isa('DateTime'))",
          " || ",
          "(Scalar::Util::looks_like_number($dt) && $dt >= 10**8 && $dt <= 2**31)",
          " || ",
          "($dt =~ /\\A([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})Z\\z/ && eval { DateTime->new(year=>\$1, month=>\$2, day=>\$3, hour=>\$4, minute=>\$5, second=>\$6, time_zone=>'UTC'); 1})",
          " || ",
          "($dt =~ /\\A([0-9]{4})-([0-9]{2})-([0-9]{2})\\z/ && eval { DateTime->new(year=>\$1, month=>\$2, day=>\$3); 1})",
          ")",
      );
  }
  
  sub before_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      # XXX only do this when there are clauses
  
      # coerce to DateTime object during validation
      $self->set_tmp_data_term($cd, $self->expr_coerce_term($cd, $dt));
  }
  
  sub after_all_clauses {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $self->restore_data_term($cd);
  }
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          if ($cd->{cl_is_expr}) {
              $ct = $self->expr_coerce_term($cd, $ct);
          } else {
              $ct = $self->expr_coerce_value($cd, $cv);
          }
          $c->add_ccl($cd, "DateTime->compare($dt, $ct)==0");
      } elsif ($which eq 'in') {
          $c->add_module('List::Util');
          if ($cd->{cl_is_expr}) {
              # i'm lazy, technical debt
              $c->_die($cd, "date's in clause with expression not yet supported");
          } else {
              $ct = join(', ', map { $self->expr_coerce_value($cd, $_) } @$cv);
          };
          $c->add_ccl($cd, "List::Util::first(sub{DateTime->compare($dt, \$_)==0}, $ct)");
      }
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          # i'm lazy, technical debt
          $c->_die($cd, "date's comparison with expression not yet supported");
      }
  
      if ($which eq 'min') {
          $c->add_ccl($cd, "DateTime->compare($dt, ".
                          $self->expr_coerce_value($cd, $cv).") >= 0");
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, "DateTime->compare($dt, ".
                          $self->expr_coerce_value($cd, $cv).") > 0");
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, "DateTime->compare($dt, ".
                          $self->expr_coerce_value($cd, $cv).") <= 0");
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, "DateTime->compare($dt, ".
                          $self->expr_coerce_value($cd, $cv).") < 0");
      } elsif ($which eq 'between') {
          $c->add_ccl($cd,
                      join(
                          '',
                          "DateTime->compare($dt, ",
                          $self->expr_coerce_value($cd, $cv->[0]).") >= 0 && ",
                          "DateTime->compare($dt, ",
                          $self->expr_coerce_value($cd, $cv->[1]).") <= 0",
                      ));
      } elsif ($which eq 'xbetween') {
          $c->add_ccl($cd,
                      join(
                          '',
                          "DateTime->compare($dt, ",
                          $self->expr_coerce_value($cd, $cv->[0]).") > 0 && ",
                          "DateTime->compare($dt, ",
                          $self->expr_coerce_value($cd, $cv->[1]).") < 0",
                      ));
      }
  }
  
  1;
  # ABSTRACT: perl's type handler for type "date"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::date - perl's type handler for type "date"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::date (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 DESCRIPTION
  
  What constitutes a valid date value:
  
  =over
  
  =item * L<DateTime> object
  
  =item * integers from 100 million to 2^31
  
  For convenience, some integers are accepted and interpreted as Unix epoch (32
  bit). They will be converted to DateTime objects during validation. The values
  correspond to dates from Mar 3rd, 1973 to Jan 19, 2038 (Y2038).
  
  Choosing 100 million (9 decimal digits) as the lower limit is to avoid parsing
  numbers like 20141231 (8 digit) as YMD date.
  
  =item * string in the form of "YYYY-MM-DD"
  
  For convenience, string of this form, like C<2014-04-25> is accepted and will be
  converted to DateTime object. Invalid dates like C<2014-04-31> will of course
  fail the validation.
  
  =item * string in the form of "YYYY-MM-DDThh:mm:ssZ"
  
  This is the Zulu form of ISO8601 date+time.
  
  =back
  
  =for Pod::Coverage ^(clause_.+|superclause_.+|handle_.+|before_.+|after_.+|expr_coerce_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_DATE

$fatpacked{"Data/Sah/Compiler/perl/TH/float.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_FLOAT';
  package Data::Sah::Compiler::perl::TH::float;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH::num';
  with 'Data::Sah::Type::float';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $c->add_sun_module($cd);
      # we use isnum = isint + isfloat, because isfloat(3) is false
      $cd->{_ccl_check_type} = "$cd->{_sun_module}::isnum($dt)";
  }
  
  sub clause_is_nan {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl(
              $cd,
              join(
                  "",
                  "$ct ? $cd->{_sun_module}::isnan($dt) : ",
                  "defined($ct) ? !$cd->{_sun_module}::isnan($dt) : 1",
              )
          );
      } else {
          if ($cd->{cl_value}) {
              $c->add_ccl($cd, "$cd->{_sun_module}::isnan($dt)");
          } elsif (defined $cd->{cl_value}) {
              $c->add_ccl($cd, "!$cd->{_sun_module}::isnan($dt)");
          }
      }
  }
  
  sub clause_is_neg_inf {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl($cd, "$ct ? $cd->{_sun_module}::isinf($dt) && $cd->{_sun_module}::isneg($dt) : ".
                          "defined($ct) ? !($cd->{_sun_module}::isinf($dt) && $cd->{_sun_module}::isneg($dt)) : 1");
      } else {
          if ($cd->{cl_value}) {
              $c->add_ccl($cd, "$cd->{_sun_module}::isinf($dt) && $cd->{_sun_module}::isneg($dt)");
          } elsif (defined $cd->{cl_value}) {
              $c->add_ccl($cd, "!($cd->{_sun_module}::isinf($dt) && $cd->{_sun_module}::isneg($dt))");
          }
      }
  }
  
  sub clause_is_pos_inf {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl($cd, "$ct ? $cd->{_sun_module}::isinf($dt) && !$cd->{_sun_module}::isneg($dt) : ".
                          "defined($ct) ? !($cd->{_sun_module}::isinf($dt) && !$cd->{_sun_module}::isneg($dt)) : 1");
      } else {
          if ($cd->{cl_value}) {
              $c->add_ccl($cd, "$cd->{_sun_module}::isinf($dt) && !$cd->{_sun_module}::isneg($dt)");
          } elsif (defined $cd->{cl_value}) {
              $c->add_ccl($cd, "!($cd->{_sun_module}::isinf($dt) && !$cd->{_sun_module}::isneg($dt))");
          }
      }
  }
  
  sub clause_is_inf {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl($cd, "$ct ? $cd->{_sun_module}::isinf($dt) : ".
                          "defined($ct) ? $cd->{_sun_module}::isinf($dt) : 1");
      } else {
          if ($cd->{cl_value}) {
              $c->add_ccl($cd, "$cd->{_sun_module}::isinf($dt)");
          } elsif (defined $cd->{cl_value}) {
              $c->add_ccl($cd, "!$cd->{_sun_module}::isinf($dt)");
          }
      }
  }
  
  1;
  # ABSTRACT: perl's type handler for type "float"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::float - perl's type handler for type "float"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::float (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(compiler|clause_.+|handle_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_FLOAT

$fatpacked{"Data/Sah/Compiler/perl/TH/hash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_HASH';
  package Data::Sah::Compiler::perl::TH::hash;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH';
  with 'Data::Sah::Type::hash';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "ref($dt) eq 'HASH'";
  }
  
  my $FRZ = "Storable::freeze";
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      # Storable is chosen because it's core and fast. ~~ is not very
      # specific.
      $c->add_module($cd, 'Storable');
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "$FRZ($dt) eq $FRZ($ct)");
      } elsif ($which eq 'in') {
          $c->add_smartmatch_pragma($cd);
          $c->add_ccl($cd, "$FRZ($dt) ~~ [map {$FRZ(\$_)} \@{ $ct }]");
      }
  }
  
  sub superclause_has_elems {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'len') {
          $c->add_ccl($cd, "keys(\%{$dt}) == $ct");
      } elsif ($which eq 'min_len') {
          $c->add_ccl($cd, "keys(\%{$dt}) >= $ct");
      } elsif ($which eq 'max_len') {
          $c->add_ccl($cd, "keys(\%{$dt}) <= $ct");
      } elsif ($which eq 'len_between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl(
                  $cd, "keys(\%{$dt}) >= $ct\->[0] && ".
                      "keys(\%{$dt}) >= $ct\->[1]");
          } else {
              # simplify code
              $c->add_ccl(
                  $cd, "keys(\%{$dt}) >= $cv->[0] && ".
                      "keys(\%{$dt}) <= $cv->[1]");
          }
      } elsif ($which eq 'has') {
          $c->add_smartmatch_pragma($cd);
          #$c->add_ccl($cd, "$FRZ($ct) ~~ [map {$FRZ(\$_)} values \%{ $dt }]");
  
          # XXX currently we choose below for speed, but only works for hash of
          # scalars. stringifying is required because smartmatch will switch to
          # numeric if we feed something like {a=>1}
          $c->add_ccl($cd, "$ct ~~ [values \%{ $dt }]");
      } elsif ($which eq 'each_index') {
          $self_th->gen_each($cd, "sort keys(\%{$dt})", '', '$_');
      } elsif ($which eq 'each_elem') {
          $self_th->gen_each($cd, "sort keys(\%{$dt})", '_', "$dt\->{\$_}");
      } elsif ($which eq 'check_each_index') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'check_each_elem') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'uniq') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'exists') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      }
  }
  
  sub _clause_keys_or_re_keys {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      local $cd->{_subdata_level} = $cd->{_subdata_level} + 1;
      my $use_dpath = $cd->{args}{return_type} ne 'bool';
  
      # we handle subdata manually here, because in generated code for
      # {keys,re_keys}.restrict, we haven't delved into the keys
  
      my $jccl;
      {
          local $cd->{ccls} = [];
  
          my $lit_valid_keys;
          if ($which eq 'keys') {
              $lit_valid_keys = $c->literal([sort keys %$cv]);
          } else {
              $lit_valid_keys = "[".
                  join(",", map { "qr/".$c->_str2reliteral($cd, $_)."/" }
                           sort keys %$cv)."]";
          }
  
          if ($cd->{clset}{"$which.restrict"} // 1) {
              local $cd->{_debug_ccl_note} = "$which.restrict";
              $c->add_module($cd, "List::Util");
              $c->add_smartmatch_pragma($cd);
              $c->add_ccl(
                  $cd,
                  # here we need ~~ because it can match against strs or regexes
                  "!defined(List::Util::first(sub {!(\$_ ~~ $lit_valid_keys)}, ".
                      "keys %{$dt}))",
                  {
                      err_msg => 'TMP1',
                      err_expr => join(
                          "",
                          'sprintf(',
                          $c->literal($c->_xlt(
                              $cd, "hash contains ".
                                  "unknown field(s) (%s)")),
                          ',',
                          "join(', ', sort grep {!(\$_ ~~ $lit_valid_keys)} ",
                          "keys %{$dt})",
                          ')',
                      ),
                  },
              );
          }
          delete $cd->{uclset}{"$which.restrict"};
  
          my $cdef;
          if ($which eq 'keys') {
              $cdef = $cd->{clset}{"keys.create_default"} // 1;
              delete $cd->{uclset}{"keys.create_default"};
          }
  
          #local $cd->{args}{return_type} = 'bool';
          my $nkeys = scalar(keys %$cv);
          my $i = 0;
          for my $k (sort keys %$cv) {
              my $kre = $c->_str2reliteral($cd, $k);
              local $cd->{spath} = [@{ $cd->{spath} }, $k];
              ++$i;
              my $sch = $c->main->normalize_schema($cv->{$k});
              my $kdn = $k; $kdn =~ s/\W+/_/g;
              my $klit = $which eq 're_keys' ? '$_' : $c->literal($k);
              my $kdt = "$dt\->{$klit}";
              my %iargs = %{$cd->{args}};
              $iargs{outer_cd}             = $cd;
              $iargs{data_name}            = $kdn;
              $iargs{data_term}            = $kdt;
              $iargs{schema}               = $sch;
              $iargs{schema_is_normalized} = 1;
              $iargs{indent_level}++;
              my $icd = $c->compile(%iargs);
  
              # should we set default for hash value?
              my $sdef = $cdef && defined($sch->[1]{default});
  
              # stack is used to store (non-bool) subresults
              $c->add_var($cd, '_sahv_stack', []) if $use_dpath;
  
              my @code = (
                  ($c->indent_str($cd), "(push(@\$_sahv_dpath, undef), push(\@\$_sahv_stack, undef), \$_sahv_stack->[-1] = \n")
                      x !!($use_dpath && $i == 1),
  
                  # for re_keys, we iterate over all data's keys which match regex
                  ('(!defined(List::Util::first(sub {!(')
                      x !!($which eq 're_keys'),
  
                  $which eq 're_keys' ? "\$_ !~ /$kre/ || (" :
                      ($sdef ? "" : "!exists($kdt) || ("),
  
                  ($c->indent_str($cd), "(\$_sahv_dpath->[-1] = ".
                       ($which eq 're_keys' ? '$_' : $klit)."),\n")
                           x !!$use_dpath,
                  $icd->{result}, "\n",
  
                  $which eq 're_keys' || !$sdef ? ")" : "",
  
                  # close iteration over all data's keys which match regex
                  (")}, sort keys %{ $dt })))")
                      x !!($which eq 're_keys'),
  
                  ($c->indent_str($cd), "), pop(\@\$_sahv_dpath), pop(\@\$_sahv_stack)\n")
                      x !!($use_dpath && $i == $nkeys),
              );
              my $ires = join("", @code);
              local $cd->{_debug_ccl_note} = "$which: ".$c->literal($k);
              $c->add_ccl($cd, $ires);
          }
          $jccl = $c->join_ccls(
              $cd, $cd->{ccls}, {err_msg => ''});
      }
      $c->add_ccl($cd, $jccl, {});
  }
  
  sub clause_keys {
      my ($self, $cd) = @_;
      $self->_clause_keys_or_re_keys('keys', $cd);
  }
  
  sub clause_re_keys {
      my ($self, $cd) = @_;
      $self->_clause_keys_or_re_keys('re_keys', $cd);
  }
  
  sub clause_req_keys {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      # we assign to $h first to avoid variable clashing if $dt is '$_'.
  
      $c->add_module($cd, "List::Util");
      $c->add_ccl(
        $cd,
        "do { my \$h = $dt; !defined(List::Util::first(sub {!exists(\$h\->{\$_})}, \@{ $ct })) }",
        {
          err_msg => 'TMP',
          err_expr =>
            "sprintf(".
            $c->literal($c->_xlt($cd, "hash has missing required field(s) (%s)")).
            ",join(', ', do { my \$h = $dt; grep { !exists(\$h\->{\$_}) } \@{ $ct } }))"
        }
      );
  }
  
  sub clause_allowed_keys {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_module($cd, "List::Util");
      $c->add_smartmatch_pragma($cd);
      $c->add_ccl(
        $cd,
        "!defined(List::Util::first(sub {!(\$_ ~~ $ct)}, keys \%{ $dt }))",
        {
          err_msg => 'TMP',
          err_expr =>
            "sprintf(".
            $c->literal($c->_xlt($cd, "hash contains non-allowed field(s) (%s)")).
            ",join(', ', sort grep { !(\$_ ~~ $ct) } keys \%{ $dt }))"
        }
      );
  }
  
  sub clause_allowed_keys_re {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      #my $ct = $cd->{cl_term};
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          # i'm lazy atm and does not need expr yet
          $c->_die_unimplemented_clause($cd, "with expr");
      }
  
      my $re = $c->_str2reliteral($cd, $cv);
      $c->add_module($cd, "List::Util");
      $c->add_smartmatch_pragma($cd);
      $c->add_ccl(
          $cd,
          "!defined(List::Util::first(sub {\$_ !~ /$re/}, keys \%{ $dt }))",
          {
            err_msg => 'TMP',
            err_expr =>
            "sprintf(".
            $c->literal($c->_xlt($cd, "hash contains non-allowed field(s) (%s)")).
            ",join(', ', sort grep { \$_ !~ /$re/ } keys \%{ $dt }))"
        }
      );
  }
  
  sub clause_forbidden_keys {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_module($cd, "List::Util");
      $c->add_smartmatch_pragma($cd);
      $c->add_ccl(
        $cd,
        "!defined(List::Util::first(sub {\$_ ~~ $ct}, keys \%{ $dt }))",
        {
          err_msg => 'TMP',
          err_expr =>
            "sprintf(".
            $c->literal($c->_xlt($cd, "hash contains forbidden field(s) (%s)")).
            ",join(', ', sort grep { \$_ ~~ $ct } keys \%{ $dt }))"
        }
      );
  }
  
  sub clause_forbidden_keys_re {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      #my $ct = $cd->{cl_term};
      my $cv = $cd->{cl_value};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          # i'm lazy atm and does not need expr yet
          $c->_die_unimplemented_clause($cd, "with expr");
      }
  
      my $re = $c->_str2reliteral($cd, $cv);
      $c->add_module($cd, "List::Util");
      $c->add_smartmatch_pragma($cd);
      $c->add_ccl(
          $cd,
          "!defined(List::Util::first(sub {\$_ =~ /$re/}, keys \%{ $dt }))",
          {
            err_msg => 'TMP',
            err_expr =>
            "sprintf(".
            $c->literal($c->_xlt($cd, "hash contains forbidden field(s) (%s)")).
            ",join(', ', sort grep { \$_ =~ /$re/ } keys \%{ $dt }))"
        }
      );
  }
  
  1;
  # ABSTRACT: perl's type handler for type "hash"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::hash - perl's type handler for type "hash"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::hash (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_HASH

$fatpacked{"Data/Sah/Compiler/perl/TH/int.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_INT';
  package Data::Sah::Compiler::perl::TH::int;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH::num';
  with 'Data::Sah::Type::int';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $c->add_sun_module($cd);
      $cd->{_ccl_check_type} =
          "$cd->{_sun_module}::isint($dt)";
  }
  
  sub clause_div_by {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl($cd, "$dt % $ct == 0");
  }
  
  sub clause_mod {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl($cd, "$dt % $ct\->[0] == $ct\->[1]");
  }
  
  1;
  # ABSTRACT: perl's type handler for type "int"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::int - perl's type handler for type "int"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::int (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_INT

$fatpacked{"Data/Sah/Compiler/perl/TH/num.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_NUM';
  package Data::Sah::Compiler::perl::TH::num;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH';
  with 'Data::Sah::Type::num';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
      my $dt = $cd->{data_term};
  
      $c->add_sun_module($cd);
      $cd->{_ccl_check_type} = "$cd->{_sun_module}::isnum($dt)";
  }
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "$dt == $ct");
      } elsif ($which eq 'in') {
          $c->add_smartmatch_pragma($cd);
          $c->add_ccl($cd, "$dt ~~ $ct");
      }
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'min') {
          $c->add_ccl($cd, "$dt >= $ct");
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, "$dt > $ct");
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, "$dt <= $ct");
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, "$dt < $ct");
      } elsif ($which eq 'between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt >= $ct\->[0] && $dt <= $ct\->[1]");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt >= $cv->[0] && $dt <= $cv->[1]");
          }
      } elsif ($which eq 'xbetween') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt > $ct\->[0] && $dt < $ct\->[1]");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt > $cv->[0] && $dt < $cv->[1]");
          }
      }
  }
  
  1;
  # ABSTRACT: perl's type handler for type "num"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::num - perl's type handler for type "num"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::num (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_NUM

$fatpacked{"Data/Sah/Compiler/perl/TH/obj.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_OBJ';
  package Data::Sah::Compiler::perl::TH::obj;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH';
  with 'Data::Sah::Type::obj';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $c->add_module($cd, 'Scalar::Util');
      $cd->{_ccl_check_type} = "Scalar::Util::blessed($dt)";
  }
  
  sub clause_can {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl($cd, "$dt->can($ct)");
  }
  
  sub clause_isa {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->add_ccl($cd, "$dt->isa($ct)");
  }
  
  1;
  # ABSTRACT: perl's type handler for type "obj"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::obj - perl's type handler for type "obj"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::obj (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_OBJ

$fatpacked{"Data/Sah/Compiler/perl/TH/re.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_RE';
  package Data::Sah::Compiler::perl::TH::re;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH';
  with 'Data::Sah::Type::re';
  
  # XXX prefilter to convert string to regex object
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "ref($dt) eq 'Regexp' || !ref($dt) && ".
          "eval { my \$tmp = $dt; qr/\$tmp/; 1 }";
  }
  
  1;
  # ABSTRACT: perl's type handler for type "re"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::re - perl's type handler for type "re"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::re (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_RE

$fatpacked{"Data/Sah/Compiler/perl/TH/str.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_STR';
  package Data::Sah::Compiler::perl::TH::str;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH';
  with 'Data::Sah::Type::str';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "!ref($dt)";
  }
  
  sub superclause_comparable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'is') {
          $c->add_ccl($cd, "$dt eq $ct");
      } elsif ($which eq 'in') {
          $c->add_smartmatch_pragma($cd);
          $c->add_ccl($cd, "$dt ~~ $ct");
      }
  }
  
  sub superclause_sortable {
      my ($self, $which, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'min') {
          $c->add_ccl($cd, "$dt ge $ct");
      } elsif ($which eq 'xmin') {
          $c->add_ccl($cd, "$dt gt $ct");
      } elsif ($which eq 'max') {
          $c->add_ccl($cd, "$dt le $ct");
      } elsif ($which eq 'xmax') {
          $c->add_ccl($cd, "$dt lt $ct");
      } elsif ($which eq 'between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt ge $ct\->[0] && $dt le $ct\->[1]");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt ge ".$c->literal($cv->[0]).
                              " && $dt le ".$c->literal($cv->[1]));
          }
      } elsif ($which eq 'xbetween') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl($cd, "$dt gt $ct\->[0] && $dt lt $ct\->[1]");
          } else {
              # simplify code
              $c->add_ccl($cd, "$dt gt ".$c->literal($cv->[0]).
                              " && $dt lt ".$c->literal($cv->[1]));
          }
      }
  }
  
  sub superclause_has_elems {
      my ($self_th, $which, $cd) = @_;
      my $c  = $self_th->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($which eq 'len') {
          $c->add_ccl($cd, "length($dt) == $ct");
      } elsif ($which eq 'min_len') {
          $c->add_ccl($cd, "length($dt) >= $ct");
      } elsif ($which eq 'max_len') {
          $c->add_ccl($cd, "length($dt) <= $ct");
      } elsif ($which eq 'len_between') {
          if ($cd->{cl_is_expr}) {
              $c->add_ccl(
                  $cd, "length($dt) >= $ct\->[0] && ".
                      "length($dt) >= $ct\->[1]");
          } else {
              # simplify code
              $c->add_ccl(
                  $cd, "length($dt) >= $cv->[0] && ".
                      "length($dt) <= $cv->[1]");
          }
      } elsif ($which eq 'has') {
          $c->add_ccl($cd, "index($dt, $ct) >= 0");
      } elsif ($which eq 'each_index') {
          $self_th->gen_each($cd, "0..length($dt)-1", '_', '$_');
      } elsif ($which eq 'each_elem') {
          $self_th->gen_each($cd, "0..length($dt)-1", '_', "substr($dt, \$_, 1)");
      } elsif ($which eq 'check_each_index') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'check_each_elem') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'uniq') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      } elsif ($which eq 'exists') {
          $self_th->compiler->_die_unimplemented_clause($cd);
      }
  }
  
  sub clause_encoding {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      $c->_die($cd, "Only 'utf8' encoding is currently supported")
          unless $cv eq 'utf8';
      # currently does nothing
  }
  
  sub clause_match {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl($cd, join(
              "",
              "ref($ct) eq 'Regexp' ? $dt =~ $ct : ",
              "do { my \$re = $ct; eval { \$re = /\$re/; 1 } && ",
              "$dt =~ \$re }",
          ));
      } else {
          # simplify code and we can check regex at compile time
          my $re = $c->_str2reliteral($cd, $cv);
          $c->add_ccl($cd, "$dt =~ qr($re)");
      }
  }
  
  sub clause_is_re {
      my ($self, $cd) = @_;
      my $c  = $self->compiler;
      my $cv = $cd->{cl_value};
      my $ct = $cd->{cl_term};
      my $dt = $cd->{data_term};
  
      if ($cd->{cl_is_expr}) {
          $c->add_ccl($cd, join(
              "",
              "do { my \$re = $dt; ",
              "(eval { \$re = qr/\$re/; 1 } ? 1:0) == ($ct ? 1:0) }",
          ));
      } else {
          # simplify code
          $c->add_ccl($cd, join(
              "",
              "do { my \$re = $dt; ",
              ($cv ? "" : "!"), "(eval { \$re = qr/\$re/; 1 })",
              "}",
          ));
      }
  }
  
  1;
  # ABSTRACT: perl's type handler for type "str"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::str - perl's type handler for type "str"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::str (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_STR

$fatpacked{"Data/Sah/Compiler/perl/TH/undef.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_COMPILER_PERL_TH_UNDEF';
  package Data::Sah::Compiler::perl::TH::undef;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Mo qw(build default);
  use Role::Tiny::With;
  
  extends 'Data::Sah::Compiler::perl::TH';
  with 'Data::Sah::Type::undef';
  
  sub handle_type {
      my ($self, $cd) = @_;
      my $c = $self->compiler;
  
      my $dt = $cd->{data_term};
      $cd->{_ccl_check_type} = "!defined($dt)";
  }
  
  1;
  # ABSTRACT: perl's type handler for type "undef"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Compiler::perl::TH::undef - perl's type handler for type "undef"
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Compiler::perl::TH::undef (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|superclause_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_COMPILER_PERL_TH_UNDEF

$fatpacked{"Data/Sah/Human.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_HUMAN';
  package Data::Sah::Human;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any::IfLOG qw($log);
  
  our $Log_Validator_Code = $ENV{LOG_SAH_VALIDATOR_CODE} // 0;
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(gen_human_msg);
  
  sub gen_human_msg {
      require Data::Sah;
  
      my ($schema, $opts) = @_;
  
      state $hc = Data::Sah->new->get_compiler("human");
  
      my %args = (schema => $schema, %{$opts // {}});
      my $opt_source = delete $args{source};
  
      $args{log_result} = 1 if $Log_Validator_Code;
  
      my $cd = $hc->compile(%args);
      $opt_source ? $cd : $cd->{result};
  }
  
  1;
  # ABSTRACT: Some functions to use Data::Sah human compiler
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Human - Some functions to use Data::Sah human compiler
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Human (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 SYNOPSIS
  
   use Data::Sah::Human qw(gen_human_msg);
  
   say gen_human_msg(["int*", min=>2]); # -> "Integer, minimum 2"
  
  =head1 DESCRIPTION
  
  =head1 FUNCTIONS
  
  None exported by default.
  
  =head2 gen_human_msg($schema, \%opts) => STR (or ANY)
  
  Compile schema using human compiler and return the result.
  
  Known options (unknown ones will be passed to the compiler):
  
  =over
  
  =item * source => BOOL (default: 0)
  
  If set to true, will return raw compilation result.
  
  =back
  
  =head1 ENVIRONMENT
  
  L<LOG_SAH_VALIDATOR_CODE>
  
  =head1 SEE ALSO
  
  L<Data::Sah>, L<Data::Sah::Compiler::human>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_HUMAN

$fatpacked{"Data/Sah/JS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_JS';
  package Data::Sah::JS;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any qw($log);
  
  our $Log_Validator_Code = $ENV{LOG_SAH_VALIDATOR_CODE} // 0;
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(gen_validator);
  
  # check availability of the node.js executable, return the path to executable or
  # undef if none is available. node.js is normally installed as 'node', except on
  # debian ('nodejs').
  sub get_nodejs_path {
      require File::Which;
  
      my $path;
      for my $name (qw/nodejs node/) {
          $path = File::Which::which($name);
          next unless $path;
  
          # check if it's really nodejs
          my $cmd = "$path -e 'console.log(1+1)'";
          my $out = `$cmd`;
          if ($out =~ /\A2\n?\z/) {
              return $path;
          } else {
              #say "D:Output of $cmd: $out";
          }
      }
      return undef;
  }
  
  sub gen_validator {
      require Data::Sah;
  
      my ($schema, $opts) = @_;
  
      state $jsc = Data::Sah->new->get_compiler("js");
  
      my %args = (schema => $schema, %{$opts // {}});
      my $opt_source = delete $args{source};
  
      $args{log_result} = 1 if $Log_Validator_Code;
  
      my $v_src = $jsc->expr_validator_sub(%args);
      return $v_src if $opt_source;
  
      state $nodejs_path = get_nodejs_path();
      die "Can't find node.js in PATH" unless $nodejs_path;
  
  
      sub {
          require File::Temp;
          require JSON;
          #require String::ShellQuote;
  
          my $data = shift;
  
          state $json = JSON->new->allow_nonref;
  
          # code to be sent to nodejs
          my $src = "var validator = $v_src;\n\n".
              "console.log(JSON.stringify(validator(".
                  $json->encode($data).")))";
  
          my ($jsh, $jsfn) = File::Temp::tempfile();
          print $jsh $src;
          close($jsh) or die "Can't write JS code to file $jsfn: $!";
  
          my $cmd = "$nodejs_path $jsfn";
          my $out = `$cmd`;
          $json->decode($out);
      };
  }
  
  1;
  # ABSTRACT: Some functions to use JavaScript Sah validator code from Perl
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::JS - Some functions to use JavaScript Sah validator code from Perl
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::JS (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 SYNOPSIS
  
   use Data::Sah::JS qw(gen_validator);
  
   my $v = gen_validator(["int*", min=>1, max=>10]);
  
   # validate your data using the generated validator
   say "valid" if $v->(5);     # valid
   say "valid" if $v->(11);    # invalid
   say "valid" if $v->(undef); # invalid
   say "valid" if $v->("x");   # invalid
  
   # generate validator which reports error message string, in Indonesian
   my $v = gen_validator(["int*", min=>1, max=>10],
                         {return_type=>'str', lang=>'id_ID'});
   say $v->(5);  # ''
   say $v->(12); # 'Data tidak boleh lebih besar dari 10'
                 # (in English: 'Data must not be larger than 10')
  
  =head1 DESCRIPTION
  
  =for Pod::Coverage ^(get_nodejs_path)$
  
  =head1 FUNCTIONS
  
  None exported by default.
  
  =head2 gen_validator($schema, \%opts) => CODE (or STR)
  
  Generate validator code for C<$schema>. This is currently used for testing
  purposes only, as this will first generate JavaScript validator code, then
  generate a Perl coderef that will feed generated JavaScript validator code to a
  JavaScript engine (currently node.js) via command-line. Not exactly efficient.
  
  Known options (unknown options will be passed to JS schema compiler):
  
  =over
  
  =item * source => BOOL (default: 0)
  
  If set to 1, return JavaScript source code string instead of Perl coderef.
  Usually only needed for debugging (but see also
  C<$Data::Sah::Log_Validator_Code> and C<LOG_SAH_VALIDATOR_CODE> if you want to
  log validator source code).
  
  =back
  
  =head1 ENVIRONMENT
  
  L<LOG_SAH_VALIDATOR_CODE>
  
  =head1 SEE ALSO
  
  L<Data::Sah>, L<Data::Sah::Compiler::js>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_JS

$fatpacked{"Data/Sah/Lang.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_LANG';
  package Data::Sah::Lang;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  our @ISA    = qw(Exporter);
  our @EXPORT = qw(add_translations);
  
  sub add_translations {
      my %args = @_;
  
      # XXX check caller package and determine language, fill translations in
      # %Data::Sah::Lang::<lang>::translations
  }
  
  1;
  # ABSTRACT: Language routines
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Lang - Language routines
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Lang (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage add_translations
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_LANG

$fatpacked{"Data/Sah/Lang/fr_FR.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_LANG_FR_FR';
  package Data::Sah::Lang::fr_FR;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use Tie::IxHash;
  
  # currently incomplete
  
  our %translations;
  tie %translations, 'Tie::IxHash', (
  
      # punctuations
  
      q[ ], # inter-word boundary
      q[ ],
  
      q[, ],
      q[, ],
  
      q[: ],
      q[: ],
  
      q[. ],
      q[. ],
  
      q[(],
      q[(],
  
      q[)],
      q[)],
  
      # modal verbs
  
      q[must],
      q[doit],
  
      q[must not],
      q[ne doit pas],
  
      q[should],
      q[devrait],
  
      q[should not],
      q[ne devrait pas],
  
      # multi
  
      q[%s and %s],
      q[%s et %s],
  
      q[%s or %s],
      q[%s ou %s],
  
      q[one of %s],
      q[une des %s],
  
      q[all of %s],
      q[toutes les valeurs %s],
  
      q[%(modal_verb)s satisfy all of the following],
      q[%(modal_verb)s satisfaire Ã  toutes les conditions suivantes],
  
      q[%(modal_verb)s satisfy one of the following],
      q[%(modal_verb)s satisfaire l'une des conditions suivantes],
  
      q[%(modal_verb)s satisfy none of the following],
      q[%(modal_verb)s satisfaire Ã  aucune des conditions suivantes],
  
      # type: BaseType
  
      # type: Sortable
  
      # type: Comparable
  
      # type: HasElems
  
      # type: num
  
      # type: int
  
      q[integer],
      q[nombre entier],
  
      q[integers],
      q[nombres entiers],
  
      q[%(modal_verb)s be divisible by %s],
      q[%(modal_verb)s Ãªtre divisible par %s],
  
      q[%(modal_verb)s leave a remainder of %2$s when divided by %1$s],
      q[%(modal_verb)s laisser un reste %2$s si divisÃ© par %1$s],
  
  );
  
  1;
  # ABSTRACT: fr_FR locale
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Lang::fr_FR - fr_FR locale
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Lang::fr_FR (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage .+
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_LANG_FR_FR

$fatpacked{"Data/Sah/Lang/id_ID.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_LANG_ID_ID';
  package Data::Sah::Lang::id_ID;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use Tie::IxHash;
  
  sub ordinate {
      my ($n, $noun) = @_;
      "$noun ke-$n";
  }
  
  our %translations;
  tie %translations, 'Tie::IxHash', (
  
      # punctuations
  
      q[ ], # inter-word boundary
      q[ ],
  
      q[, ],
      q[, ],
  
      q[: ],
      q[: ],
  
      q[. ],
      q[. ],
  
      q[(],
      q[(],
  
      q[)],
      q[)],
  
      # modal verbs
  
      q[must],
      q[harus],
  
      q[must not],
      q[tidak boleh],
  
      q[should],
      q[sebaiknya],
  
      q[should not],
      q[sebaiknya tidak],
  
      # multi
  
      q[%s and %s],
      q[%s dan %s],
  
      q[%s or %s],
      q[%s atau %s],
  
      q[%s nor %s],
      q[%s maupun %s],
  
      q[one of %s],
      q[salah satu dari %s],
  
      q[all of %s],
      q[semua dari nilai-nilai %s],
  
      q[any of %s],
      q[satupun dari %s],
  
      q[none of %s],
      q[tak satupun dari %s],
  
      q[%(modal_verb)s satisfy all of the following],
      q[%(modal_verb)s memenuhi semua ketentuan ini],
  
      q[%(modal_verb)s satisfy none all of the following],
      q[%(modal_verb)s melanggar semua ketentuan ini],
  
      q[%(modal_verb)s satisfy one of the following],
      q[%(modal_verb)s memenuhi salah satu ketentuan ini],
  
      # type: BaseType
  
      q[default value is %s],
      q[jika tidak diisi diset ke %s],
  
      q[required %s],
      q[%s wajib diisi],
  
      q[optional %s],
      q[%s opsional],
  
      q[forbidden %s],
      q[%s tidak boleh diisi],
  
      # type: Comparable
  
      q[%(modal_verb)s have the value %s],
      q[%(modal_verb)s bernilai %s],
  
      q[%(modal_verb)s be one of %s],
      q[%(modal_verb)s salah satu dari %s],
  
      # type: HasElems
  
      q[length %(modal_verb)s be %s],
      q[panjang %(modal_verb)s %s],
  
      q[length %(modal_verb)s be at least %s],
      q[panjang %(modal_verb)s minimal %s],
  
      q[length %(modal_verb)s be at most %s],
      q[panjang %(modal_verb)s maksimal %s],
  
      q[length %(modal_verb)s be between %s and %s],
      q[panjang %(modal_verb)s antara %s dan %s],
  
      q[%(modal_verb)s have %s in its elements],
      q[%(modal_verb)s mengandung %s di elemennya],
  
      # type: Sortable
  
      q[%(modal_verb)s be at least %s],
      q[%(modal_verb)s minimal %s],
  
      q[%(modal_verb)s be larger than %s],
      q[%(modal_verb)s lebih besar dari %s],
  
      q[%(modal_verb)s be at most %s],
      q[%(modal_verb)s maksimal %s],
  
      q[%(modal_verb)s be smaller than %s],
      q[%(modal_verb)s lebih kecil dari %s],
  
      q[%(modal_verb)s be between %s and %s],
      q[%(modal_verb)s antara %s dan %s],
  
      q[%(modal_verb)s be larger than %s and smaller than %s],
      q[%(modal_verb)s lebih besar dari %s dan lebih kecil dari %s],
  
      # type: undef
  
      q[undefined value],
      q[nilai tak terdefinisi],
  
      q[undefined values],
      q[nilai tak terdefinisi],
  
      # type: all
  
      q[%(modal_verb)s be %s],
      q[%(modal_verb)s %s],
  
      q[as well as %s],
      q[juga %s],
  
      q[%(modal_verb)s be all of the following],
      q[%(modal_verb)s merupakan semua ini],
  
      # type: any
  
      q[%(modal_verb)s be either %s],
      q[%s],
  
      q[or %s],
      q[atau %s],
  
      q[%(modal_verb)s be one of the following],
      q[%(modal_verb)s merupakan salah satu dari],
  
      # type: array
  
      q[array],
      q[larik],
  
      q[arrays],
      q[larik],
  
      q[%s of %s],
      q[%s %s],
  
      q[each array element %(modal_verb)s be],
      q[setiap elemen larik %(modal_verb)s],
  
      q[%s %(modal_verb)s be],
      q[%s %(modal_verb)s],
  
      q[element],
      q[elemen],
  
      q[each array subscript %(modal_verb)s be],
      q[setiap subskrip larik %(modal_verb)s],
  
      # type: bool
  
      q[boolean value],
      q[nilai boolean],
  
      q[boolean values],
      q[nilai boolean],
  
      q[%(modal_verb)s be true],
      q[%(modal_verb)s bernilai benar],
  
      q[%(modal_verb)s be false],
      q[%(modal_verb)s bernilai salah],
  
      # type: code
  
      q[code],
      q[kode],
  
      q[codes],
      q[kode],
  
      # type: float
  
      q[decimal number],
      q[bilangan desimal],
  
      q[decimal numbers],
      q[bilangan desimal],
  
      q[%(modal_verb)s be a NaN],
      q[%(modal_verb)s NaN],
  
      q[%(modal_verb_neg)s be a NaN],
      q[%(modal_verb_neg)s NaN],
  
      q[%(modal_verb)s be an infinity],
      q[%(modal_verb)s tak hingga],
  
      q[%(modal_verb_neg)s be an infinity],
      q[%(modal_verb_neg)s tak hingga],
  
      q[%(modal_verb)s be a positive infinity],
      q[%(modal_verb)s positif tak hingga],
  
      q[%(modal_verb_neg)s be a positive infinity],
      q[%(modal_verb_neg)s positif tak hingga],
  
      q[%(modal_verb)s be a negative infinity],
      q[%(modal_verb)s negatif tak hingga],
  
      q[%(modal_verb)s be a negative infinity],
      q[%(modal_verb)s negatif tak hingga],
  
      # type: hash
  
      q[hash],
      q[hash],
  
      q[hashes],
      q[hash],
  
      q[field %s %(modal_verb)s be],
      q[field %s %(modal_verb)s],
  
      q[field name %(modal_verb)s be],
      q[nama field %(modal_verb)s],
  
      q[each field %(modal_verb)s be],
      q[setiap field %(modal_verb)s],
  
      q[hash contains unknown field(s) (%s)],
      q[hash mengandung field yang tidak dikenali (%s)],
  
      q[hash contains unknown field(s) (%s)],
      q[hash mengandung field yang tidak dikenali (%s)],
  
      q[%(modal_verb)s have required fields %s],
      q[%(modal_verb)s mengandung field wajib %s],
  
      q[hash has missing required field(s) (%s)],
      q[hash kekurangan field wajib (%s)],
  
      q[%(modal_verb)s have %s in its field values],
      q[%(modal_verb)s mengandung %s di nilai field],
  
      q[%(modal_verb)s only have these allowed fields %s],
      q[%(modal_verb)s hanya mengandung field yang diizinkan %s],
  
      q[%(modal_verb)s only have fields matching regex pattern %s],
      q[%(modal_verb)s hanya mengandung field yang namanya mengikuti pola regex %s],
  
      q[%(modal_verb_neg)s have these forbidden fields %s],
      q[%(modal_verb_neg)s mengandung field yang dilarang %s],
  
      q[%(modal_verb_neg)s have fields matching regex pattern %s],
      q[%(modal_verb_neg)s mengandung field yang namanya mengikuti pola regex %s],
  
      q[hash contains non-allowed field(s) (%s)],
      q[hash mengandung field yang tidak diizinkan (%s)],
  
      q[hash contains forbidden field(s) (%s)],
      q[hash mengandung field yang dilarang (%s)],
  
      q[fields whose names match regex pattern %s %(modal_verb)s be],
      q[field yang namanya cocok dengan pola regex %s %(modal_verb)s],
  
      # type: int
  
      q[integer],
      q[bilangan bulat],
  
      q[integers],
      q[bilangan bulat],
  
      q[%(modal_verb)s be divisible by %s],
      q[%(modal_verb)s dapat dibagi oleh %s],
  
      q[%(modal_verb)s be odd],
      q[%(modal_verb)s ganjil],
  
      q[%(modal_verb)s be even],
      q[%(modal_verb)s genap],
  
      q[%(modal_verb)s leave a remainder of %2$s when divided by %1$s],
      q[jika dibagi %1$s %(modal_verb)s menyisakan %2$s],
  
      # type: num
  
      q[number],
      q[bilangan],
  
      q[numbers],
      q[bilangan],
  
      # type: obj
  
      q[object],
      q[objek],
  
      q[objects],
      q[objek],
  
      # type: re
  
      q[regex pattern],
      q[pola regex],
  
      q[regex patterns],
      q[pola regex],
  
      # type: str
  
      q[text],
      q[teks],
  
      q[texts],
      q[teks],
  
      q[%(modal_verb)s match regex pattern %s],
      q[%(modal_verb)s cocok dengan pola regex %s],
  
      q[%(modal_verb)s be a regex pattern],
      q[%(modal_verb)s pola regex],
  
      q[each subscript of text %(modal_verb)s be],
      q[setiap subskrip dari teks %(modal_verb)s],
  
      q[each character of the text %(modal_verb)s be],
      q[setiap karakter dari teks %(modal_verb)s],
  
      q[character],
      q[karakter],
  
      # type: cistr
  
      # type: buf
  
      q[buffer],
      q[buffer],
  
      q[buffers],
      q[buffer],
  
      # messages for compiler
  
      q[Does not satisfy the following schema: %s],
      q[Tidak memenuhi skema ini: %s],
  
      q[Not of type %s],
      q[Tidak bertipe %s],
  
      q[Required but not specified],
      q[Wajib tapi belum diisi],
  
      q[Forbidden but specified],
      q[Dilarang tapi diisi],
  
      q[Structure contains unknown field(s) [%%s]],
      q[Struktur mengandung field yang tidak dikenal [%%s]],
  
  );
  
  1;
  # ABSTRACT: id_ID locale
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Lang::id_ID - id_ID locale
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Lang::id_ID (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage .+
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_LANG_ID_ID

$fatpacked{"Data/Sah/Lang/zh_CN.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_LANG_ZH_CN';
  package Data::Sah::Lang::zh_CN;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use Tie::IxHash;
  
  # currently incomplete
  
  our %translations;
  tie %translations, 'Tie::IxHash', (
  
      # punctuations
  
      q[ ], # inter-word boundary
      q[],
  
      q[, ],
      q[ï¼],
  
      q[: ],
      q[ï¼],
  
      q[. ],
      q[ã],
  
      q[(],
      q[ï¼],
  
      q[)],
      q[ï¼],
  
      # modal verbs
  
      q[must],
      q[å¿é¡»],
  
      q[must not],
      q[å¿é¡»ä¸],
  
      q[should],
      q[åº],
  
      q[should not],
      q[åºä¸],
  
      # multi
  
      q[%s and %s],
      q[%så%s],
  
      q[%s or %s],
      q[%sæ%s],
  
      q[one of %s],
      q[è¿äºå¼%sä¹ä¸],
  
      q[all of %s],
      q[ææè¿äºå¼%s],
  
      q[%(modal_verb)s satisfy all of the following],
      q[%(modal_verb)sæ»¡è¶³ææè¿äºæ¡ä»¶],
  
      q[%(modal_verb)s satisfy one of the following],
      q[%(modal_verb)sæ»¡è¶³è¿äºæ¡ä»¶ä¹ä¸],
  
      q[%(modal_verb)s satisfy none of the following],
      q[%(modal_verb_neg)sæ»¡è¶³ææè¿äºæ¡ä»¶],
  
      # type: BaseType
  
      # type: Sortable
  
      # type: Comparable
  
      # type: HasElems
  
      # type: num
  
      # type: int
  
      q[integer],
      q[æ´æ°],
  
      q[integers],
      q[æ´æ°],
  
      q[%(modal_verb)s be divisible by %s],
      q[%(modal_verb)sè¢«%sæ´é¤],
  
      q[%(modal_verb)s leave a remainder of %2$s when divided by %1$s],
      q[é¤ä»¥%1$sæ¶ä½æ°%(modal_verb)sä¸º%2$s],
  
  );
  
  1;
  # ABSTRACT: zh_CN locale
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Lang::zh_CN - zh_CN locale
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Lang::zh_CN (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage .+
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_LANG_ZH_CN

$fatpacked{"Data/Sah/Normalize.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_NORMALIZE';
  package Data::Sah::Normalize;
  
  use 5.010001;
  use strict;
  use warnings;
  
  our $DATE = '2014-07-08'; # DATE
  our $VERSION = '0.01'; # VERSION
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(
                         normalize_clset
                         normalize_schema
  
                         $type_re
                         $clause_name_re
                         $clause_re
                         $attr_re
                         $funcset_re
                         $compiler_re
                 );
  
  our $type_re        = qr/\A(?:[A-Za-z_]\w*::)*[A-Za-z_]\w*\z/;
  our $clause_name_re = qr/\A[A-Za-z_]\w*\z/;
  our $clause_re      = qr/\A[A-Za-z_]\w*(?:\.[A-Za-z_]\w*)*\z/;
  our $attr_re        = $clause_re;
  our $funcset_re     = qr/\A(?:[A-Za-z_]\w*::)*[A-Za-z_]\w*\z/;
  our $compiler_re    = qr/\A[A-Za-z_]\w*\z/;
  our $clause_attr_on_empty_clause_re = qr/\A(?:\.[A-Za-z_]\w*)+\z/;
  
  sub normalize_clset {
      my ($clset0, $opts) = @_;
      $opts //= {};
  
      my $clset = {};
      for my $c (sort keys %$clset0) {
          my $c0 = $c;
  
          my $v = $clset0->{$c};
  
          # ignore expression
          my $expr;
          if ($c =~ s/=\z//) {
              $expr++;
              # XXX currently can't disregard merge prefix when checking
              # conflict
              die "Conflict between '$c=' and '$c'" if exists $clset0->{$c};
              $clset->{"$c.is_expr"} = 1;
              }
  
          my $sc = "";
          my $cn;
          {
              my $errp = "Invalid clause name syntax '$c0'"; # error prefix
              if (!$expr && $c =~ s/\A!(?=.)//) {
                  die "$errp, syntax should be !CLAUSE"
                      unless $c =~ $clause_name_re;
                  $sc = "!";
              } elsif (!$expr && $c =~ s/(?<=.)\|\z//) {
                  die "$errp, syntax should be CLAUSE|"
                      unless $c =~ $clause_name_re;
                  $sc = "|";
              } elsif (!$expr && $c =~ s/(?<=.)\&\z//) {
                  die "$errp, syntax should be CLAUSE&"
                      unless $c =~ $clause_name_re;
                  $sc = "&";
              } elsif (!$expr && $c =~ /\A([^.]+)(?:\.(.+))?\((\w+)\)\z/) {
                  my ($c2, $a, $lang) = ($1, $2, $3);
                  die "$errp, syntax should be CLAUSE(LANG) or C.ATTR(LANG)"
                      unless $c2 =~ $clause_name_re &&
                          (!defined($a) || $a =~ $attr_re);
                  $sc = "(LANG)";
                  $cn = $c2 . (defined($a) ? ".$a" : "") . ".alt.lang.$lang";
              } elsif ($c !~ $clause_re &&
                           $c !~ $clause_attr_on_empty_clause_re) {
                  die "$errp, please use letter/digit/underscore only";
              }
          }
  
          # XXX can't disregard merge prefix when checking conflict
          if ($sc eq '!') {
              die "Conflict between clause shortcuts '!$c' and '$c'"
                  if exists $clset0->{$c};
              die "Conflict between clause shortcuts '!$c' and '$c|'"
                  if exists $clset0->{"$c|"};
              die "Conflict between clause shortcuts '!$c' and '$c&'"
                  if exists $clset0->{"$c&"};
              $clset->{$c} = $v;
              $clset->{"$c.op"} = "not";
          } elsif ($sc eq '&') {
              die "Conflict between clause shortcuts '$c&' and '$c'"
                  if exists $clset0->{$c};
              die "Conflict between clause shortcuts '$c&' and '$c|'"
                  if exists $clset0->{"$c|"};
              die "Clause 'c&' value must be an array"
                  unless ref($v) eq 'ARRAY';
              $clset->{$c} = $v;
              $clset->{"$c.op"} = "and";
          } elsif ($sc eq '|') {
              die "Conflict between clause shortcuts '$c|' and '$c'"
                  if exists $clset0->{$c};
              die "Clause 'c|' value must be an array"
                  unless ref($v) eq 'ARRAY';
              $clset->{$c} = $v;
              $clset->{"$c.op"} = "or";
          } elsif ($sc eq '(LANG)') {
              die "Conflict between clause '$c' and '$cn'"
                  if exists $clset0->{$cn};
              $clset->{$cn} = $v;
          } else {
              $clset->{$c} = $v;
          }
  
      }
      $clset->{req} = 1 if $opts->{has_req};
  
      # XXX option to recursively normalize clset, any's of, all's of, ...
      #if ($clset->{clset}) {
      #    local $opts->{has_req};
      #    if ($clset->{'clset.op'} && $clset->{'clset.op'} =~ /and|or/) {
      #        # multiple clause sets
      #        $clset->{clset} = map { $self->normalize_clset($_, $opts) }
      #            @{ $clset->{clset} };
      #    } else {
      #        $clset->{clset} = $self->normalize_clset($_, $opts);
      #    }
      #}
  
      $clset;
  }
  
  sub normalize_schema {
      my ($s) = @_;
  
      my $ref = ref($s);
      if (!defined($s)) {
  
          die "Schema is missing";
  
      } elsif (!$ref) {
  
          my $has_req = $s =~ s/\*\z//;
          $s =~ $type_re or die "Invalid type syntax $s, please use ".
              "letter/digit/underscore only";
          return [$s, $has_req ? {req=>1} : {}, {}];
  
      } elsif ($ref eq 'ARRAY') {
  
          my $t = $s->[0];
          my $has_req = $t && $t =~ s/\*\z//;
          if (!defined($t)) {
              die "For array form, at least 1 element is needed for type";
          } elsif (ref $t) {
              die "For array form, first element must be a string";
          }
          $t =~ $type_re or die "Invalid type syntax $s, please use ".
              "letter/digit/underscore only";
  
          my $clset0;
          my $extras;
          if (defined($s->[1])) {
              if (ref($s->[1]) eq 'HASH') {
                  $clset0 = $s->[1];
                  $extras = $s->[2];
                  die "For array form, there should not be more than 3 elements"
                      if @$s > 3;
              } else {
                  # flattened clause set [t, c=>1, c2=>2, ...]
                  die "For array in the form of [t, c1=>1, ...], there must be ".
                      "3 elements (or 5, 7, ...)"
                          unless @$s % 2;
                  $clset0 = { @{$s}[1..@$s-1] };
              }
          } else {
              $clset0 = {};
          }
  
          # check clauses and parse shortcuts (!c, c&, c|, c=)
          my $clset = normalize_clset($clset0, {has_req=>$has_req});
          if (defined $extras) {
              die "For array form with 3 elements, extras must be hash"
                  unless ref($extras) eq 'HASH';
              die "'def' in extras must be a hash"
                  if exists $extras->{def} && ref($extras->{def}) ne 'HASH';
              return [$t, $clset, { %{$extras} }];
          } else {
              return [$t, $clset, {}];
          }
      }
  
      die "Schema must be a string or arrayref (not $ref)";
  }
  
  1;
  # ABSTRACT: Normalize Sah schema
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Normalize - Normalize Sah schema
  
  =head1 VERSION
  
  This document describes version 0.01 of Data::Sah::Normalize (from Perl distribution Data-Sah-Normalize), released on 2014-07-08.
  
  =head1 SYNOPSIS
  
   use Data::Sah::Normalize qw(normalize_clset normalize_schema);
  
   my $nclset = normalize_clset({'!a'=>1}); # -> {a=>1, 'a.op'=>'not'}
   my $nsch   = normalize_schema("int");    # -> ["int", {}, {}]
  
  =head1 DESCRIPTION
  
  This often-needed functionality is split from the main L<Data::Sah> to keep it
  in a small and minimal-dependencies package.
  
  =head1 FUNCTIONS
  
  =head2 normalize_clset($clset) => HASH
  
  Normalize a clause set (hash). Return a shallow copy of the original hash. Die
  on failure.
  
  TODO: option to recursively normalize clause which contains sah clauses (e.g.
  C<of>).
  
  =head2 normalize_schema($sch) => ARRAY
  
  Normalize a Sah schema (scalar or array). Return an array. Produce a 2-level
  copy of schema, so it's safe to add/delete/modify the normalized schema's clause
  set and extras (but clause set's and extras' values are still references to the
  original). Die on failure.
  
  TODO: recursively normalize clause which contains sah clauses (e.g. C<of>).
  
  =head1 SEE ALSO
  
  L<Sah>, L<Data::Sah>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah-Normalize>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Data-Sah-Normalize>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah-Normalize>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  Steven Haryanto <stevenharyanto@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Steven Haryanto.
  
  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
DATA_SAH_NORMALIZE

$fatpacked{"Data/Sah/Type/BaseType.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_BASETYPE';
  package Data::Sah::Type::BaseType;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  # why name it BaseType instead of Base? because I'm sick of having 5 files named
  # Base.pm in my editor (there would be Type::Base and the various
  # Compiler::*::Type::Base).
  
  use 5.010;
  use strict;
  use warnings;
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  #use Sah::Schema::Common;
  #use Sah::Schema::Sah;
  
  requires 'handle_type';
  
  has_clause 'v',
      prio=>0, tags=>['meta', 'defhash'],
      arg=>['int*'=>{is=>1}];
  
  #has_clause 'defhash_v';
  
  #has_clause 'schema_v';
  
  #has_clause 'base_v';
  
  has_clause 'ok',
      tags       => ['constraint'],
      prio       => 1,
      arg        => 'any',
      allow_expr => 1,
      ;
  has_clause 'default',
      prio       => 1,
      tags       => [],
      arg        => 'any',
      allow_expr => 1,
      attrs      => {
          temp => {
              arg        => [bool => default=>0],
              allow_expr => 0,
          },
      },
      ;
  # has_clause 'prefilters',
  #     tags       => ['filter'],
  #     prio       => 10,
  #     arg        => ['array*' => of=>'expr*'],
  #     attrs      => {
  #         temp => {
  #         },
  #     }
  #     ;
  has_clause 'default_lang',
      tags       => ['meta', 'defhash'],
      prio       => 2,
      arg        => ['str*'=>{default=>'en_US'}],
      ;
  has_clause 'name',
      tags       => ['meta', 'defhash'],
      prio       => 2,
      arg        => 'str*'
      ;
  has_clause 'summary',
      prio       => 2,
      tags       => ['meta', 'defhash'],
      arg        => 'str*',
      ;
  has_clause 'description',
      tags       => ['meta', 'defhash'],
      prio       => 2,
      arg        => 'str*',
      ;
  has_clause 'tags',
      tags       => ['meta', 'defhash'],
      prio       => 2,
      arg        => ['array*', of=>'str*'],
      ;
  has_clause 'req',
      tags       => ['constraint'],
      prio       => 3,
      arg        => 'bool',
      allow_expr => 1,
      ;
  has_clause 'forbidden',
      tags       => ['constraint'],
      prio       => 3,
      arg        => 'bool',
      allow_expr => 1,
      ;
  #has_clause 'if', tags=>['constraint'];
  
  #has_clause 'each', tags=>['constraint'];
  
  #has_clause 'check_each', tags=>['constraint'];
  
  #has_clause 'exists', tags=>['constraint'];
  
  #has_clause 'check_exists', tags=>['constraint'];
  
  #has_clause 'check', arg=>'expr*', tags=>['constraint'];
  
  has_clause 'clause',
      tags       => ['constraint'],
      prio       => 50,
      arg        => ['array*' => elems => ['clname*', 'any']],
      ;
  has_clause 'clset',
      prio=>50, tags=>['constraint'],
      arg=>['clset*']
      ;
  # has_clause 'postfilters',
  #     tags       => ['filter'],
  #     prio       => 90,
  #     arg        => ['array*' => of=>'expr*'],
  #     attrs      => {
  #         temp => {
  #         },
  #     }
  #     ;
  
  1;
  # ABSTRACT: Base type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::BaseType - Base type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::BaseType (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_BASETYPE

$fatpacked{"Data/Sah/Type/Comparable.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_COMPARABLE';
  package Data::Sah::Type::Comparable;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  
  requires 'superclause_comparable';
  
  has_clause 'in',
      tags       => ['constraint'],
      arg        => '(any[])*',
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_comparable('in', $cd);
      };
  has_clause 'is',
      tags       => ['constraint'],
      arg        => 'any',
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_comparable('is', $cd);
      };
  
  1;
  # ABSTRACT: Comparable type role
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::Comparable - Comparable type role
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::Comparable (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 DESCRIPTION
  
  Role consumer must provide method C<superclause_comparable> which will be given
  normal C<%args> given to clause methods, but with extra key C<-which> (either
  C<in>, C<is>).
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_COMPARABLE

$fatpacked{"Data/Sah/Type/HasElems.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_HASELEMS';
  package Data::Sah::Type::HasElems;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  
  requires 'superclause_has_elems';
  
  has_clause 'max_len',
      prio       => 51,
      arg        => ['int*' => {min=>0}],
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('max_len', $cd);
      };
  
  has_clause 'min_len',
      arg        => ['int*' => {min=>0}],
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('min_len', $cd);
      };
  
  has_clause 'len_between',
      arg        => ['array*' => {elems => ['int*', 'int*']}],
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('len_between', $cd);
      };
  
  has_clause 'len',
      arg        => ['int*' => {min=>0}],
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('len', $cd);
      };
  
  has_clause 'has',
      arg        => 'any',
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('has', $cd);
      };
  
  has_clause 'each_index',
      arg        => 'schema*',
      allow_expr => 0,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('each_index', $cd);
      };
  
  has_clause 'each_elem',
      arg        => 'schema*',
      allow_expr => 0,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('each_elem', $cd);
      };
  
  has_clause 'check_each_index',
      arg        => 'schema*',
      allow_expr => 0,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('check_each_index', $cd);
      };
  
  has_clause 'check_each_elem',
      arg        => 'schema*',
      allow_expr => 0,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('check_each_elem', $cd);
      };
  
  has_clause 'uniq',
      arg        => 'schema*',
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('uniq', $cd);
      };
  
  has_clause 'exists',
      arg        => 'schema*',
      allow_expr => 0,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_has_elems('exists', $cd);
      };
  
  # has_prop 'len';
  
  # has_prop 'elems';
  
  # has_prop 'indices';
  
  1;
  # ABSTRACT: HasElems role
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::HasElems - HasElems role
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::HasElems (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_HASELEMS

$fatpacked{"Data/Sah/Type/Sortable.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_SORTABLE';
  package Data::Sah::Type::Sortable;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  
  requires 'superclause_sortable';
  
  has_clause 'min',
      tags       => ['constraint'],
      arg        => 'any*',
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_sortable('min', $cd);
      },
      ;
  has_clause 'xmin',
      tags       => ['constraint'],
      arg        => 'any*',
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_sortable('xmin', $cd);
      },
      ;
  has_clause 'max',
      prio       => 51,
      tags       => ['constraint'],
      arg        => 'any*',
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_sortable('max', $cd);
      },
      ;
  has_clause 'xmax',
      prio       => 51,
      tags       => ['constraint'],
      arg        => 'any*',
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_sortable('xmax', $cd);
      },
      ;
  has_clause 'between',
      tags       => ['constraint'],
      arg        => '[any*, any*]*',
      allow_expr => 1,
      code       => sub {
          my ($self, $cd) = @_;
          $self->superclause_sortable('between', $cd);
      },
      ;
  has_clause 'xbetween',
      tags       => ['constraint'],
      arg        => '[any*, any*]*',
      allow_expr => 1,
      code => sub {
          my ($self, $cd) = @_;
          $self->superclause_sortable('xbetween', $cd);
      },
      ;
  
  1;
  # ABSTRACT: Role for sortable types
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::Sortable - Role for sortable types
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::Sortable (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 DESCRIPTION
  
  Role consumer must provide method C<superclause_sortable> which will receive the
  same C<%args> as clause methods, but with additional key: C<-which> (either
  C<min>, C<max>, C<xmin>, C<xmax>, C<between>, C<xbetween>).
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_SORTABLE

$fatpacked{"Data/Sah/Type/all.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_ALL';
  package Data::Sah::Type::all;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  
  has_clause 'of',
      tags       => ['constraint'],
      arg        => ['array*' => {min_len=>1, each_elem => 'schema*'}],
      allow_expr => 0,
      ;
  
  1;
  # ABSTRACT: all type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::all - all type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::all (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_ALL

$fatpacked{"Data/Sah/Type/any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_ANY';
  package Data::Sah::Type::any;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  
  has_clause 'of',
      tags       => ['constraint'],
      arg        => ['array*' => {min_len=>1, each_elem => 'schema*'}],
      allow_expr => 0,
      ;
  
  1;
  # ABSTRACT: any type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::any - any type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::any (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_ANY

$fatpacked{"Data/Sah/Type/array.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_ARRAY';
  package Data::Sah::Type::array;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause', 'has_clause_alias';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  with 'Data::Sah::Type::Comparable';
  with 'Data::Sah::Type::HasElems';
  
  has_clause 'elems',
      tags       => ['constraint'],
      arg        => ['array*' => {of=>'schema*'}],
      allow_expr => 0,
      attrs      => {
          create_default => {
              arg        => [bool => default=>1],
              allow_expr => 0, # TODO
          },
      },
      ;
  has_clause_alias each_elem => 'of';
  
  1;
  # ABSTRACT: array type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::array - array type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::array (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_ARRAY

$fatpacked{"Data/Sah/Type/bool.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_BOOL';
  package Data::Sah::Type::bool;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  with 'Data::Sah::Type::Comparable';
  with 'Data::Sah::Type::Sortable';
  
  has_clause 'is_true',
      tags       => ['constraint'],
      arg        => 'bool',
      allow_expr => 1,
      ;
  
  1;
  # ABSTRACT: bool type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::bool - bool type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::bool (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_BOOL

$fatpacked{"Data/Sah/Type/buf.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_BUF';
  package Data::Sah::Type::buf;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::str';
  
  1;
  # ABSTRACT: buf type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::buf - buf type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::buf (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_BUF

$fatpacked{"Data/Sah/Type/cistr.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_CISTR';
  package Data::Sah::Type::cistr;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::str';
  
  1;
  # ABSTRACT: cistr type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::cistr - cistr type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::cistr (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_CISTR

$fatpacked{"Data/Sah/Type/code.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_CODE';
  package Data::Sah::Type::code;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  
  1;
  # ABSTRACT: code type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::code - code type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::code (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_CODE

$fatpacked{"Data/Sah/Type/date.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_DATE';
  package Data::Sah::Type::date;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  with 'Data::Sah::Type::Comparable';
  with 'Data::Sah::Type::Sortable';
  
  # XXX prop: year
  # XXX prop: quarter (1-4)
  # XXX prop: month
  # XXX prop: day
  # XXX prop: day_of_month
  # XXX prop: hour
  # XXX prop: minute
  # XXX prop: second
  # XXX prop: millisecond
  # XXX prop: microsecond
  # XXX prop: nanosecond
  # XXX prop: day_of_week
  # XXX prop: day_of_quarter
  # XXX prop: day_of_year
  # XXX prop: week_of_month
  # XXX prop: week_of_year
  # XXX prop: date?
  # XXX prop: time?
  # XXX prop: time_zone_long_name
  # XXX prop: time_zone_offset
  # XXX prop: is_leap_year
  
  1;
  # ABSTRACT: date type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::date - date type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::date (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_DATE

$fatpacked{"Data/Sah/Type/float.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_FLOAT';
  package Data::Sah::Type::float;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::num';
  
  has_clause 'is_nan',
      tags        => ['constraint'],
      arg         => ['bool'],
      allow_expr  => 1,
      allow_multi => 0,
      ;
  
  has_clause 'is_inf',
      tags        => ['constraint'],
      arg         => ['bool'],
      allow_expr  => 1,
      allow_multi => 1,
      ;
  
  has_clause 'is_pos_inf',
      tags        => ['constraint'],
      arg         => ['bool'],
      allow_expr  => 1,
      allow_multi => 1,
      ;
  
  has_clause 'is_neg_inf',
      tags        => ['constraint'],
      arg         => ['bool'],
      allow_expr  => 1,
      allow_multi => 1,
      ;
  
  1;
  # ABSTRACT: float type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::float - float type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::float (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_FLOAT

$fatpacked{"Data/Sah/Type/hash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_HASH';
  package Data::Sah::Type::hash;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause', 'has_clause_alias';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  with 'Data::Sah::Type::Comparable';
  with 'Data::Sah::Type::HasElems';
  
  has_clause_alias each_elem => 'of';
  
  has_clause "keys",
      tags       => ['constraint'],
      arg        => ['hash*' => {values => 'schema*'}],
      allow_expr => 0,
      attrs      => {
          restrict => {
              arg        => [bool => default=>1],
              allow_expr => 0, # TODO
          },
          create_default => {
              arg        => [bool => default=>1],
              allow_expr => 0, # TODO
          },
      },
      ;
  has_clause "re_keys",
      prio       => 51,
      tags       => ['constraint'],
      arg        => ['hash*' => {keys => 're*', values => 'schema*'}],
      allow_expr => 0,
      attrs      => {
          restrict => {
              arg        => [bool => default=>1],
              allow_expr => 0, # TODO
          },
      },
      ;
  has_clause "req_keys",
      tags       => ['constraint'],
      arg        => ['array*'],
      allow_expr => 1,
      ;
  has_clause "allowed_keys",
      tags       => ['constraint'],
      arg        => ['array*'],
      allow_expr => 1,
      ;
  has_clause "allowed_keys_re",
      prio       => 51,
      tags       => ['constraint'],
      arg        => 're*',
      allow_expr => 1,
      ;
  has_clause "forbidden_keys",
      tags       => ['constraint'],
      arg        => ['array*'],
      allow_expr => 1,
      ;
  has_clause "forbidden_keys_re",
      prio       => 51,
      tags       => ['constraint'],
      arg        => 're*',
      allow_expr => 1,
      ;
  has_clause_alias each_index => 'each_key';
  has_clause_alias each_elem => 'each_value';
  has_clause_alias check_each_index => 'check_each_key';
  has_clause_alias check_each_elem => 'check_each_value';
  
  # prop_alias indices => 'keys'
  
  # prop_alias elems => 'values'
  
  1;
  # ABSTRACT: hash type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::hash - hash type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::hash (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_HASH

$fatpacked{"Data/Sah/Type/int.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_INT';
  package Data::Sah::Type::int;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::num';
  
  has_clause 'mod',
      tags       => ['constraint'],
      arg        => ['array*' => {elems => [['int*' => {'!is'=>0}], 'int*']}],
      allow_expr => 1,
      ;
  has_clause 'div_by',
      tags       => ['constraint'],
      arg        => ['int*' => {'!is'=>0}],
      allow_expr => 1,
      ;
  
  1;
  # ABSTRACT: int type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::int - int type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::int (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_INT

$fatpacked{"Data/Sah/Type/num.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_NUM';
  package Data::Sah::Type::num;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  with 'Data::Sah::Type::Comparable';
  with 'Data::Sah::Type::Sortable';
  
  1;
  # ABSTRACT: num type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::num - num type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::num (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_NUM

$fatpacked{"Data/Sah/Type/obj.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_OBJ';
  package Data::Sah::Type::obj;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  
  has_clause 'can',
      tags       => ['constraint'],
      arg        => 'str*', # XXX perl_method_name
      allow_expr => 1,
      ;
  has_clause 'isa',
      tags       => ['constraint'],
      arg        => 'str*', # XXX perl_class_name
      allow_expr => 1,
      ;
  
  1;
  # ABSTRACT: obj type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::obj - obj type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::obj (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_OBJ

$fatpacked{"Data/Sah/Type/re.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_RE';
  package Data::Sah::Type::re;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  
  1;
  # ABSTRACT: re type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::re - re type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::re (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_RE

$fatpacked{"Data/Sah/Type/str.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_STR';
  package Data::Sah::Type::str;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Data::Sah::Util::Role 'has_clause';
  use Role::Tiny;
  use Role::Tiny::With;
  
  with 'Data::Sah::Type::BaseType';
  with 'Data::Sah::Type::Comparable';
  with 'Data::Sah::Type::Sortable';
  with 'Data::Sah::Type::HasElems';
  
  my $t_re = 'regex*|{*=>regex*}';
  
  has_clause 'encoding',
      tags       => ['constraint'],
      arg        => 'str*',
      allow_expr => 0,
      ;
  has_clause 'match',
      tags       => ['constraint'],
      arg        => $t_re,
      allow_expr => 1,
      ;
  has_clause 'is_re',
      tags       => ['constraint'],
      arg        => 'bool',
      allow_expr => 1,
      ;
  
  1;
  # ABSTRACT: str type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::str - str type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::str (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_STR

$fatpacked{"Data/Sah/Type/undef.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_TYPE_UNDEF';
  package Data::Sah::Type::undef;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use Role::Tiny;
  use Data::Sah::Util::Role 'has_clause';
  
  1;
  # ABSTRACT: undef type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Type::undef - undef type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Type::undef (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =for Pod::Coverage ^(clause_.+|clausemeta_.+)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_TYPE_UNDEF

$fatpacked{"Data/Sah/Util/Func.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_UTIL_FUNC';
  package Data::Sah::Util::Func;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  #use Sub::Install qw(install_sub);
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         add_func
                 );
  
  sub add_func {
      my ($funcset, $func, %opts) = @_;
      # not yet implemented
  }
  
  1;
  # ABSTRACT: Sah utility routines for adding function
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Util::Func - Sah utility routines for adding function
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Util::Func (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 DESCRIPTION
  
  This module provides some utility routines to be used by modules that add Sah
  functions.
  
  =head1 FUNCTIONS
  
  =head2 add_func($funcset, $func, %opts)
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_UTIL_FUNC

$fatpacked{"Data/Sah/Util/Role.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_UTIL_ROLE';
  package Data::Sah::Util::Role;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Sub::Install qw(install_sub);
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         has_clause has_clause_alias
                         has_func   has_func_alias
                 );
  
  sub has_clause {
      my ($name, %args) = @_;
      my $caller = caller;
      my $into   = $args{into} // $caller;
  
      if ($args{code}) {
          install_sub({code => $args{code}, into => $into,
                       as => "clause_$name"});
      } else {
          eval "package $into; use Role::Tiny; ".
              "requires 'clause_$name';";
      }
      install_sub({code => sub {
                       state $meta = {
                           names      => [$name],
                           tags       => $args{tags},
                           prio       => $args{prio} // 50,
                           arg        => $args{arg},
                           allow_expr => $args{allow_expr},
                           attrs      => $args{attrs} // {},
                       };
                       $meta;
                   },
                   into => $into,
                   as => "clausemeta_$name"});
      has_clause_alias($name, $args{alias}  , $into);
      has_clause_alias($name, $args{aliases}, $into);
  }
  
  sub has_clause_alias {
      my ($name, $aliases, $into) = @_;
      my $caller   = caller;
      $into      //= $caller;
      my @aliases = !$aliases ? () :
          ref($aliases) eq 'ARRAY' ? @$aliases : $aliases;
      my $meta = $into->${\("clausemeta_$name")};
  
      for my $alias (@aliases) {
          push @{ $meta->{names} }, $alias;
          eval
              "package $into;".
              "sub clause_$alias { shift->clause_$name(\@_) } ".
              "sub clausemeta_$alias { shift->clausemeta_$name(\@_) } ";
          $@ and die "Can't make clause alias $alias -> $name: $@";
      }
  }
  
  sub has_func {
      my ($name, %args) = @_;
      my $caller = caller;
      my $into   = $args{into} // $caller;
  
      if ($args{code}) {
          install_sub({code => $args{code}, into => $into, as => "func_$name"});
      } else {
          eval "package $into; use Role::Tiny; requires 'func_$name';";
      }
      install_sub({code => sub {
                       state $meta = {
                           names => [$name],
                           args  => $args{args},
                       };
                       $meta;
                   },
                   into => $into,
                   as => "funcmeta_$name"});
      my @aliases =
          map { (!$args{$_} ? () :
                     ref($args{$_}) eq 'ARRAY' ? @{ $args{$_} } : $args{$_}) }
              qw/alias aliases/;
      has_func_alias($name, $args{alias}  , $into);
      has_func_alias($name, $args{aliases}, $into);
  }
  
  sub has_func_alias {
      my ($name, $aliases, $into) = @_;
      my $caller   = caller;
      $into      //= $caller;
      my @aliases = !$aliases ? () :
          ref($aliases) eq 'ARRAY' ? @$aliases : $aliases;
      my $meta = $into->${\("funcmeta_$name")};
  
      for my $alias (@aliases) {
          push @{ $meta->{names} }, $alias;
          eval
              "package $into;".
              "sub func_$alias { shift->func_$name(\@_) } ".
              "sub funcmeta_$alias { shift->funcmeta_$name(\@_) } ";
          $@ and die "Can't make func alias $alias -> $name: $@";
      }
  }
  
  1;
  # ABSTRACT: Sah utility routines for roles
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Util::Role - Sah utility routines for roles
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Util::Role (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 DESCRIPTION
  
  This module provides some utility routines to be used in roles, e.g.
  C<Data::Sah::Type::*> and C<Data::Sah::FuncSet::*>.
  
  =head1 FUNCTIONS
  
  =head2 has_clause($name, %opts)
  
  Define a clause. Used in type roles (C<Data::Sah::Type::*>). Internally it adds
  a L<Moo> C<requires> for C<clause_$name>.
  
  Options:
  
  =over 4
  
  =item * arg => $schema
  
  Define schema for clause value.
  
  =item * prio => $priority
  
  Optional. Default is 50. The higher the priority, the earlier the clause will be
  processed.
  
  =item * aliases => \@aliases OR $alias
  
  Define aliases. Optional.
  
  =item * code => $code
  
  Optional. Define implementation for the clause. The code will be installed as
  'clause_$name'.
  
  =item * into => $package
  
  By default it is the caller package, but can be set to other package.
  
  =back
  
  Example:
  
   has_clause minimum => (arg => 'int*', aliases => 'min');
  
  =head2 has_clause_alias TARGET => ALIAS | [ALIAS1, ...]
  
  Specify that clause named ALIAS is an alias for TARGET.
  
  You have to define TARGET clause first (see B<has_clause> above).
  
  Example:
  
   has_clause max_length => ...;
   has_clause_alias max_length => "max_len";
  
  =head2 has_func($name, %opts)
  
  Define a Sah function. Used in function set roles (C<Data::Sah::FuncSet::*>).
  Internally it adds a L<Moo> C<requires> for C<func_$name>.
  
  Options:
  
  =over 4
  
  =item * args => [$schema_arg0, $schema_arg1, ...]
  
  Declare schema for arguments.
  
  =item * aliases => \@aliases OR $alias
  
  Optional. Declare aliases.
  
  =item * code => $code
  
  Supply implementation for the function. The code will be installed as
  'func_$name'.
  
  =item * into => $package
  
  By default it is the caller package, but can be set to other package.
  
  =back
  
  Example:
  
   has_func abs => (args => 'num');
  
  =head2 has_func_alias TARGET => ALIAS | [ALIASES...]
  
  Specify that function named ALIAS is an alias for TARGET.
  
  You have to specify TARGET function first (see B<has_func> above).
  
  Example:
  
   has_func_alias 'atan' => 'arctan';
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_UTIL_ROLE

$fatpacked{"Data/Sah/Util/Type.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_UTIL_TYPE';
  package Data::Sah::Util::Type;
  
  our $DATE = '2015-01-20'; # DATE
  our $VERSION = '0.42'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(get_type is_simple is_numeric is_collection is_ref);
  
  # XXX absorb and use metadata from Data::Sah::Type::*
  my $type_metas = {
      all   => {scalar=>0, numeric=>0, ref=>0},
      any   => {scalar=>0, numeric=>0, ref=>0},
      array => {scalar=>0, numeric=>0, ref=>1},
      bool  => {scalar=>1, numeric=>0, ref=>0},
      buf   => {scalar=>1, numeric=>0, ref=>0},
      cistr => {scalar=>1, numeric=>0, ref=>0},
      code  => {scalar=>1, numeric=>0, ref=>1},
      float => {scalar=>1, numeric=>1, ref=>0},
      hash  => {scalar=>0, numeric=>0, ref=>1},
      int   => {scalar=>1, numeric=>1, ref=>0},
      num   => {scalar=>1, numeric=>1, ref=>0},
      obj   => {scalar=>1, numeric=>0, ref=>1},
      re    => {scalar=>1, numeric=>0, ref=>1, simple=>1},
      str   => {scalar=>1, numeric=>0, ref=>0},
      undef => {scalar=>1, numeric=>0, ref=>0},
  };
  
  sub get_type {
      my $sch = shift;
  
      if (ref($sch) eq 'ARRAY') {
          $sch = $sch->[0];
      }
  
      if (defined($sch) && !ref($sch)) {
          $sch =~ s/\*\z//;
          return $sch;
      } else {
          return undef;
      }
  }
  
  sub _normalize {
      require Data::Sah::Normalize;
  
      my ($sch, $opts) = @_;
      return $sch if $opts->{schema_is_normalized};
      return Data::Sah::Normalize::normalize_schema($sch);
  }
  
  # for any|all to pass a criteria, we assume that all of the schemas in the 'of'
  # clause must also pass (and there must not be '!of', 'of&', or that kind of
  # thing.
  sub _handle_any_all {
      my ($sch, $opts, $crit) = @_;
      $sch = _normalize($sch, $opts);
      return 0 if $sch->[1]{'of.op'};
      my $of = $sch->[1]{of};
      return 0 unless $of && ref($of) eq 'ARRAY' && @$of;
      for (@$of) {
          return 0 unless $crit->($_);
      }
      1;
  }
  
  sub is_simple {
      my ($sch, $opts) = @_;
      $opts //= {};
  
      my $type = get_type($sch) or return undef;
      my $tmeta = $type_metas->{$type} or return undef;
      if ($type eq 'any' || $type eq 'all') {
          return _handle_any_all($sch, $opts, sub { is_simple(shift) });
      }
      return $tmeta->{simple} // ($tmeta->{scalar} && !$tmeta->{ref});
  }
  
  sub is_collection {
      my ($sch, $opts) = @_;
      $opts //= {};
  
      my $type = get_type($sch) or return undef;
      my $tmeta = $type_metas->{$type} or return undef;
      if ($type eq 'any' || $type eq 'all') {
          return _handle_any_all($sch, $opts, sub { is_collection(shift) });
      }
      return !$tmeta->{scalar};
  }
  
  sub is_numeric {
      my ($sch, $opts) = @_;
      $opts //= {};
  
      my $type = get_type($sch) or return undef;
      my $tmeta = $type_metas->{$type} or return undef;
      if ($type eq 'any' || $type eq 'all') {
          return _handle_any_all($sch, $opts, sub { is_numeric(shift) });
      }
      return $tmeta->{numeric};
  }
  
  sub is_ref {
      my ($sch, $opts) = @_;
      $opts //= {};
  
      my $type = get_type($sch) or return undef;
      my $tmeta = $type_metas->{$type} or return undef;
      if ($type eq 'any' || $type eq 'all') {
          return _handle_any_all($sch, $opts, sub { is_ref(shift) });
      }
      return $tmeta->{ref};
  }
  
  1;
  # ABSTRACT: Utility functions related to types
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Util::Type - Utility functions related to types
  
  =head1 VERSION
  
  This document describes version 0.42 of Data::Sah::Util::Type (from Perl distribution Data-Sah-Util-Type), released on 2015-01-20.
  
  =head1 SYNOPSIS
  
   use Data::Sah::Util::Type qw(
       get_type
       is_simple is_numeric is_collection is_ref
   );
  
   say get_type("int");                          # -> int
   say get_type("int*");                         # -> int
   say get_type([int => min=>0]);                # -> int
  
   say is_simple("int");                          # -> 1
   say is_simple("array");                        # -> 0
   say is_simple([any => of => ["float", "str"]); # -> 1
  
   say is_numeric(["int", min=>0]); # -> 1
  
   say is_collection("array*"); # -> 1
  
   say is_ref("code*"); # -> 1
  
  =head1 DESCRIPTION
  
  This module provides some secondary utility functions related to L<Sah> and
  L<Data::Sah>. It is deliberately distributed separately from the Data-Sah main
  distribution to be differentiated from Data::Sah::Util which contains "primary"
  utilities and is distributed with Data-Sah.
  
  =head1 FUNCTIONS
  
  None exported by default, but they are exportable.
  
  =head2 get_type($sch) => STR
  
  =head2 is_simple($sch[, \%opts]) => BOOL
  
  Simple means scalar and not a reference.
  
  Options:
  
  =over
  
  =item * schema_is_normalized => BOOL
  
  =back
  
  =head2 is_collection($sch[, \%opts]) => BOOL
  
  =head2 is_numeric($sch[, \%opts]) => BOOL
  
  Currently, only C<num>, C<int>, and C<float> are numeric.
  
  =head2 is_ref($sch[, \%opts]) => BOOL
  
  =head1 SEE ALSO
  
  L<Data::Sah>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah-Util-Type>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah-Util-Type>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah-Util-Type>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_UTIL_TYPE

$fatpacked{"Data/Sah/Util/Type/Date.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_UTIL_TYPE_DATE';
  package Data::Sah::Util::Type::Date;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Scalar::Util qw(blessed looks_like_number);
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         coerce_date
                 );
  
  sub coerce_date {
      my $val = shift;
      if (!defined($val)) {
          return undef;
      } elsif (blessed($val) && $val->isa('DateTime')) {
          return $val;
      } elsif (looks_like_number($val) && $val >= 10**8 && $val <= 2**31) {
          require DateTime;
          return DateTime->from_epoch(epoch => $val);
      } elsif ($val =~ /\A([0-9]{4})-([0-9]{2})-([0-9]{2})\z/) {
          require DateTime;
          my $d;
          eval { $d = DateTime->new(year=>$1, month=>$2, day=>$3) };
          return undef if $@;
          return $d;
      } else {
          return undef;
      }
  }
  
  1;
  # ABSTRACT: Utility related to date type
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Util::Type::Date - Utility related to date type
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Util::Type::Date (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 DESCRIPTION
  
  =head1 FUNCTIONS
  
  =head2 coerce_date($val) => DATETIME OBJ|undef
  
  Coerce value to DateTime object according to perl Sah compiler (see
  L<Data::Sah::Compiler::perl::TH::date>). Return undef if value is not
  acceptable.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_UTIL_TYPE_DATE

$fatpacked{"Data/Sah/Util/TypeX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_SAH_UTIL_TYPEX';
  package Data::Sah::Util::TypeX;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  #use Sub::Install qw(install_sub);
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         add_clause
                 );
  
  sub add_clause {
      my ($type, $clause, %opts) = @_;
      # not yet implemented
  
      # * check duplicate
  
      # * call Data::Sah::Util::Role::has_clause
      # * install handlers to Data::Sah::Compiler::$Compiler::TH::$type
      # * push @{ $Data::Sah::Compiler::human::TypeX{$type} }, $clause;
  }
  
  1;
  # ABSTRACT: Sah utility routines for type extensions
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Data::Sah::Util::TypeX - Sah utility routines for type extensions
  
  =head1 VERSION
  
  This document describes version 0.52 of Data::Sah::Util::TypeX (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 DESCRIPTION
  
  This module provides some utility routines to be used by type extension modules
  (C<Data::Sah::TypeX::*>).
  
  =head1 FUNCTIONS
  
  =head2 add_clause($type, $clause, %opts)
  
  Add a clause. Used when wanting to add a clause to an existing type.
  
  Options:
  
  =over 4
  
  =item * definition => HASH
  
  Will be passed to L<Data::Sah::Util::Role>'s C<has_clause>.
  
  =item * handlers => HASH
  
  A mapping of compiler name and coderefs. Coderef will be installed as
  C<clause_$clause> in the C<Data::Sah::Compiler::$Compiler::TH::>.
  
  =item * prio => $priority
  
  Optional. Default is 50. The higher the priority, the earlier the clause will be
  processed.
  
  =item * aliases => \@aliases OR $alias
  
  Define aliases. Optional.
  
  =item * code => $code
  
  Optional. Define implementation for the clause. The code will be installed as
  'clause_$name'.
  
  =back
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DATA_SAH_UTIL_TYPEX

$fatpacked{"Date/Format.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_FORMAT';
  # 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
  
  
DATE_FORMAT

$fatpacked{"Date/Language.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE';
  
  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
  
DATE_LANGUAGE

$fatpacked{"Date/Language/Afar.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_AFAR';
  ##
  ## 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;
DATE_LANGUAGE_AFAR

$fatpacked{"Date/Language/Amharic.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_AMHARIC';
  ##
  ## 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;
DATE_LANGUAGE_AMHARIC

$fatpacked{"Date/Language/Austrian.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_AUSTRIAN';
  ##
  ## 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;
DATE_LANGUAGE_AUSTRIAN

$fatpacked{"Date/Language/Brazilian.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_BRAZILIAN';
  ##
  ## 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;
DATE_LANGUAGE_BRAZILIAN

$fatpacked{"Date/Language/Bulgarian.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_BULGARIAN';
  ##
  ## 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
  
  
DATE_LANGUAGE_BULGARIAN

$fatpacked{"Date/Language/Chinese.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_CHINESE';
  ##
  ## 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;
DATE_LANGUAGE_CHINESE

$fatpacked{"Date/Language/Chinese_GB.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_CHINESE_GB';
  ##
  ## 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;
DATE_LANGUAGE_CHINESE_GB

$fatpacked{"Date/Language/Czech.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_CZECH';
  ##
  ## 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;
DATE_LANGUAGE_CZECH

$fatpacked{"Date/Language/Danish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_DANISH';
  ##
  ## 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;
DATE_LANGUAGE_DANISH

$fatpacked{"Date/Language/Dutch.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_DUTCH';
  ##
  ## 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;
DATE_LANGUAGE_DUTCH

$fatpacked{"Date/Language/English.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_ENGLISH';
  ##
  ## 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;
DATE_LANGUAGE_ENGLISH

$fatpacked{"Date/Language/Finnish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_FINNISH';
  ##
  ## 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;
DATE_LANGUAGE_FINNISH

$fatpacked{"Date/Language/French.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_FRENCH';
  ##
  ## 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;
DATE_LANGUAGE_FRENCH

$fatpacked{"Date/Language/Gedeo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_GEDEO';
  ##
  ## 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;
DATE_LANGUAGE_GEDEO

$fatpacked{"Date/Language/German.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_GERMAN';
  ##
  ## 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;
DATE_LANGUAGE_GERMAN

$fatpacked{"Date/Language/Greek.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_GREEK';
  ##
  ## 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;
  
  
  
DATE_LANGUAGE_GREEK

$fatpacked{"Date/Language/Hungarian.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_HUNGARIAN';
  ##
  ## 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;
DATE_LANGUAGE_HUNGARIAN

$fatpacked{"Date/Language/Icelandic.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_ICELANDIC';
  ##
  ## 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;
DATE_LANGUAGE_ICELANDIC

$fatpacked{"Date/Language/Italian.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_ITALIAN';
  ##
  ## 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;
DATE_LANGUAGE_ITALIAN

$fatpacked{"Date/Language/Norwegian.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_NORWEGIAN';
  ##
  ## 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;
DATE_LANGUAGE_NORWEGIAN

$fatpacked{"Date/Language/Oromo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_OROMO';
  ##
  ## 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;
DATE_LANGUAGE_OROMO

$fatpacked{"Date/Language/Romanian.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_ROMANIAN';
  ##
  ## 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;
DATE_LANGUAGE_ROMANIAN

$fatpacked{"Date/Language/Russian.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_RUSSIAN';
  ##
  ## 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;
DATE_LANGUAGE_RUSSIAN

$fatpacked{"Date/Language/Russian_cp1251.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_RUSSIAN_CP1251';
  ##
  ## 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;
DATE_LANGUAGE_RUSSIAN_CP1251

$fatpacked{"Date/Language/Russian_koi8r.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_RUSSIAN_KOI8R';
  ##
  ## 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;
DATE_LANGUAGE_RUSSIAN_KOI8R

$fatpacked{"Date/Language/Sidama.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_SIDAMA';
  ##
  ## 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;
DATE_LANGUAGE_SIDAMA

$fatpacked{"Date/Language/Somali.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_SOMALI';
  ##
  ## 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;
DATE_LANGUAGE_SOMALI

$fatpacked{"Date/Language/Spanish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_SPANISH';
  ##
  ## 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;
DATE_LANGUAGE_SPANISH

$fatpacked{"Date/Language/Swedish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_SWEDISH';
  ##
  ## 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;
DATE_LANGUAGE_SWEDISH

$fatpacked{"Date/Language/Tigrinya.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_TIGRINYA';
  ##
  ## 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;
DATE_LANGUAGE_TIGRINYA

$fatpacked{"Date/Language/TigrinyaEritrean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_TIGRINYAERITREAN';
  ##
  ## 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;
DATE_LANGUAGE_TIGRINYAERITREAN

$fatpacked{"Date/Language/TigrinyaEthiopian.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_TIGRINYAETHIOPIAN';
  ##
  ## 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;
DATE_LANGUAGE_TIGRINYAETHIOPIAN

$fatpacked{"Date/Language/Turkish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_LANGUAGE_TURKISH';
  #----------------------------------------------------#
  #
  # 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__
DATE_LANGUAGE_TURKISH

$fatpacked{"Date/Parse.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_PARSE';
  # 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
  
DATE_PARSE

$fatpacked{"DefHash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DEFHASH';
  package DefHash;
  
  our $VERSION = '1.0.9'; # VERSION
  
  1;
  # ABSTRACT: Define things according to a specification, using hashes
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  DefHash - Define things according to a specification, using hashes
  
  =head1 VERSION
  
  This document describes version 1.0.9 of DefHash (from Perl distribution DefHash), released on 2015-04-02.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/DefHash>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-DefHash>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=DefHash>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
DEFHASH

$fatpacked{"File/Which.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_WHICH';
  package File::Which;
  
  use 5.005003;
  use strict;
  use Exporter   ();
  use File::Spec ();
  
  use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK};
  BEGIN {
  	$VERSION   = '1.16';
  	@ISA       = 'Exporter';
  	@EXPORT    = 'which';
  	@EXPORT_OK = 'where';
  }
  
  use constant IS_VMS => ($^O eq 'VMS');
  use constant IS_MAC => ($^O eq 'MacOS');
  use constant IS_DOS => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2');
  use constant IS_CYG => ($^O eq 'cygwin');
  
  # 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_DOS ) {
  	# 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 $exec;
  
  	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_DOS and $exec =~ /\// and -f $exec and -x $exec;
  
  	my @path = File::Spec->path;
  	if ( IS_DOS or IS_VMS or IS_MAC ) {
  		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_DOS 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
  
  =head1 NAME
  
  File::Which - Portable implementation of the `which' utility
  
  =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
  
  C<File::Which> was created to be able to get the paths to executable programs
  on systems under which the `which' program wasn't implemented in the shell.
  
  C<File::Which> searches the directories of the user's C<PATH> (as returned by
  C<File::Spec-E<gt>path()>), looking for executable files having the name
  specified as a parameter to C<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.)
  
  =head1 Steps Used on Win32, DOS, OS2 and VMS
  
  =head2 Windows NT
  
  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.
  
  =head2 Windows 9x and other ancient Win/DOS/OS2
  
  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.
  
  =head2 VMS
  
  Same case as Windows 9x: uses C<.exe> and C<.com> (in that order).
  
  =head1 Functions
  
  =head2 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($short_exe_name)
  
  Not exported by default.
  
  Same as C<which($short_exe_name)> in array context. Same as the
  C<`where'> utility, will return an array containing all the path names
  matching C<$short_exe_name>.
  
  =head1 CAVEATS
  
  Not tested on VMS or MacOS, 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>
  
  Command line interface to this module.
  
  =item L<IPC::Cmd>
  
  Comes with a C<can_run> function with slightly different semantics that
  the traditional UNIX where.  It will find executables in the current
  directory, even though the current directory is not searched for by
  default on Unix.
  
  =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 AUTHOR
  
  Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
  
  Previous maintainer: Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  Original author: Per Einar Ellefsen E<lt>pereinar@cpan.orgE<gt>
  
  Originated in F<modperl-2.0/lib/Apache/Build.pm>. Changed for use in DocSet
  (for the mod_perl site) and Win32-awareness by me, with slight modifications
  by Stas Bekman, then extracted to create C<File::Which>.
  
  Version 0.04 had some significant platform-related changes, taken from
  the Perl Power Tools C<`which'> implementation by Abigail with
  enhancements from Peter Prymmer. See
  L<http://www.perl.com/language/ppt/src/which/index.html> for more
  information.
  
  =head1 COPYRIGHT
  
  Copyright 2002 Per Einar Ellefsen.
  
  Some parts copyright 2009 Adam Kennedy.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<File::Spec>, L<which(1)>, Perl Power Tools:
  L<http://www.perl.com/language/ppt/index.html>.
  
  =cut
FILE_WHICH

$fatpacked{"Function/Fallback/CoreOrPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FUNCTION_FALLBACK_COREORPP';
  package Function::Fallback::CoreOrPP;
  
  use 5.010001;
  use strict;
  use warnings;
  
  our $VERSION = '0.06'; # VERSION
  
  our $USE_NONCORE_XS_FIRST = 1;
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(
                         clone
                         unbless
                         uniq
                 );
  
  sub clone {
      my $data = shift;
      goto FALLBACK unless $USE_NONCORE_XS_FIRST;
      goto FALLBACK unless eval { require Data::Clone; 1 };
  
    STANDARD:
      return Data::Clone::clone($data);
  
    FALLBACK:
      require Clone::PP;
      return Clone::PP::clone($data);
  }
  
  sub _unbless_fallback {
      my $ref = shift;
  
      my $r = ref($ref);
      # not a reference
      return $ref unless $r;
  
      # return if not a blessed ref
      my ($r2, $r3) = "$ref" =~ /(.+)=(.+?)\(/
          or return $ref;
  
      if ($r3 eq 'HASH') {
          return { %$ref };
      } elsif ($r3 eq 'ARRAY') {
          return [ @$ref ];
      } elsif ($r3 eq 'SCALAR') {
          return \( my $copy = ${$ref} );
      } else {
          die "Can't handle $ref";
      }
  }
  
  sub unbless {
      my $ref = shift;
  
      goto FALLBACK unless $USE_NONCORE_XS_FIRST;
      goto FALLBACK unless eval { require Acme::Damn; 1 };
  
    STANDARD:
      return Acme::Damn::damn($ref);
  
    FALLBACK:
      return _unbless_fallback($ref);
  }
  
  sub uniq {
      goto FALLBACK unless $USE_NONCORE_XS_FIRST;
      goto FALLBACK unless eval { require List::MoreUtils; 1 };
  
    STANDARD:
      return List::MoreUtils::uniq(@_);
  
    FALLBACK:
      my %h;
      my @res;
      for (@_) {
          push @res, $_ unless $h{$_}++;
      }
      return @res;
  }
  
  1;
  #ABSTRACT: Functions that use non-core XS module but provide pure-Perl/core fallback
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Function::Fallback::CoreOrPP - Functions that use non-core XS module but provide pure-Perl/core fallback
  
  =head1 VERSION
  
  This document describes version 0.06 of Function::Fallback::CoreOrPP (from Perl distribution Function-Fallback-CoreOrPP), released on 2014-09-16.
  
  =head1 SYNOPSIS
  
   use Function::Fallback::CoreOrPP qw(clone unbless uniq);
  
   my $clone = clone({blah=>1});
   my $unblessed = unbless($blessed_ref);
   my @uniq  = uniq(1, 3, 2, 1, 4);  # -> (1, 3, 2, 4)
  
  =head1 DESCRIPTION
  
  This module provides functions that use non-core XS modules (for best speed,
  reliability, feature, etc) but falls back to those that use core XS or pure-Perl
  modules when the non-core XS module is not available.
  
  This module helps when you want to bootstrap your Perl application with a
  portable, dependency-free Perl script. In a vanilla Perl installation (having
  only core modules), you can use L<App::FatPacker> to include non-core pure-Perl
  dependencies to your script.
  
  =for Pod::Coverage ^()$
  
  =head1 FUNCTIONS
  
  =head2 clone($data) => $cloned
  
  Try to use L<Data::Clone>'s C<clone>, but fall back to using L<Clone::PP>'s
  C<clone>.
  
  =head2 unbless($ref) => $unblessed_ref
  
  Try to use L<Acme::Damn>'s C<damn> to unbless a reference but fall back to
  shallow copying.
  
  NOTE: C<damn()> B<MODIFIES> the original reference. (XXX in the future an option
  to clone the reference first will be provided), while shallow copying will
  return a shallow copy.
  
  NOTE: The shallow copy method currently only handles blessed
  {scalar,array,hash}ref as those are the most common.
  
  =head2 uniq(@ary) => @uniq_ary
  
  Try to use L<List::MoreUtils>'s C<uniq>, but fall back to using slower,
  pure-Perl implementation.
  
  =head1 SEE ALSO
  
  L<Clone::Any> can also uses multiple backends, but I avoid it because I don't
  think L<Storable>'s C<dclone> should be used (no Regexp support out of the box +
  must use deparse to handle coderefs).
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Function-Fallback-CoreOrPP>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Function-Fallback-CoreOrPP>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Function-Fallback-CoreOrPP>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
FUNCTION_FALLBACK_COREORPP

$fatpacked{"Getopt/Long/Negate/EN.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GETOPT_LONG_NEGATE_EN';
  package Getopt::Long::Negate::EN;
  
  our $DATE = '2015-03-19'; # DATE
  our $VERSION = '0.01'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Exporter qw(import);
  our @EXPORT_OK = qw(negations_for_option);
  
  sub negations_for_option {
      my $word = shift;
      if    ($word =~ /\Awith([_-].+)/   ) { return ("without$1") }
      elsif ($word =~ /\Awithout([_-].+)/) { return ("with$1")    }
      elsif ($word =~ /\Ais([_-].+)/     ) { return ("isnt$1")    }
      elsif ($word =~ /\Aisnt([_-].+)/   ) { return ("is$1")      }
      elsif ($word =~ /\Aare([_-].+)/    ) { return ("arent$1")   }
      elsif ($word =~ /\Aarent([_-].+)/  ) { return ("are$1")     }
      elsif ($word =~ /\Ano[_-](.+)/     ) { return ($1)          }
      else {
          # default from Getopt::Long
          return ("no-$word", "no$word");
      }
  }
  
  1;
  # ABSTRACT: Better negation of boolean option names
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Getopt::Long::Negate::EN - Better negation of boolean option names
  
  =head1 VERSION
  
  This document describes version 0.01 of Getopt::Long::Negate::EN (from Perl distribution Getopt-Long-Negate-EN), released on 2015-03-19.
  
  =head1 SYNOPSIS
  
   use Getopt::Long::Negate::EN qw(negations_for_option);
  
   # the Getopt::Long's default
   @negs = negations_for_option('foo'); # ('no-foo', 'nofoo')
  
   @negs = negations_for_option('with-foo');    # ('without-foo')
   @negs = negations_for_option('without-foo'); # ('with-foo')
  
   @negs = negations_for_option('is-foo');      # ('isnt-foo')
   @negs = negations_for_option('isnt-foo');    # ('is-foo')
  
   @negs = negations_for_option('are-foo');     # ('isnt-foo')
   @negs = negations_for_option('arent-foo');   # ('arent-foo')
  
   @negs = negations_for_option('no-foo');      # ('foo')
  
  =head1 DESCRIPTION
  
  This module aims to provide a nicer negative boolean option names. By default,
  L<Getopt::Long> provides options C<--foo> as well as C<--no-foo> and C<--nofoo>
  if you specify boolean option specification C<foo!>. But this produces
  awkward/incorrect English word like C<--nowith-foo> or C<--no-is-foo>. In those
  two cases, C<--without-foo> and C<--isnt-foo> are better option names.
  
  =head1 FUNCTIONS
  
  None are exported by default, but they are exportable.
  
  =head2 negations_for_option($str) => list
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Getopt-Long-Negate-EN>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Getopt-Long-Negate-EN>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Getopt-Long-Negate-EN>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
GETOPT_LONG_NEGATE_EN

$fatpacked{"Getopt/Long/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GETOPT_LONG_UTIL';
  package Getopt::Long::Util;
  
  our $DATE = '2015-03-24'; # DATE
  our $VERSION = '0.81'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use List::Util qw(first);
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(
                         parse_getopt_long_opt_spec
                         humanize_getopt_long_opt_spec
                         detect_getopt_long_script
                 );
  
  our %SPEC;
  
  $SPEC{parse_getopt_long_opt_spec} = {
      v => 1.1,
      summary => 'Parse a single Getopt::Long option specification',
      description => <<'_',
  
  Will produce a hash with some keys: `opts` (array of option names, in the order
  specified in the opt spec), `type` (string, type name), `desttype` (either '',
  or '@' or '%'), `is_neg` (true for `--opt!`), `is_inc` (true for `--opt+`),
  `min_vals` (int, usually 0 or 1), `max_vals` (int, usually 0 or 1 except for
  option that requires multiple values),
  
  Will return undef if it can't parse the string.
  
  _
      args => {
          optspec => {
              schema => 'str*',
              req => 1,
              pos => 0,
          },
      },
      args_as => 'array',
      result_naked => 1,
      result => {
          schema => 'hash*',
      },
      examples => [
          {
              args => {optspec => 'help|h|?'},
              result => {dash_prefix=>'', opts=>['help', 'h', '?']},
          },
          {
              args => {optspec=>'--foo=s'},
              result => {dash_prefix=>'--', opts=>['foo'], type=>'s', desttype=>''},
          },
      ],
  };
  sub parse_getopt_long_opt_spec {
      my $optspec = shift;
      $optspec =~ qr/\A
                 (?P<dash_prefix>-{0,2})
                 (?P<name>[A-Za-z0-9_][A-Za-z0-9_-]*)
                 (?P<aliases> (?: \| (?:[^:|!+=:-][^:|!+=:]*) )*)?
                 (?:
                     (?P<is_neg>!) |
                     (?P<is_inc>\+) |
                     (?:
                         =
                         (?P<type>[siof])
                         (?P<desttype>|[%@])?
                         (?:
                             \{
                             (?: (?P<min_vals>\d+), )?
                             (?P<max_vals>\d+)
                             \}
                         )?
                     ) |
                     (?:
                         :
                         (?P<opttype>[siof])
                         (?P<desttype>|[%@])
                     ) |
                     (?:
                         :
                         (?P<optnum>\d+)
                         (?P<desttype>|[%@])
                     )
                     (?:
                         :
                         (?P<optplus>\+)
                         (?P<desttype>|[%@])
                     )
                 )?
                 \z/x
                     or return undef;
      my %res = %+;
  
      if ($res{aliases}) {
          my @als;
          for my $al (split /\|/, $res{aliases}) {
              next unless length $al;
              next if $al eq $res{name};
              next if first {$_ eq $al} @als;
              push @als, $al;
          }
          $res{opts} = [$res{name}, @als];
      } else {
          $res{opts} = [$res{name}];
      }
      delete $res{name};
      delete $res{aliases};
  
      $res{is_neg} = 1 if $res{is_neg};
      $res{is_inc} = 1 if $res{is_inc};
  
      \%res;
  }
  
  $SPEC{humanize_getopt_long_opt_spec} = {
      v => 1.1,
      description => <<'_',
  
  Convert `Getopt::Long` option specification like `help|h|?` or `--foo=s` or
  `debug!` into, respectively, `--help, -h, -?` or `--foo=s` or `--(no)debug`.
  Will die if can't parse the string. The output is suitable for including in
  help/usage text.
  
  _
      args => {
          optspec => {
              schema => 'str*',
              req => 1,
              pos => 0,
          },
      },
      args_as => 'array',
      result_naked => 1,
      result => {
          schema => 'str*',
      },
  };
  sub humanize_getopt_long_opt_spec {
      my $optspec = shift;
  
      my $parse = parse_getopt_long_opt_spec($optspec)
          or die "Can't parse opt spec $optspec";
  
      my $res = '';
      my $i = 0;
      for (@{ $parse->{opts} }) {
          $i++;
          $res .= ", " if length($res);
          if ($parse->{is_neg} && length($_) > 1) {
              $res .= "--(no)$_";
          } else {
              if (length($_) > 1) {
                  $res .= "--$_";
              } else {
                  $res .= "-$_";
              }
              $res .= "=$parse->{type}" if $i==1 && $parse->{type};
          }
      }
      $res;
  }
  
  $SPEC{detect_getopt_long_script} = {
      v => 1.1,
      summary => 'Detect whether a file is a Getopt::Long-based CLI script',
      description => <<'_',
  
  The criteria are:
  
  * the file must exist and readable;
  
  * (optional, if `include_noexec` is false) file must have its executable mode
    bit set;
  
  * content must start with a shebang C<#!>;
  
  * either: must be perl script (shebang line contains 'perl') and must contain
    something like `use Getopt::Long`;
  
  _
      args => {
          filename => {
              summary => 'Path to file to be checked',
              schema => 'str*',
              description => <<'_',
  
  Either `filename` or `string` must be specified.
  
  _
          },
          string => {
              summary => 'Path to file to be checked',
              schema => 'buf*',
              description => <<'_',
  
  Either `file` or `string` must be specified.
  
  _
          },
          include_noexec => {
              summary => 'Include scripts that do not have +x mode bit set',
              schema  => 'bool*',
              default => 1,
          },
      },
  };
  sub detect_getopt_long_script {
      my %args = @_;
  
      (defined($args{filename}) xor defined($args{string}))
          or return [400, "Please specify either filename or string"];
      my $include_noexec  = $args{include_noexec}  // 1;
  
      my $yesno = 0;
      my $reason = "";
  
      my $str = $args{string};
    DETECT:
      {
          if (defined $args{filename}) {
              my $fn = $args{filename};
              unless (-f $fn) {
                  $reason = "'$fn' is not a file";
                  last;
              };
              if (!$include_noexec && !(-x _)) {
                  $reason = "'$fn' is not an executable";
                  last;
              }
              my $fh;
              unless (open $fh, "<", $fn) {
                  $reason = "Can't be read";
                  last;
              }
              # for efficiency, we read a bit only here
              read $fh, $str, 2;
              unless ($str eq '#!') {
                  $reason = "Does not start with a shebang (#!) sequence";
                  last;
              }
              my $shebang = <$fh>;
              unless ($shebang =~ /perl/) {
                  $reason = "Does not have 'perl' in the shebang line";
                  last;
              }
              seek $fh, 0, 0;
              {
                  local $/;
                  $str = <$fh>;
              }
          }
          unless ($str =~ /\A#!/) {
              $reason = "Does not start with a shebang (#!) sequence";
              last;
          }
          unless ($str =~ /\A#!.*perl/) {
              $reason = "Does not have 'perl' in the shebang line";
              last;
          }
          if ($str =~ /^\s*(use|require)\s+Getopt::Long(\s|;)/m) {
              $yesno = 1;
              last DETECT;
          }
          $reason = "Can't find any statement requiring Getopt::Long module";
      } # DETECT
  
      [200, "OK", $yesno, {"func.reason"=>$reason}];
  }
  
  # ABSTRACT: Utilities for Getopt::Long
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Getopt::Long::Util - Utilities for Getopt::Long
  
  =head1 VERSION
  
  This document describes version 0.81 of Getopt::Long::Util (from Perl distribution Getopt-Long-Util), released on 2015-03-24.
  
  =head1 FUNCTIONS
  
  
  =head2 detect_getopt_long_script(%args) -> [status, msg, result, meta]
  
  Detect whether a file is a Getopt::Long-based CLI script.
  
  The criteria are:
  
  =over
  
  =item * the file must exist and readable;
  
  =item * (optional, if C<include_noexec> is false) file must have its executable mode
  bit set;
  
  =item * content must start with a shebang C<#!>;
  
  =item * either: must be perl script (shebang line contains 'perl') and must contain
  something like C<use Getopt::Long>;
  
  =back
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<filename> => I<str>
  
  Path to file to be checked.
  
  Either C<filename> or C<string> must be specified.
  
  =item * B<include_noexec> => I<bool> (default: 1)
  
  Include scripts that do not have +x mode bit set.
  
  =item * B<string> => I<buf>
  
  Path to file to be checked.
  
  Either C<file> or C<string> must be specified.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 humanize_getopt_long_opt_spec($optspec) -> str
  
  Convert C<Getopt::Long> option specification like C<help|h|?> or C<--foo=s> or
  C<debug!> into, respectively, C<--help, -h, -?> or C<--foo=s> or C<--(no)debug>.
  Will die if can't parse the string. The output is suitable for including in
  help/usage text.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<optspec>* => I<str>
  
  =back
  
  Return value:  (str)
  
  
  =head2 parse_getopt_long_opt_spec($optspec) -> hash
  
  Parse a single Getopt::Long option specification.
  
  Examples:
  
   parse_getopt_long_opt_spec("help|h|?"); # -> { dash_prefix => "", opts => ["help", "h", "?"] }
   parse_getopt_long_opt_spec("--foo=s"); # -> { dash_prefix => "--", desttype => "", opts => ["foo"], type => "s" }
  Will produce a hash with some keys: C<opts> (array of option names, in the order
  specified in the opt spec), C<type> (string, type name), C<desttype> (either '',
  or '@' or '%'), C<is_neg> (true for C<--opt!>), C<is_inc> (true for C<--opt+>),
  C<min_vals> (int, usually 0 or 1), C<max_vals> (int, usually 0 or 1 except for
  option that requires multiple values),
  
  Will return undef if it can't parse the string.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<optspec>* => I<str>
  
  =back
  
  Return value:  (hash)
  
  =head1 SEE ALSO
  
  L<Getopt::Long>
  
  L<Getopt::Long::Spec>, which can also parse Getopt::Long spec into hash as well
  as transform back the hash to Getopt::Long spec. OO interface. I should've found
  this module first before writing my own C<parse_getopt_long_opt_spec()>. But at
  least currently C<parse_getopt_long_opt_spec()> is at least about 30-100+%
  faster than Getopt::Long::Spec::Parser, has a much simpler implementation (a
  single regex match), and can handle valid Getopt::Long specs that
  Getopt::Long::Spec::Parser fails to parse, e.g. C<foo|f=s@>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Getopt-Long-Util>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Getopt-Long-Util>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Getopt-Long-Util>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
GETOPT_LONG_UTIL

$fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY';
  # vim: ts=4 sts=4 sw=4 et:
  package HTTP::Tiny;
  use strict;
  use warnings;
  # ABSTRACT: A small, simple, correct HTTP/1.1 client
  
  our $VERSION = '0.054';
  
  use Carp ();
  
  #pod =method new
  #pod
  #pod     $http = HTTP::Tiny->new( %attributes );
  #pod
  #pod This constructor returns a new HTTP::Tiny object.  Valid attributes include:
  #pod
  #pod =for :list
  #pod * C<agent> â
  #pod     A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> â ends in a space character, the default user-agent string is appended.
  #pod * C<cookie_jar> â
  #pod     An instance of L<HTTP::CookieJar> â or equivalent class that supports the C<add> and C<cookie_header> methods
  #pod * C<default_headers> â
  #pod     A hashref of default headers to apply to requests
  #pod * C<local_address> â
  #pod     The local IP address to bind to
  #pod * C<keep_alive> â
  #pod     Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
  #pod * C<max_redirect> â
  #pod     Maximum number of redirects allowed (defaults to 5)
  #pod * C<max_size> â
  #pod     Maximum response size (only when not using a data callback).  If defined, responses larger than this will return an exception.
  #pod * C<http_proxy> â
  #pod     URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> â if set)
  #pod * C<https_proxy> â
  #pod     URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> â if set)
  #pod * C<proxy> â
  #pod     URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> â if set)
  #pod * C<no_proxy> â
  #pod     List of domain suffixes that should not be proxied.  Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> â)
  #pod * C<timeout> â
  #pod     Request timeout in seconds (default is 60)
  #pod * C<verify_SSL> â
  #pod     A boolean that indicates whether to validate the SSL certificate of an C<https> â
  #pod     connection (default is false)
  #pod * C<SSL_options> â
  #pod     A hashref of C<SSL_*> â options to pass through to L<IO::Socket::SSL>
  #pod
  #pod Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
  #pod prevent getting the corresponding proxies from the environment.
  #pod
  #pod Exceptions from C<max_size>, C<timeout> or other errors will result in a
  #pod pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
  #pod content field in the response will contain the text of the exception.
  #pod
  #pod The C<keep_alive> parameter enables a persistent connection, but only to a
  #pod single destination scheme, host and port.  Also, if any connection-relevant
  #pod attributes are modified, or if the process ID or thread ID change, the
  #pod persistent connection will be dropped.  If you want persistent connections
  #pod across multiple destinations, use multiple HTTP::Tiny objects.
  #pod
  #pod See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
  #pod
  #pod =cut
  
  my @attributes;
  BEGIN {
      @attributes = qw(
          cookie_jar default_headers http_proxy https_proxy keep_alive
          local_address max_redirect max_size proxy no_proxy timeout
          SSL_options verify_SSL
      );
      my %persist_ok = map {; $_ => 1 } qw(
          cookie_jar default_headers max_redirect max_size
      );
      no strict 'refs';
      no warnings 'uninitialized';
      for my $accessor ( @attributes ) {
          *{$accessor} = sub {
              @_ > 1
                  ? do {
                      delete $_[0]->{handle} if !$persist_ok{$accessor} && $_[1] ne $_[0]->{$accessor};
                      $_[0]->{$accessor} = $_[1]
                  }
                  : $_[0]->{$accessor};
          };
      }
  }
  
  sub agent {
      my($self, $agent) = @_;
      if( @_ > 1 ){
          $self->{agent} =
              (defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent;
      }
      return $self->{agent};
  }
  
  sub new {
      my($class, %args) = @_;
  
      my $self = {
          max_redirect => 5,
          timeout      => 60,
          keep_alive   => 1,
          verify_SSL   => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default
          no_proxy     => $ENV{no_proxy},
      };
  
      bless $self, $class;
  
      $class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar};
  
      for my $key ( @attributes ) {
          $self->{$key} = $args{$key} if exists $args{$key}
      }
  
      $self->agent( exists $args{agent} ? $args{agent} : $class->_agent );
  
      $self->_set_proxies;
  
      return $self;
  }
  
  sub _set_proxies {
      my ($self) = @_;
  
      # get proxies from %ENV only if not provided; explicit undef will disable
      # getting proxies from the environment
  
      # generic proxy
      if (! exists $self->{proxy} ) {
          $self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY};
      }
  
      if ( defined $self->{proxy} ) {
          $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate
      }
      else {
          delete $self->{proxy};
      }
  
      # http proxy
      if (! exists $self->{http_proxy} ) {
          # under CGI, bypass HTTP_PROXY as request sets it from Proxy header
          local $ENV{HTTP_PROXY} if $ENV{REQUEST_METHOD};
          $self->{http_proxy} = $ENV{http_proxy} || $ENV{HTTP_PROXY} || $self->{proxy};
      }
  
      if ( defined $self->{http_proxy} ) {
          $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate
          $self->{_has_proxy}{http} = 1;
      }
      else {
          delete $self->{http_proxy};
      }
  
      # https proxy
      if (! exists $self->{https_proxy} ) {
          $self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy};
      }
  
      if ( $self->{https_proxy} ) {
          $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate
          $self->{_has_proxy}{https} = 1;
      }
      else {
          delete $self->{https_proxy};
      }
  
      # Split no_proxy to array reference if not provided as such
      unless ( ref $self->{no_proxy} eq 'ARRAY' ) {
          $self->{no_proxy} =
              (defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : [];
      }
  
      return;
  }
  
  #pod =method get|head|put|post|delete
  #pod
  #pod     $response = $http->get($url);
  #pod     $response = $http->get($url, \%options);
  #pod     $response = $http->head($url);
  #pod
  #pod These methods are shorthand for calling C<request()> for the given method.  The
  #pod URL must have unsafe characters escaped and international domain names encoded.
  #pod See C<request()> for valid options and a description of the response.
  #pod
  #pod The C<success> field of the response will be true if the status code is 2XX.
  #pod
  #pod =cut
  
  for my $sub_name ( qw/get head put post delete/ ) {
      my $req_method = uc $sub_name;
      no strict 'refs';
      eval <<"HERE"; ## no critic
      sub $sub_name {
          my (\$self, \$url, \$args) = \@_;
          \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
          or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
          return \$self->request('$req_method', \$url, \$args || {});
      }
  HERE
  }
  
  #pod =method post_form
  #pod
  #pod     $response = $http->post_form($url, $form_data);
  #pod     $response = $http->post_form($url, $form_data, \%options);
  #pod
  #pod This method executes a C<POST> request and sends the key/value pairs from a
  #pod form data hash or array reference to the given URL with a C<content-type> of
  #pod C<application/x-www-form-urlencoded>.  If data is provided as an array
  #pod reference, the order is preserved; if provided as a hash reference, the terms
  #pod are sorted on key and value for consistency.  See documentation for the
  #pod C<www_form_urlencode> method for details on the encoding.
  #pod
  #pod The URL must have unsafe characters escaped and international domain names
  #pod encoded.  See C<request()> for valid options and a description of the response.
  #pod Any C<content-type> header or content in the options hashref will be ignored.
  #pod
  #pod The C<success> field of the response will be true if the status code is 2XX.
  #pod
  #pod =cut
  
  sub post_form {
      my ($self, $url, $data, $args) = @_;
      (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
          or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
  
      my $headers = {};
      while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
          $headers->{lc $key} = $value;
      }
      delete $args->{headers};
  
      return $self->request('POST', $url, {
              %$args,
              content => $self->www_form_urlencode($data),
              headers => {
                  %$headers,
                  'content-type' => 'application/x-www-form-urlencoded'
              },
          }
      );
  }
  
  #pod =method mirror
  #pod
  #pod     $response = $http->mirror($url, $file, \%options)
  #pod     if ( $response->{success} ) {
  #pod         print "$file is up to date\n";
  #pod     }
  #pod
  #pod Executes a C<GET> request for the URL and saves the response body to the file
  #pod name provided.  The URL must have unsafe characters escaped and international
  #pod domain names encoded.  If the file already exists, the request will include an
  #pod C<If-Modified-Since> header with the modification timestamp of the file.  You
  #pod may specify a different C<If-Modified-Since> header yourself in the C<<
  #pod $options->{headers} >> hash.
  #pod
  #pod The C<success> field of the response will be true if the status code is 2XX
  #pod or if the status code is 304 (unmodified).
  #pod
  #pod If the file was modified and the server response includes a properly
  #pod formatted C<Last-Modified> header, the file modification time will
  #pod be updated accordingly.
  #pod
  #pod =cut
  
  sub mirror {
      my ($self, $url, $file, $args) = @_;
      @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
        or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
      if ( -e $file and my $mtime = (stat($file))[9] ) {
          $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
      }
      my $tempfile = $file . int(rand(2**31));
  
      require Fcntl;
      sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()
         or Carp::croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
      binmode $fh;
      $args->{data_callback} = sub { print {$fh} $_[0] };
      my $response = $self->request('GET', $url, $args);
      close $fh
          or Carp::croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);
  
      if ( $response->{success} ) {
          rename $tempfile, $file
              or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);
          my $lm = $response->{headers}{'last-modified'};
          if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
              utime $mtime, $mtime, $file;
          }
      }
      $response->{success} ||= $response->{status} eq '304';
      unlink $tempfile;
      return $response;
  }
  
  #pod =method request
  #pod
  #pod     $response = $http->request($method, $url);
  #pod     $response = $http->request($method, $url, \%options);
  #pod
  #pod Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
  #pod 'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
  #pod international domain names encoded.
  #pod
  #pod If the URL includes a "user:password" stanza, they will be used for Basic-style
  #pod authorization headers.  (Authorization headers will not be included in a
  #pod redirected request.) For example:
  #pod
  #pod     $http->request('GET', 'http://Aladdin:open sesame@example.com/');
  #pod
  #pod If the "user:password" stanza contains reserved characters, they must
  #pod be percent-escaped:
  #pod
  #pod     $http->request('GET', 'http://john%40example.com:password@example.com/');
  #pod
  #pod A hashref of options may be appended to modify the request.
  #pod
  #pod Valid options are:
  #pod
  #pod =for :list
  #pod * C<headers> â
  #pod     A hashref containing headers to include with the request.  If the value for
  #pod     a header is an array reference, the header will be output multiple times with
  #pod     each value in the array.  These headers over-write any default headers.
  #pod * C<content> â
  #pod     A scalar to include as the body of the request OR a code reference
  #pod     that will be called iteratively to produce the body of the request
  #pod * C<trailer_callback> â
  #pod     A code reference that will be called if it exists to provide a hashref
  #pod     of trailing headers (only used with chunked transfer-encoding)
  #pod * C<data_callback> â
  #pod     A code reference that will be called for each chunks of the response
  #pod     body received.
  #pod
  #pod The C<Host> header is generated from the URL in accordance with RFC 2616.  It
  #pod is a fatal error to specify C<Host> in the C<headers> option.  Other headers
  #pod may be ignored or overwritten if necessary for transport compliance.
  #pod
  #pod If the C<content> option is a code reference, it will be called iteratively
  #pod to provide the content body of the request.  It should return the empty
  #pod string or undef when the iterator is exhausted.
  #pod
  #pod If the C<content> option is the empty string, no C<content-type> or
  #pod C<content-length> headers will be generated.
  #pod
  #pod If the C<data_callback> option is provided, it will be called iteratively until
  #pod the entire response body is received.  The first argument will be a string
  #pod containing a chunk of the response body, the second argument will be the
  #pod in-progress response hash reference, as described below.  (This allows
  #pod customizing the action of the callback based on the C<status> or C<headers>
  #pod received prior to the content body.)
  #pod
  #pod The C<request> method returns a hashref containing the response.  The hashref
  #pod will have the following keys:
  #pod
  #pod =for :list
  #pod * C<success> â
  #pod     Boolean indicating whether the operation returned a 2XX status code
  #pod * C<url> â
  #pod     URL that provided the response. This is the URL of the request unless
  #pod     there were redirections, in which case it is the last URL queried
  #pod     in a redirection chain
  #pod * C<status> â
  #pod     The HTTP status code of the response
  #pod * C<reason> â
  #pod     The response phrase returned by the server
  #pod * C<content> â
  #pod     The body of the response.  If the response does not have any content
  #pod     or if a data callback is provided to consume the response body,
  #pod     this will be the empty string
  #pod * C<headers> â
  #pod     A hashref of header fields.  All header field names will be normalized
  #pod     to be lower case. If a header is repeated, the value will be an arrayref;
  #pod     it will otherwise be a scalar string containing the value
  #pod
  #pod On an exception during the execution of the request, the C<status> field will
  #pod contain 599, and the C<content> field will contain the text of the exception.
  #pod
  #pod =cut
  
  my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
  
  sub request {
      my ($self, $method, $url, $args) = @_;
      @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
        or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
      $args ||= {}; # we keep some state in this during _request
  
      # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
      my $response;
      for ( 0 .. 1 ) {
          $response = eval { $self->_request($method, $url, $args) };
          last unless $@ && $idempotent{$method}
              && $@ =~ m{^(?:Socket closed|Unexpected end)};
      }
  
      if (my $e = $@) {
          # maybe we got a response hash thrown from somewhere deep
          if ( ref $e eq 'HASH' && exists $e->{status} ) {
              return $e;
          }
  
          # otherwise, stringify it
          $e = "$e";
          $response = {
              url     => $url,
              success => q{},
              status  => 599,
              reason  => 'Internal Exception',
              content => $e,
              headers => {
                  'content-type'   => 'text/plain',
                  'content-length' => length $e,
              }
          };
      }
      return $response;
  }
  
  #pod =method www_form_urlencode
  #pod
  #pod     $params = $http->www_form_urlencode( $data );
  #pod     $response = $http->get("http://example.com/query?$params");
  #pod
  #pod This method converts the key/value pairs from a data hash or array reference
  #pod into a C<x-www-form-urlencoded> string.  The keys and values from the data
  #pod reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
  #pod array reference, the key will be repeated with each of the values of the array
  #pod reference.  If data is provided as a hash reference, the key/value pairs in the
  #pod resulting string will be sorted by key and value for consistent ordering.
  #pod
  #pod =cut
  
  sub www_form_urlencode {
      my ($self, $data) = @_;
      (@_ == 2 && ref $data)
          or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
      (ref $data eq 'HASH' || ref $data eq 'ARRAY')
          or Carp::croak("form data must be a hash or array reference\n");
  
      my @params = ref $data eq 'HASH' ? %$data : @$data;
      @params % 2 == 0
          or Carp::croak("form data reference must have an even number of terms\n");
  
      my @terms;
      while( @params ) {
          my ($key, $value) = splice(@params, 0, 2);
          if ( ref $value eq 'ARRAY' ) {
              unshift @params, map { $key => $_ } @$value;
          }
          else {
              push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
          }
      }
  
      return join("&", (ref $data eq 'ARRAY') ? (@terms) : (sort @terms) );
  }
  
  #--------------------------------------------------------------------------#
  # private methods
  #--------------------------------------------------------------------------#
  
  my %DefaultPort = (
      http => 80,
      https => 443,
  );
  
  sub _agent {
      my $class = ref($_[0]) || $_[0];
      (my $default_agent = $class) =~ s{::}{-}g;
      return $default_agent . "/" . $class->VERSION;
  }
  
  sub _request {
      my ($self, $method, $url, $args) = @_;
  
      my ($scheme, $host, $port, $path_query, $auth) = $self->_split_url($url);
  
      my $request = {
          method    => $method,
          scheme    => $scheme,
          host      => $host,
          port      => $port,
          host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
          uri       => $path_query,
          headers   => {},
      };
  
      # We remove the cached handle so it is not reused in the case of redirect.
      # If all is well, it will be recached at the end of _request.  We only
      # reuse for the same scheme, host and port
      my $handle = delete $self->{handle};
      if ( $handle ) {
          unless ( $handle->can_reuse( $scheme, $host, $port ) ) {
              $handle->close;
              undef $handle;
          }
      }
      $handle ||= $self->_open_handle( $request, $scheme, $host, $port );
  
      $self->_prepare_headers_and_cb($request, $args, $url, $auth);
      $handle->write_request($request);
  
      my $response;
      do { $response = $handle->read_response_header }
          until (substr($response->{status},0,1) ne '1');
  
      $self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
  
      if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
          $handle->close;
          return $self->_request(@redir_args, $args);
      }
  
      my $known_message_length;
      if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
          # response has no message body
          $known_message_length = 1;
      }
      else {
          my $data_cb = $self->_prepare_data_cb($response, $args);
          $known_message_length = $handle->read_body($data_cb, $response);
      }
  
      if ( $self->{keep_alive}
          && $known_message_length
          && $response->{protocol} eq 'HTTP/1.1'
          && ($response->{headers}{connection} || '') ne 'close'
      ) {
          $self->{handle} = $handle;
      }
      else {
          $handle->close;
      }
  
      $response->{success} = substr( $response->{status}, 0, 1 ) eq '2';
      $response->{url} = $url;
      return $response;
  }
  
  sub _open_handle {
      my ($self, $request, $scheme, $host, $port) = @_;
  
      my $handle  = HTTP::Tiny::Handle->new(
          timeout         => $self->{timeout},
          SSL_options     => $self->{SSL_options},
          verify_SSL      => $self->{verify_SSL},
          local_address   => $self->{local_address},
          keep_alive      => $self->{keep_alive}
      );
  
      if ($self->{_has_proxy}{$scheme} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) {
          return $self->_proxy_connect( $request, $handle );
      }
      else {
          return $handle->connect($scheme, $host, $port);
      }
  }
  
  sub _proxy_connect {
      my ($self, $request, $handle) = @_;
  
      my @proxy_vars;
      if ( $request->{scheme} eq 'https' ) {
          Carp::croak(qq{No https_proxy defined}) unless $self->{https_proxy};
          @proxy_vars = $self->_split_proxy( https_proxy => $self->{https_proxy} );
          if ( $proxy_vars[0] eq 'https' ) {
              Carp::croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}});
          }
      }
      else {
          Carp::croak(qq{No http_proxy defined}) unless $self->{http_proxy};
          @proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} );
      }
  
      my ($p_scheme, $p_host, $p_port, $p_auth) = @proxy_vars;
  
      if ( length $p_auth && ! defined $request->{headers}{'proxy-authorization'} ) {
          $self->_add_basic_auth_header( $request, 'proxy-authorization' => $p_auth );
      }
  
      $handle->connect($p_scheme, $p_host, $p_port);
  
      if ($request->{scheme} eq 'https') {
          $self->_create_proxy_tunnel( $request, $handle );
      }
      else {
          # non-tunneled proxy requires absolute URI
          $request->{uri} = "$request->{scheme}://$request->{host_port}$request->{uri}";
      }
  
      return $handle;
  }
  
  sub _split_proxy {
      my ($self, $type, $proxy) = @_;
  
      my ($scheme, $host, $port, $path_query, $auth) = eval { $self->_split_url($proxy) };
  
      unless(
          defined($scheme) && length($scheme) && length($host) && length($port)
          && $path_query eq '/'
      ) {
          Carp::croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n});
      }
  
      return ($scheme, $host, $port, $auth);
  }
  
  sub _create_proxy_tunnel {
      my ($self, $request, $handle) = @_;
  
      $handle->_assert_ssl;
  
      my $agent = exists($request->{headers}{'user-agent'})
          ? $request->{headers}{'user-agent'} : $self->{agent};
  
      my $connect_request = {
          method    => 'CONNECT',
          uri       => "$request->{host}:$request->{port}",
          headers   => {
              host => "$request->{host}:$request->{port}",
              'user-agent' => $agent,
          }
      };
  
      if ( $request->{headers}{'proxy-authorization'} ) {
          $connect_request->{headers}{'proxy-authorization'} =
              delete $request->{headers}{'proxy-authorization'};
      }
  
      $handle->write_request($connect_request);
      my $response;
      do { $response = $handle->read_response_header }
          until (substr($response->{status},0,1) ne '1');
  
      # if CONNECT failed, throw the response so it will be
      # returned from the original request() method;
      unless (substr($response->{status},0,1) eq '2') {
          die $response;
      }
  
      # tunnel established, so start SSL handshake
      $handle->start_ssl( $request->{host} );
  
      return;
  }
  
  sub _prepare_headers_and_cb {
      my ($self, $request, $args, $url, $auth) = @_;
  
      for ($self->{default_headers}, $args->{headers}) {
          next unless defined;
          while (my ($k, $v) = each %$_) {
              $request->{headers}{lc $k} = $v;
          }
      }
  
      if (exists $request->{headers}{'host'}) {
          die(qq/The 'Host' header must not be provided as header option\n/);
      }
  
      $request->{headers}{'host'}         = $request->{host_port};
      $request->{headers}{'user-agent'} ||= $self->{agent};
      $request->{headers}{'connection'}   = "close"
          unless $self->{keep_alive};
  
      if ( defined $args->{content} ) {
          if (ref $args->{content} eq 'CODE') {
              $request->{headers}{'content-type'} ||= "application/octet-stream";
              $request->{headers}{'transfer-encoding'} = 'chunked'
                unless $request->{headers}{'content-length'}
                    || $request->{headers}{'transfer-encoding'};
              $request->{cb} = $args->{content};
          }
          elsif ( length $args->{content} ) {
              my $content = $args->{content};
              if ( $] ge '5.008' ) {
                  utf8::downgrade($content, 1)
                      or die(qq/Wide character in request message body\n/);
              }
              $request->{headers}{'content-type'} ||= "application/octet-stream";
              $request->{headers}{'content-length'} = length $content
                unless $request->{headers}{'content-length'}
                    || $request->{headers}{'transfer-encoding'};
              $request->{cb} = sub { substr $content, 0, length $content, '' };
          }
          $request->{trailer_cb} = $args->{trailer_callback}
              if ref $args->{trailer_callback} eq 'CODE';
      }
  
      ### If we have a cookie jar, then maybe add relevant cookies
      if ( $self->{cookie_jar} ) {
          my $cookies = $self->cookie_jar->cookie_header( $url );
          $request->{headers}{cookie} = $cookies if length $cookies;
      }
  
      # if we have Basic auth parameters, add them
      if ( length $auth && ! defined $request->{headers}{authorization} ) {
          $self->_add_basic_auth_header( $request, 'authorization' => $auth );
      }
  
      return;
  }
  
  sub _add_basic_auth_header {
      my ($self, $request, $header, $auth) = @_;
      require MIME::Base64;
      $request->{headers}{$header} =
          "Basic " . MIME::Base64::encode_base64($auth, "");
      return;
  }
  
  sub _prepare_data_cb {
      my ($self, $response, $args) = @_;
      my $data_cb = $args->{data_callback};
      $response->{content} = '';
  
      if (!$data_cb || $response->{status} !~ /^2/) {
          if (defined $self->{max_size}) {
              $data_cb = sub {
                  $_[1]->{content} .= $_[0];
                  die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
                    if length $_[1]->{content} > $self->{max_size};
              };
          }
          else {
              $data_cb = sub { $_[1]->{content} .= $_[0] };
          }
      }
      return $data_cb;
  }
  
  sub _update_cookie_jar {
      my ($self, $url, $response) = @_;
  
      my $cookies = $response->{headers}->{'set-cookie'};
      return unless defined $cookies;
  
      my @cookies = ref $cookies ? @$cookies : $cookies;
  
      $self->cookie_jar->add( $url, $_ ) for @cookies;
  
      return;
  }
  
  sub _validate_cookie_jar {
      my ($class, $jar) = @_;
  
      # duck typing
      for my $method ( qw/add cookie_header/ ) {
          Carp::croak(qq/Cookie jar must provide the '$method' method\n/)
              unless ref($jar) && ref($jar)->can($method);
      }
  
      return;
  }
  
  sub _maybe_redirect {
      my ($self, $request, $response, $args) = @_;
      my $headers = $response->{headers};
      my ($status, $method) = ($response->{status}, $request->{method});
      if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/))
          and $headers->{location}
          and ++$args->{redirects} <= $self->{max_redirect}
      ) {
          my $location = ($headers->{location} =~ /^\//)
              ? "$request->{scheme}://$request->{host_port}$headers->{location}"
              : $headers->{location} ;
          return (($status eq '303' ? 'GET' : $method), $location);
      }
      return;
  }
  
  sub _split_url {
      my $url = pop;
  
      # URI regex adapted from the URI module
      my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
        or die(qq/Cannot parse URL: '$url'\n/);
  
      $scheme     = lc $scheme;
      $path_query = "/$path_query" unless $path_query =~ m<\A/>;
  
      my $auth = '';
      if ( (my $i = index $host, '@') != -1 ) {
          # user:pass@host
          $auth = substr $host, 0, $i, ''; # take up to the @ for auth
          substr $host, 0, 1, '';          # knock the @ off the host
  
          # userinfo might be percent escaped, so recover real auth info
          $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
      }
      my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
               : $scheme eq 'http'                  ? 80
               : $scheme eq 'https'                 ? 443
               : undef;
  
      return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
  }
  
  # Date conversions adapted from HTTP::Date
  my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
  my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
  sub _http_date {
      my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
      return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
          substr($DoW,$wday*4,3),
          $mday, substr($MoY,$mon*4,3), $year+1900,
          $hour, $min, $sec
      );
  }
  
  sub _parse_http_date {
      my ($self, $str) = @_;
      require Time::Local;
      my @tl_parts;
      if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
          @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
      }
      elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
          @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
      }
      elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
          @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
      }
      return eval {
          my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
          $t < 0 ? undef : $t;
      };
  }
  
  # URI escaping adapted from URI::Escape
  # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
  # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
  my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
  $escapes{' '}="+";
  my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
  
  sub _uri_escape {
      my ($self, $str) = @_;
      if ( $] ge '5.008' ) {
          utf8::encode($str);
      }
      else {
          $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
              if ( length $str == do { use bytes; length $str } );
          $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
      }
      $str =~ s/($unsafe_char)/$escapes{$1}/ge;
      return $str;
  }
  
  package
      HTTP::Tiny::Handle; # hide from PAUSE/indexers
  use strict;
  use warnings;
  
  use Errno      qw[EINTR EPIPE];
  use IO::Socket qw[SOCK_STREAM];
  
  # PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old
  # behavior if someone is unable to boostrap CPAN from a new perl install; it is
  # not intended for general, per-client use and may be removed in the future
  my $SOCKET_CLASS =
      $ENV{PERL_HTTP_TINY_IPV4_ONLY} ? 'IO::Socket::INET' :
      eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.25) } ? 'IO::Socket::IP' :
      'IO::Socket::INET';
  
  sub BUFSIZE () { 32768 } ## no critic
  
  my $Printable = sub {
      local $_ = shift;
      s/\r/\\r/g;
      s/\n/\\n/g;
      s/\t/\\t/g;
      s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
      $_;
  };
  
  my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
  
  sub new {
      my ($class, %args) = @_;
      return bless {
          rbuf             => '',
          timeout          => 60,
          max_line_size    => 16384,
          max_header_lines => 64,
          verify_SSL       => 0,
          SSL_options      => {},
          %args
      }, $class;
  }
  
  sub connect {
      @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
      my ($self, $scheme, $host, $port) = @_;
  
      if ( $scheme eq 'https' ) {
          $self->_assert_ssl;
      }
      elsif ( $scheme ne 'http' ) {
        die(qq/Unsupported URL scheme '$scheme'\n/);
      }
      $self->{fh} = $SOCKET_CLASS->new(
          PeerHost  => $host,
          PeerPort  => $port,
          $self->{local_address} ?
              ( LocalAddr => $self->{local_address} ) : (),
          Proto     => 'tcp',
          Type      => SOCK_STREAM,
          Timeout   => $self->{timeout},
          KeepAlive => !!$self->{keep_alive}
      ) or die(qq/Could not connect to '$host:$port': $@\n/);
  
      binmode($self->{fh})
        or die(qq/Could not binmode() socket: '$!'\n/);
  
      $self->start_ssl($host) if $scheme eq 'https';
  
      $self->{scheme} = $scheme;
      $self->{host} = $host;
      $self->{port} = $port;
      $self->{pid} = $$;
      $self->{tid} = _get_tid();
  
      return $self;
  }
  
  sub start_ssl {
      my ($self, $host) = @_;
  
      # As this might be used via CONNECT after an SSL session
      # to a proxy, we shut down any existing SSL before attempting
      # the handshake
      if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
          unless ( $self->{fh}->stop_SSL ) {
              my $ssl_err = IO::Socket::SSL->errstr;
              die(qq/Error halting prior SSL connection: $ssl_err/);
          }
      }
  
      my $ssl_args = $self->_ssl_args($host);
      IO::Socket::SSL->start_SSL(
          $self->{fh},
          %$ssl_args,
          SSL_create_ctx_callback => sub {
              my $ctx = shift;
              Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
          },
      );
  
      unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
          my $ssl_err = IO::Socket::SSL->errstr;
          die(qq/SSL connection failed for $host: $ssl_err\n/);
      }
  }
  
  sub close {
      @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
      my ($self) = @_;
      CORE::close($self->{fh})
        or die(qq/Could not close socket: '$!'\n/);
  }
  
  sub write {
      @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
      my ($self, $buf) = @_;
  
      if ( $] ge '5.008' ) {
          utf8::downgrade($buf, 1)
              or die(qq/Wide character in write()\n/);
      }
  
      my $len = length $buf;
      my $off = 0;
  
      local $SIG{PIPE} = 'IGNORE';
  
      while () {
          $self->can_write
            or die(qq/Timed out while waiting for socket to become ready for writing\n/);
          my $r = syswrite($self->{fh}, $buf, $len, $off);
          if (defined $r) {
              $len -= $r;
              $off += $r;
              last unless $len > 0;
          }
          elsif ($! == EPIPE) {
              die(qq/Socket closed by remote server: $!\n/);
          }
          elsif ($! != EINTR) {
              if ($self->{fh}->can('errstr')){
                  my $err = $self->{fh}->errstr();
                  die (qq/Could not write to SSL socket: '$err'\n /);
              }
              else {
                  die(qq/Could not write to socket: '$!'\n/);
              }
  
          }
      }
      return $off;
  }
  
  sub read {
      @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
      my ($self, $len, $allow_partial) = @_;
  
      my $buf  = '';
      my $got = length $self->{rbuf};
  
      if ($got) {
          my $take = ($got < $len) ? $got : $len;
          $buf  = substr($self->{rbuf}, 0, $take, '');
          $len -= $take;
      }
  
      while ($len > 0) {
          $self->can_read
            or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
          my $r = sysread($self->{fh}, $buf, $len, length $buf);
          if (defined $r) {
              last unless $r;
              $len -= $r;
          }
          elsif ($! != EINTR) {
              if ($self->{fh}->can('errstr')){
                  my $err = $self->{fh}->errstr();
                  die (qq/Could not read from SSL socket: '$err'\n /);
              }
              else {
                  die(qq/Could not read from socket: '$!'\n/);
              }
          }
      }
      if ($len && !$allow_partial) {
          die(qq/Unexpected end of stream\n/);
      }
      return $buf;
  }
  
  sub readline {
      @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
      my ($self) = @_;
  
      while () {
          if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
              return $1;
          }
          if (length $self->{rbuf} >= $self->{max_line_size}) {
              die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
          }
          $self->can_read
            or die(qq/Timed out while waiting for socket to become ready for reading\n/);
          my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
          if (defined $r) {
              last unless $r;
          }
          elsif ($! != EINTR) {
              if ($self->{fh}->can('errstr')){
                  my $err = $self->{fh}->errstr();
                  die (qq/Could not read from SSL socket: '$err'\n /);
              }
              else {
                  die(qq/Could not read from socket: '$!'\n/);
              }
          }
      }
      die(qq/Unexpected end of stream while looking for line\n/);
  }
  
  sub read_header_lines {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
      my ($self, $headers) = @_;
      $headers ||= {};
      my $lines   = 0;
      my $val;
  
      while () {
           my $line = $self->readline;
  
           if (++$lines >= $self->{max_header_lines}) {
               die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
           }
           elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
               my ($field_name) = lc $1;
               if (exists $headers->{$field_name}) {
                   for ($headers->{$field_name}) {
                       $_ = [$_] unless ref $_ eq "ARRAY";
                       push @$_, $2;
                       $val = \$_->[-1];
                   }
               }
               else {
                   $val = \($headers->{$field_name} = $2);
               }
           }
           elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
               $val
                 or die(qq/Unexpected header continuation line\n/);
               next unless length $1;
               $$val .= ' ' if length $$val;
               $$val .= $1;
           }
           elsif ($line =~ /\A \x0D?\x0A \z/x) {
              last;
           }
           else {
              die(q/Malformed header line: / . $Printable->($line) . "\n");
           }
      }
      return $headers;
  }
  
  sub write_request {
      @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
      my($self, $request) = @_;
      $self->write_request_header(@{$request}{qw/method uri headers/});
      $self->write_body($request) if $request->{cb};
      return;
  }
  
  my %HeaderCase = (
      'content-md5'      => 'Content-MD5',
      'etag'             => 'ETag',
      'te'               => 'TE',
      'www-authenticate' => 'WWW-Authenticate',
      'x-xss-protection' => 'X-XSS-Protection',
  );
  
  # to avoid multiple small writes and hence nagle, you can pass the method line or anything else to
  # combine writes.
  sub write_header_lines {
      (@_ == 2 || @_ == 3 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers[,prefix])/ . "\n");
      my($self, $headers, $prefix_data) = @_;
  
      my $buf = (defined $prefix_data ? $prefix_data : '');
      while (my ($k, $v) = each %$headers) {
          my $field_name = lc $k;
          if (exists $HeaderCase{$field_name}) {
              $field_name = $HeaderCase{$field_name};
          }
          else {
              $field_name =~ /\A $Token+ \z/xo
                or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
              $field_name =~ s/\b(\w)/\u$1/g;
              $HeaderCase{lc $field_name} = $field_name;
          }
          for (ref $v eq 'ARRAY' ? @$v : $v) {
              $_ = '' unless defined $_;
              $buf .= "$field_name: $_\x0D\x0A";
          }
      }
      $buf .= "\x0D\x0A";
      return $self->write($buf);
  }
  
  # return value indicates whether message length was defined; this is generally
  # true unless there was no content-length header and we just read until EOF.
  # Other message length errors are thrown as exceptions
  sub read_body {
      @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
      my ($self, $cb, $response) = @_;
      my $te = $response->{headers}{'transfer-encoding'} || '';
      my $chunked = grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ;
      return $chunked
          ? $self->read_chunked_body($cb, $response)
          : $self->read_content_body($cb, $response);
  }
  
  sub write_body {
      @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
      my ($self, $request) = @_;
      if ($request->{headers}{'content-length'}) {
          return $self->write_content_body($request);
      }
      else {
          return $self->write_chunked_body($request);
      }
  }
  
  sub read_content_body {
      @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
      my ($self, $cb, $response, $content_length) = @_;
      $content_length ||= $response->{headers}{'content-length'};
  
      if ( defined $content_length ) {
          my $len = $content_length;
          while ($len > 0) {
              my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
              $cb->($self->read($read, 0), $response);
              $len -= $read;
          }
          return length($self->{rbuf}) == 0;
      }
  
      my $chunk;
      $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
  
      return;
  }
  
  sub write_content_body {
      @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
      my ($self, $request) = @_;
  
      my ($len, $content_length) = (0, $request->{headers}{'content-length'});
      while () {
          my $data = $request->{cb}->();
  
          defined $data && length $data
            or last;
  
          if ( $] ge '5.008' ) {
              utf8::downgrade($data, 1)
                  or die(qq/Wide character in write_content()\n/);
          }
  
          $len += $self->write($data);
      }
  
      $len == $content_length
        or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);
  
      return $len;
  }
  
  sub read_chunked_body {
      @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
      my ($self, $cb, $response) = @_;
  
      while () {
          my $head = $self->readline;
  
          $head =~ /\A ([A-Fa-f0-9]+)/x
            or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
  
          my $len = hex($1)
            or last;
  
          $self->read_content_body($cb, $response, $len);
  
          $self->read(2) eq "\x0D\x0A"
            or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
      }
      $self->read_header_lines($response->{headers});
      return 1;
  }
  
  sub write_chunked_body {
      @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
      my ($self, $request) = @_;
  
      my $len = 0;
      while () {
          my $data = $request->{cb}->();
  
          defined $data && length $data
            or last;
  
          if ( $] ge '5.008' ) {
              utf8::downgrade($data, 1)
                  or die(qq/Wide character in write_chunked_body()\n/);
          }
  
          $len += length $data;
  
          my $chunk  = sprintf '%X', length $data;
             $chunk .= "\x0D\x0A";
             $chunk .= $data;
             $chunk .= "\x0D\x0A";
  
          $self->write($chunk);
      }
      $self->write("0\x0D\x0A");
      $self->write_header_lines($request->{trailer_cb}->())
          if ref $request->{trailer_cb} eq 'CODE';
      return $len;
  }
  
  sub read_response_header {
      @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
      my ($self) = @_;
  
      my $line = $self->readline;
  
      $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
        or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
  
      my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
  
      die (qq/Unsupported HTTP protocol: $protocol\n/)
          unless $version =~ /0*1\.0*[01]/;
  
      return {
          status       => $status,
          reason       => $reason,
          headers      => $self->read_header_lines,
          protocol     => $protocol,
      };
  }
  
  sub write_request_header {
      @_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n");
      my ($self, $method, $request_uri, $headers) = @_;
  
      return $self->write_header_lines($headers, "$method $request_uri HTTP/1.1\x0D\x0A");
  }
  
  sub _do_timeout {
      my ($self, $type, $timeout) = @_;
      $timeout = $self->{timeout}
          unless defined $timeout && $timeout >= 0;
  
      my $fd = fileno $self->{fh};
      defined $fd && $fd >= 0
        or die(qq/select(2): 'Bad file descriptor'\n/);
  
      my $initial = time;
      my $pending = $timeout;
      my $nfound;
  
      vec(my $fdset = '', $fd, 1) = 1;
  
      while () {
          $nfound = ($type eq 'read')
              ? select($fdset, undef, undef, $pending)
              : select(undef, $fdset, undef, $pending) ;
          if ($nfound == -1) {
              $! == EINTR
                or die(qq/select(2): '$!'\n/);
              redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
              $nfound = 0;
          }
          last;
      }
      $! = 0;
      return $nfound;
  }
  
  sub can_read {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
      my $self = shift;
      if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
          return 1 if $self->{fh}->pending;
      }
      return $self->_do_timeout('read', @_)
  }
  
  sub can_write {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
      my $self = shift;
      return $self->_do_timeout('write', @_)
  }
  
  sub _assert_ssl {
      # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback
      die(qq/IO::Socket::SSL 1.42 must be installed for https support\n/)
          unless eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)};
      # Need Net::SSLeay 1.49 for MODE_AUTO_RETRY
      die(qq/Net::SSLeay 1.49 must be installed for https support\n/)
          unless eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)};
  }
  
  sub can_reuse {
      my ($self,$scheme,$host,$port) = @_;
      return 0 if
          $self->{pid} != $$
          || $self->{tid} != _get_tid()
          || length($self->{rbuf})
          || $scheme ne $self->{scheme}
          || $host ne $self->{host}
          || $port ne $self->{port}
          || eval { $self->can_read(0) }
          || $@ ;
          return 1;
  }
  
  # Try to find a CA bundle to validate the SSL cert,
  # prefer Mozilla::CA or fallback to a system file
  sub _find_CA_file {
      my $self = shift();
  
      return $self->{SSL_options}->{SSL_ca_file}
          if $self->{SSL_options}->{SSL_ca_file} and -e $self->{SSL_options}->{SSL_ca_file};
  
      return Mozilla::CA::SSL_ca_file()
          if eval { require Mozilla::CA };
  
      # cert list copied from golang src/crypto/x509/root_unix.go
      foreach my $ca_bundle (
          "/etc/ssl/certs/ca-certificates.crt",     # Debian/Ubuntu/Gentoo etc.
          "/etc/pki/tls/certs/ca-bundle.crt",       # Fedora/RHEL
          "/etc/ssl/ca-bundle.pem",                 # OpenSUSE
          "/etc/openssl/certs/ca-certificates.crt", # NetBSD
          "/etc/ssl/cert.pem",                      # OpenBSD
          "/usr/local/share/certs/ca-root-nss.crt", # FreeBSD/DragonFly
          "/etc/pki/tls/cacert.pem",                # OpenELEC
          "/etc/certs/ca-certificates.crt",         # Solaris 11.2+
      ) {
          return $ca_bundle if -e $ca_bundle;
      }
  
      die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
        . qq/Try installing Mozilla::CA from CPAN\n/;
  }
  
  # for thread safety, we need to know thread id if threads are loaded
  sub _get_tid {
      no warnings 'reserved'; # for 'threads'
      return threads->can("tid") ? threads->tid : 0;
  }
  
  sub _ssl_args {
      my ($self, $host) = @_;
  
      my %ssl_args;
  
      # This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't
      # added until IO::Socket::SSL 1.84
      if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) {
          $ssl_args{SSL_hostname} = $host,          # Sane SNI support
      }
  
      if ($self->{verify_SSL}) {
          $ssl_args{SSL_verifycn_scheme}  = 'http'; # enable CN validation
          $ssl_args{SSL_verifycn_name}    = $host;  # set validation hostname
          $ssl_args{SSL_verify_mode}      = 0x01;   # enable cert validation
          $ssl_args{SSL_ca_file}          = $self->_find_CA_file;
      }
      else {
          $ssl_args{SSL_verifycn_scheme}  = 'none'; # disable CN validation
          $ssl_args{SSL_verify_mode}      = 0x00;   # disable cert validation
      }
  
      # user options override settings from verify_SSL
      for my $k ( keys %{$self->{SSL_options}} ) {
          $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
      }
  
      return \%ssl_args;
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  HTTP::Tiny - A small, simple, correct HTTP/1.1 client
  
  =head1 VERSION
  
  version 0.054
  
  =head1 SYNOPSIS
  
      use HTTP::Tiny;
  
      my $response = HTTP::Tiny->new->get('http://example.com/');
  
      die "Failed!\n" unless $response->{success};
  
      print "$response->{status} $response->{reason}\n";
  
      while (my ($k, $v) = each %{$response->{headers}}) {
          for (ref $v eq 'ARRAY' ? @$v : $v) {
              print "$k: $_\n";
          }
      }
  
      print $response->{content} if length $response->{content};
  
  =head1 DESCRIPTION
  
  This is a very simple HTTP/1.1 client, designed for doing simple
  requests without the overhead of a large framework like L<LWP::UserAgent>.
  
  It is more correct and more complete than L<HTTP::Lite>.  It supports
  proxies and redirection.  It also correctly resumes after EINTR.
  
  If L<IO::Socket::IP> 0.25 or later is installed, HTTP::Tiny will use it instead
  of L<IO::Socket::INET> for transparent support for both IPv4 and IPv6.
  
  Cookie support requires L<HTTP::CookieJar> or an equivalent class.
  
  =head1 METHODS
  
  =head2 new
  
      $http = HTTP::Tiny->new( %attributes );
  
  This constructor returns a new HTTP::Tiny object.  Valid attributes include:
  
  =over 4
  
  =item *
  
  C<agent> â A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> â ends in a space character, the default user-agent string is appended.
  
  =item *
  
  C<cookie_jar> â An instance of L<HTTP::CookieJar> â or equivalent class that supports the C<add> and C<cookie_header> methods
  
  =item *
  
  C<default_headers> â A hashref of default headers to apply to requests
  
  =item *
  
  C<local_address> â The local IP address to bind to
  
  =item *
  
  C<keep_alive> â Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
  
  =item *
  
  C<max_redirect> â Maximum number of redirects allowed (defaults to 5)
  
  =item *
  
  C<max_size> â Maximum response size (only when not using a data callback).  If defined, responses larger than this will return an exception.
  
  =item *
  
  C<http_proxy> â URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> â if set)
  
  =item *
  
  C<https_proxy> â URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> â if set)
  
  =item *
  
  C<proxy> â URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> â if set)
  
  =item *
  
  C<no_proxy> â List of domain suffixes that should not be proxied.  Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> â)
  
  =item *
  
  C<timeout> â Request timeout in seconds (default is 60)
  
  =item *
  
  C<verify_SSL> â A boolean that indicates whether to validate the SSL certificate of an C<https> â connection (default is false)
  
  =item *
  
  C<SSL_options> â A hashref of C<SSL_*> â options to pass through to L<IO::Socket::SSL>
  
  =back
  
  Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
  prevent getting the corresponding proxies from the environment.
  
  Exceptions from C<max_size>, C<timeout> or other errors will result in a
  pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
  content field in the response will contain the text of the exception.
  
  The C<keep_alive> parameter enables a persistent connection, but only to a
  single destination scheme, host and port.  Also, if any connection-relevant
  attributes are modified, or if the process ID or thread ID change, the
  persistent connection will be dropped.  If you want persistent connections
  across multiple destinations, use multiple HTTP::Tiny objects.
  
  See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
  
  =head2 get|head|put|post|delete
  
      $response = $http->get($url);
      $response = $http->get($url, \%options);
      $response = $http->head($url);
  
  These methods are shorthand for calling C<request()> for the given method.  The
  URL must have unsafe characters escaped and international domain names encoded.
  See C<request()> for valid options and a description of the response.
  
  The C<success> field of the response will be true if the status code is 2XX.
  
  =head2 post_form
  
      $response = $http->post_form($url, $form_data);
      $response = $http->post_form($url, $form_data, \%options);
  
  This method executes a C<POST> request and sends the key/value pairs from a
  form data hash or array reference to the given URL with a C<content-type> of
  C<application/x-www-form-urlencoded>.  If data is provided as an array
  reference, the order is preserved; if provided as a hash reference, the terms
  are sorted on key and value for consistency.  See documentation for the
  C<www_form_urlencode> method for details on the encoding.
  
  The URL must have unsafe characters escaped and international domain names
  encoded.  See C<request()> for valid options and a description of the response.
  Any C<content-type> header or content in the options hashref will be ignored.
  
  The C<success> field of the response will be true if the status code is 2XX.
  
  =head2 mirror
  
      $response = $http->mirror($url, $file, \%options)
      if ( $response->{success} ) {
          print "$file is up to date\n";
      }
  
  Executes a C<GET> request for the URL and saves the response body to the file
  name provided.  The URL must have unsafe characters escaped and international
  domain names encoded.  If the file already exists, the request will include an
  C<If-Modified-Since> header with the modification timestamp of the file.  You
  may specify a different C<If-Modified-Since> header yourself in the C<<
  $options->{headers} >> hash.
  
  The C<success> field of the response will be true if the status code is 2XX
  or if the status code is 304 (unmodified).
  
  If the file was modified and the server response includes a properly
  formatted C<Last-Modified> header, the file modification time will
  be updated accordingly.
  
  =head2 request
  
      $response = $http->request($method, $url);
      $response = $http->request($method, $url, \%options);
  
  Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
  'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
  international domain names encoded.
  
  If the URL includes a "user:password" stanza, they will be used for Basic-style
  authorization headers.  (Authorization headers will not be included in a
  redirected request.) For example:
  
      $http->request('GET', 'http://Aladdin:open sesame@example.com/');
  
  If the "user:password" stanza contains reserved characters, they must
  be percent-escaped:
  
      $http->request('GET', 'http://john%40example.com:password@example.com/');
  
  A hashref of options may be appended to modify the request.
  
  Valid options are:
  
  =over 4
  
  =item *
  
  C<headers> â A hashref containing headers to include with the request.  If the value for a header is an array reference, the header will be output multiple times with each value in the array.  These headers over-write any default headers.
  
  =item *
  
  C<content> â A scalar to include as the body of the request OR a code reference that will be called iteratively to produce the body of the request
  
  =item *
  
  C<trailer_callback> â A code reference that will be called if it exists to provide a hashref of trailing headers (only used with chunked transfer-encoding)
  
  =item *
  
  C<data_callback> â A code reference that will be called for each chunks of the response body received.
  
  =back
  
  The C<Host> header is generated from the URL in accordance with RFC 2616.  It
  is a fatal error to specify C<Host> in the C<headers> option.  Other headers
  may be ignored or overwritten if necessary for transport compliance.
  
  If the C<content> option is a code reference, it will be called iteratively
  to provide the content body of the request.  It should return the empty
  string or undef when the iterator is exhausted.
  
  If the C<content> option is the empty string, no C<content-type> or
  C<content-length> headers will be generated.
  
  If the C<data_callback> option is provided, it will be called iteratively until
  the entire response body is received.  The first argument will be a string
  containing a chunk of the response body, the second argument will be the
  in-progress response hash reference, as described below.  (This allows
  customizing the action of the callback based on the C<status> or C<headers>
  received prior to the content body.)
  
  The C<request> method returns a hashref containing the response.  The hashref
  will have the following keys:
  
  =over 4
  
  =item *
  
  C<success> â Boolean indicating whether the operation returned a 2XX status code
  
  =item *
  
  C<url> â URL that provided the response. This is the URL of the request unless there were redirections, in which case it is the last URL queried in a redirection chain
  
  =item *
  
  C<status> â The HTTP status code of the response
  
  =item *
  
  C<reason> â The response phrase returned by the server
  
  =item *
  
  C<content> â The body of the response.  If the response does not have any content or if a data callback is provided to consume the response body, this will be the empty string
  
  =item *
  
  C<headers> â A hashref of header fields.  All header field names will be normalized to be lower case. If a header is repeated, the value will be an arrayref; it will otherwise be a scalar string containing the value
  
  =back
  
  On an exception during the execution of the request, the C<status> field will
  contain 599, and the C<content> field will contain the text of the exception.
  
  =head2 www_form_urlencode
  
      $params = $http->www_form_urlencode( $data );
      $response = $http->get("http://example.com/query?$params");
  
  This method converts the key/value pairs from a data hash or array reference
  into a C<x-www-form-urlencoded> string.  The keys and values from the data
  reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
  array reference, the key will be repeated with each of the values of the array
  reference.  If data is provided as a hash reference, the key/value pairs in the
  resulting string will be sorted by key and value for consistent ordering.
  
  =for Pod::Coverage SSL_options
  agent
  cookie_jar
  default_headers
  http_proxy
  https_proxy
  keep_alive
  local_address
  max_redirect
  max_size
  no_proxy
  proxy
  timeout
  verify_SSL
  
  =head1 SSL SUPPORT
  
  Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
  greater and L<Net::SSLeay> 1.49 or greater are installed. An exception will be
  thrown if new enough versions of these modules are not installed or if the SSL
  encryption fails. An C<https> connection may be made via an C<http> proxy that
  supports the CONNECT command (i.e. RFC 2817).  You may not proxy C<https> via
  a proxy that itself requires C<https> to communicate.
  
  SSL provides two distinct capabilities:
  
  =over 4
  
  =item *
  
  Encrypted communication channel
  
  =item *
  
  Verification of server identity
  
  =back
  
  B<By default, HTTP::Tiny does not verify server identity>.
  
  Server identity verification is controversial and potentially tricky because it
  depends on a (usually paid) third-party Certificate Authority (CA) trust model
  to validate a certificate as legitimate.  This discriminates against servers
  with self-signed certificates or certificates signed by free, community-driven
  CA's such as L<CAcert.org|http://cacert.org>.
  
  By default, HTTP::Tiny does not make any assumptions about your trust model,
  threat level or risk tolerance.  It just aims to give you an encrypted channel
  when you need one.
  
  Setting the C<verify_SSL> attribute to a true value will make HTTP::Tiny verify
  that an SSL connection has a valid SSL certificate corresponding to the host
  name of the connection and that the SSL certificate has been verified by a CA.
  Assuming you trust the CA, this will protect against a L<man-in-the-middle
  attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>.  If you are
  concerned about security, you should enable this option.
  
  Certificate verification requires a file containing trusted CA certificates.
  If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file
  included with it as a source of trusted CA's.  (This means you trust Mozilla,
  the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the
  toolchain used to install it, and your operating system security, right?)
  
  If that module is not available, then HTTP::Tiny will search several
  system-specific default locations for a CA certificate file:
  
  =over 4
  
  =item *
  
  /etc/ssl/certs/ca-certificates.crt
  
  =item *
  
  /etc/pki/tls/certs/ca-bundle.crt
  
  =item *
  
  /etc/ssl/ca-bundle.pem
  
  =back
  
  An exception will be raised if C<verify_SSL> is true and no CA certificate file
  is available.
  
  If you desire complete control over SSL connections, the C<SSL_options> attribute
  lets you provide a hash reference that will be passed through to
  C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For
  example, to provide your own trusted CA file:
  
      SSL_options => {
          SSL_ca_file => $file_path,
      }
  
  The C<SSL_options> attribute could also be used for such things as providing a
  client certificate for authentication to a server or controlling the choice of
  cipher used for the SSL connection. See L<IO::Socket::SSL> documentation for
  details.
  
  =head1 PROXY SUPPORT
  
  HTTP::Tiny can proxy both C<http> and C<https> requests.  Only Basic proxy
  authorization is supported and it must be provided as part of the proxy URL:
  C<http://user:pass@proxy.example.com/>.
  
  HTTP::Tiny supports the following proxy environment variables:
  
  =over 4
  
  =item *
  
  http_proxy or HTTP_PROXY
  
  =item *
  
  https_proxy or HTTPS_PROXY
  
  =item *
  
  all_proxy or ALL_PROXY
  
  =back
  
  If the C<REQUEST_METHOD> environment variable is set, then this might be a CGI
  process and C<HTTP_PROXY> would be set from the C<Proxy:> header, which is a
  security risk.  If C<REQUEST_METHOD> is set, C<HTTP_PROXY> (the upper case
  variant only) is ignored.
  
  Tunnelling C<https> over an C<http> proxy using the CONNECT method is
  supported.  If your proxy uses C<https> itself, you can not tunnel C<https>
  over it.
  
  Be warned that proxying an C<https> connection opens you to the risk of a
  man-in-the-middle attack by the proxy server.
  
  The C<no_proxy> environment variable is supported in the format of a
  comma-separated list of domain extensions proxy should not be used for.
  
  Proxy arguments passed to C<new> will override their corresponding
  environment variables.
  
  =head1 LIMITATIONS
  
  HTTP::Tiny is I<conditionally compliant> with the
  L<HTTP/1.1 specifications|http://www.w3.org/Protocols/>:
  
  =over 4
  
  =item *
  
  "Message Syntax and Routing" [RFC7230]
  
  =item *
  
  "Semantics and Content" [RFC7231]
  
  =item *
  
  "Conditional Requests" [RFC7232]
  
  =item *
  
  "Range Requests" [RFC7233]
  
  =item *
  
  "Caching" [RFC7234]
  
  =item *
  
  "Authentication" [RFC7235]
  
  =back
  
  It attempts to meet all "MUST" requirements of the specification, but does not
  implement all "SHOULD" requirements.  (Note: it was developed against the
  earlier RFC 2616 specification and may not yet meet the revised RFC 7230-7235
  spec.)
  
  Some particular limitations of note include:
  
  =over
  
  =item *
  
  HTTP::Tiny focuses on correct transport.  Users are responsible for ensuring
  that user-defined headers and content are compliant with the HTTP/1.1
  specification.
  
  =item *
  
  Users must ensure that URLs are properly escaped for unsafe characters and that
  international domain names are properly encoded to ASCII. See L<URI::Escape>,
  L<URI::_punycode> and L<Net::IDN::Encode>.
  
  =item *
  
  Redirection is very strict against the specification.  Redirection is only
  automatic for response codes 301, 302 and 307 if the request method is 'GET' or
  'HEAD'.  Response code 303 is always converted into a 'GET' redirection, as
  mandated by the specification.  There is no automatic support for status 305
  ("Use proxy") redirections.
  
  =item *
  
  There is no provision for delaying a request body using an C<Expect> header.
  Unexpected C<1XX> responses are silently ignored as per the specification.
  
  =item *
  
  Only 'chunked' C<Transfer-Encoding> is supported.
  
  =item *
  
  There is no support for a Request-URI of '*' for the 'OPTIONS' request.
  
  =back
  
  Despite the limitations listed above, HTTP::Tiny is considered
  feature-complete.  New feature requests should be directed to
  L<HTTP::Tiny::UA>.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item *
  
  L<HTTP::Tiny::UA> - Higher level UA features for HTTP::Tiny
  
  =item *
  
  L<HTTP::Thin> - HTTP::Tiny wrapper with L<HTTP::Request>/L<HTTP::Response> compatibility
  
  =item *
  
  L<HTTP::Tiny::Mech> - Wrap L<WWW::Mechanize> instance in HTTP::Tiny compatible interface
  
  =item *
  
  L<IO::Socket::IP> - Required for IPv6 support
  
  =item *
  
  L<IO::Socket::SSL> - Required for SSL support
  
  =item *
  
  L<LWP::UserAgent> - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things
  
  =item *
  
  L<Mozilla::CA> - Required if you want to validate SSL certificates
  
  =item *
  
  L<Net::SSLeay> - Required for SSL support
  
  =back
  
  =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
  
  =head1 SUPPORT
  
  =head2 Bugs / Feature Requests
  
  Please report any bugs or feature requests through the issue tracker
  at L<https://github.com/chansen/p5-http-tiny/issues>.
  You will be notified automatically of any progress on your issue.
  
  =head2 Source Code
  
  This is open source software.  The code repository is available for
  public review and contribution under the terms of the license.
  
  L<https://github.com/chansen/p5-http-tiny>
  
    git clone https://github.com/chansen/p5-http-tiny.git
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Christian Hansen <chansen@cpan.org>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 CONTRIBUTORS
  
  =for stopwords Alan Gardner Alessandro Ghedini Brad Gilbert Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Mitchell Dean Pearce Edward Zborowski James Raspass Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Olaf Alders Petr PÃ­saÅ Serguei Trouchelle SÃ¶ren Kornetzki Syohei YOSHIDA Tom Hukins Tony Cook
  
  =over 4
  
  =item *
  
  Alan Gardner <gardner@pythian.com>
  
  =item *
  
  Alessandro Ghedini <al3xbio@gmail.com>
  
  =item *
  
  Brad Gilbert <bgills@cpan.org>
  
  =item *
  
  Chris Nehren <apeiron@cpan.org>
  
  =item *
  
  Chris Weyl <cweyl@alumni.drew.edu>
  
  =item *
  
  Claes Jakobsson <claes@surfar.nu>
  
  =item *
  
  Clinton Gormley <clint@traveljury.com>
  
  =item *
  
  Craig Berry <cberry@cpan.org>
  
  =item *
  
  David Mitchell <davem@iabyn.com>
  
  =item *
  
  Dean Pearce <pearce@pythian.com>
  
  =item *
  
  Edward Zborowski <ed@rubensteintech.com>
  
  =item *
  
  James Raspass <jraspass@gmail.com>
  
  =item *
  
  Jess Robinson <castaway@desert-island.me.uk>
  
  =item *
  
  Lukas Eklund <leklund@gmail.com>
  
  =item *
  
  Martin J. Evans <mjegh@ntlworld.com>
  
  =item *
  
  Martin-Louis Bright <mlbright@gmail.com>
  
  =item *
  
  Mike Doherty <doherty@cpan.org>
  
  =item *
  
  Olaf Alders <olaf@wundersolutions.com>
  
  =item *
  
  Petr PÃ­saÅ <ppisar@redhat.com>
  
  =item *
  
  Serguei Trouchelle <stro@cpan.org>
  
  =item *
  
  SÃ¶ren Kornetzki <soeren.kornetzki@delti.com>
  
  =item *
  
  Syohei YOSHIDA <syohex@gmail.com>
  
  =item *
  
  Tom Hukins <tom@eborcom.com>
  
  =item *
  
  Tony Cook <tony@develop-help.com>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by Christian Hansen.
  
  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
HTTP_TINY

$fatpacked{"HTTP/Tiny/UNIX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY_UNIX';
  package HTTP::Tiny::UNIX;
  
  use 5.010001;
  use strict;
  use warnings;
  
  our $DATE = '2014-07-04'; # DATE
  our $VERSION = '0.04'; # VERSION
  
  # issue: port must be numeric to avoid warning
  # put everything in path_query
  
  use parent qw(HTTP::Tiny);
  
  use IO::Socket::UNIX;
  
  sub _split_url {
      my ($self, $url) = @_;
  
      if ($url =~ m<\A[^:/?#]+://>) {
          $self->{_unix} = 0;
          return $self->SUPER::_split_url($url);
      }
  
      my ($scheme, $sock_path, $path_query) =
          $url =~ m<\A(\w+):(.+?)/(/[^#]*)>
              or die "Cannot parse HTTP-over-Unix URL: '$url'\n";
  
      # a hack
      $self->{_unix} = 1;
      $self->{_path_query} = $path_query;
  
      $scheme = lc $scheme;
      die "Only http scheme is supported\n" unless $scheme eq 'http';
  
      #return ($scheme, $host,      $port, $path_query, $auth);
      return  ($scheme, $sock_path, -1,    $path_query, '');
  }
  
  sub _open_handle {
      my ($self, $request, $scheme, $host, $port) = @_;
  
      return $self->SUPER::_open_handle($request, $scheme, $host, $port)
          unless $self->{_unix};
  
      my $handle = HTTP::Tiny::Handle::UNIX->new(
          timeout => $self->{timeout},
      );
  
      $handle->connect($scheme, $host, $port, $self);
  }
  
  package
      HTTP::Tiny::Handle::UNIX;
  
  use parent -norequire, 'HTTP::Tiny::Handle';
  
  use IO::Socket;
  
  sub connect {
      my ($self, $scheme, $host, $port, $tiny) = @_;
  
      # on Unix, we use $host for path and leave port at -1 (unused)
      my $path = $host;
  
      local($^W) = 0;
      my $sock = IO::Socket::UNIX->new(
          Peer    => $path,
          Type    => SOCK_STREAM,
          Timeout => $self->{timeout},
          Host    => 'localhost',
      );
  
      unless ($sock) {
          $@ =~ s/^.*?: //;
          die "Can't open Unix socket $path\: $@";
      }
  
      eval { $sock->blocking(0); };
  
      $self->{fh} = $sock;
  
      $self->{scheme} = $scheme;
      $self->{host} = $host;
      $self->{port} = $port;
      $self->{_unix} = 1;
      # this is a hack, we inject this so we can get HTTP::Tiny::UNIX object from
      # HTTP::Tiny::Handle::UNIX, to get path
      $self->{_tiny} = $tiny;
      $self;
  }
  
  sub write_request_header {
      my ($self, $method, $request_uri, $headers) = @_;
  
      return $self->write_request_header($method, $request_uri, $headers)
          unless $self->{_unix};
  
      return $self->write_header_lines($headers, "$method $self->{_tiny}{_path_query} HTTP/1.1\x0D\x0A");
  }
  
  1;
  # ABSTRACT: A subclass of HTTP::Tiny to connect to HTTP server over Unix socket
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  HTTP::Tiny::UNIX - A subclass of HTTP::Tiny to connect to HTTP server over Unix socket
  
  =head1 VERSION
  
  This document describes version 0.04 of HTTP::Tiny::UNIX (from Perl distribution HTTP-Tiny-UNIX), released on 2014-07-04.
  
  =head1 SYNOPSIS
  
   use HTTP::Tiny::UNIX;
  
   my $response = HTTP::Tiny::UNIX->new->get('http:/path/to/unix.sock//uri/path');
  
   die "Failed!\n" unless $response->{success};
   print "$response->{status} $response->{reason}\n";
  
   while (my ($k, $v) = each %{$response->{headers}}) {
       for (ref $v eq 'ARRAY' ? @$v : $v) {
           print "$k: $_\n";
       }
   }
  
   print $response->{content} if length $response->{content};
  
  =head1 DESCRIPTION
  
  This is a subclass of L<HTTP::Tiny> to connect to HTTP server over Unix socket.
  URL syntax is C<"http:"> + I<path to unix socket> + C<"/"> + I<uri path>. For
  example: C<http:/var/run/apid.sock//api/v1/matches>. URL not matching this
  pattern will be passed to HTTP::Tiny.
  
  Proxy is currently not supported.
  
  =head1 SEE ALSO
  
  L<HTTP::Tiny>
  
  To use L<LWP> to connect over Unix sockets, see
  L<LWP::protocol::http::SocketUnixAlt>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/HTTP-Tiny-UNIX>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-HTTP-Tiny-UNIX>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=HTTP-Tiny-UNIX>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  Steven Haryanto <stevenharyanto@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Steven Haryanto.
  
  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
HTTP_TINY_UNIX

$fatpacked{"IOD.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IOD';
  package IOD;
  
  our $DATE = '2015-03-18'; # DATE
  our $VERSION = '0.9.9'; # VERSION
  
  1;
  # ABSTRACT: IOD (INI On Drugs) file format specification
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  IOD - IOD (INI On Drugs) file format specification
  
  =head1 VERSION
  
  This document describes version 0.9.9 of IOD (from Perl distribution IOD), released on 2015-03-18.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/IOD>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-IOD>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=IOD>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
IOD

$fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
  package JSON;
  
  
  use strict;
  use Carp ();
  use base qw(Exporter);
  @JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json);
  
  BEGIN {
      $JSON::VERSION = '2.90';
      $JSON::DEBUG   = 0 unless (defined $JSON::DEBUG);
      $JSON::DEBUG   = $ENV{ PERL_JSON_DEBUG } if exists $ENV{ PERL_JSON_DEBUG };
  }
  
  my $Module_XS  = 'JSON::XS';
  my $Module_PP  = 'JSON::PP';
  my $Module_bp  = 'JSON::backportPP'; # included in JSON distribution
  my $PP_Version = '2.27203';
  my $XS_Version = '2.34';
  
  
  # XS and PP common methods
  
  my @PublicMethods = qw/
      ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref 
      allow_blessed convert_blessed filter_json_object filter_json_single_key_object 
      shrink max_depth max_size encode decode decode_prefix allow_unknown
  /;
  
  my @Properties = qw/
      ascii latin1 utf8 indent space_before space_after relaxed canonical allow_nonref
      allow_blessed convert_blessed shrink max_depth max_size allow_unknown
  /;
  
  my @XSOnlyMethods = qw/allow_tags/; # Currently nothing
  
  my @PPOnlyMethods = qw/
      indent_length sort_by
      allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed
  /; # JSON::PP specific
  
  
  # used in _load_xs and _load_pp ($INSTALL_ONLY is not used currently)
  my $_INSTALL_DONT_DIE  = 1; # When _load_xs fails to load XS, don't die.
  my $_INSTALL_ONLY      = 2; # Don't call _set_methods()
  my $_ALLOW_UNSUPPORTED = 0;
  my $_UNIV_CONV_BLESSED = 0;
  my $_USSING_bpPP       = 0;
  
  
  # Check the environment variable to decide worker module. 
  
  unless ($JSON::Backend) {
      $JSON::DEBUG and  Carp::carp("Check used worker module...");
  
      my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1;
  
      if ($backend eq '1' or $backend =~ /JSON::XS\s*,\s*JSON::PP/) {
          _load_xs($_INSTALL_DONT_DIE) or _load_pp();
      }
      elsif ($backend eq '0' or $backend eq 'JSON::PP') {
          _load_pp();
      }
      elsif ($backend eq '2' or $backend eq 'JSON::XS') {
          _load_xs();
      }
      elsif ($backend eq 'JSON::backportPP') {
          $_USSING_bpPP = 1;
          _load_pp();
      }
      else {
          Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid.";
      }
  }
  
  
  sub import {
      my $pkg = shift;
      my @what_to_export;
      my $no_export;
  
      for my $tag (@_) {
          if ($tag eq '-support_by_pp') {
              if (!$_ALLOW_UNSUPPORTED++) {
                  JSON::Backend::XS
                      ->support_by_pp(@PPOnlyMethods) if ($JSON::Backend eq $Module_XS);
              }
              next;
          }
          elsif ($tag eq '-no_export') {
              $no_export++, next;
          }
          elsif ( $tag eq '-convert_blessed_universally' ) {
              eval q|
                  require B;
                  *UNIVERSAL::TO_JSON = sub {
                      my $b_obj = B::svref_2object( $_[0] );
                      return    $b_obj->isa('B::HV') ? { %{ $_[0] } }
                              : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
                              : undef
                              ;
                  }
              | if ( !$_UNIV_CONV_BLESSED++ );
              next;
          }
          push @what_to_export, $tag;
      }
  
      return if ($no_export);
  
      __PACKAGE__->export_to_level(1, $pkg, @what_to_export);
  }
  
  
  # OBSOLETED
  
  sub jsonToObj {
      my $alternative = 'from_json';
      if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
          shift @_; $alternative = 'decode';
      }
      Carp::carp "'jsonToObj' will be obsoleted. Please use '$alternative' instead.";
      return JSON::from_json(@_);
  };
  
  sub objToJson {
      my $alternative = 'to_json';
      if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
          shift @_; $alternative = 'encode';
      }
      Carp::carp "'objToJson' will be obsoleted. Please use '$alternative' instead.";
      JSON::to_json(@_);
  };
  
  
  # INTERFACES
  
  sub to_json ($@) {
      if (
          ref($_[0]) eq 'JSON'
          or (@_ > 2 and $_[0] eq 'JSON')
      ) {
          Carp::croak "to_json should not be called as a method.";
      }
      my $json = JSON->new;
  
      if (@_ == 2 and ref $_[1] eq 'HASH') {
          my $opt  = $_[1];
          for my $method (keys %$opt) {
              $json->$method( $opt->{$method} );
          }
      }
  
      $json->encode($_[0]);
  }
  
  
  sub from_json ($@) {
      if ( ref($_[0]) eq 'JSON' or $_[0] eq 'JSON' ) {
          Carp::croak "from_json should not be called as a method.";
      }
      my $json = JSON->new;
  
      if (@_ == 2 and ref $_[1] eq 'HASH') {
          my $opt  = $_[1];
          for my $method (keys %$opt) {
              $json->$method( $opt->{$method} );
          }
      }
  
      return $json->decode( $_[0] );
  }
  
  
  
  sub true  { $JSON::true  }
  
  sub false { $JSON::false }
  
  sub null  { undef; }
  
  
  sub require_xs_version { $XS_Version; }
  
  sub backend {
      my $proto = shift;
      $JSON::Backend;
  }
  
  #*module = *backend;
  
  
  sub is_xs {
      return $_[0]->backend eq $Module_XS;
  }
  
  
  sub is_pp {
      return not $_[0]->is_xs;
  }
  
  
  sub pureperl_only_methods { @PPOnlyMethods; }
  
  
  sub property {
      my ($self, $name, $value) = @_;
  
      if (@_ == 1) {
          my %props;
          for $name (@Properties) {
              my $method = 'get_' . $name;
              if ($name eq 'max_size') {
                  my $value = $self->$method();
                  $props{$name} = $value == 1 ? 0 : $value;
                  next;
              }
              $props{$name} = $self->$method();
          }
          return \%props;
      }
      elsif (@_ > 3) {
          Carp::croak('property() can take only the option within 2 arguments.');
      }
      elsif (@_ == 2) {
          if ( my $method = $self->can('get_' . $name) ) {
              if ($name eq 'max_size') {
                  my $value = $self->$method();
                  return $value == 1 ? 0 : $value;
              }
              $self->$method();
          }
      }
      else {
          $self->$name($value);
      }
  
  }
  
  
  
  # INTERNAL
  
  sub _load_xs {
      my $opt = shift;
  
      $JSON::DEBUG and Carp::carp "Load $Module_XS.";
  
      # if called after install module, overload is disable.... why?
      JSON::Boolean::_overrride_overload($Module_XS);
      JSON::Boolean::_overrride_overload($Module_PP);
  
      eval qq|
          use $Module_XS $XS_Version ();
      |;
  
      if ($@) {
          if (defined $opt and $opt & $_INSTALL_DONT_DIE) {
              $JSON::DEBUG and Carp::carp "Can't load $Module_XS...($@)";
              return 0;
          }
          Carp::croak $@;
      }
  
      unless (defined $opt and $opt & $_INSTALL_ONLY) {
          _set_module( $JSON::Backend = $Module_XS );
          my $data = join("", <DATA>); # this code is from Jcode 2.xx.
          close(DATA);
          eval $data;
          JSON::Backend::XS->init;
      }
  
      return 1;
  };
  
  
  sub _load_pp {
      my $opt = shift;
      my $backend = $_USSING_bpPP ? $Module_bp : $Module_PP;
  
      $JSON::DEBUG and Carp::carp "Load $backend.";
  
      # if called after install module, overload is disable.... why?
      JSON::Boolean::_overrride_overload($Module_XS);
      JSON::Boolean::_overrride_overload($backend);
  
      if ( $_USSING_bpPP ) {
          eval qq| require $backend |;
      }
      else {
          eval qq| use $backend $PP_Version () |;
      }
  
      if ($@) {
          if ( $backend eq $Module_PP ) {
              $JSON::DEBUG and Carp::carp "Can't load $Module_PP ($@), so try to load $Module_bp";
              $_USSING_bpPP++;
              $backend = $Module_bp;
              JSON::Boolean::_overrride_overload($backend);
              local $^W; # if PP installed but invalid version, backportPP redefines methods.
              eval qq| require $Module_bp |;
          }
          Carp::croak $@ if $@;
      }
  
      unless (defined $opt and $opt & $_INSTALL_ONLY) {
          _set_module( $JSON::Backend = $Module_PP ); # even if backportPP, set $Backend with 'JSON::PP'
          JSON::Backend::PP->init;
      }
  };
  
  
  sub _set_module {
      return if defined $JSON::true;
  
      my $module = shift;
  
      local $^W;
      no strict qw(refs);
  
      $JSON::true  = ${"$module\::true"};
      $JSON::false = ${"$module\::false"};
  
      push @JSON::ISA, $module;
      if ( JSON->is_xs and JSON->backend->VERSION < 3 ) {
          eval 'package JSON::PP::Boolean';
          push @{"$module\::Boolean::ISA"}, qw(JSON::PP::Boolean);
      }
  
      *{"JSON::is_bool"} = \&{"$module\::is_bool"};
  
      for my $method ($module eq $Module_XS ? @PPOnlyMethods : @XSOnlyMethods) {
          *{"JSON::$method"} = sub {
              Carp::carp("$method is not supported in $module.");
              $_[0];
          };
      }
  
      return 1;
  }
  
  
  
  #
  # JSON Boolean
  #
  
  package JSON::Boolean;
  
  my %Installed;
  
  sub _overrride_overload {
      return; # this function is currently disable.
      return if ($Installed{ $_[0] }++);
  
      my $boolean = $_[0] . '::Boolean';
  
      eval sprintf(q|
          package %s;
          use overload (
              '""' => sub { ${$_[0]} == 1 ? 'true' : 'false' },
              'eq' => sub {
                  my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]);
                  if ($op eq 'true' or $op eq 'false') {
                      return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op;
                  }
                  else {
                      return $obj ? 1 == $op : 0 == $op;
                  }
              },
          );
      |, $boolean);
  
      if ($@) { Carp::croak $@; }
  
      if ( exists $INC{'JSON/XS.pm'} and $boolean eq 'JSON::XS::Boolean' ) {
          local $^W;
          my $true  = do { bless \(my $dummy = 1), $boolean };
          my $false = do { bless \(my $dummy = 0), $boolean };
          *JSON::XS::true  = sub () { $true };
          *JSON::XS::false = sub () { $false };
      }
      elsif ( exists $INC{'JSON/PP.pm'} and $boolean eq 'JSON::PP::Boolean' ) {
          local $^W;
          my $true  = do { bless \(my $dummy = 1), $boolean };
          my $false = do { bless \(my $dummy = 0), $boolean };
          *JSON::PP::true  = sub { $true };
          *JSON::PP::false = sub { $false };
      }
  
      return 1;
  }
  
  
  #
  # Helper classes for Backend Module (PP)
  #
  
  package JSON::Backend::PP;
  
  sub init {
      local $^W;
      no strict qw(refs); # this routine may be called after JSON::Backend::XS init was called.
      *{"JSON::decode_json"} = \&{"JSON::PP::decode_json"};
      *{"JSON::encode_json"} = \&{"JSON::PP::encode_json"};
      *{"JSON::PP::is_xs"}  = sub { 0 };
      *{"JSON::PP::is_pp"}  = sub { 1 };
      return 1;
  }
  
  #
  # To save memory, the below lines are read only when XS backend is used.
  #
  
  package JSON;
  
  1;
  __DATA__
  
  
  #
  # Helper classes for Backend Module (XS)
  #
  
  package JSON::Backend::XS;
  
  use constant INDENT_LENGTH_FLAG => 15 << 12;
  
  use constant UNSUPPORTED_ENCODE_FLAG => {
      ESCAPE_SLASH      => 0x00000010,
      ALLOW_BIGNUM      => 0x00000020,
      AS_NONBLESSED     => 0x00000040,
      EXPANDED          => 0x10000000, # for developer's
  };
  
  use constant UNSUPPORTED_DECODE_FLAG => {
      LOOSE             => 0x00000001,
      ALLOW_BIGNUM      => 0x00000002,
      ALLOW_BAREKEY     => 0x00000004,
      ALLOW_SINGLEQUOTE => 0x00000008,
      EXPANDED          => 0x20000000, # for developer's
  };
  
  
  sub init {
      local $^W;
      no strict qw(refs);
      *{"JSON::decode_json"} = \&{"JSON::XS::decode_json"};
      *{"JSON::encode_json"} = \&{"JSON::XS::encode_json"};
      *{"JSON::XS::is_xs"}  = sub { 1 };
      *{"JSON::XS::is_pp"}  = sub { 0 };
      return 1;
  }
  
  
  sub support_by_pp {
      my ($class, @methods) = @_;
  
      local $^W;
      no strict qw(refs);
  
      my $JSON_XS_encode_orignal     = \&JSON::XS::encode;
      my $JSON_XS_decode_orignal     = \&JSON::XS::decode;
      my $JSON_XS_incr_parse_orignal = \&JSON::XS::incr_parse;
  
      *JSON::XS::decode     = \&JSON::Backend::XS::Supportable::_decode;
      *JSON::XS::encode     = \&JSON::Backend::XS::Supportable::_encode;
      *JSON::XS::incr_parse = \&JSON::Backend::XS::Supportable::_incr_parse;
  
      *{JSON::XS::_original_decode}     = $JSON_XS_decode_orignal;
      *{JSON::XS::_original_encode}     = $JSON_XS_encode_orignal;
      *{JSON::XS::_original_incr_parse} = $JSON_XS_incr_parse_orignal;
  
      push @JSON::Backend::XS::Supportable::ISA, 'JSON';
  
      my $pkg = 'JSON::Backend::XS::Supportable';
  
      *{JSON::new} = sub {
          my $proto = JSON::XS->new; $$proto = 0;
          bless  $proto, $pkg;
      };
  
  
      for my $method (@methods) {
          my $flag = uc($method);
          my $type |= (UNSUPPORTED_ENCODE_FLAG->{$flag} || 0);
             $type |= (UNSUPPORTED_DECODE_FLAG->{$flag} || 0);
  
          next unless($type);
  
          $pkg->_make_unsupported_method($method => $type);
      }
  
  #    push @{"JSON::XS::Boolean::ISA"}, qw(JSON::PP::Boolean);
  #    push @{"JSON::PP::Boolean::ISA"}, qw(JSON::Boolean);
  
      $JSON::DEBUG and Carp::carp("set -support_by_pp mode.");
  
      return 1;
  }
  
  
  
  
  #
  # Helper classes for XS
  #
  
  package JSON::Backend::XS::Supportable;
  
  $Carp::Internal{'JSON::Backend::XS::Supportable'} = 1;
  
  sub _make_unsupported_method {
      my ($pkg, $method, $type) = @_;
  
      local $^W;
      no strict qw(refs);
  
      *{"$pkg\::$method"} = sub {
          local $^W;
          if (defined $_[1] ? $_[1] : 1) {
              ${$_[0]} |= $type;
          }
          else {
              ${$_[0]} &= ~$type;
          }
          $_[0];
      };
  
      *{"$pkg\::get_$method"} = sub {
          ${$_[0]} & $type ? 1 : '';
      };
  
  }
  
  
  sub _set_for_pp {
      JSON::_load_pp( $_INSTALL_ONLY );
  
      my $type  = shift;
      my $pp    = JSON::PP->new;
      my $prop = $_[0]->property;
  
      for my $name (keys %$prop) {
          $pp->$name( $prop->{$name} ? $prop->{$name} : 0 );
      }
  
      my $unsupported = $type eq 'encode' ? JSON::Backend::XS::UNSUPPORTED_ENCODE_FLAG
                                          : JSON::Backend::XS::UNSUPPORTED_DECODE_FLAG;
      my $flags       = ${$_[0]} || 0;
  
      for my $name (keys %$unsupported) {
          next if ($name eq 'EXPANDED'); # for developer's
          my $enable = ($flags & $unsupported->{$name}) ? 1 : 0;
          my $method = lc $name;
          $pp->$method($enable);
      }
  
      $pp->indent_length( $_[0]->get_indent_length );
  
      return $pp;
  }
  
  sub _encode { # using with PP encode
      if (${$_[0]}) {
          _set_for_pp('encode' => @_)->encode($_[1]);
      }
      else {
          $_[0]->_original_encode( $_[1] );
      }
  }
  
  
  sub _decode { # if unsupported-flag is set, use PP
      if (${$_[0]}) {
          _set_for_pp('decode' => @_)->decode($_[1]);
      }
      else {
          $_[0]->_original_decode( $_[1] );
      }
  }
  
  
  sub decode_prefix { # if unsupported-flag is set, use PP
      _set_for_pp('decode' => @_)->decode_prefix($_[1]);
  }
  
  
  sub _incr_parse {
      if (${$_[0]}) {
          _set_for_pp('decode' => @_)->incr_parse($_[1]);
      }
      else {
          $_[0]->_original_incr_parse( $_[1] );
      }
  }
  
  
  sub get_indent_length {
      ${$_[0]} << 4 >> 16;
  }
  
  
  sub indent_length {
      my $length = $_[1];
  
      if (!defined $length or $length > 15 or $length < 0) {
          Carp::carp "The acceptable range of indent_length() is 0 to 15.";
      }
      else {
          local $^W;
          $length <<= 12;
          ${$_[0]} &= ~ JSON::Backend::XS::INDENT_LENGTH_FLAG;
          ${$_[0]} |= $length;
          *JSON::XS::encode = \&JSON::Backend::XS::Supportable::_encode;
      }
  
      $_[0];
  }
  
  
  1;
  __END__
  
  =head1 NAME
  
  JSON - JSON (JavaScript Object Notation) encoder/decoder
  
  =head1 SYNOPSIS
  
   use JSON; # imports encode_json, decode_json, to_json and from_json.
   
   # simple and fast interfaces (expect/generate UTF-8)
   
   $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
   $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
   
   # OO-interface
   
   $json = JSON->new->allow_nonref;
   
   $json_text   = $json->encode( $perl_scalar );
   $perl_scalar = $json->decode( $json_text );
   
   $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
   
   # If you want to use PP only support features, call with '-support_by_pp'
   # When XS unsupported feature is enable, using PP (de|en)code instead of XS ones.
   
   use JSON -support_by_pp;
   
   # option-acceptable interfaces (expect/generate UNICODE by default)
   
   $json_text   = to_json( $perl_scalar, { ascii => 1, pretty => 1 } );
   $perl_scalar = from_json( $json_text, { utf8  => 1 } );
   
   # Between (en|de)code_json and (to|from)_json, if you want to write
   # a code which communicates to an outer world (encoded in UTF-8),
   # recommend to use (en|de)code_json.
   
  =head1 VERSION
  
      2.90
  
  This version is compatible with JSON::XS B<2.34> and later.
  (Not yet compatble to JSON::XS B<3.0x>.)
  
  
  =head1 NOTE
  
  JSON::PP was earlier included in the C<JSON> distribution, but
  has since Perl 5.14 been a core module. For this reason,
  L<JSON::PP> was removed from the JSON distribution and can now
  be found also in the Perl5 repository at
  
  =over
  
  =item * L<http://perl5.git.perl.org/perl.git>
  
  =back
  
  (The newest JSON::PP version still exists in CPAN.)
  
  Instead, the C<JSON> distribution will include JSON::backportPP
  for backwards computability. JSON.pm should thus work as it did
  before.
  
  =head1 DESCRIPTION
  
   *************************** CAUTION **************************************
   *                                                                        *
   * INCOMPATIBLE CHANGE (JSON::XS version 2.90)                            *
   *                                                                        *
   * JSON.pm had patched JSON::XS::Boolean and JSON::PP::Boolean internally *
   * on loading time for making these modules inherit JSON::Boolean.        *
   * But since JSON::XS v3.0 it use Types::Serialiser as boolean class.     *
   * Then now JSON.pm breaks boolean classe overload features and           *
   * -support_by_pp if JSON::XS v3.0 or later is installed.                 *
   *                                                                        *
   * JSON::true and JSON::false returned JSON::Boolean objects.             *
   * For workaround, they return JSON::PP::Boolean objects in this version. *
   *                                                                        *
   *     isa_ok(JSON::true, 'JSON::PP::Boolean');                           *
   *                                                                        *
   * And it discards a feature:                                             *
   *                                                                        *
   *     ok(JSON::true eq 'true');                                          *
   *                                                                        *
   * In other word, JSON::PP::Boolean overload numeric only.                *
   *                                                                        *
   *     ok( JSON::true == 1 );                                             *
   *                                                                        *
   **************************************************************************
  
   ************************** CAUTION ********************************
   * This is 'JSON module version 2' and there are many differences  *
   * to version 1.xx                                                 *
   * Please check your applications using old version.              *
   *   See to 'INCOMPATIBLE CHANGES TO OLD VERSION'                  *
   *******************************************************************
  
  JSON (JavaScript Object Notation) is a simple data format.
  See to L<http://www.json.org/> and C<RFC4627>(L<http://www.ietf.org/rfc/rfc4627.txt>).
  
  This module converts Perl data structures to JSON and vice versa using either
  L<JSON::XS> or L<JSON::PP>.
  
  JSON::XS is the fastest and most proper JSON module on CPAN which must be
  compiled and installed in your environment.
  JSON::PP is a pure-Perl module which is bundled in this distribution and
  has a strong compatibility to JSON::XS.
  
  This module try to use JSON::XS by default and fail to it, use JSON::PP instead.
  So its features completely depend on JSON::XS or JSON::PP.
  
  See to L<BACKEND MODULE DECISION>.
  
  To distinguish the module name 'JSON' and the format type JSON,
  the former is quoted by CE<lt>E<gt> (its results vary with your using media),
  and the latter is left just as it is.
  
  Module name : C<JSON>
  
  Format type : JSON
  
  =head2 FEATURES
  
  =over
  
  =item * correct unicode handling
  
  This module (i.e. backend modules) knows how to handle Unicode, documents
  how and when it does so, and even documents what "correct" means.
  
  Even though there are limitations, this feature is available since Perl version 5.6.
  
  JSON::XS requires Perl 5.8.2 (but works correctly in 5.8.8 or later), so in older versions
  C<JSON> should call JSON::PP as the backend which can be used since Perl 5.005.
  
  With Perl 5.8.x JSON::PP works, but from 5.8.0 to 5.8.2, because of a Perl side problem,
  JSON::PP works slower in the versions. And in 5.005, the Unicode handling is not available.
  See to L<JSON::PP/UNICODE HANDLING ON PERLS> for more information.
  
  See also to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>
  and L<JSON::XS/ENCODING/CODESET_FLAG_NOTES>.
  
  
  =item * round-trip integrity
  
  When you serialise a perl data structure using only data types supported
  by JSON and Perl, the deserialised 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
  L</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).
  
  See to L<JSON::XS/FEATURES> and L<JSON::PP/FEATURES>.
  
  =item * fast
  
  This module returns a JSON::XS object itself if available.
  Compared to other JSON modules and other serialisers such as Storable,
  JSON::XS usually compares favorably in terms of speed, too.
  
  If not available, C<JSON> returns a JSON::PP object instead of JSON::XS and
  it is very slow as pure-Perl.
  
  =item * simple to use
  
  This module has both a simple functional interface as well as an
  object oriented interface 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
  
  =head1 FUNCTIONAL INTERFACE
  
  Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
  C<to_json> and C<from_json> are additional functions.
  
  =head2 encode_json
  
      $json_text = encode_json $perl_scalar
  
  Converts the given Perl data structure to a UTF-8 encoded, binary string.
  
  This function call is functionally identical to:
  
      $json_text = JSON->new->utf8->encode($perl_scalar)
  
  =head2 decode_json
  
      $perl_scalar = decode_json $json_text
  
  The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
  to parse that as an UTF-8 encoded JSON text, returning the resulting
  reference.
  
  This function call is functionally identical to:
  
      $perl_scalar = JSON->new->utf8->decode($json_text)
  
  
  =head2 to_json
  
     $json_text = to_json($perl_scalar)
  
  Converts the given Perl data structure to a json string.
  
  This function call is functionally identical to:
  
     $json_text = JSON->new->encode($perl_scalar)
  
  Takes a hash reference as the second.
  
     $json_text = to_json($perl_scalar, $flag_hashref)
  
  So,
  
     $json_text = to_json($perl_scalar, {utf8 => 1, pretty => 1})
  
  equivalent to:
  
     $json_text = JSON->new->utf8(1)->pretty(1)->encode($perl_scalar)
  
  If you want to write a modern perl code which communicates to outer world,
  you should use C<encode_json> (supposed that JSON data are encoded in UTF-8).
  
  =head2 from_json
  
     $perl_scalar = from_json($json_text)
  
  The opposite of C<to_json>: expects a json string and tries
  to parse it, returning the resulting reference.
  
  This function call is functionally identical to:
  
      $perl_scalar = JSON->decode($json_text)
  
  Takes a hash reference as the second.
  
      $perl_scalar = from_json($json_text, $flag_hashref)
  
  So,
  
      $perl_scalar = from_json($json_text, {utf8 => 1})
  
  equivalent to:
  
      $perl_scalar = JSON->new->utf8(1)->decode($json_text)
  
  If you want to write a modern perl code which communicates to outer world,
  you should use C<decode_json> (supposed that JSON data are encoded in UTF-8).
  
  =head2 JSON::is_bool
  
      $is_boolean = JSON::is_bool($scalar)
  
  Returns true if the passed scalar represents either JSON::true or
  JSON::false, two constants that act like C<1> and C<0> respectively
  and are also used to represent JSON C<true> and C<false> in Perl strings.
  
  =head2 JSON::true
  
  Returns JSON true value which is blessed object.
  It C<isa> JSON::Boolean object.
  
  =head2 JSON::false
  
  Returns JSON false value which is blessed object.
  It C<isa> JSON::Boolean object.
  
  =head2 JSON::null
  
  Returns C<undef>.
  
  See L<MAPPING>, below, for more information on how JSON values are mapped to
  Perl.
  
  =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
  
  This section supposes that your perl version is 5.8 or later.
  
  If you know a JSON text from an outer world - a network, a file content, and so on,
  is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
  with C<utf8> enable. And the decoded result will contain UNICODE characters.
  
    # from network
    my $json        = JSON->new->utf8;
    my $json_text   = CGI->new->param( 'json_data' );
    my $perl_scalar = $json->decode( $json_text );
    
    # from file content
    local $/;
    open( my $fh, '<', 'json.data' );
    $json_text   = <$fh>;
    $perl_scalar = decode_json( $json_text );
  
  If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
  
    use Encode;
    local $/;
    open( my $fh, '<', 'json.data' );
    my $encoding = 'cp932';
    my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
    
    # or you can write the below code.
    #
    # open( my $fh, "<:encoding($encoding)", 'json.data' );
    # $unicode_json_text = <$fh>;
  
  In this case, C<$unicode_json_text> is of course UNICODE string.
  So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
  Instead of them, you use C<JSON> module object with C<utf8> disable or C<from_json>.
  
    $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
    # or
    $perl_scalar = from_json( $unicode_json_text );
  
  Or C<encode 'utf8'> and C<decode_json>:
  
    $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
    # this way is not efficient.
  
  And now, you want to convert your C<$perl_scalar> into JSON data and
  send it to an outer world - a network or a file content, and so on.
  
  Your data usually contains UNICODE strings and you want the converted data to be encoded
  in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
  
    print encode_json( $perl_scalar ); # to a network? file? or display?
    # or
    print $json->utf8->encode( $perl_scalar );
  
  If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
  for some reason, then its characters are regarded as B<latin1> for perl
  (because it does not concern with your $encoding).
  You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
  Instead of them, you use C<JSON> module object with C<utf8> disable or C<to_json>.
  Note that the resulted text is a UNICODE string but no problem to print it.
  
    # $perl_scalar contains $encoding encoded string values
    $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
    # or 
    $unicode_json_text = to_json( $perl_scalar );
    # $unicode_json_text consists of characters less than 0x100
    print $unicode_json_text;
  
  Or C<decode $encoding> all string values and C<encode_json>:
  
    $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
    # ... do it to each string values, then encode_json
    $json_text = encode_json( $perl_scalar );
  
  This method is a proper way but probably not efficient.
  
  See to L<Encode>, L<perluniintro>.
  
  
  =head1 COMMON OBJECT-ORIENTED INTERFACE
  
  =head2 new
  
      $json = JSON->new
  
  Returns a new C<JSON> object inherited from either JSON::XS or JSON::PP
  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 = JSON->new->utf8->space_after->encode({a => [1,2]})
     => {"a": [1, 2]}
  
  =head2 ascii
  
      $json = $json->ascii([$enable])
      
      $enabled = $json->get_ascii
  
  If $enable is true (or missing), then the encode method will not generate characters outside
  the code range 0..127. Any Unicode characters outside that range will be escaped using either
  a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
  
  If $enable is false, then the 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.
  
  This feature depends on the used Perl version and environment.
  
  See to L<JSON::PP/UNICODE HANDLING ON PERLS> if the backend is PP.
  
    JSON->new->ascii(1)->encode([chr 0x10401])
    => ["\ud801\udc01"]
  
  =head2 latin1
  
      $json = $json->latin1([$enable])
      
      $enabled = $json->get_latin1
  
  If $enable is true (or missing), then the encode method will encode the resulting JSON
  text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
  
  If $enable is false, then the encode method will not escape Unicode characters
  unless required by the JSON syntax or other flags.
  
    JSON->new->latin1->encode (["\x{89}\x{abc}"]
    => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
  
  =head2 utf8
  
      $json = $json->utf8([$enable])
      
      $enabled = $json->get_utf8
  
  If $enable is true (or missing), then the encode method will encode the JSON result
  into UTF-8, as required by many protocols, while the 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 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 $enable is false, then the encode method will return the JSON string as a (non-encoded)
  Unicode string, while 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.
  
  
  Example, output UTF-16BE-encoded JSON:
  
    use Encode;
    $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
  
  Example, decode UTF-32LE-encoded JSON:
  
    use Encode;
    $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
  
  See to L<JSON::PP/UNICODE HANDLING ON PERLS> if the backend is PP.
  
  
  =head2 pretty
  
      $json = $json->pretty([$enable])
  
  This enables (or disables) all of the C<indent>, C<space_before> and
  C<space_after> (and in the future possibly more) flags in one call to
  generate the most readable (or most compact) form possible.
  
  Equivalent to:
  
     $json->indent->space_before->space_after
  
  The indent space length is three and JSON::XS cannot change the indent
  space length.
  
  =head2 indent
  
      $json = $json->indent([$enable])
      
      $enabled = $json->get_indent
  
  If C<$enable> is true (or missing), then the C<encode> method will use a multiline
  format as output, putting every array member or object/hash key-value pair
  into its own line, identifying them properly.
  
  If C<$enable> is false, no newlines or indenting will be produced, and the
  resulting JSON text is guaranteed not to contain any C<newlines>.
  
  This setting has no effect when decoding JSON texts.
  
  The indent space length is three.
  With JSON::PP, you can also access C<indent_length> to change indent space length.
  
  
  =head2 space_before
  
      $json = $json->space_before([$enable])
      
      $enabled = $json->get_space_before
  
  If C<$enable> is true (or missing), then the C<encode> method will add an extra
  optional space before the C<:> separating keys from values in JSON objects.
  
  If C<$enable> is false, then the C<encode> method will not add any extra
  space at those places.
  
  This setting has no effect when decoding JSON texts.
  
  Example, space_before enabled, space_after and indent disabled:
  
     {"key" :"value"}
  
  
  =head2 space_after
  
      $json = $json->space_after([$enable])
      
      $enabled = $json->get_space_after
  
  If C<$enable> is true (or missing), then the C<encode> method will add an extra
  optional space after the C<:> separating keys from values in JSON objects
  and extra whitespace after the C<,> separating key-value pairs and array
  members.
  
  If C<$enable> is false, then the C<encode> method will not add any extra
  space at those places.
  
  This setting has no effect when decoding JSON texts.
  
  Example, space_before and indent disabled, space_after enabled:
  
     {"key": "value"}
  
  
  =head2 relaxed
  
      $json = $json->relaxed([$enable])
      
      $enabled = $json->get_relaxed
  
  If C<$enable> is true (or missing), then C<decode> will accept some
  extensions to normal JSON syntax (see below). C<encode> will not be
  affected in anyway. I<Be aware that this option makes you accept invalid
  JSON texts as if they were valid!>. I suggest only to use this option to
  parse application-specific files written by humans (configuration files,
  resource files etc.)
  
  If C<$enable> is false (the default), then C<decode> will only accept
  valid JSON texts.
  
  Currently accepted extensions are:
  
  =over 4
  
  =item * list items can have an end-comma
  
  JSON I<separates> array elements and key-value pairs with commas. This
  can be annoying if you write JSON texts manually and want to be able to
  quickly append elements, so this extension accepts comma at the end of
  such items not just between them:
  
     [
        1,
        2, <- this comma not normally allowed
     ]
     {
        "k1": "v1",
        "k2": "v2", <- this comma not normally allowed
     }
  
  =item * shell-style '#'-comments
  
  Whenever JSON allows whitespace, shell-style comments are additionally
  allowed. They are terminated by the first carriage-return or line-feed
  character, after which more white-space and comments are allowed.
  
    [
       1, # this comment not allowed in JSON
          # neither this one...
    ]
  
  =back
  
  
  =head2 canonical
  
      $json = $json->canonical([$enable])
      
      $enabled = $json->get_canonical
  
  If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
  by sorting their keys. This is adding a comparatively high overhead.
  
  If C<$enable> is false, then the C<encode> method will output key-value
  pairs in the order Perl stores them (which will likely change between runs
  of the same script).
  
  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.
  
  =head2 allow_nonref
  
      $json = $json->allow_nonref([$enable])
      
      $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.
  
     JSON->new->allow_nonref->encode ("Hello, World!")
     => "Hello, World!"
  
  =head2 allow_unknown
  
      $json = $json->allow_unknown ([$enable])
      
      $enabled = $json->get_allow_unknown
  
  If $enable is true (or missing), then "encode" will *not* throw an
  exception when it encounters values it cannot represent in JSON (for
  example, filehandles) but instead will encode a JSON "null" value.
  Note that blessed objects are not included here and are handled
  separately by c<allow_nonref>.
  
  If $enable is false (the default), then "encode" will throw an
  exception when it encounters anything it cannot encode as JSON.
  
  This option does not affect "decode" in any way, and it is
  recommended to leave it off unless you know your communications
  partner.
  
  =head2 allow_blessed
  
      $json = $json->allow_blessed([$enable])
      
      $enabled = $json->get_allow_blessed
  
  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.
  
  
  =head2 convert_blessed
  
      $json = $json->convert_blessed([$enable])
      
      $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, 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 the C<to_json>
  function or method.
  
  This setting does not yet influence C<decode> in any way.
  
  If C<$enable> is false, then the C<allow_blessed> setting will decide what
  to do when a blessed object is found.
  
  =over
  
  =item convert_blessed_universally mode
  
  If use C<JSON> with C<-convert_blessed_universally>, the C<UNIVERSAL::TO_JSON>
  subroutine is defined as the below code:
  
     *UNIVERSAL::TO_JSON = sub {
         my $b_obj = B::svref_2object( $_[0] );
         return    $b_obj->isa('B::HV') ? { %{ $_[0] } }
                 : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
                 : undef
                 ;
     }
  
  This will cause that C<encode> method converts simple blessed objects into
  JSON objects as non-blessed object.
  
     JSON -convert_blessed_universally;
     $json->allow_blessed->convert_blessed->encode( $blessed_object )
  
  This feature is experimental and may be removed in the future.
  
  =back
  
  =head2 filter_json_object
  
      $json = $json->filter_json_object([$coderef])
  
  When C<$coderef> is specified, it will be called from C<decode> each
  time it decodes a JSON object. The only argument passed to the coderef
  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
  deserialised data structure. If it returns an empty list
  (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
  hash will be inserted. This setting can slow down decoding considerably.
  
  When C<$coderef> is omitted or undefined, any existing callback will
  be removed and C<decode> will not change the deserialised hash in any
  way.
  
  Example, convert all JSON objects into the integer 5:
  
     my $js = JSON->new->filter_json_object (sub { 5 });
     # returns [5]
     $js->decode ('[{}]'); # the given subroutine takes a hash reference.
     # throw an exception because allow_nonref is not enabled
     # so a lone 5 is not allowed.
     $js->decode ('{"a":1, "b":2}');
  
  
  =head2 filter_json_single_key_object
  
      $json = $json->filter_json_single_key_object($key [=> $coderef])
  
  Works remotely similar to C<filter_json_object>, but is only called for
  JSON objects having a single key named C<$key>.
  
  This C<$coderef> is called before the one specified via
  C<filter_json_object>, if any. It gets passed the single value in the JSON
  object. If it returns a single value, it will be inserted into the data
  structure. If it returns nothing (not even C<undef> but the empty list),
  the callback from C<filter_json_object> will be called next, as if no
  single-key callback were specified.
  
  If C<$coderef> is omitted or undefined, the corresponding callback will be
  disabled. There can only ever be one callback for a given key.
  
  As this callback gets called less often then the C<filter_json_object>
  one, decoding speed will not usually suffer as much. Therefore, single-key
  objects make excellent targets to serialise Perl objects into, especially
  as single-key JSON objects are as close to the type-tagged value concept
  as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
  support this in any way, so you need to make sure your data never looks
  like a serialised Perl hash.
  
  Typical names for the single object key are C<__class_whatever__>, or
  C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
  things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
  with real hashes.
  
  Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
  into the corresponding C<< $WIDGET{<id>} >> object:
  
     # return whatever is in $WIDGET{5}:
     JSON
        ->new
        ->filter_json_single_key_object (__widget__ => sub {
              $WIDGET{ $_[0] }
           })
        ->decode ('{"__widget__": 5')
  
     # this can be used with a TO_JSON method in some "widget" class
     # for serialisation to json:
     sub WidgetBase::TO_JSON {
        my ($self) = @_;
  
        unless ($self->{id}) {
           $self->{id} = ..get..some..id..;
           $WIDGET{$self->{id}} = $self;
        }
  
        { __widget__ => $self->{id} }
     }
  
  
  =head2 shrink
  
      $json = $json->shrink([$enable])
      
      $enabled = $json->get_shrink
  
  With JSON::XS, this flag 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).
  
  With JSON::PP, it is noop about resizing strings but tries
  C<utf8::downgrade> to the returned string by C<encode>. See to L<utf8>.
  
  See to L<JSON::XS/OBJECT-ORIENTED INTERFACE> and L<JSON::PP/METHODS>.
  
  =head2 max_depth
  
      $json = $json->max_depth([$maximum_nesting_depth])
      
      $max_depth = $json->get_max_depth
  
  Sets the maximum nesting level (default C<512>) accepted while encoding
  or decoding. If a higher nesting level is detected in JSON text or a Perl
  data structure, then the encoder and decoder will stop and croak at that
  point.
  
  Nesting level is defined by number of hash- or arrayrefs that the encoder
  needs to traverse to reach a given point or the number of C<{> or C<[>
  characters without their matching closing parenthesis crossed to reach a
  given character in a string.
  
  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. (JSON::XS)
  
  With JSON::PP as the backend, when a large value (100 or more) was set and
  it de/encodes a deep nested object/text, it may raise a warning
  'Deep recursion on subroutine' at the perl runtime phase.
  
  See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
  
  =head2 max_size
  
      $json = $json->max_size([$maximum_string_size])
      
      $max_size = $json->get_max_size
  
  Set the maximum length a JSON text may have (in bytes) where decoding is
  being attempted. The default is C<0>, meaning no limit. When C<decode>
  is called on a string that is longer then this many bytes, it will not
  attempt to decode the string but throw an exception. This setting has no
  effect on C<encode> (yet).
  
  If no argument is given, the limit check will be deactivated (same as when
  C<0> is specified).
  
  See L<JSON::XS/SECURITY CONSIDERATIONS>, below, for more info on why this is useful.
  
  =head2 encode
  
      $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.
  References to the integers C<0> and C<1> are converted into C<true> and C<false>.
  
  =head2 decode
  
      $perl_scalar = $json->decode($json_text)
  
  The opposite of C<encode>: expects a JSON text and tries to parse it,
  returning the resulting simple scalar or reference. Croaks on error.
  
  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<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
  C<null> becomes C<undef>.
  
  =head2 decode_prefix
  
      ($perl_scalar, $characters) = $json->decode_prefix($json_text)
  
  This works like the C<decode> method, but instead of raising an exception
  when there is trailing garbage after the first JSON object, it will
  silently stop parsing there and return the number of characters consumed
  so far.
  
     JSON->new->decode_prefix ("[1] the tail")
     => ([], 3)
  
  See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
  
  =head2 property
  
      $boolean = $json->property($property_name)
  
  Returns a boolean value about above some properties.
  
  The available properties are C<ascii>, C<latin1>, C<utf8>,
  C<indent>,C<space_before>, C<space_after>, C<relaxed>, C<canonical>,
  C<allow_nonref>, C<allow_unknown>, C<allow_blessed>, C<convert_blessed>,
  C<shrink>, C<max_depth> and C<max_size>.
  
     $boolean = $json->property('utf8');
      => 0
     $json->utf8;
     $boolean = $json->property('utf8');
      => 1
  
  Sets the property with a given boolean value.
  
      $json = $json->property($property_name => $boolean);
  
  With no argument, it returns all the above properties as a hash reference.
  
      $flag_hashref = $json->property();
  
  =head1 INCREMENTAL PARSING
  
  Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
  
  In some cases, there is the need for incremental parsing of JSON texts.
  This module 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).
  
  The backend module will only attempt to parse the JSON text once it is sure it
  has enough text to get a decisive result, using a very simple but
  truly incremental parser. This means that it sometimes won't stop as
  early as the full parser, for example, it doesn't detect parenthesis
  mismatches. The only thing it guarantees is that it starts decoding as
  soon as a syntactically valid JSON text has been seen. This means you need
  to set resource limits (e.g. C<max_size>) to ensure the parser will stop
  parsing in the presence if syntax errors.
  
  The following methods implement this incremental parser.
  
  =head2 incr_parse
  
      $json->incr_parse( [$string] ) # void context
      
      $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
      
      @obj_or_empty = $json->incr_parse( [$string] ) # list context
  
  This is the central parsing function. It can both append new text and
  extract objects from the stream accumulated so far (both of these
  functions are optional).
  
  If C<$string> is given, then this string is appended to the already
  existing JSON fragment stored in the C<$json> object.
  
  After that, if the function is called in void context, it will simply
  return without doing anything further. This can be used to add more text
  in as many chunks as you want.
  
  If the method is called in scalar context, then it will try to extract
  exactly I<one> JSON object. If that is successful, it will return this
  object, otherwise it will return C<undef>. If there is a parse error,
  this method will croak just as C<decode> would do (one can then use
  C<incr_skip> to skip the erroneous part). This is the most common way of
  using the method.
  
  And finally, in list context, it will try to extract as many objects
  from the stream as it can find and return them, or the empty list
  otherwise. For this to work, there must be no separators between the JSON
  objects or arrays, instead they must be concatenated back-to-back. If
  an error occurs, an exception will be raised as in the scalar context
  case. Note that in this case, any previously-parsed JSON texts will be
  lost.
  
  Example: Parse some JSON arrays/objects in a given string and return them.
  
      my @objs = JSON->new->incr_parse ("[5][7][1,2]");
  
  =head2 incr_text
  
      $lvalue_string = $json->incr_text
  
  This method returns the currently stored JSON fragment as an lvalue, that
  is, you can manipulate it. This I<only> works when a preceding call to
  C<incr_parse> in I<scalar context> successfully returned an object. Under
  all other circumstances you must not call this function (I mean it.
  although in simple tests it might actually work, it I<will> fail under
  real world conditions). As a special exception, you can also call this
  method before having parsed anything.
  
  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).
  
      $json->incr_text =~ s/\s*,\s*//;
  
  In Perl 5.005, C<lvalue> attribute is not available.
  You must write codes like the below:
  
      $string = $json->incr_text;
      $string =~ s/\s*,\s*//;
      $json->incr_text( $string );
  
  =head2 incr_skip
  
      $json->incr_skip
  
  This will reset the state of the incremental parser and will remove the
  parsed text from the input buffer. 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.
  
  =head2 incr_reset
  
      $json->incr_reset
  
  This completely resets the incremental parser, that is, after this call,
  it will be as if the parser had never parsed anything.
  
  This is useful if you want to repeatedly parse JSON objects and want to
  ignore any trailing data, which means you have to reset the parser after
  each successful decode.
  
  See to L<JSON::XS/INCREMENTAL PARSING> for examples.
  
  
  =head1 JSON::PP SUPPORT METHODS
  
  The below methods are JSON::PP own methods, so when C<JSON> works
  with JSON::PP (i.e. the created object is a JSON::PP object), available.
  See to L<JSON::PP/JSON::PP OWN METHODS> in detail.
  
  If you use C<JSON> with additional C<-support_by_pp>, some methods
  are available even with JSON::XS. See to L<USE PP FEATURES EVEN THOUGH XS BACKEND>.
  
     BEING { $ENV{PERL_JSON_BACKEND} = 'JSON::XS' }
     
     use JSON -support_by_pp;
     
     my $json = JSON->new;
     $json->allow_nonref->escape_slash->encode("/");
  
     # functional interfaces too.
     print to_json(["/"], {escape_slash => 1});
     print from_json('["foo"]', {utf8 => 1});
  
  If you do not want to all functions but C<-support_by_pp>,
  use C<-no_export>.
  
     use JSON -support_by_pp, -no_export;
     # functional interfaces are not exported.
  
  =head2 allow_singlequote
  
      $json = $json->allow_singlequote([$enable])
  
  If C<$enable> is true (or missing), then C<decode> will accept
  any 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'});
  
  As same as the C<relaxed> option, this option may be used to parse
  application-specific files written by humans.
  
  =head2 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.
  
  As same as the C<relaxed> option, this option may be used to parse
  application-specific files written by humans.
  
      $json->allow_barekey->decode('{foo:"bar"}');
  
  =head2 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 to L<MAPPING> about the conversion of JSON number.
  
  =head2 loose
  
      $json = $json->loose([$enable])
  
  The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
  and the module doesn't allow to C<decode> to these (except for \x2f).
  If C<$enable> is true (or missing), then C<decode>  will accept these
  unescaped strings.
  
      $json->loose->decode(qq|["abc
                                     def"]|);
  
  See to L<JSON::PP/JSON::PP OWN METHODS>.
  
  =head2 escape_slash
  
      $json = $json->escape_slash([$enable])
  
  According to JSON Grammar, I<slash> (U+002F) is escaped. But by default
  JSON backend modules encode strings without escaping slash.
  
  If C<$enable> is true (or missing), then C<encode> will escape slashes.
  
  =head2 indent_length
  
      $json = $json->indent_length($length)
  
  With JSON::XS, The indent space length is 3 and cannot be changed.
  With JSON::PP, it sets the indent space length with the given $length.
  The default is 3. The acceptable range is 0 to 15.
  
  =head2 sort_by
  
      $json = $json->sort_by($function_name)
      $json = $json->sort_by($subroutine_ref)
  
  If $function_name or $subroutine_ref are set, its sort routine are used.
  
     $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
     # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
  
     $js = $pc->sort_by('own_sort')->encode($obj);
     # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
  
     sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
  
  As the sorting routine runs in the JSON::PP scope, the given
  subroutine name and the special variables C<$a>, C<$b> will begin
  with 'JSON::PP::'.
  
  If $integer is set, then the effect is same as C<canonical> on.
  
  See to L<JSON::PP/JSON::PP OWN METHODS>.
  
  =head1 MAPPING
  
  This section is copied from JSON::XS and modified to C<JSON>.
  JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
  
  See to L<JSON::XS/MAPPING>.
  
  =head2 JSON -> PERL
  
  =over 4
  
  =item object
  
  A JSON object becomes a reference to a hash in Perl. No ordering of object
  keys is preserved (JSON does not preserver object key ordering itself).
  
  =item array
  
  A JSON array becomes a reference to an array in Perl.
  
  =item string
  
  A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
  are represented by the same codepoints in the Perl string, so no manual
  decoding is necessary.
  
  =item number
  
  A JSON number becomes either an integer, numeric (floating point) or
  string scalar in perl, depending on its range and any fractional parts. On
  the Perl level, there is no difference between those as Perl handles all
  the conversion details, but an integer may take slightly less memory and
  might represent more values exactly than floating point numbers.
  
  If the number consists of digits only, C<JSON> 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<JSON> only guarantees precision up to but not including
  the least significant bit.
  
  If the backend is JSON::PP and C<allow_bignum> is enable, the big integers 
  and the numeric can be optionally converted into L<Math::BigInt> and
  L<Math::BigFloat> objects.
  
  =item true, false
  
  These JSON atoms become C<JSON::true> and C<JSON::false>,
  respectively. They are overloaded to act almost exactly like the numbers
  C<1> and C<0>. You can check whether a scalar is a JSON boolean by using
  the C<JSON::is_bool> function.
  
     print JSON::true + 1;
      => 1
  
     ok(JSON::true eq  '1');
     ok(JSON::true == 1);
  
  C<JSON> will install these missing overloading features to the backend modules.
  
  
  =item null
  
  A JSON null atom becomes C<undef> in Perl.
  
  C<JSON::null> returns C<undef>.
  
  =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. C<JSON>
  optionally sort the hash keys (determined by the I<canonical> flag), so
  the same data structure will serialise to the same JSON text (given same
  settings and version of 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.
  
  In future, the ordered object feature will be added to JSON::PP using C<tie> mechanism.
  
  
  =item array references
  
  Perl array references become JSON arrays.
  
  =item other references
  
  Other unblessed references are generally not allowed and will cause an
  exception to be thrown, except for references to the integers C<0> and
  C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
  also use C<JSON::false> and C<JSON::true> to improve readability.
  
     to_json [\0,JSON::true]      # yields [false,true]
  
  =item JSON::true, JSON::false, JSON::null
  
  These special values become JSON true and JSON false values,
  respectively. You can also use C<\1> and C<\0> directly if you want.
  
  JSON::null returns C<undef>.
  
  =item blessed objects
  
  Blessed objects are not directly representable in JSON. 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, or provide
  your own serialiser method.
  
  With C<convert_blessed_universally> mode,  C<encode> converts blessed
  hash references or blessed array references (contains other blessed references)
  into JSON members and arrays.
  
     use JSON -convert_blessed_universally;
     JSON->new->allow_blessed->convert_blessed->encode( $blessed_object );
  
  See to L<convert_blessed>.
  
  =item simple scalars
  
  Simple Perl scalars (any scalar that is not a reference) are the most
  difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
  JSON C<null> values, scalars that have last been used in a string context
  before encoding as JSON strings, and anything else as number value:
  
     # dump as number
     encode_json [2]                      # yields [2]
     encode_json [-3.0e17]                # yields [-3e+17]
     my $value = 5; encode_json [$value]  # yields [5]
  
     # used as string, so dump as string
     print $value;
     encode_json [$value]                 # yields ["5"]
  
     # undef becomes null
     encode_json [undef]                  # yields [null]
  
  You can force the type to be a string by stringifying it:
  
     my $x = 3.1; # some variable containing a number
     "$x";        # stringified
     $x .= "";    # another, more awkward way to stringify
     print $x;    # perl does it for you, too, quite often
  
  You can force the type to be a number by numifying it:
  
     my $x = "3"; # some variable containing a string
     $x += 0;     # numify it, ensuring it will be dumped as a number
     $x *= 1;     # same thing, the choice is yours.
  
  You can not currently force the type in other, less obscure, ways.
  
  Note that numerical precision has the same meaning as under Perl (so
  binary to decimal conversion follows the same rules as in Perl, which
  can differ to other languages). Also, your perl interpreter might expose
  extensions to the floating point numbers of your platform, such as
  infinities or NaN's - these cannot be represented in JSON, and it is an
  error to pass those in.
  
  =item Big Number
  
  If the backend is JSON::PP and C<allow_bignum> is enable, 
  C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
  objects into JSON numbers.
  
  
  =back
  
  =head1 JSON and ECMAscript
  
  See to L<JSON::XS/JSON and ECMAscript>.
  
  =head1 JSON and YAML
  
  JSON is not a subset of YAML.
  See to L<JSON::XS/JSON and YAML>.
  
  
  =head1 BACKEND MODULE DECISION
  
  When you use C<JSON>, C<JSON> tries to C<use> JSON::XS. If this call failed, it will
  C<uses> JSON::PP. The required JSON::XS version is I<2.2> or later.
  
  The C<JSON> constructor method returns an object inherited from the backend module,
  and JSON::XS object is a blessed scalar reference while JSON::PP is a blessed hash
  reference.
  
  So, your program should not depend on the backend module, especially
  returned objects should not be modified.
  
   my $json = JSON->new; # XS or PP?
   $json->{stash} = 'this is xs object'; # this code may raise an error!
  
  To check the backend module, there are some methods - C<backend>, C<is_pp> and C<is_xs>.
  
    JSON->backend; # 'JSON::XS' or 'JSON::PP'
    
    JSON->backend->is_pp: # 0 or 1
    
    JSON->backend->is_xs: # 1 or 0
    
    $json->is_xs; # 1 or 0
    
    $json->is_pp; # 0 or 1
  
  
  If you set an environment variable C<PERL_JSON_BACKEND>, the calling action will be changed.
  
  =over
  
  =item PERL_JSON_BACKEND = 0 or PERL_JSON_BACKEND = 'JSON::PP'
  
  Always use JSON::PP
  
  =item PERL_JSON_BACKEND == 1 or PERL_JSON_BACKEND = 'JSON::XS,JSON::PP'
  
  (The default) Use compiled JSON::XS if it is properly compiled & installed,
  otherwise use JSON::PP.
  
  =item PERL_JSON_BACKEND == 2 or PERL_JSON_BACKEND = 'JSON::XS'
  
  Always use compiled JSON::XS, die if it isn't properly compiled & installed.
  
  =item PERL_JSON_BACKEND = 'JSON::backportPP'
  
  Always use JSON::backportPP.
  JSON::backportPP is JSON::PP back port module.
  C<JSON> includes JSON::backportPP instead of JSON::PP.
  
  =back
  
  These ideas come from L<DBI::PurePerl> mechanism.
  
  example:
  
   BEGIN { $ENV{PERL_JSON_BACKEND} = 'JSON::PP' }
   use JSON; # always uses JSON::PP
  
  In future, it may be able to specify another module.
  
  =head1 USE PP FEATURES EVEN THOUGH XS BACKEND
  
  Many methods are available with either JSON::XS or JSON::PP and
  when the backend module is JSON::XS, if any JSON::PP specific (i.e. JSON::XS unsupported)
  method is called, it will C<warn> and be noop.
  
  But If you C<use> C<JSON> passing the optional string C<-support_by_pp>,
  it makes a part of those unsupported methods available.
  This feature is achieved by using JSON::PP in C<de/encode>.
  
     BEGIN { $ENV{PERL_JSON_BACKEND} = 2 } # with JSON::XS
     use JSON -support_by_pp;
     my $json = JSON->new;
     $json->allow_nonref->escape_slash->encode("/");
  
  At this time, the returned object is a C<JSON::Backend::XS::Supportable>
  object (re-blessed XS object), and  by checking JSON::XS unsupported flags
  in de/encoding, can support some unsupported methods - C<loose>, C<allow_bignum>,
  C<allow_barekey>, C<allow_singlequote>, C<escape_slash> and C<indent_length>.
  
  When any unsupported methods are not enable, C<XS de/encode> will be
  used as is. The switch is achieved by changing the symbolic tables.
  
  C<-support_by_pp> is effective only when the backend module is JSON::XS
  and it makes the de/encoding speed down a bit.
  
  See to L<JSON::PP SUPPORT METHODS>.
  
  =head1 INCOMPATIBLE CHANGES TO OLD VERSION
  
  There are big incompatibility between new version (2.00) and old (1.xx).
  If you use old C<JSON> 1.xx in your code, please check it.
  
  See to L<Transition ways from 1.xx to 2.xx.>
  
  =over
  
  =item jsonToObj and objToJson are obsoleted.
  
  Non Perl-style name C<jsonToObj> and C<objToJson> are obsoleted
  (but not yet deleted from the source).
  If you use these functions in your code, please replace them
  with C<from_json> and C<to_json>.
  
  
  =item Global variables are no longer available.
  
  C<JSON> class variables - C<$JSON::AUTOCONVERT>, C<$JSON::BareKey>, etc...
  - are not available any longer.
  Instead, various features can be used through object methods.
  
  
  =item Package JSON::Converter and JSON::Parser are deleted.
  
  Now C<JSON> bundles with JSON::PP which can handle JSON more properly than them.
  
  =item Package JSON::NotString is deleted.
  
  There was C<JSON::NotString> class which represents JSON value C<true>, C<false>, C<null>
  and numbers. It was deleted and replaced by C<JSON::Boolean>.
  
  C<JSON::Boolean> represents C<true> and C<false>.
  
  C<JSON::Boolean> does not represent C<null>.
  
  C<JSON::null> returns C<undef>.
  
  C<JSON> makes L<JSON::XS::Boolean> and L<JSON::PP::Boolean> is-a relation
  to L<JSON::Boolean>.
  
  =item function JSON::Number is obsoleted.
  
  C<JSON::Number> is now needless because JSON::XS and JSON::PP have
  round-trip integrity.
  
  =item JSONRPC modules are deleted.
  
  Perl implementation of JSON-RPC protocol - C<JSONRPC >, C<JSONRPC::Transport::HTTP>
  and C<Apache::JSONRPC > are deleted in this distribution.
  Instead of them, there is L<JSON::RPC> which supports JSON-RPC protocol version 1.1.
  
  =back
  
  =head2 Transition ways from 1.xx to 2.xx.
  
  You should set C<suport_by_pp> mode firstly, because
  it is always successful for the below codes even with JSON::XS.
  
      use JSON -support_by_pp;
  
  =over
  
  =item Exported jsonToObj (simple)
  
    from_json($json_text);
  
  =item Exported objToJson (simple)
  
    to_json($perl_scalar);
  
  =item Exported jsonToObj (advanced)
  
    $flags = {allow_barekey => 1, allow_singlequote => 1};
    from_json($json_text, $flags);
  
  equivalent to:
  
    $JSON::BareKey = 1;
    $JSON::QuotApos = 1;
    jsonToObj($json_text);
  
  =item Exported objToJson (advanced)
  
    $flags = {allow_blessed => 1, allow_barekey => 1};
    to_json($perl_scalar, $flags);
  
  equivalent to:
  
    $JSON::BareKey = 1;
    objToJson($perl_scalar);
  
  =item jsonToObj as object method
  
    $json->decode($json_text);
  
  =item objToJson as object method
  
    $json->encode($perl_scalar);
  
  =item new method with parameters
  
  The C<new> method in 2.x takes any parameters no longer.
  You can set parameters instead;
  
     $json = JSON->new->pretty;
  
  =item $JSON::Pretty, $JSON::Indent, $JSON::Delimiter
  
  If C<indent> is enable, that means C<$JSON::Pretty> flag set. And
  C<$JSON::Delimiter> was substituted by C<space_before> and C<space_after>.
  In conclusion:
  
     $json->indent->space_before->space_after;
  
  Equivalent to:
  
    $json->pretty;
  
  To change indent length, use C<indent_length>.
  
  (Only with JSON::PP, if C<-support_by_pp> is not used.)
  
    $json->pretty->indent_length(2)->encode($perl_scalar);
  
  =item $JSON::BareKey
  
  (Only with JSON::PP, if C<-support_by_pp> is not used.)
  
    $json->allow_barekey->decode($json_text)
  
  =item $JSON::ConvBlessed
  
  use C<-convert_blessed_universally>. See to L<convert_blessed>.
  
  =item $JSON::QuotApos
  
  (Only with JSON::PP, if C<-support_by_pp> is not used.)
  
    $json->allow_singlequote->decode($json_text)
  
  =item $JSON::SingleQuote
  
  Disable. C<JSON> does not make such a invalid JSON string any longer.
  
  =item $JSON::KeySort
  
    $json->canonical->encode($perl_scalar)
  
  This is the ascii sort.
  
  If you want to use with your own sort routine, check the C<sort_by> method.
  
  (Only with JSON::PP, even if C<-support_by_pp> is used currently.)
  
    $json->sort_by($sort_routine_ref)->encode($perl_scalar)
   
    $json->sort_by(sub { $JSON::PP::a <=> $JSON::PP::b })->encode($perl_scalar)
  
  Can't access C<$a> and C<$b> but C<$JSON::PP::a> and C<$JSON::PP::b>.
  
  =item $JSON::SkipInvalid
  
    $json->allow_unknown
  
  =item $JSON::AUTOCONVERT
  
  Needless. C<JSON> backend modules have the round-trip integrity.
  
  =item $JSON::UTF8
  
  Needless because C<JSON> (JSON::XS/JSON::PP) sets
  the UTF8 flag on properly.
  
      # With UTF8-flagged strings
  
      $json->allow_nonref;
      $str = chr(1000); # UTF8-flagged
  
      $json_text  = $json->utf8(0)->encode($str);
      utf8::is_utf8($json_text);
      # true
      $json_text  = $json->utf8(1)->encode($str);
      utf8::is_utf8($json_text);
      # false
  
      $str = '"' . chr(1000) . '"'; # UTF8-flagged
  
      $perl_scalar  = $json->utf8(0)->decode($str);
      utf8::is_utf8($perl_scalar);
      # true
      $perl_scalar  = $json->utf8(1)->decode($str);
      # died because of 'Wide character in subroutine'
  
  See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
  
  =item $JSON::UnMapping
  
  Disable. See to L<MAPPING>.
  
  =item $JSON::SelfConvert
  
  This option was deleted.
  Instead of it, if a given blessed object has the C<TO_JSON> method,
  C<TO_JSON> will be executed with C<convert_blessed>.
  
    $json->convert_blessed->encode($blessed_hashref_or_arrayref)
    # if need, call allow_blessed
  
  Note that it was C<toJson> in old version, but now not C<toJson> but C<TO_JSON>.
  
  =back
  
  =head1 TODO
  
  =over
  
  =item example programs
  
  =back
  
  =head1 THREADS
  
  No test with JSON::PP. If with JSON::XS, See to L<JSON::XS/THREADS>.
  
  
  =head1 BUGS
  
  Please report bugs relevant to C<JSON> to E<lt>makamaka[at]cpan.orgE<gt>.
  
  
  =head1 SEE ALSO
  
  Most of the document is copied and modified from JSON::XS doc.
  
  L<JSON::XS>, L<JSON::PP>
  
  C<RFC4627>(L<http://www.ietf.org/rfc/rfc4627.txt>)
  
  =head1 AUTHOR
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  JSON::XS was written by  Marc Lehmann <schmorp[at]schmorp.de>
  
  The release of this new version owes to the courtesy of Marc Lehmann.
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2005-2013 by Makamaka Hannyaharamitu
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =cut
  
JSON

$fatpacked{"JSON/Syck.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_SYCK';
  package JSON::Syck;
  use strict;
  use vars qw( $VERSION @EXPORT_OK @ISA );
  use Exporter;
  use YAML::Syck ();
  
  BEGIN {
      $VERSION   = '1.29';
      @EXPORT_OK = qw( Load Dump LoadFile DumpFile DumpInto );
      @ISA       = 'Exporter';
      *Load      = \&YAML::Syck::LoadJSON;
      *Dump      = \&YAML::Syck::DumpJSON;
  }
  
  sub DumpFile {
      my $file = shift;
      if ( YAML::Syck::_is_glob($file) ) {
          my $err = YAML::Syck::DumpJSONFile( $_[0], $file );
          if ($err) {
              $! = 0 + $err;
              die "Error writing to filehandle $file: $!\n";
          }
      }
      else {
          open( my $fh, '>', $file ) or die "Cannot write to $file: $!";
          my $err = YAML::Syck::DumpJSONFile( $_[0], $fh );
          if ($err) {
              $! = 0 + $err;
              die "Error writing to file $file: $!\n";
          }
          close $fh
            or die "Error writing to file $file: $!\n";
      }
      return 1;
  }
  
  sub LoadFile {
      my $file = shift;
      if ( YAML::Syck::_is_glob($file) ) {
          YAML::Syck::LoadJSON(
              do { local $/; <$file> }
          );
      }
      else {
          if ( !-e $file || -z $file ) {
              die("'$file' is non-existent or empty");
          }
          open( my $fh, '<', $file ) or die "Cannot read from $file: $!";
          YAML::Syck::LoadJSON(
              do { local $/; <$fh> }
          );
      }
  }
  
  sub DumpInto {
      my $bufref = shift;
      ( ref $bufref ) or die "DumpInto not given reference to output buffer\n";
      YAML::Syck::DumpJSONInto( $_[0], $bufref );
      1;
  }
  
  $JSON::Syck::ImplicitTyping  = 1;
  $JSON::Syck::MaxDepth        = 512;
  $JSON::Syck::Headless        = 1;
  $JSON::Syck::ImplicitUnicode = 0;
  $JSON::Syck::SingleQuote     = 0;
  
  1;
  
  __END__
  
  =head1 NAME
  
  JSON::Syck - JSON is YAML (but consider using L<JSON::XS> instead!)
  
  =head1 SYNOPSIS
  
      use JSON::Syck; # no exports by default 
  
      my $data = JSON::Syck::Load($json);
      my $json = JSON::Syck::Dump($data);
  
      # $file can be an IO object, or a filename
      my $data = JSON::Syck::LoadFile($file);
      JSON::Syck::DumpFile($file, $data);
  
      # Dump into a pre-existing buffer
      my $json;
      JSON::Syck::DumpInto(\$json, $data);
  
  =head1 DESCRIPTION
  
  JSON::Syck is a syck implementation of JSON parsing and generation. Because
  JSON is YAML (L<http://redhanded.hobix.com/inspect/yamlIsJson.html>), using
  syck gives you a fast and memory-efficient parser and dumper for JSON data
  representation.
  
  However, a newer module L<JSON::XS>, has since emerged.  It is more flexible,
  efficient and robust, so please consider using it instead of this module.
  
  =head1 DIFFERENCE WITH JSON
  
  You might want to know the difference between the I<JSON> module and
  this one.
  
  Since JSON is a pure-perl module and JSON::Syck is based on libsyck,
  JSON::Syck is supposed to be very fast and memory efficient. See
  chansen's benchmark table at
  L<http://idisk.mac.com/christian.hansen/Public/perl/serialize.pl>
  
  JSON.pm comes with dozens of ways to do the same thing and lots of
  options, while JSON::Syck doesn't. There's only C<Load> and C<Dump>.
  
  Oh, and JSON::Syck doesn't use camelCase method names :-)
  
  =head1 REFERENCES
  
  =head2 SCALAR REFERENCE
  
  For now, when you pass a scalar reference to JSON::Syck, it
  dereferences to get the actual scalar value.
  
  JSON::Syck raises an exception when you pass in circular references.
  
  If you want to serialize self referencing stuff, you should use
  YAML which supports it.
  
  =head2 SUBROUTINE REFERENCE
  
  When you pass subroutine reference, JSON::Syck dumps it as null.
  
  =head1 UTF-8 FLAGS
  
  By default this module doesn't touch any of utf-8 flags set in
  strings, and assumes UTF-8 bytes to be passed and emit.
  
  However, when you set C<$JSON::Syck::ImplicitUnicode> to 1, this
  module properly decodes UTF-8 binaries and sets UTF-8 flag everywhere,
  as in:
  
    JSON (UTF-8 bytes)   => Perl (UTF-8 flagged)
    JSON (UTF-8 flagged) => Perl (UTF-8 flagged)
    Perl (UTF-8 bytes)   => JSON (UTF-8 flagged)
    Perl (UTF-8 flagged) => JSON (UTF-8 flagged)
  
  By default, JSON::Syck::Dump will only transverse up to 512 levels of
  a datastructure in order to avoid an infinite loop when it is
  presented with an circular reference.
  
  However, you set C<$JSON::Syck::MaxLevels> to a larger value if you
  have very complex structures.
  
  Unfortunately, there's no implicit way to dump Perl UTF-8 flagged data
  structure to utf-8 encoded JSON. To do this, simply use Encode module, e.g.:
  
    use Encode;
    use JSON::Syck qw(Dump);
  
    my $json = encode_utf8( Dump($data) );
  
  Alternatively you can use Encode::JavaScript::UCS to encode Unicode
  strings as in I<%uXXXX> form.
  
    use Encode;
    use Encode::JavaScript::UCS;
    use JSON::Syck qw(Dump);
  
    my $json_unicode_escaped = encode( 'JavaScript-UCS', Dump($data) );
  
  =head1 QUOTING
  
  According to the JSON specification, all JSON strings are to be double-quoted.
  However, when embedding JavaScript in HTML attributes, it may be more
  convenient to use single quotes.
  
  Set C<$JSON::Syck::SingleQuote> to 1 will make both C<Dump> and C<Load> expect
  single-quoted string literals.
  
  =head1 BUGS
  
  Dumping into tied (or other magic variables) with C<DumpInto> might not work
  properly in all cases.
  
  When dumping with C<DumpFile>, some spacing might be wrong and
  C<$JSON::Syck::SingleQuote> might be handled incorrectly.
  
  =head1 SEE ALSO
  
  L<JSON::XS>, L<YAML::Syck>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  Tatsuhiko Miyagawa E<lt>miyagawa@gmail.comE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2005-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  The F<libsyck> code bundled with this library is released by
  "why the lucky stiff", under a BSD-style license.  See the F<COPYING>
  file for details.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =cut
JSON_SYCK

$fatpacked{"JSON/backportPP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_BACKPORTPP_BOOLEAN';
  =head1 NAME
  
  JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
  
  =head1 SYNOPSIS
  
   # do not "use" yourself
  
  =head1 DESCRIPTION
  
  This module exists only to provide overload resolution for Storable
  and similar modules. See L<JSON::PP> for more info about this class.
  
  =cut
  
  use JSON::backportPP ();
  use strict;
  
  1;
  
  =head1 AUTHOR
  
  This idea is from L<JSON::XS::Boolean> written by
  Marc Lehmann <schmorp[at]schmorp.de>
  
  =cut
  
JSON_BACKPORTPP_BOOLEAN

$fatpacked{"Lingua/EN/Numbers/Ordinate.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LINGUA_EN_NUMBERS_ORDINATE';
  package Lingua::EN::Numbers::Ordinate;
  $Lingua::EN::Numbers::Ordinate::VERSION = '1.03';
  # ABSTRACT: go from cardinal number (3) to ordinal ("3rd")
  
  use 5.006;
  use strict;
  use warnings;
  require Exporter;
  
  our @ISA        = qw/ Exporter  /;
  our @EXPORT     = qw/ ordinate  /;
  our @EXPORT_OK  = qw/ ordsuf th /;
  
  ###########################################################################
  
  =head1 NAME
  
  Lingua::EN::Numbers::Ordinate -- go from cardinal number (3) to ordinal ("3rd")
  
  =head1 SYNOPSIS
  
    use Lingua::EN::Numbers::Ordinate;
    print ordinate(4), "\n";
     # prints 4th
    print ordinate(-342), "\n";
     # prints -342nd
  
    # Example of actual use:
    ...
    for(my $i = 0; $i < @records; $i++) {
      unless(is_valid($record[$i]) {
        warn "The ", ordinate($i), " record is invalid!\n"; 
        next;
      }
      ...
    }
  
  =head1 DESCRIPTION
  
  There are two kinds of numbers in English -- cardinals (1, 2, 3...), and
  ordinals (1st, 2nd, 3rd...).  This library provides functions for giving
  the ordinal form of a number, given its cardinal value.
  
  =head1 FUNCTIONS
  
  =over
  
  =item ordinate(SCALAR)
  
  Returns a string consisting of that scalar's string form, plus the
  appropriate ordinal suffix.  Example: C<ordinate(23)> returns "23rd".
  
  As a special case, C<ordinate(undef)> and C<ordinate("")> return "0th",
  not "th".
  
  This function is exported by default.
  
  =item th(SCALAR)
  
  Merely an alias for C<ordinate>, but not exported by default.
  
  =item ordsuf(SCALAR)
  
  Returns just the appropriate ordinal suffix for the given scalar
  numeric value.  This is what C<ordinate> uses to actually do its
  work.  For example, C<ordsuf(3)> is "rd". 
  
  Not exported by default.
  
  =back
  
  The above functions are all prototyped to take a scalar value,
  so C<ordinate(@stuff)> is the same as C<ordinate(scalar @stuff)>.
  
  =head1 CAVEATS
  
  * Note that this library knows only about numbers, not number-words.
  C<ordinate('seven')> might just as well be C<ordinate('superglue')>
  or C<ordinate("\x1E\x9A")> -- you'll get the fallthru case of the input
  string plus "th".
  
  * As is unavoidable, C<ordinate(0256)> returns "174th" (because ordinate
  sees the value 174). Similarly, C<ordinate(1E12)> returns
  "1000000000000th".  Returning "trillionth" would be nice, but that's an
  awfully atypical case.
  
  * Note that this library's algorithm (as well as the basic concept
  and implementation of ordinal numbers) is totally language specific.
  
  To pick a trivial example, consider that in French, 1 ordinates
  as "1ier", whereas 41 ordinates as "41ieme".
  
  =head1 STILL NOT SATISFIED?
  
  Bored of this...?
  
    use Lingua::EN::Numbers::Ordinate qw(ordinate th);
    ...
    print th($n), " entry processed...\n";
    ...
  
  Try this bit of lunacy:
  
    {
      my $th_object;
      sub _th () { $th_object }
  
      package Lingua::EN::Numbers::Ordinate::Overloader;
      my $x; # Gotta have something to bless.
      $th_object = bless \$x; # Define the object now, which _th returns
      use Carp ();
      use Lingua::EN::Numbers::Ordinate ();
      sub overordinate {
        Carp::croak "_th should be used only as postfix!" unless $_[2];
        Lingua::EN::Numbers::Ordinate::ordinate($_[1]);
      }
      use overload '&' => \&overordinate;
    }
  
  Then you get to do:
  
    print 3 & _th, "\n";
      # prints "3rd"
    
    print 1 + 2 & _th, "\n";
      # prints "3rd" too!
      # Because of the precedence of & !
    
    print _th & 3, "\n";
      # dies with: "th should be used only as postfix!"
  
  Kooky, isn't it?  For more delightful deleria like this, see
  Damian Conway's I<Object Oriented Perl> from Manning Press.
  
  Kinda makes you like C<th(3)>, doesn't it?
  
  =head1 SEE ALSO
  
  L<Lingua::EN::Inflect> provides an C<ORD> function,
  which returns the ordinal form of a cardinal number.
  
  L<Lingua::EN::Number::IsOrdinal> provides an C<is_ordinal>
  function, which returns true if passed an ordinal number.
  
  =head1 REPOSITORY
  
  L<https://github.com/neilbowers/Lingua-EN-Numbers-Ordinate>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2000 Sean M. Burke.  All rights reserved.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =head1 AUTHOR
  
  Sean M. Burke C<sburke@cpan.org>
  
  =cut
  
  ###########################################################################
  
  sub ordsuf ($) {
    return 'th' if not(defined($_[0])) or not( 0 + $_[0] );
     # 'th' for undef, 0, or anything non-number.
    my $n = abs($_[0]);  # Throw away the sign.
    return 'th' unless $n == int($n); # Best possible, I guess.
    $n %= 100;
    return 'th' if $n == 11 or $n == 12 or $n == 13;
    $n %= 10;
    return 'st' if $n == 1; 
    return 'nd' if $n == 2;
    return 'rd' if $n == 3;
    return 'th';
  }
  
  sub ordinate ($) {
    my $i = $_[0] || 0;
    return $i . ordsuf($i);
  }
  
  no warnings 'all';
  *th = \&ordinate; # correctly copies the prototype, too.
  
  ###########################################################################
  1;
  
  __END__
LINGUA_EN_NUMBERS_ORDINATE

$fatpacked{"Lingua/EN/PluralToSingular.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LINGUA_EN_PLURALTOSINGULAR';
  package Lingua::EN::PluralToSingular;
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT_OK = qw/to_singular is_plural/;
  use warnings;
  use strict;
  our $VERSION = '0.14';
  
  # Irregular plurals.
  
  # References:
  # http://www.macmillandictionary.com/thesaurus-category/british/Irregular-plurals
  # http://web2.uvcs.uvic.ca/elc/studyzone/330/grammar/irrplu.htm
  # http://www.scribd.com/doc/3271143/List-of-100-Irregular-Plural-Nouns-in-English
  
  # This mixes latin/greek plurals and anglo-saxon together. It may be
  # desirable to split things like corpora and genera from "feet" and
  # "geese" at some point.
  
  my %irregular = (qw/
      analyses analysis
      children child
      corpora corpus
      craftsmen craftsman
      crises crisis
      criteria criterion
      curricula curriculum
      feet foot
      fungi fungus
      geese goose
      genera genus
      indices index
      lice louse
      matrices matrix
      memoranda memorandum
      men man
      mice mouse
      monies money
      neuroses neurosis
      nuclei nucleus
      oases oasis
      pence penny
      people person
      phenomena phenomenon
      quanta quantum
      strata stratum
      teeth tooth
      testes testis
      these this
      theses thesis
      those that
      women woman
  /);
  
  # Words ending in ves need care, since the ves may become "f" or "fe".
  
  # References:
  # http://www.macmillandictionary.com/thesaurus-category/british/Irregular-plurals
  
  my %ves = (qw/
      calves calf
      dwarves dwarf
      elves elf
      halves half
      knives knife
      leaves leaf
      lives life
      loaves loaf
      scarves scarf
      sheaves sheaf
      shelves shelf
      wharves wharf 
      wives wife
      wolves wolf
  /);
  
  # A dictionary of plurals.
  
  my %plural = (
      # Words ending in "us" which are plural, in contrast to words like
      # "citrus" or "bogus".
      'menus' => 'menu',
      'buses' => 'bus',
      %ves,
      %irregular,
  );
  
  # A store of words which are the same in both singular and plural.
  
  my @no_change = qw/
                        clothes
                        deer
                        ides
                        fish
                        means
                        offspring
                        series
                        sheep
                        species
                    /;
  
  @plural{@no_change} = @no_change;
  
  # A store of words which look like plurals but are not.
  
  # References:
  
  # http://wiki.answers.com/Q/What_are_some_examples_of_singular_nouns_ending_in_S
  # http://virtuallinguist.typepad.com/the_virtual_linguist/2009/10/singular-nouns-ending-in-s.html
  
  my @not_plural = (qw/
      Charles
      Texas
  Hades 
  Hercules 
  Hermes 
  Gonzales 
  Holmes 
  Hughes 
  Ives 
  Jacques 
  James 
  Keyes 
  Mercedes 
  Naples 
  Oates 
  Raines 
  
      dias
      iris
      molasses
      this
      yes
      chaos
      lens
      corps
      mews
      news
  
      athletics
      mathematics
      physics
      metaphysics
  
  
      bogus
      bus
      cactus
      citrus
      corpus
      hippopotamus
      homunculus
      minus
      narcissus
      octopus
      papyrus
      platypus
      plus
      pus
      stylus
      various
      previous
      devious
      metropolis
      miscellaneous
      perhaps
      thus
      famous
      mrs
  sometimes
  
  ourselves
  themselves
  cannabis
  /);
  
  my %not_plural;
  
  @not_plural{@not_plural} = (1) x @not_plural;
  
  # A store of words which end in "oe" and whose plural ends in "oes".
  
  # References
  # http://www.scrabblefinder.com/ends-with/oe/
  
  my @oes = (qw/
  		 foes
  		 shoes
                   hoes
  		 throes
                   toes
  		 oboes
               /);
  
  my %oes;
  
  @oes{@oes} = (1) x @oes;
  
  # A store of words which end in "ie" and whose plural ends in "ies".
  
  # References:
  # http://www.scrabblefinder.com/ends-with/ie/
  # (most of the words are invalid, the above list was manually searched
  # for useful words).
  
  my @ies = (qw/
  calories
  genies
  lies
  movies
  neckties
  pies
  ties
  /);
  
  my %ies;
  
  @ies{@ies} = (1) x @ies;
  
  # Words which end in -se, so that we want the singular to change from
  # -ses to -se.
  
  my @ses = (qw/
  horses
  tenses
  /);
  
  my %ses;
  @ses{@ses} = (1) x @ses;
  
  # A regular expression which matches the end of words like "dishes"
  # and "sandwiches". $1 is a capture which contains the part of the
  # word which should be kept in a substitution.
  
  my $es_re = qr/([^aeiou]s|ch|sh)es$/;
  
  # See documentation below.
  
  sub to_singular
  {
      my ($word) = @_;
      # The return value.
      my $singular = $word;
      if (! $not_plural{$word}) {
          # The word is not in the list of exceptions.
          if ($plural{$word}) {
              # The word has an irregular plural, like "children", or
              # "geese", so look up the singular in the table.
              $singular = $plural{$word};
          }
          elsif ($word =~ /s$/) {
              # The word ends in "s".
  	    if ($word =~ /'s$/) {
  		# report's, etc.
  		;
  	    }
  	    elsif (length ($word) <= 2) {
  		# is, as, letter s, etc.
  		;
  	    }
  	    elsif ($word =~ /ss$/) {
  		# useless, etc.
  		;
  	    }
  	    elsif ($word =~ /sis$/) {
  		# basis, dialysis etc.
  		;
  	    }
              elsif ($word =~ /ies$/) {
                  # The word ends in "ies".
                  if ($ies{$word}) {
                      # Lies -> lie
                      $singular =~ s/ies$/ie/;
                  }
                  else {
                      # Fries -> fry
                      $singular =~ s/ies$/y/;
                  }
              }
              elsif ($word =~ /oes$/) {
                  # The word ends in "oes".
                  if ($oes{$word}) {
                      # Toes -> toe
                      $singular =~ s/oes$/oe/;
                  }
                  else {
                      # Potatoes -> potato
                      $singular =~ s/oes$/o/;
                  }
              }
              elsif ($word =~ /xes$/) {
                  # The word ends in "xes".
  		$singular =~ s/xes$/x/;
              }
  	    elsif ($word =~ /ses$/) {
  		if ($ses{$word}) {
  		    $singular =~ s/ses$/se/;
  		}
  		else {
  		    $singular =~ s/ses$/s/;
  		}
  	    }
              elsif ($word =~ $es_re) {
                  # Sandwiches -> sandwich
                  # Dishes -> dish
                  $singular =~ s/$es_re/$1/;
              }
              else {
                  # Now the program has checked for every exception it
                  # can think of, so it assumes that it is OK to remove
                  # the "s" from the end of the word.
                  $singular =~ s/s$//;
              }
          }
      }            
      return $singular;
  }
  
  sub is_plural
  {
      my ($word) = @_;
      my $singular = to_singular ($word);
      my $is_plural;
      if ($singular ne $word) {
  	$is_plural = 1;
      }
      elsif ($plural{$singular} && $plural{$singular} eq $singular) {
  	$is_plural = 1;
      }
      else {
  	$is_plural = 0;
      }
      return $is_plural;
  }
  
  1;
  
LINGUA_EN_PLURALTOSINGULAR

$fatpacked{"Log/Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any;
  
  # ABSTRACT: Bringing loggers and listeners together
  our $VERSION = '1.032';
  
  use Log::Any::Manager;
  use Log::Any::Adapter::Util qw(
    require_dynamic
    detection_aliases
    detection_methods
    log_level_aliases
    logging_aliases
    logging_and_detection_methods
    logging_methods
  );
  
  # This is overridden in Log::Any::Test
  our $OverrideDefaultAdapterClass;
  our $OverrideDefaultProxyClass;
  
  # singleton and accessor
  {
      my $manager = Log::Any::Manager->new();
      sub _manager { return $manager }
  }
  
  sub import {
      my $class  = shift;
      my $caller = caller();
  
      my @export_params = ( $caller, @_ );
      $class->_export_to_caller(@export_params);
  }
  
  sub _export_to_caller {
      my $class  = shift;
      my $caller = shift;
  
      # Parse parameters passed to 'use Log::Any'
      my $saw_log_param;
      my @params;
      while ( my $param = shift @_ ) {
          if ( $param eq '$log' ) {
              $saw_log_param = 1;    # defer until later
              next;                  # singular
          }
          else {
              push @params, $param, shift @_;    # pairwise
          }
      }
  
      unless ( @params % 2 == 0 ) {
          require Carp;
          Carp::croak("Argument list not balanced: @params");
      }
  
      # get logger if one was requested
      if ($saw_log_param) {
          no strict 'refs';
          my $proxy = $class->get_logger( category => $caller, @params );
          my $varname = "$caller\::log";
          *$varname = \$proxy;
      }
  }
  
  sub get_logger {
      my ( $class, %params ) = @_;
      no warnings 'once';
  
      my $proxy_class = $class->_get_proxy_class( delete $params{proxy_class} );
      my $category =
        defined $params{category} ? delete $params{'category'} : caller;
  
      if ( my $default = delete $params{'default_adapter'} ) {
          $class->_manager->set_default( $category, $default );
      }
  
      my $adapter = $class->_manager->get_adapter( $category );
  
      require_dynamic($proxy_class);
      return $proxy_class->new(
          %params, adapter => $adapter, category => $category,
      );
  }
  
  sub _get_proxy_class {
      my ( $self, $proxy_name ) = @_;
      return $Log::Any::OverrideDefaultProxyClass
        if $Log::Any::OverrideDefaultProxyClass;
      return "Log::Any::Proxy" unless $proxy_name;
      my $proxy_class = (
            substr( $proxy_name, 0, 1 ) eq '+'
          ? substr( $proxy_name, 1 )
          : "Log::Any::Proxy::$proxy_name"
      );
      return $proxy_class;
  }
  
  # For backward compatibility
  sub set_adapter {
      my $class = shift;
      Log::Any->_manager->set(@_);
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any - Bringing loggers and listeners together
  
  =head1 VERSION
  
  version 1.032
  
  =head1 SYNOPSIS
  
  In a CPAN or other module:
  
      package Foo;
      use Log::Any qw($log);
  
      # log a string
      $log->error("an error occurred");
  
      # log a string and data using a formatting filter
      $log->debugf("arguments are: %s", \@_);
  
  In a Moo/Moose-based module:
  
      package Foo;
      use Moo;
  
      has log => (
          is => 'ro',
          isa => 'Log::Any::Proxy',
          default => sub { Log::Any->get_logger },
      );
  
  In your application:
  
      use Foo;
      use Log::Any::Adapter;
  
      # Send all logs to Log::Log4perl
      Log::Any::Adapter->set('Log4perl');
  
      # Send all logs to Log::Dispatch
      my $log = Log::Dispatch->new(outputs => [[ ... ]]);
      Log::Any::Adapter->set( 'Dispatch', dispatcher => $log );
  
      # See Log::Any::Adapter documentation for more options
  
  =head1 DESCRIPTION
  
  C<Log::Any> provides a standard log production API for modules.
  L<Log::Any::Adapter> allows applications to choose the mechanism for log
  consumption, whether screen, file or another logging mechanism like
  L<Log::Dispatch> or L<Log::Log4perl>.
  
  Many modules have something interesting to say. Unfortunately there is no
  standard way for them to say it - some output to STDERR, others to C<warn>,
  others to custom file logs. And there is no standard way to get a module to
  start talking - sometimes you must call a uniquely named method, other times
  set a package variable.
  
  This being Perl, there are many logging mechanisms available on CPAN.  Each has
  their pros and cons. Unfortunately, the existence of so many mechanisms makes
  it difficult for a CPAN author to commit his/her users to one of them. This may
  be why many CPAN modules invent their own logging or choose not to log at all.
  
  To untangle this situation, we must separate the two parts of a logging API.
  The first, I<log production>, includes methods to output logs (like
  C<$log-E<gt>debug>) and methods to inspect whether a log level is activated
  (like C<$log-E<gt>is_debug>). This is generally all that CPAN modules care
  about. The second, I<log consumption>, includes a way to configure where
  logging goes (a file, the screen, etc.) and the code to send it there. This
  choice generally belongs to the application.
  
  A CPAN module uses C<Log::Any> to get a log producer object.  An application,
  in turn, may choose one or more logging mechanisms via L<Log::Any::Adapter>, or
  none at all.
  
  C<Log::Any> has a very tiny footprint and no dependencies beyond Perl 5.8.1,
  which makes it appropriate for even small CPAN modules to use. It defaults to
  'null' logging activity, so a module can safely log without worrying about
  whether the application has chosen (or will ever choose) a logging mechanism.
  
  See L<http://www.openswartz.com/2007/09/06/standard-logging-api/> for the
  original post proposing this module.
  
  =head1 LOG LEVELS
  
  C<Log::Any> supports the following log levels and aliases, which is meant to be
  inclusive of the major logging packages:
  
       trace
       debug
       info (inform)
       notice
       warning (warn)
       error (err)
       critical (crit, fatal)
       alert
       emergency
  
  Levels are translated as appropriate to the underlying logging mechanism. For
  example, log4perl only has six levels, so we translate 'notice' to 'info' and
  the top three levels to 'fatal'.  See the documentation of an adapter class
  for specifics.
  
  =head1 CATEGORIES
  
  Every logger has a category, generally the name of the class that asked for the
  logger. Some logging mechanisms, like log4perl, can direct logs to different
  places depending on category.
  
  =head1 PRODUCING LOGS (FOR MODULES)
  
  =head2 Getting a logger
  
  The most convenient way to get a logger in your module is:
  
      use Log::Any qw($log);
  
  This creates a package variable I<$log> and assigns it to the logger for the
  current package. It is equivalent to
  
      our $log = Log::Any->get_logger;
  
  In general, to get a logger for a specified category:
  
      my $log = Log::Any->get_logger(category => $category)
  
  If no category is specified, the calling package is used.
  
  A logger object is an instance of L<Log::Any::Proxy>, which passes
  on messages to the L<Log::Any::Adapter> handling its category.
  
  =head2 Logging
  
  To log a message, pass a single string to any of the log levels or aliases. e.g.
  
      $log->error("this is an error");
      $log->warn("this is a warning");
      $log->warning("this is also a warning");
  
  You should B<not> include a newline in your message; that is the responsibility
  of the logging mechanism, which may or may not want the newline.
  
  There are also versions of each of these methods with an additional "f" suffix
  (C<infof>, C<errorf>, C<debugf>, etc.) that format a list of arguments.  The
  specific formatting mechanism and meaning of the arguments is controlled by the
  L<Log::Any::Proxy> object.
  
      $log->errorf("an error occurred: %s", $@);
      $log->debugf("called with %d params: %s", $param_count, \@params);
  
  By default it renders like C<sprintf>, with the following additional features:
  
  =over
  
  =item *
  
  Any complex references (like C<\@params> above) are automatically converted to
  single-line strings with C<Data::Dumper>.
  
  =item *
  
  Any undefined values are automatically converted to the string "<undef>".
  
  =back
  
  =head2 Log level detection
  
  To detect whether a log level is on, use "is_" followed by any of the log
  levels or aliases. e.g.
  
      if ($log->is_info()) { ... }
      $log->debug("arguments are: " . Dumper(\@_))
          if $log->is_debug();
  
  This is important for efficiency, as you can avoid the work of putting together
  the logging message (in the above case, stringifying C<@_>) if the log level is
  not active.
  
  The formatting methods (C<infof>, C<errorf>, etc.) check the log level for you.
  
  Some logging mechanisms don't support detection of log levels. In these cases
  the detection methods will always return 1.
  
  In contrast, the default logging mechanism - Null - will return 0 for all
  detection methods.
  
  =head2 Setting an alternate default logger
  
  To choose something other than Null as the default, pass it as a parameter when
  loading C<Log::Any>
  
      use Log::Any '$log', default_adapter => 'Stderr';
  
  The name of the default class follows the same rules as used by L<Log::Any::Adapter>.
  
  =head2 Configuring the proxy
  
  Any parameter passed on the import line or via the C<get_logger> method
  are passed on the the L<Log::Any::Proxy> constructor.
  
      use Log::Any '$log', filter => \&myfilter;
  
  =head2 Testing
  
  L<Log::Any::Test> provides a mechanism to test code that uses C<Log::Any>.
  
  =head1 CONSUMING LOGS (FOR APPLICATIONS)
  
  Log::Any provides modules with a L<Log::Any::Proxy> object, which is the log
  producer.  To consume its output and direct it where you want (a file, the
  screen, syslog, etc.), you use L<Log::Any::Adapter> along with a
  destination-specific subclass.
  
  For example, to send output to a file via L<Log::Any::Adapter::File>, your
  application could do this:
  
      use Log::Any::Adapter ('File', '/path/to/file.log');
  
  See the L<Log::Any::Adapter> documentation for more details.
  
  =head1 Q & A
  
  =over
  
  =item Isn't Log::Any just yet another logging mechanism?
  
  No. C<Log::Any> does not include code that knows how to log to a particular
  place (file, screen, etc.) It can only forward logging requests to another
  logging mechanism.
  
  =item Why don't you just pick the best logging mechanism, and use and promote it?
  
  Each of the logging mechanisms have their pros and cons, particularly in terms
  of how they are configured. For example, log4perl offers a great deal of power
  and flexibility but uses a global and potentially heavy configuration, whereas
  C<Log::Dispatch> is extremely configuration-light but doesn't handle
  categories. There is also the unnamed future logger that may have advantages
  over either of these two, and all the custom in-house loggers people have
  created and cannot (for whatever reason) stop using.
  
  =item Is it safe for my critical module to depend on Log::Any?
  
  Our intent is to keep C<Log::Any> minimal, and change it only when absolutely
  necessary. Most of the "innovation", if any, is expected to occur in
  C<Log::Any::Adapter>, which your module should not have to depend on (unless it
  wants to direct logs somewhere specific). C<Log::Any> has no non-core dependencies.
  
  =item Why doesn't Log::Any use I<insert modern Perl technique>?
  
  To encourage CPAN module authors to adopt and use C<Log::Any>, we aim to have
  as few dependencies and chances of breakage as possible. Thus, no C<Moose> or
  other niceties.
  
  =back
  
  =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
  
  =head1 SUPPORT
  
  =head2 Bugs / Feature Requests
  
  Please report any bugs or feature requests through the issue tracker
  at L<https://github.com/dagolden/Log-Any/issues>.
  You will be notified automatically of any progress on your issue.
  
  =head2 Source Code
  
  This is open source software.  The code repository is available for
  public review and contribution under the terms of the license.
  
  L<https://github.com/dagolden/Log-Any>
  
    git clone https://github.com/dagolden/Log-Any.git
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Jonathan Swartz <swartz@pobox.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 CONTRIBUTORS
  
  =for stopwords Maxim Vuets Stephen Thirlwall
  
  =over 4
  
  =item *
  
  Maxim Vuets <maxim.vuets@booking.com>
  
  =item *
  
  Stephen Thirlwall <sdt@dr.com>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
  
  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
LOG_ANY

$fatpacked{"Log/Any/Adapter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_ADAPTER';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Adapter;
  
  # ABSTRACT: Tell Log::Any where to send its logs
  our $VERSION = '1.032';
  
  use Log::Any;
  
  sub import {
      my $pkg = shift;
      Log::Any->_manager->set(@_) if (@_);
  }
  
  sub set {
      my $pkg = shift;
      Log::Any->_manager->set(@_)
  }
  
  sub remove {
      my $pkg = shift;
      Log::Any->_manager->remove(@_)
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any::Adapter - Tell Log::Any where to send its logs
  
  =head1 VERSION
  
  version 1.032
  
  =head1 SYNOPSIS
  
      # Log to a file, or stdout, or stderr for all categories
      #
      use Log::Any::Adapter ('File', '/path/to/file.log');
      use Log::Any::Adapter ('Stdout');
      use Log::Any::Adapter ('Stderr');
  
      # Use Log::Log4perl for all categories
      #
      Log::Log4perl::init('/etc/log4perl.conf');
      Log::Any::Adapter->set('Log4perl');
  
      # Use Log::Dispatch for Foo::Baz
      #
      use Log::Dispatch;
      my $log = Log::Dispatch->new(outputs => [[ ... ]]);
      Log::Any::Adapter->set( { category => 'Foo::Baz' },
          'Dispatch', dispatcher => $log );
  
      # Use Log::Dispatch::Config for Foo::Baz and its subcategories
      #
      use Log::Dispatch::Config;
      Log::Dispatch::Config->configure('/path/to/log.conf');
      Log::Any::Adapter->set(
          { category => qr/^Foo::Baz/ },
          'Dispatch', dispatcher => Log::Dispatch::Config->instance() );
  
      # Use your own adapter for all categories
      #
      Log::Any::Adapter->set('+My::Log::Any::Adapter', ...);
  
  =head1 DESCRIPTION
  
  Log::Any::Adapter connects log producers and log consumers.  Its methods
  instantiate a logging adapter (a subclass of L<Log::Any::Adapter::Base>)
  and route log messages from one or more categories to it.
  
  =head1 ADAPTERS
  
  In order to use a logging mechanism with C<Log::Any>, there needs to be an
  adapter class for it. Typically this is named Log::Any::Adapter::I<something>.
  
  =head2 Adapters in this distribution
  
  Three basic adapters come with this distribution -- L<Log::Any::Adapter::File>,
  L<Log::Any::Adapter::Stdout> and L<Log::Any::Adapter::Stderr>:
  
      use Log::Any::Adapter ('File', '/path/to/file.log');
      use Log::Any::Adapter ('Stdout');
      use Log::Any::Adapter ('Stderr');
  
      # or
  
      use Log::Any::Adapter;
      Log::Any::Adapter->set('File', '/path/to/file.log');
      Log::Any::Adapter->set('Stdout');
      Log::Any::Adapter->set('Stderr');
  
  All of them simply output the message and newline to the specified destination;
  a datestamp prefix is added in the C<File> case. For anything more complex
  you'll want to use a more robust adapter from CPAN.
  
  =head2 Adapters on CPAN
  
  A sampling of adapters available on CPAN as of this writing:
  
  =over
  
  =item *
  
  L<Log::Any::Adapter::Log4perl|Log::Any::Adapter::Log4perl>
  
  =item *
  
  L<Log::Any::Adapter::Dispatch|Log::Any::Adapter::Dispatch>
  
  =item *
  
  L<Log::Any::Adapter::FileHandle|Log::Any::Adapter::FileHandle>
  
  =item *
  
  L<Log::Any::Adapter::Syslog|Log::Any::Adapter::Syslog>
  
  =back
  
  You may find other adapters on CPAN by searching for "Log::Any::Adapter", or
  create your own adapter. See
  L<Log::Any::Adapter::Development|Log::Any::Adapter::Development> for more
  information on the latter.
  
  =head1 SETTING AND REMOVING ADAPTERS
  
  =over
  
  =item Log::Any::Adapter->set ([options, ]adapter_name, adapter_params...)
  
  This method sets the adapter to use for all log categories, or for a particular
  set of categories.
  
  I<adapter_name> is the name of an adapter. It is automatically prepended with
  "Log::Any::Adapter::". If instead you want to pass the full name of an adapter,
  prefix it with a "+". e.g.
  
      # Use My::Adapter class
      Log::Any::Adapter->set('+My::Adapter', arg => $value);
  
  I<adapter_params> are passed along to the adapter constructor. See the
  documentation for the individual adapter classes for more information.
  
  An optional hash of I<options> may be passed as the first argument. Options
  are:
  
  =over
  
  =item category
  
  A string containing a category name, or a regex (created with C<qr//>) matching
  multiple categories.  If not specified, all categories will be routed to the
  adapter.
  
  =item lexically
  
  A reference to a lexical variable. When the variable goes out of scope, the
  adapter setting will be removed. e.g.
  
      {
          Log::Any::Adapter->set({lexically => \my $lex}, ...);
  
          # in effect here
          ...
      }
      # no longer in effect here
  
  =back
  
  C<set> returns an entry object, which can be passed to C<remove>.
  
  =item use Log::Any::Adapter (...)
  
  If you pass arguments to C<use Log::Any::Adapter>, it calls C<<
  Log::Any::Adapter->set >> with those arguments.
  
  =item Log::Any::Adapter->remove (entry)
  
  Remove an I<entry> previously returned by C<set>.
  
  =back
  
  =head1 MULTIPLE ADAPTER SETTINGS
  
  C<Log::Any> maintains a stack of entries created via C<set>.
  
  When you get a logger for a particular category, C<Log::Any> will work its way
  down the stack and use the first matching entry.
  
  Whenever the stack changes, any C<Log::Any> loggers that have previously been
  created will automatically adjust to the new stack. For example:
  
      my $log = Log::Any->get_logger();
      $log->error("aiggh!");   # this goes nowhere
      ...
      {
          Log::Any::Adapter->set({ lexically => \my $lex }, 'Log4perl');
          $log->error("aiggh!");   # this goes to log4perl
          ...
      }
      $log->error("aiggh!");   # this goes nowhere again
  
  =head1 SEE ALSO
  
  L<Log::Any|Log::Any>
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Jonathan Swartz <swartz@pobox.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
  
  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
LOG_ANY_ADAPTER

$fatpacked{"Log/Any/Adapter/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_ADAPTER_BASE';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Adapter::Base;
  
  our $VERSION = '1.032';
  
  # we import these in case any legacy adapter uses them as class methods
  use Log::Any::Adapter::Util qw/make_method dump_one_line/;
  
  sub new {
      my $class = shift;
      my $self  = {@_};
      bless $self, $class;
      $self->init(@_);
      return $self;
  }
  
  sub init { }
  
  # Create stub logging methods
  for my $method ( Log::Any::Adapter::Util::logging_and_detection_methods() ) {
      no strict 'refs';
      *$method = sub {
          my $class = ref( $_[0] ) || $_[0];
          die "$class does not implement $method";
      };
  }
  
  # This methods installs a method that delegates to an object attribute
  sub delegate_method_to_slot {
      my ( $class, $slot, $method, $adapter_method ) = @_;
  
      make_method( $method,
          sub { my $self = shift; return $self->{$slot}->$adapter_method(@_) },
          $class );
  }
  
  1;
LOG_ANY_ADAPTER_BASE

$fatpacked{"Log/Any/Adapter/Core.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_ADAPTER_CORE';
  package Log::Any::Adapter::Core;
  {
    $Log::Any::Adapter::Core::VERSION = '0.15';
  }
  use strict;
  use warnings;
  
  # Forward 'warn' to 'warning', 'is_warn' to 'is_warning', and so on for all aliases
  #
  my %aliases = Log::Any->log_level_aliases;
  while ( my ( $alias, $realname ) = each(%aliases) ) {
      _make_method( $alias, sub { my $self = shift; $self->$realname(@_) } );
      my $is_alias    = "is_$alias";
      my $is_realname = "is_$realname";
      _make_method( $is_alias,
          sub { my $self = shift; $self->$is_realname(@_) } );
  }
  
  # Add printf-style versions of all logging methods and aliases - e.g. errorf, debugf
  #
  foreach my $name ( Log::Any->logging_methods, keys(%aliases) ) {
      my $methodf = $name . "f";
      my $method = $aliases{$name} || $name;
      _make_method(
          $methodf,
          sub {
              my ( $self, $format, @params ) = @_;
              my @new_params =
                map {
                     !defined($_) ? '<undef>'
                    : ref($_)     ? _dump_one_line($_)
                    : $_
                } @params;
              my $new_message = sprintf( $format, @new_params );
              $self->$method($new_message);
          }
      );
  }
  
  sub _make_method {
      my ( $method, $code, $pkg ) = @_;
  
      $pkg ||= caller();
      no strict 'refs';
      *{ $pkg . "::$method" } = $code;
  }
  
  sub _dump_one_line {
      my ($value) = @_;
  
      return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0)
        ->Terse(1)->Dump();
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Log::Any::Adapter::Core -- Base class for Log::Any adapters
  
  =head1 VERSION
  
  version 0.15
  
  =head1 DESCRIPTION
  
  This is the base class for both real Log::Any adapters and
  Log::Any::Adapter::Null.
  
  =head1 AUTHOR
  
  Jonathan Swartz
  
  =head1 COPYRIGHT & LICENSE
  
  Copyright (C) 2009 Jonathan Swartz, all rights reserved.
  
  This program is free software; you can redistribute it and/or modify it under
  the same terms as Perl itself.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Jonathan Swartz.
  
  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
LOG_ANY_ADAPTER_CORE

$fatpacked{"Log/Any/Adapter/File.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_ADAPTER_FILE';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Adapter::File;
  
  # ABSTRACT: Simple adapter for logging to files
  our $VERSION = '1.032';
  
  use Config;
  use Fcntl qw/:flock/;
  use IO::File;
  use Log::Any::Adapter::Util ();
  
  use base qw/Log::Any::Adapter::Base/;
  
  my $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf};
  
  my $trace_level = Log::Any::Adapter::Util::numeric_level('trace');
  sub new {
      my ( $class, $file, @args ) = @_;
      return $class->SUPER::new( file => $file, log_level => $trace_level, @args );
  }
  
  sub init {
      my $self = shift;
      if ( exists $self->{log_level} ) {
          $self->{log_level} = Log::Any::Adapter::Util::numeric_level( $self->{log_level} )
              unless $self->{log_level} =~ /^\d+$/;
      }
      else {
          $self->{log_level} = $trace_level;
      }
      my $file = $self->{file};
      open( $self->{fh}, ">>", $file )
        or die "cannot open '$file' for append: $!";
      $self->{fh}->autoflush(1);
  }
  
  foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
      no strict 'refs';
      my $method_level = Log::Any::Adapter::Util::numeric_level( $method );
      *{$method} = sub {
          my ( $self, $text ) = @_;
          return if $method_level > $self->{log_level};
          my $msg = sprintf( "[%s] %s\n", scalar(localtime), $text );
          flock($self->{fh}, LOCK_EX) if $HAS_FLOCK;
          $self->{fh}->print($msg);
          flock($self->{fh}, LOCK_UN) if $HAS_FLOCK;
        }
  }
  
  foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
      no strict 'refs';
      my $base = substr($method,3);
      my $method_level = Log::Any::Adapter::Util::numeric_level( $base );
      *{$method} = sub {
          return !!(  $method_level <= $_[0]->{log_level} );
      };
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any::Adapter::File - Simple adapter for logging to files
  
  =head1 VERSION
  
  version 1.032
  
  =head1 SYNOPSIS
  
      use Log::Any::Adapter ('File', '/path/to/file.log');
  
      # or
  
      use Log::Any::Adapter;
      ...
      Log::Any::Adapter->set('File', '/path/to/file.log');
  
      # with minimum level 'warn'
  
      use Log::Any::Adapter (
          'File', '/path/to/file.log', log_level => 'warn',
      );
  
  =head1 DESCRIPTION
  
  This simple built-in L<Log::Any|Log::Any> adapter logs each message to the
  specified file, with a datestamp prefix and newline appended. The file is
  opened for append with autoflush on.  If C<flock> is available, the handle
  will be locked when writing.
  
  The C<log_level> attribute may be set to define a minimum level to log.
  
  Category is ignored.
  
  =head1 SEE ALSO
  
  L<Log::Any|Log::Any>, L<Log::Any::Adapter|Log::Any::Adapter>
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Jonathan Swartz <swartz@pobox.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
  
  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
LOG_ANY_ADAPTER_FILE

$fatpacked{"Log/Any/Adapter/Null.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_ADAPTER_NULL';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Adapter::Null;
  
  # ABSTRACT: Discards all log messages
  our $VERSION = '1.032';
  
  use base qw/Log::Any::Adapter::Base/;
  
  use Log::Any::Adapter::Util ();
  
  # All methods are no-ops and return false
  
  foreach my $method (Log::Any::Adapter::Util::logging_and_detection_methods()) {
      no strict 'refs';
      *{$method} = sub { return '' }; # false
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any::Adapter::Null - Discards all log messages
  
  =head1 VERSION
  
  version 1.032
  
  =head1 SYNOPSIS
  
      Log::Any::Adapter->set('Null');
  
  =head1 DESCRIPTION
  
  This Log::Any adapter discards all log messages and returns false for all
  detection methods (e.g. is_debug). This is the default adapter when Log::Any is
  loaded.
  
  =head1 SEE ALSO
  
  L<Log::Any|Log::Any>, L<Log::Any::Adapter|Log::Any::Adapter>
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Jonathan Swartz <swartz@pobox.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
  
  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
LOG_ANY_ADAPTER_NULL

$fatpacked{"Log/Any/Adapter/ScreenColoredLevel.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_ADAPTER_SCREENCOLOREDLEVEL';
  package Log::Any::Adapter::ScreenColoredLevel;
  
  our $DATE = '2015-01-28'; # DATE
  our $VERSION = '0.07'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Log::Any;
  use Log::Any::Adapter::Util qw(make_method);
  use base qw(Log::Any::Adapter::Base);
  use Term::ANSIColor;
  
  my @logging_methods = Log::Any->logging_methods;
  our %logging_levels;
  for my $i (0..@logging_methods-1) {
      $logging_levels{$logging_methods[$i]} = $i;
  }
  # some common typos
  $logging_levels{warn} = $logging_levels{warning};
  
  sub _default_level {
      return $ENV{LOG_LEVEL}
          if $ENV{LOG_LEVEL} && $logging_levels{$ENV{LOG_LEVEL}};
      return 'trace' if $ENV{TRACE};
      return 'debug' if $ENV{DEBUG};
      return 'info'  if $ENV{VERBOSE};
      return 'error' if $ENV{QUIET};
      'warning';
  }
  
  sub init {
      my ($self) = @_;
      $self->{stderr}    //= 1;
      $self->{use_color} //= (-t STDOUT);
      $self->{colors}    //= {
          trace     => 'yellow',
          debug     => '',
          info      => 'green',
          notice    => 'green',
          warning   => 'bold blue',
          error     => 'magenta',
          critical  => 'red',
          alert     => 'red',
          emergency => 'red',
      };
      $self->{min_level} //= _default_level();
  
      $self->{_fh} = $self->{stderr} ? \*STDERR : \*STDOUT;
  }
  
  sub hook_before_log {
      return;
      #my ($self, $msg) = @_;
  }
  
  sub hook_after_log {
      my ($self, $msg) = @_;
      print { $self->{_fh} } "\n" unless $msg =~ /\n\z/;
  }
  
  for my $method (Log::Any->logging_methods()) {
      make_method(
          $method,
          sub {
              my ($self, $msg) = @_;
  
              return if $logging_levels{$method} <
                  $logging_levels{$self->{min_level}};
  
              $self->hook_before_log($msg);
  
              if ($self->{formatter}) {
                  $msg = $self->{formatter}->($self, $msg);
              }
  
              if ($self->{use_color} && $self->{colors}{$method}) {
                  $msg = Term::ANSIColor::colored($msg, $self->{colors}{$method});
              }
  
              print { $self->{_fh} } $msg;
  
              $self->hook_after_log($msg);
          }
      );
  }
  
  for my $method (Log::Any->detection_methods()) {
      my $level = $method; $level =~ s/^is_//;
      make_method(
          $method,
          sub {
              my $self = shift;
              $logging_levels{$level} >= $logging_levels{$self->{min_level}};
          }
      );
  }
  
  1;
  # ABSTRACT: Send logs to screen with colorized messages according to level
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any::Adapter::ScreenColoredLevel - Send logs to screen with colorized messages according to level
  
  =head1 VERSION
  
  This document describes version 0.07 of Log::Any::Adapter::ScreenColoredLevel (from Perl distribution Log-Any-Adapter-ScreenColoredLevel), released on 2015-01-28.
  
  =head1 SYNOPSIS
  
   use Log::Any::Adapter;
   Log::Any::Adapter->set('ScreenColoredLevel',
       # min_level => 'debug', # default is 'warning'
       # colors    => { trace => 'bold yellow on_gray', ... }, # customize colors
       # use_color => 1, # force color even when not interactive
       # stderr    => 0, # print to STDOUT instead of STDERR
       # formatter => sub { "LOG: $_[1]" }, # default none
   );
  
  =head1 DESCRIPTION
  
  This Log::Any adapter prints log messages to screen (STDERR/STDOUT) colored
  according to level. It is just like
  L<Log::Log4perl::Appender::ScreenColoredLevel>, even down to the default colors
  (with a tiny difference), except that you don't have to use Log::Log4perl. Of
  course, unlike Log4perl, it only logs to screen and has minimal features.
  
  Parameters:
  
  =over 4
  
  =item * min_level => STRING
  
  Set logging level. Default is warning. If LOG_LEVEL environment variable is set,
  it will be used instead. If TRACE environment variable is set to true, level
  will be set to 'trace'. If DEBUG environment variable is set to true, level will
  be set to 'debug'. If VERBOSE environment variable is set to true, level will be
  set to 'info'.If QUIET environment variable is set to true, level will be set to
  'error'.
  
  =item * use_color => BOOL
  
  Whether to use color or not. Default is true only when running interactively (-t
  STDOUT returns true).
  
  =item * colors => HASH
  
  Customize colors. Hash keys are the logging methods, hash values are colors
  supported by L<Term::ANSIColor>.
  
  The default colors are:
  
   method/level                 color
   ------------                 -----
   trace                        yellow
   debug                        (none, terminal default)
   info, notice                 green
   warning                      bold blue
   error                        magenta
   critical, alert, emergency   red
  
  =item * stderr => BOOL
  
  Whether to print to STDERR, default is true. If set to 0, will print to STDOUT
  instead.
  
  =item * formatter => CODEREF
  
  Allow formatting message. Default is none.
  
  Message will be passed before being colorized. Coderef will be passed:
  
   ($self, $message)
  
  and is expected to return the formatted message.
  
  =back
  
  =for Pod::Coverage ^(init|hook_.+)$
  
  =head1 SEE ALSO
  
  L<Log::Any>
  
  L<Log::Log4perl::Appender::ScreenColoredLevel>
  
  L<Term::ANSIColor>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Log-Any-Adapter-ScreenColoredLevel>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Log-Any-Adapter-ScreenColoredLevel>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Log-Any-Adapter-ScreenColoredLevel>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
LOG_ANY_ADAPTER_SCREENCOLOREDLEVEL

$fatpacked{"Log/Any/Adapter/Stderr.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_ADAPTER_STDERR';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Adapter::Stderr;
  
  # ABSTRACT: Simple adapter for logging to STDERR
  our $VERSION = '1.032';
  
  use Log::Any::Adapter::Util ();
  
  use base qw/Log::Any::Adapter::Base/;
  
  my $trace_level = Log::Any::Adapter::Util::numeric_level('trace');
  
  sub init {
      my ($self) = @_;
      if ( exists $self->{log_level} ) {
          $self->{log_level} =
            Log::Any::Adapter::Util::numeric_level( $self->{log_level} )
            unless $self->{log_level} =~ /^\d+$/;
      }
      else {
          $self->{log_level} = $trace_level;
      }
  }
  
  foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
      no strict 'refs';
      my $method_level = Log::Any::Adapter::Util::numeric_level($method);
      *{$method} = sub {
          my ( $self, $text ) = @_;
          return if $method_level > $self->{log_level};
          print STDERR "$text\n";
      };
  }
  
  foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
      no strict 'refs';
      my $base = substr( $method, 3 );
      my $method_level = Log::Any::Adapter::Util::numeric_level($base);
      *{$method} = sub {
          return !!( $method_level <= $_[0]->{log_level} );
      };
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any::Adapter::Stderr - Simple adapter for logging to STDERR
  
  =head1 VERSION
  
  version 1.032
  
  =head1 SYNOPSIS
  
      use Log::Any::Adapter ('Stderr');
  
      # or
  
      use Log::Any::Adapter;
      ...
      Log::Any::Adapter->set('Stderr');
  
      # with minimum level 'warn'
  
      use Log::Any::Adapter ('Stderr', log_level => 'warn' );
  
  =head1 DESCRIPTION
  
  This simple built-in L<Log::Any|Log::Any> adapter logs each message to STDERR
  with a newline appended. Category is ignored.
  
  The C<log_level> attribute may be set to define a minimum level to log.
  
  =head1 SEE ALSO
  
  L<Log::Any|Log::Any>, L<Log::Any::Adapter|Log::Any::Adapter>
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Jonathan Swartz <swartz@pobox.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
  
  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
LOG_ANY_ADAPTER_STDERR

$fatpacked{"Log/Any/Adapter/Stdout.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_ADAPTER_STDOUT';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Adapter::Stdout;
  
  # ABSTRACT: Simple adapter for logging to STDOUT
  our $VERSION = '1.032';
  
  use Log::Any::Adapter::Util ();
  
  use base qw/Log::Any::Adapter::Base/;
  
  my $trace_level = Log::Any::Adapter::Util::numeric_level('trace');
  
  sub init {
      my ($self) = @_;
      if ( exists $self->{log_level} ) {
          $self->{log_level} =
            Log::Any::Adapter::Util::numeric_level( $self->{log_level} )
            unless $self->{log_level} =~ /^\d+$/;
      }
      else {
          $self->{log_level} = $trace_level;
      }
  }
  
  foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
      no strict 'refs';
      my $method_level = Log::Any::Adapter::Util::numeric_level($method);
      *{$method} = sub {
          my ( $self, $text ) = @_;
          return if $method_level > $self->{log_level};
          print STDOUT "$text\n";
      };
  }
  
  foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
      no strict 'refs';
      my $base = substr( $method, 3 );
      my $method_level = Log::Any::Adapter::Util::numeric_level($base);
      *{$method} = sub {
          return !!( $method_level <= $_[0]->{log_level} );
      };
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any::Adapter::Stdout - Simple adapter for logging to STDOUT
  
  =head1 VERSION
  
  version 1.032
  
  =head1 SYNOPSIS
  
      use Log::Any::Adapter ('Stdout');
  
      # or
  
      use Log::Any::Adapter;
      ...
      Log::Any::Adapter->set('Stdout');
  
      # with minimum level 'warn'
  
      use Log::Any::Adapter ('Stdout', log_level => 'warn' );
  
  =head1 DESCRIPTION
  
  This simple built-in L<Log::Any|Log::Any> adapter logs each message to STDOUT
  with a newline appended. Category is ignored.
  
  The C<log_level> attribute may be set to define a minimum level to log.
  
  =head1 SEE ALSO
  
  L<Log::Any|Log::Any>, L<Log::Any::Adapter|Log::Any::Adapter>
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Jonathan Swartz <swartz@pobox.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
  
  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
LOG_ANY_ADAPTER_STDOUT

$fatpacked{"Log/Any/Adapter/Test.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_ADAPTER_TEST';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Adapter::Test;
  
  our $VERSION = '1.032';
  
  use Log::Any::Adapter::Util qw/dump_one_line/;
  use Test::Builder;
  
  use base qw/Log::Any::Adapter::Base/;
  
  my $tb = Test::Builder->new();
  my @msgs;
  
  # Ignore arguments for the original adapter if we're overriding, but recover
  # category from argument list; this depends on category => $category being put
  # at the end of the list in Log::Any::Manager. If not overriding, allow
  # arguments as usual.
  
  sub new {
      my $class = shift;
      if ( defined $Log::Any::OverrideDefaultAdapterClass
          && $Log::Any::OverrideDefaultAdapterClass eq __PACKAGE__ )
      {
          my $category = pop @_;
          return $class->SUPER::new( category => $category );
      }
      else {
          return $class->SUPER::new(@_);
      }
  }
  
  # All detection methods return true
  #
  foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
      no strict 'refs';
      *{$method} = sub { 1 };
  }
  
  # All logging methods push onto msgs array
  #
  foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
      no strict 'refs';
      *{$method} = sub {
          my ( $self, $msg ) = @_;
          push(
              @msgs,
              {
                  message  => $msg,
                  level    => $method,
                  category => $self->{category}
              }
          );
      };
  }
  
  # Testing methods below
  #
  
  sub msgs {
      my $self = shift;
  
      return \@msgs;
  }
  
  sub clear {
      my ($self) = @_;
  
      @msgs = ();
  }
  
  sub contains_ok {
      my ( $self, $regex, $test_name ) = @_;
  
      $test_name ||= "log contains '$regex'";
      my $found =
        _first_index( sub { $_->{message} =~ /$regex/ }, @{ $self->msgs } );
      if ( $found != -1 ) {
          splice( @{ $self->msgs }, $found, 1 );
          $tb->ok( 1, $test_name );
      }
      else {
          $tb->ok( 0, $test_name );
          $tb->diag( "could not find message matching $regex; log contains: "
                . $self->dump_one_line( $self->msgs ) );
      }
  }
  
  sub category_contains_ok {
      my ( $self, $category, $regex, $test_name ) = @_;
  
      $test_name ||= "log for $category contains '$regex'";
      my $found =
        _first_index(
          sub { $_->{category} eq $category && $_->{message} =~ /$regex/ },
          @{ $self->msgs } );
      if ( $found != -1 ) {
          splice( @{ $self->msgs }, $found, 1 );
          $tb->ok( 1, $test_name );
      }
      else {
          $tb->ok( 0, $test_name );
          $tb->diag(
              "could not find $category message matching $regex; log contains: "
                . $self->dump_one_line( $self->msgs ) );
      }
  }
  
  sub does_not_contain_ok {
      my ( $self, $regex, $test_name ) = @_;
  
      $test_name ||= "log does not contain '$regex'";
      my $found =
        _first_index( sub { $_->{message} =~ /$regex/ }, @{ $self->msgs } );
      if ( $found != -1 ) {
          $tb->ok( 0, $test_name );
          $tb->diag( "found message matching $regex: " . $self->msgs->[$found] );
      }
      else {
          $tb->ok( 1, $test_name );
      }
  }
  
  sub category_does_not_contain_ok {
      my ( $self, $category, $regex, $test_name ) = @_;
  
      $test_name ||= "log for $category contains '$regex'";
      my $found =
        _first_index(
          sub { $_->{category} eq $category && $_->{message} =~ /$regex/ },
          @{ $self->msgs } );
      if ( $found != -1 ) {
          $tb->ok( 0, $test_name );
          $tb->diag( "found $category message matching $regex: "
                . $self->msgs->[$found] );
      }
      else {
          $tb->ok( 1, $test_name );
      }
  }
  
  sub empty_ok {
      my ( $self, $test_name ) = @_;
  
      $test_name ||= "log is empty";
      if ( !@{ $self->msgs } ) {
          $tb->ok( 1, $test_name );
      }
      else {
          $tb->ok( 0, $test_name );
          $tb->diag( "log is not empty; contains "
                . $self->dump_one_line( $self->msgs ) );
          $self->clear();
      }
  }
  
  sub contains_only_ok {
      my ( $self, $regex, $test_name ) = @_;
  
      $test_name ||= "log contains only '$regex'";
      my $count = scalar( @{ $self->msgs } );
      if ( $count == 1 ) {
          local $Test::Builder::Level = $Test::Builder::Level + 1;
          $self->contains_ok( $regex, $test_name );
      }
      else {
          $tb->ok( 0, $test_name );
          $tb->diag( "log contains $count messages: "
                . $self->dump_one_line( $self->msgs ) );
      }
  }
  
  sub _first_index {
      my $f = shift;
      for my $i ( 0 .. $#_ ) {
          local *_ = \$_[$i];
          return $i if $f->();
      }
      return -1;
  }
  
  1;
LOG_ANY_ADAPTER_TEST

$fatpacked{"Log/Any/Adapter/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_ADAPTER_UTIL';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Adapter::Util;
  
  # ABSTRACT: Common utility functions for Log::Any
  our $VERSION = '1.032';
  
  use Data::Dumper;
  use base qw(Exporter);
  
  my %LOG_LEVELS;
  BEGIN {
      %LOG_LEVELS = (
          EMERGENCY => 0,
          ALERT     => 1,
          CRITICAL  => 2,
          ERROR     => 3,
          WARNING   => 4,
          NOTICE    => 5,
          INFO      => 6,
          DEBUG     => 7,
          TRACE     => 8,
      );
  }
  
  use constant \%LOG_LEVELS;
  
  our @EXPORT_OK = qw(
    cmp_deeply
    detection_aliases
    detection_methods
    dump_one_line
    log_level_aliases
    logging_aliases
    logging_and_detection_methods
    logging_methods
    make_method
    numeric_level
    read_file
    require_dynamic
  );
  
  push @EXPORT_OK, keys %LOG_LEVELS;
  
  our %EXPORT_TAGS = ( 'levels' => [ keys %LOG_LEVELS ] );
  
  my ( %LOG_LEVEL_ALIASES, @logging_methods, @logging_aliases, @detection_methods,
      @detection_aliases, @logging_and_detection_methods );
  
  BEGIN {
      %LOG_LEVEL_ALIASES = (
          inform => 'info',
          warn   => 'warning',
          err    => 'error',
          crit   => 'critical',
          fatal  => 'critical'
      );
      @logging_methods =
        qw(trace debug info notice warning error critical alert emergency);
      @logging_aliases               = keys(%LOG_LEVEL_ALIASES);
      @detection_methods             = map { "is_$_" } @logging_methods;
      @detection_aliases             = map { "is_$_" } @logging_aliases;
      @logging_and_detection_methods = ( @logging_methods, @detection_methods );
  }
  
  #pod =func logging_methods
  #pod
  #pod Returns a list of all logging method. E.g. "trace", "info", etc.
  #pod
  #pod =cut
  
  sub logging_methods               { @logging_methods }
  
  #pod =func detection_methods
  #pod
  #pod Returns a list of detection methods.  E.g. "is_trace", "is_info", etc.
  #pod
  #pod =cut
  
  sub detection_methods             { @detection_methods }
  
  #pod =func logging_and_detection_methods
  #pod
  #pod Returns a list of logging and detection methods (but not aliases).
  #pod
  #pod =cut
  
  sub logging_and_detection_methods { @logging_and_detection_methods }
  
  #pod =func log_level_aliases
  #pod
  #pod Returns key/value pairs mapping aliases to "official" names.  E.g. "err" maps
  #pod to "error".
  #pod
  #pod =cut
  
  sub log_level_aliases             { %LOG_LEVEL_ALIASES }
  
  #pod =func logging_aliases
  #pod
  #pod Returns a list of logging alias names.  These are the keys from
  #pod L</log_level_aliases>.
  #pod
  #pod =cut
  
  sub logging_aliases               { @logging_aliases }
  
  #pod =func detection_aliases
  #pod
  #pod Returns a list of detection aliases.  E.g. "is_err", "is_fatal", etc.
  #pod
  #pod =cut
  
  sub detection_aliases             { @detection_aliases }
  
  #pod =func numeric_level
  #pod
  #pod Given a level name (or alias), returns the numeric value described above under
  #pod log level constants.  E.g. "err" would return 3.
  #pod
  #pod =cut
  
  sub numeric_level {
      my ($level) = @_;
      my $canonical =
        exists $LOG_LEVEL_ALIASES{$level} ? $LOG_LEVEL_ALIASES{$level} : $level;
      return $LOG_LEVELS{ uc($canonical) };
  }
  
  #pod =func dump_one_line
  #pod
  #pod Given a reference, returns a one-line L<Data::Dumper> dump with keys sorted.
  #pod
  #pod =cut
  
  sub dump_one_line {
      my ($value) = @_;
  
      return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0)
        ->Terse(1)->Dump();
  }
  
  #pod =func make_method
  #pod
  #pod Given a method name, a code reference and a package name, installs the code
  #pod reference as a method in the package.
  #pod
  #pod =cut
  
  sub make_method {
      my ( $method, $code, $pkg ) = @_;
  
      $pkg ||= caller();
      no strict 'refs';
      *{ $pkg . "::$method" } = $code;
  }
  
  #pod =func require_dynamic (DEPRECATED)
  #pod
  #pod Given a class name, attempts to load it via require unless the class
  #pod already has a constructor available.  Throws an error on failure. Used
  #pod internally and may become private in the future.
  #pod
  #pod =cut
  
  sub require_dynamic {
      my ($class) = @_;
  
      return 1 if $class->can('new'); # duck-type that class is loaded
  
      unless ( defined( eval "require $class; 1" ) )
      {    ## no critic (ProhibitStringyEval)
          die $@;
      }
  }
  
  #pod =func read_file (DEPRECATED)
  #pod
  #pod Slurp a file.  Does *not* apply any layers.  Used for testing and may
  #pod become private in the future.
  #pod
  #pod =cut
  
  sub read_file {
      my ($file) = @_;
  
      local $/ = undef;
      open( my $fh, '<', $file )
        or die "cannot open '$file': $!";
      my $contents = <$fh>;
      return $contents;
  }
  
  #pod =func cmp_deeply (DEPRECATED)
  #pod
  #pod Compares L<dump_one_line> results for two references.  Also takes a test
  #pod label as a third argument.  Used for testing and may become private in the
  #pod future.
  #pod
  #pod =cut
  
  sub cmp_deeply {
      my ( $ref1, $ref2, $name ) = @_;
  
      my $tb = Test::Builder->new();
      $tb->is_eq( dump_one_line($ref1), dump_one_line($ref2), $name );
  }
  
  # 0.XX version loaded Log::Any and some adapters relied on this happening
  # behind the scenes.  Since Log::Any now uses this module, we load Log::Any
  # via require after compilation to mitigate circularity.
  require Log::Any;
  
  1;
  
  
  # vim: ts=4 sts=4 sw=4 et tw=75:
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any::Adapter::Util - Common utility functions for Log::Any
  
  =head1 VERSION
  
  version 1.032
  
  =head1 DESCRIPTION
  
  This module has utility functions to help develop L<Log::Any::Adapter>
  subclasses or L<Log::Any::Proxy> formatters/filters.  It also has some
  functions used in internal testing.
  
  =head1 USAGE
  
  Nothing is exported by default.
  
  =head2 Log level constants
  
  If the C<:levels> tag is included in the import list, the following numeric
  constants will be imported:
  
      EMERGENCY => 0
      ALERT     => 1
      CRITICAL  => 2
      ERROR     => 3
      WARNING   => 4
      NOTICE    => 5
      INFO      => 6
      DEBUG     => 7
      TRACE     => 8
  
  =head1 FUNCTIONS
  
  =head2 logging_methods
  
  Returns a list of all logging method. E.g. "trace", "info", etc.
  
  =head2 detection_methods
  
  Returns a list of detection methods.  E.g. "is_trace", "is_info", etc.
  
  =head2 logging_and_detection_methods
  
  Returns a list of logging and detection methods (but not aliases).
  
  =head2 log_level_aliases
  
  Returns key/value pairs mapping aliases to "official" names.  E.g. "err" maps
  to "error".
  
  =head2 logging_aliases
  
  Returns a list of logging alias names.  These are the keys from
  L</log_level_aliases>.
  
  =head2 detection_aliases
  
  Returns a list of detection aliases.  E.g. "is_err", "is_fatal", etc.
  
  =head2 numeric_level
  
  Given a level name (or alias), returns the numeric value described above under
  log level constants.  E.g. "err" would return 3.
  
  =head2 dump_one_line
  
  Given a reference, returns a one-line L<Data::Dumper> dump with keys sorted.
  
  =head2 make_method
  
  Given a method name, a code reference and a package name, installs the code
  reference as a method in the package.
  
  =head2 require_dynamic (DEPRECATED)
  
  Given a class name, attempts to load it via require unless the class
  already has a constructor available.  Throws an error on failure. Used
  internally and may become private in the future.
  
  =head2 read_file (DEPRECATED)
  
  Slurp a file.  Does *not* apply any layers.  Used for testing and may
  become private in the future.
  
  =head2 cmp_deeply (DEPRECATED)
  
  Compares L<dump_one_line> results for two references.  Also takes a test
  label as a third argument.  Used for testing and may become private in the
  future.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Jonathan Swartz <swartz@pobox.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
  
  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
LOG_ANY_ADAPTER_UTIL

$fatpacked{"Log/Any/IfLOG.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_IFLOG';
  package Log::Any::IfLOG;
  
  our $DATE = '2015-04-05'; # DATE
  our $VERSION = '0.05'; # VERSION
  
  my $log_singleton;
  
  our $DEBUG;
  our $ENABLE_LOG;
  
  sub import {
      my $self = shift;
  
      my $log_enabled;
      if (defined $ENABLE_LOG) {
          $log_enabled = $ENABLE_LOG;
      } elsif ($INC{'Log/Any.pm'}) {
          # Log::Any has been loaded, so we have absorbed the cost anyway
          $log_enabled = 1;
      } else {
          $log_enabled =
              $ENV{LOG} || $ENV{TRACE} || $ENV{DEBUG} ||
              $ENV{VERBOSE} || $ENV{QUIET} || $ENV{LOG_LEVEL};
      }
      #warn "D:log_enabled: $log_enabled" if $DEBUG;
  
      my $caller = caller();
      if ($log_enabled) {
          require Log::Any;
          Log::Any->_export_to_caller($caller, @_);
      } else {
          my $saw_log_param = grep { $_ eq '$log' } @_;
          if ($saw_log_param) {
              if (!$log_singleton) { $log_singleton = Object::Dumb->new }
              *{"$caller\::log"} = \$log_singleton;
          }
      }
  }
  
  package
      Object::Dumb;
  sub new { my $o = ""; bless \$o, shift }
  sub AUTOLOAD { 0 }
  
  1;
  # ABSTRACT: Load Log::Any only if "logging is enabled"
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any::IfLOG - Load Log::Any only if "logging is enabled"
  
  =head1 VERSION
  
  This document describes version 0.05 of Log::Any::IfLOG (from Perl distribution Log-Any-IfLOG), released on 2015-04-05.
  
  =head1 SYNOPSIS
  
   use Log::Any::IfLOG '$log';
  
  =head1 DESCRIPTION
  
  This module is a drop-in replacement/wrapper for L<Log::Any> to be used from
  your modules. This is a quick-hack solution to avoid the cost of loading
  Log::Any under "normal condition". Since Log::Any 1.00, startup overhead
  increases to about 7-10ms on my PC/laptop (from under 1ms for the previous
  version). Because I want to keep startup overhead of CLI apps under 50ms (see
  L<Perinci::CmdLine::Lite>) to keep tab completion from getting a noticeable lag,
  every millisecond counts.
  
  This module will only load L<Log::Any> when "logging is enabled". Otherwise, it
  will just return without loading anything. If C<$log> is requested in import, a
  fake object is returned that responds to methods like C<debug>, C<is_debug> and
  so on but will do nothing when called and just return 0.
  
  To determine "logging is enabled":
  
  =over
  
  =item * Is $ENABLE_LOG defined?
  
  This package variable can be used to force "logging enabled" (if true) or
  "logging disabled" (if false). Normally, you don't need to do this except for
  testing.
  
  =item * Is Log::Any is already loaded (from %INC)?
  
  If Log::Any is already loaded, it means we have taken the overhead hit anyway so
  logging is enabled.
  
  =item * Is one of log-related environment variables true?
  
  If one of L<LOG>, C<TRACE>, or C<DEBUG>, or C<VERBOSE>, or C<QUIET>, or
  C<LOG_LEVEL> is true then logging is enabled. These variables are used by
  L<Perinci::CmdLine>.
  
  Otherwise, logging is disabled.
  
  =back
  
  =for Pod::Coverage ^(.+)$
  
  =head1 ENVIRONMENT
  
  =head2 LOG => bool
  
  =head2 TRACE => bool
  
  =head2 DEBUG => bool
  
  =head2 VERBOSE => bool
  
  =head2 QUIET => bool
  
  =head2 LOG_LEVEL => str
  
  =head1 VARIABLES
  
  =head2 $ENABLE_LOG => bool
  
  This setting can be forced to force loading Log::Any or not.
  
  =head1 SEE ALSO
  
  L<Log::Any>
  
  L<http://github.com/dagolden/Log-Any/issues/24>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Log-Any-IfLOG>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Log-Any-IfLOG>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Log-Any-IfLOG>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
LOG_ANY_IFLOG

$fatpacked{"Log/Any/Manager.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_MANAGER';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Manager;
  
  our $VERSION = '1.032';
  
  sub new {
      my $class = shift;
      my $self  = {
          entries         => [],
          category_cache  => {},
          default_adapter => {},
      };
      bless $self, $class;
  
      return $self;
  }
  
  sub get_adapter {
      my ( $self, $category ) = @_;
  
      # Create a new adapter for this category if it is not already in cache
      #
      my $category_cache = $self->{category_cache};
      if ( !defined( $category_cache->{$category} ) ) {
          my $entry = $self->_choose_entry_for_category($category);
          my $adapter = $self->_new_adapter_for_entry( $entry, $category );
          $category_cache->{$category} = { entry => $entry, adapter => $adapter };
      }
      return $category_cache->{$category}->{adapter};
  }
  
  {
      no warnings 'once';
      *get_logger = \&get_adapter;    # backwards compatibility
  }
  
  sub _choose_entry_for_category {
      my ( $self, $category ) = @_;
  
      foreach my $entry ( @{ $self->{entries} } ) {
          if ( $category =~ $entry->{pattern} ) {
              return $entry;
          }
      }
      # nothing requested so fallback to default
      my $default = $self->{default_adapter}{$category}
          || [ $self->_get_adapter_class("Null"), [] ];
      my ($adapter_class, $adapter_params) = @$default;
      _require_dynamic($adapter_class);
      return {
          adapter_class  => $adapter_class,
          adapter_params => $adapter_params,
      };
  }
  
  sub _new_adapter_for_entry {
      my ( $self, $entry, $category ) = @_;
  
      return $entry->{adapter_class}
        ->new( @{ $entry->{adapter_params} }, category => $category );
  }
  
  sub set_default {
      my ( $self, $category, $adapter_name, @adapter_params ) = @_;
      my $adapter_class = $self->_get_adapter_class($adapter_name);
      $self->{default_adapter}{$category} = [$adapter_class, \@adapter_params];
  }
  
  sub set {
      my $self = shift;
      my $options;
      if ( ref( $_[0] ) eq 'HASH' ) {
          $options = shift(@_);
      }
      my ( $adapter_name, @adapter_params ) = @_;
  
      unless ( defined($adapter_name) && $adapter_name =~ /\S/ ) {
          require Carp;
          Carp::croak("expected adapter name");
      }
  
      my $pattern = $options->{category};
      if ( !defined($pattern) ) {
          $pattern = qr/.*/;
      }
      elsif ( !ref($pattern) ) {
          $pattern = qr/^\Q$pattern\E$/;
      }
  
      my $adapter_class = $self->_get_adapter_class($adapter_name);
      _require_dynamic($adapter_class);
  
      my $entry = $self->_new_entry( $pattern, $adapter_class, \@adapter_params );
      unshift( @{ $self->{entries} }, $entry );
  
      $self->_reselect_matching_adapters($pattern);
  
      if ( my $lex_ref = $options->{lexically} ) {
          $$lex_ref = Log::Any::Manager::_Guard->new(
              sub { $self->remove($entry) unless _in_global_destruction() } );
      }
  
      return $entry;
  }
  
  sub remove {
      my ( $self, $entry ) = @_;
  
      my $pattern = $entry->{pattern};
      $self->{entries} = [ grep { $_ ne $entry } @{ $self->{entries} } ];
      $self->_reselect_matching_adapters($pattern);
  }
  
  sub _new_entry {
      my ( $self, $pattern, $adapter_class, $adapter_params ) = @_;
  
      return {
          pattern        => $pattern,
          adapter_class  => $adapter_class,
          adapter_params => $adapter_params,
      };
  }
  
  sub _reselect_matching_adapters {
      my ( $self, $pattern ) = @_;
  
      return if _in_global_destruction();
  
      # Reselect adapter for each category matching $pattern
      #
      while ( my ( $category, $category_info ) =
          each( %{ $self->{category_cache} } ) )
      {
          my $new_entry = $self->_choose_entry_for_category($category);
          if ( $new_entry ne $category_info->{entry} ) {
              my $new_adapter =
                $self->_new_adapter_for_entry( $new_entry, $category );
              %{ $category_info->{adapter} } = %$new_adapter;
              bless( $category_info->{adapter}, ref($new_adapter) );
              $category_info->{entry} = $new_entry;
          }
      }
  }
  
  sub _get_adapter_class {
      my ( $self, $adapter_name ) = @_;
      return $Log::Any::OverrideDefaultAdapterClass if $Log::Any::OverrideDefaultAdapterClass;
      $adapter_name =~ s/^Log:://;    # Log::Dispatch -> Dispatch, etc.
      my $adapter_class = (
            substr( $adapter_name, 0, 1 ) eq '+'
          ? substr( $adapter_name, 1 )
          : "Log::Any::Adapter::$adapter_name"
      );
      return $adapter_class;
  }
  
  # This is adapted from the pure perl parts of Devel::GlobalDestruction
  if ( defined ${^GLOBAL_PHASE} ) {
      eval 'sub _in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }; 1' ## no critic
        or die $@;
  }
  else {
      require B;
      my $started = !B::main_start()->isa(q[B::NULL]);
      unless ($started) {
          eval '0 && $started; CHECK { $started = 1 }; 1' ## no critic
            or die $@;
      }
      eval ## no critic
        '0 && $started; sub _in_global_destruction () { $started && B::main_start()->isa(q[B::NULL]) }; 1'
        or die $@;
  }
  
  # XXX not DRY and not a great way to do this, but oh, well.
  sub _require_dynamic {
      my ($class) = @_;
  
      return 1 if $class->can('new'); # duck-type that class is loaded
  
      unless ( defined( eval "require $class; 1" ) )
      {    ## no critic (ProhibitStringyEval)
          die $@;
      }
  }
  
  package    # hide from PAUSE
    Log::Any::Manager::_Guard;
  
  sub new { bless $_[1], $_[0] }
  
  sub DESTROY { $_[0]->() }
  
  1;
LOG_ANY_MANAGER

$fatpacked{"Log/Any/Proxy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_PROXY';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Proxy;
  
  # ABSTRACT: Log::Any generator proxy object
  our $VERSION = '1.032';
  
  use Log::Any::Adapter::Util ();
  
  sub _default_formatter {
      my ( $cat, $lvl, $format, @params ) = @_;
      my @new_params =
        map { !defined($_) ? '<undef>' : ref($_) ? _dump_one_line($_) : $_ }
        @params;
      return sprintf( $format, @new_params );
  }
  
  sub _dump_one_line {
      my ($value) = @_;
  
      return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0)
        ->Terse(1)->Useqq(1)->Dump();
  }
  
  sub new {
      my $class = shift;
      my $self = { formatter => \&_default_formatter, @_ };
      unless ( $self->{adapter} ) {
          require Carp;
          Carp::croak("$class requires an 'adapter' parameter");
      }
      unless ( $self->{category} ) {
          require Carp;
          Carp::croak("$class requires an 'category' parameter")
      }
      bless $self, $class;
      $self->init(@_);
      return $self;
  }
  
  sub init { }
  
  for my $attr (qw/adapter filter formatter prefix/) {
      no strict 'refs';
      *{$attr} = sub { return $_[0]->{$attr} };
  }
  
  my %aliases = Log::Any::Adapter::Util::log_level_aliases();
  
  # Set up methods/aliases and detection methods/aliases
  foreach my $name ( Log::Any::Adapter::Util::logging_methods(), keys(%aliases) )
  {
      my $realname    = $aliases{$name} || $name;
      my $namef       = $name . "f";
      my $is_name     = "is_$name";
      my $is_realname = "is_$realname";
      my $numeric     = Log::Any::Adapter::Util::numeric_level($realname);
      no strict 'refs';
      *{$is_name} = sub {
          my ($self) = @_;
          return $self->{adapter}->$is_realname;
      };
      *{$name} = sub {
          my ( $self, @parts ) = @_;
          my $message = join(" ", grep { defined($_) && length($_) } @parts );
          return unless length $message;
          $message = $self->{filter}->( $self->{category}, $numeric, $message )
            if defined $self->{filter};
          return unless defined $message and length $message;
          $message = "$self->{prefix}$message"
            if defined $self->{prefix} && length $self->{prefix};
          return $self->{adapter}->$realname($message);
      };
      *{$namef} = sub {
          my ( $self, @args ) = @_;
          return unless $self->{adapter}->$is_realname;
          my $message =
            $self->{formatter}->( $self->{category}, $numeric, @args );
          return unless defined $message and length $message;
          return $self->$name($message);
      };
  }
  
  1;
  
  
  # vim: ts=4 sts=4 sw=4 et tw=75:
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any::Proxy - Log::Any generator proxy object
  
  =head1 VERSION
  
  version 1.032
  
  =head1 SYNOPSIS
  
      # prefix log messages
      use Log::Any '$log', prefix => 'MyApp: ';
  
      # transform log messages
      use Log::Any '$log', filter => \&myfilter;
  
      # format with String::Flogger instead of the default
      use String::Flogger;
      use Log::Any '$log', formatter => sub {
          my ($cat, $lvl, @args) = @_;
          String::Flogger::flog( @args );
      };
  
  =head1 DESCRIPTION
  
  Log::Any::Proxy objects are what modules use to produce log messages.  They
  construct messages and pass them along to a configured adapter.
  
  =head1 USAGE
  
  =head2 Simple logging
  
  Your library can do simple logging using logging methods corresponding to
  the log levels (or aliases):
  
  =over 4
  
  =item *
  
  trace
  
  =item *
  
  debug
  
  =item *
  
  info (inform)
  
  =item *
  
  notice
  
  =item *
  
  warning (warn)
  
  =item *
  
  error (err)
  
  =item *
  
  critical (crit, fatal)
  
  =item *
  
  alert
  
  =item *
  
  emergency
  
  =back
  
  Pass a string to be logged.  Do not include a newline.
  
      $log->info("Got some new for you.");
  
  The log string will be tranformed via the C<filter> attribute (if any) and
  the C<prefix> (if any) will be prepended.
  
  B<NOTE>: While you are encouraged to pass a single string to be logged, if
  multiple arguments are passed, they are concatenated with a space character
  into a single string before processing.  This ensures consistency across
  adapters, some of which may support multiple arguments to their logging
  functions (and which concatenate in different ways) and some of which do
  not.
  
  =head2 Advanced logging
  
  Your library can do advanced logging using logging methods corresponding to
  the log levels (or aliases), but with an "f" appended:
  
  =over 4
  
  =item *
  
  tracef
  
  =item *
  
  debugf
  
  =item *
  
  infof (informf)
  
  =item *
  
  noticef
  
  =item *
  
  warningf (warnf)
  
  =item *
  
  errorf (errf)
  
  =item *
  
  criticalf (critf, fatalf)
  
  =item *
  
  alertf
  
  =item *
  
  emergencyf
  
  =back
  
  When these methods are called, the adapter is first checked to see if it is
  logging at that level.  If not, the method returns without logging.
  
  Next, arguments are transformed to a message string via the C<formatter>
  attribute.  The default acts like C<sprintf> with some helpful formatting.
  
  Finally, the message string is logged via the simple logging functions, which
  can transform or prefix as described above.
  
  =head1 ATTRIBUTES
  
  =head2 adapter
  
  A L<Log::Any::Adapter> object to receive any messages logged.  This is
  generated by L<Log::Any> and can not be overridden.
  
  =head2 category
  
  The category name of the proxy.  If not provided, L<Log::Any> will set it
  equal to the calling when the proxy is constructed.
  
  =head2 filter
  
  A code reference to transform messages before passing them to a
  Log::Any::Adapter.  It gets three arguments: a category, a numeric level
  and a string.  It should return a string to be logged.
  
      sub {
          my ($cat, $lvl, $msg) = @_;
          return "[$lvl] $msg";
      }
  
  If the return value is undef or the empty string, no message will be
  logged.  Otherwise, the return value is passed to the logging adapter.
  
  Numeric levels range from 0 (emergency) to 8 (trace).  Constant functions
  for these levels are available from L<Log::Any::Adapter::Util>.
  
  =head2 formatter
  
  A code reference to format messages given to the C<*f> methods (C<tracef>,
  C<debugf>, C<infof>, etc..)
  
  It get three or more arguments: a category, a numeric level and the list
  of arguments passsed to the C<*f> method.  It should return a string to
  be logged.
  
      sub {
          my ($cat, $lvl, $format, @args) = @_;
          return sprintf($format, @args);
      }
  
  The default formatter acts like C<sprintf>, except that undef arguments are
  changed to C<< <undef> >> and any references or objects are dumped via
  L<Data::Dumper> (but without newlines).
  
  Numeric levels range from 0 (emergency) to 8 (trace).  Constant functions
  for these levels are available from L<Log::Any::Adapter::Util>.
  
  =head2 prefix
  
  If defined, this string will be prepended to all messages.  It will not
  include a trailing space, so add that yourself if you want.  This is less
  flexible/powerful than L</filter>, but avoids an extra function call.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Jonathan Swartz <swartz@pobox.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
  
  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
LOG_ANY_PROXY

$fatpacked{"Log/Any/Proxy/Test.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_PROXY_TEST';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Proxy::Test;
  
  our $VERSION = '1.032';
  
  use base qw/Log::Any::Proxy/;
  
  my @test_methods = qw(
    msgs
    clear
    contains_ok
    category_contains_ok
    does_not_contain_ok
    category_does_not_contain_ok
    empty_ok
    contains_only_ok
  );
  
  foreach my $name (@test_methods) {
      no strict 'refs';
      *{$name} = sub {
          my $self = shift;
          $self->{adapter}->$name(@_);
      };
  }
  
  1;
LOG_ANY_PROXY_TEST

$fatpacked{"Log/Any/Test.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_ANY_TEST';
  use 5.008001;
  use strict;
  use warnings;
  
  package Log::Any::Test;
  
  # ABSTRACT: Test what you're logging with Log::Any
  our $VERSION = '1.032';
  
  no warnings 'once';
  $Log::Any::OverrideDefaultAdapterClass = 'Log::Any::Adapter::Test';
  $Log::Any::OverrideDefaultProxyClass   = 'Log::Any::Proxy::Test';
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Any::Test - Test what you're logging with Log::Any
  
  =head1 VERSION
  
  version 1.032
  
  =head1 SYNOPSIS
  
      use Test::More;
      use Log::Any::Test;    # should appear before 'use Log::Any'!
      use Log::Any qw($log);
  
      # ...
      # call something that logs using Log::Any
      # ...
  
      # now test to make sure you logged the right things
  
      $log->contains_ok(qr/good log message/, "good message was logged");
      $log->does_not_contain_ok(qr/unexpected log message/, "unexpected message was not logged");
      $log->empty_ok("no more logs");
  
      # or
  
      my $msgs = $log->msgs;
      cmp_deeply($msgs, [{message => 'msg1', level => 'debug'}, ...]);
  
  =head1 DESCRIPTION
  
  C<Log::Any::Test> is a simple module that allows you to test what has been
  logged with Log::Any. Most of its API and implementation have been taken from
  L<Log::Any::Dispatch|Log::Any::Dispatch>.
  
  Using C<Log::Any::Test> sends all subsequent Log::Any log messages to a single
  global in-memory buffer.  It should be used before L<Log::Any|Log::Any>.
  
  =head1 METHODS
  
  The test_name is optional in the *_ok methods; a reasonable default will be
  provided.
  
  =over
  
  =item msgs ()
  
  Returns the current contents of the global log buffer as an array reference,
  where each element is a hash containing a I<category>, I<level>, and I<message>
  key.  e.g.
  
    {
      category => 'Foo',
      level => 'error',
      message => 'this is an error'
    },
    {
      category => 'Bar::Baz',
      level => 'debug',
      message => 'this is a debug'
    }
  
  =item contains_ok ($regex[, $test_name])
  
  Tests that a message in the log buffer matches I<$regex>. On success, the
  message is I<removed> from the log buffer (but any other matches are left
  untouched).
  
  =item does_not_contain_ok ($regex[, $test_name])
  
  Tests that no message in the log buffer matches I<$regex>.
  
  =item category_contains_ok ($category, $regex[, $test_name])
  
  Tests that a message in the log buffer from a specific category matches
  I<$regex>. On success, the message is I<removed> from the log buffer (but any
  other matches are left untouched).
  
  =item category_does_not_contain_ok ($category, $regex[, $test_name])
  
  Tests that no message from a specific category in the log buffer matches
  I<$regex>.
  
  =item empty_ok ([$test_name])
  
  Tests that there is no log buffer left. On failure, the log buffer is cleared
  to limit further cascading failures.
  
  =item contains_only_ok ($regex[, $test_name])
  
  Tests that there is a single message in the log buffer and it matches
  I<$regex>. On success, the message is removed.
  
  =item clear ()
  
  Clears the log buffer.
  
  =back
  
  =head1 SEE ALSO
  
  L<Log::Any|Log::Any>, L<Test::Log::Dispatch|Test::Log::Dispatch>
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Jonathan Swartz <swartz@pobox.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
  
  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
LOG_ANY_TEST

$fatpacked{"MIME/Charset.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MIME_CHARSET';
  #-*- perl -*-
  
  package MIME::Charset;
  use 5.005;
  
  =head1 NAME
  
  MIME::Charset - Charset Information for MIME
  
  =head1 SYNOPSIS
  
      use MIME::Charset:
  
      $charset = MIME::Charset->new("euc-jp");
  
  Getting charset information:
  
      $benc = $charset->body_encoding; # e.g. "Q"
      $cset = $charset->as_string; # e.g. "US-ASCII"
      $henc = $charset->header_encoding; # e.g. "S"
      $cset = $charset->output_charset; # e.g. "ISO-2022-JP"
  
  Translating text data:
  
      ($text, $charset, $encoding) =
          $charset->header_encode(
             "\xc9\xc2\xc5\xaa\xc0\xde\xc3\xef\xc5\xaa".
             "\xc7\xd1\xca\xaa\xbd\xd0\xce\xcf\xb4\xef",
             Charset => 'euc-jp');
      # ...returns e.g. (<converted>, "ISO-2022-JP", "B").
  
      ($text, $charset, $encoding) =
          $charset->body_encode(
              "Collectioneur path\xe9tiquement ".
              "\xe9clectique de d\xe9chets",
              Charset => 'latin1');
      # ...returns e.g. (<original>, "ISO-8859-1", "QUOTED-PRINTABLE").
  
      $len = $charset->encoded_header_len(
          "Perl\xe8\xa8\x80\xe8\xaa\x9e",
          Charset => 'utf-8',
          Encoding => "b");
      # ...returns e.g. 28.
  
  Manipulating module defaults:
  
      MIME::Charset::alias("csEUCKR", "euc-kr");
      MIME::Charset::default("iso-8859-1");
      MIME::Charset::fallback("us-ascii");
  
  Non-OO functions (may be deprecated in near future):
  
      use MIME::Charset qw(:info);
  
      $benc = body_encoding("iso-8859-2"); # "Q"
      $cset = canonical_charset("ANSI X3.4-1968"); # "US-ASCII"
      $henc = header_encoding("utf-8"); # "S"
      $cset = output_charset("shift_jis"); # "ISO-2022-JP"
  
      use MIME::Charset qw(:trans);
  
      ($text, $charset, $encoding) =
          header_encode(
             "\xc9\xc2\xc5\xaa\xc0\xde\xc3\xef\xc5\xaa".
             "\xc7\xd1\xca\xaa\xbd\xd0\xce\xcf\xb4\xef",
             "euc-jp");
      # ...returns (<converted>, "ISO-2022-JP", "B");
  
      ($text, $charset, $encoding) =
          body_encode(
              "Collectioneur path\xe9tiquement ".
              "\xe9clectique de d\xe9chets",
              "latin1");
      # ...returns (<original>, "ISO-8859-1", "QUOTED-PRINTABLE");
  
      $len = encoded_header_len(
          "Perl\xe8\xa8\x80\xe8\xaa\x9e", "b", "utf-8"); # 28
  
  =head1 DESCRIPTION
  
  MIME::Charset provides information about character sets used for
  MIME messages on Internet.
  
  =head2 Definitions
  
  The B<charset> is ``character set'' used in MIME to refer to a
  method of converting a sequence of octets into a sequence of characters.
  It includes both concepts of ``coded character set'' (CCS) and
  ``character encoding scheme'' (CES) of ISO/IEC.
  
  The B<encoding> is that used in MIME to refer to a method of representing
  a body part or a header body as sequence(s) of printable US-ASCII
  characters.
  
  =cut
  
  use strict;
  use vars qw(@ISA $VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS $Config);
  use Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(body_encoding canonical_charset header_encoding output_charset
  	     body_encode encoded_header_len header_encode);
  @EXPORT_OK = qw(alias default fallback recommended);
  %EXPORT_TAGS = (
  		"info" => [qw(body_encoding header_encoding
  			      canonical_charset output_charset)],
  		"trans" =>[ qw(body_encode encoded_header_len
  			       header_encode)],
  		);
  use Carp qw(croak);
  
  use constant USE_ENCODE => ($] >= 5.007003)? 'Encode': '';
  
  my @ENCODE_SUBS = qw(FB_CROAK FB_PERLQQ FB_HTMLCREF FB_XMLCREF
  		     is_utf8 resolve_alias);
  if (USE_ENCODE) {
      eval "use ".USE_ENCODE." \@ENCODE_SUBS;";
      if ($@) { # Perl 5.7.3 + Encode 0.40
  	eval "use ".USE_ENCODE." qw(is_utf8);";
  	require MIME::Charset::_Compat;
  	for my $sub (@ENCODE_SUBS) {
  	    no strict "refs";
  	    *{$sub} = \&{"MIME::Charset::_Compat::$sub"}
  		unless $sub eq 'is_utf8';
  	}
      }
  } else {
      require MIME::Charset::_Compat;
      for my $sub (@ENCODE_SUBS) {
  	no strict "refs";
  	*{$sub} = \&{"MIME::Charset::_Compat::$sub"};
      }
  }
  
  $VERSION = '1.011.3';
  
  ######## Private Attributes ########
  
  my $DEFAULT_CHARSET = 'US-ASCII';
  my $FALLBACK_CHARSET = 'UTF-8';
  
  # This table was initially borrowed from Python email package.
  
  my %CHARSETS = (# input		    header enc body enc output conv
  		'ISO-8859-1' =>		['Q',	'Q',	undef],
  		'ISO-8859-2' =>		['Q',	'Q',	undef],
  		'ISO-8859-3' =>		['Q',	'Q',	undef],
  		'ISO-8859-4' =>		['Q',	'Q',	undef],
  		# ISO-8859-5 is Cyrillic, and not especially used
  		# ISO-8859-6 is Arabic, also not particularly used
  		# ISO-8859-7 is Greek, 'Q' will not make it readable
  		# ISO-8859-8 is Hebrew, 'Q' will not make it readable
  		'ISO-8859-9' =>		['Q',	'Q',	undef],
  		'ISO-8859-10' =>	['Q',	'Q',	undef],
  		# ISO-8859-11 is Thai, 'Q' will not make it readable
  		'ISO-8859-13' =>	['Q',	'Q',	undef],
  		'ISO-8859-14' =>	['Q',	'Q',	undef],
  		'ISO-8859-15' =>	['Q',	'Q',	undef],
  		'ISO-8859-16' =>	['Q',	'Q',	undef],
  		'WINDOWS-1252' =>	['Q',	'Q',	undef],
  		'VISCII' =>		['Q',	'Q',	undef],
  		'US-ASCII' =>		[undef,	undef,	undef],
  		'BIG5' =>		['B',	'B',	undef],
  		'GB2312' =>		['B',	'B',	undef],
  		'HZ-GB-2312' =>		['B',	undef,	undef],
  		'EUC-JP' =>		['B',	undef,	'ISO-2022-JP'],
  		'SHIFT_JIS' =>		['B',	undef,	'ISO-2022-JP'],
  		'ISO-2022-JP' =>	['B',	undef,	undef],
  		'ISO-2022-JP-1' =>	['B',	undef,	undef],
  		'ISO-2022-JP-2' =>	['B',	undef,	undef],
  		'EUC-JISX0213' =>	['B',	undef,	'ISO-2022-JP-3'],
  		'SHIFT_JISX0213' =>	['B',	undef,	'ISO-2022-JP-3'],
  		'ISO-2022-JP-3' =>	['B',	undef,	undef],
  		'EUC-JIS-2004' =>	['B',	undef,	'ISO-2022-JP-2004'],
  		'SHIFT_JIS-2004' =>	['B',	undef,	'ISO-2022-JP-2004'],
  		'ISO-2022-JP-2004' =>	['B',	undef,	undef],
  		'KOI8-R' =>		['B',	'B',	undef],
  		'TIS-620' =>		['B',	'B',	undef], # cf. Mew
  		'UTF-16' =>		['B',	'B',	undef],
  		'UTF-16BE' => 		['B',	'B',	undef],
  		'UTF-16LE' =>		['B',	'B',	undef],
  		'UTF-32' =>		['B',	'B',	undef],
  		'UTF-32BE' => 		['B',	'B',	undef],
  		'UTF-32LE' =>		['B',	'B',	undef],
  		'UTF-7' =>		['Q',	undef,	undef],
  		'UTF-8' =>		['S',	'S',	undef],
  		'GSM03.38' =>		[undef,	undef,	undef], # not for MIME
  		# We're making this one up to represent raw unencoded 8bit
  		'8BIT' =>		[undef,	'B',	'ISO-8859-1'],
  		);
  
  # Fix some unexpected or unpreferred names returned by
  # Encode::resolve_alias() or used by somebodies else.
  my %CHARSET_ALIASES = (# unpreferred		preferred
  		       "ASCII" =>		"US-ASCII",
  		       "BIG5-ETEN" =>		"BIG5",
  		       "CP1250" =>		"WINDOWS-1250",
  		       "CP1251" =>		"WINDOWS-1251",
  		       "CP1252" =>		"WINDOWS-1252",
  		       "CP1253" =>		"WINDOWS-1253",
  		       "CP1254" =>		"WINDOWS-1254",
  		       "CP1255" =>		"WINDOWS-1255",
  		       "CP1256" =>		"WINDOWS-1256",
  		       "CP1257" =>		"WINDOWS-1257",
  		       "CP1258" =>		"WINDOWS-1258",
  		       "CP874" =>		"WINDOWS-874",
  		       "CP936" =>		"GBK",
  		       "CP949" =>		"KS_C_5601-1987",
  		       "EUC-CN" =>		"GB2312",
  		       "HZ" =>			"HZ-GB-2312", # RFC 1842
  		       "KS_C_5601" =>		"KS_C_5601-1987",
  		       "SHIFTJIS" =>		"SHIFT_JIS",
  		       "SHIFTJISX0213" =>	"SHIFT_JISX0213",
  		       "TIS620" =>		"TIS-620", # IANA MIBenum 2259
  		       "UNICODE-1-1-UTF-7" =>	"UTF-7", # RFC 1642 (obs.)
  		       "UTF8" =>		"UTF-8",
  		       "UTF-8-STRICT" =>	"UTF-8", # Perl internal use
  		       "GSM0338" =>		"GSM03.38", # not for MIME
  		       );
  
  # Some vendors encode characters beyond standardized mappings using extended
  # encoders.  Some other standard encoders need additional encode modules.
  my %ENCODERS = (
  		'EXTENDED' => {
  		    'ISO-8859-1' => [['cp1252'], ],     # Encode::Byte
  		    'ISO-8859-2' => [['cp1250'], ],     # Encode::Byte
  		    'ISO-8859-5' => [['cp1251'], ],     # Encode::Byte
  		    'ISO-8859-6' => [
  				     ['cp1256'],        # Encode::Byte
  				     # ['cp1006'],      # ditto, for Farsi
  				    ],
  		    'ISO-8859-6-I'=>[['cp1256'], ],     # ditto
  		    'ISO-8859-7' => [['cp1253'], ],     # Encode::Byte
  		    'ISO-8859-8' => [['cp1255'], ],     # Encode::Byte
  		    'ISO-8859-8-I'=>[['cp1255'], ],     # ditto
  		    'ISO-8859-9' => [['cp1254'], ],     # Encode::Byte
  		    'ISO-8859-13'=> [['cp1257'], ],     # Encode::Byte
  		    'GB2312'     => [
  				     ['gb18030',	'Encode::HanExtra'],
  				     ['cp936'],		# Encode::CN
  				    ],
  		    'EUC-JP'     => [
  				     ['eucJP-ascii',	'Encode::EUCJPASCII'],
  				     # ['cp51932',	'Encode::EUCJPMS'],
  				    ],
  		    'ISO-2022-JP'=> [
  				     ['x-iso2022jp-ascii',
  				      			'Encode::EUCJPASCII'],
  				     # ['iso-2022-jp-ms','Encode::ISO2022JPMS'],
  				     # ['cp50220',      'Encode::EUCJPMS'],
  				     # ['cp50221',      'Encode::EUCJPMS'],
  				     ['iso-2022-jp-1'], # Encode::JP (note*)
  				    ],
  		    'SHIFT_JIS'  => [
  				     ['cp932'],		# Encode::JP
  				    ],
  		    'EUC-JISX0213'  => [['euc-jis-2004', 'Encode::JISX0213'], ],
  		    'ISO-2022-JP-3' => [['iso-2022-jp-2004', 'Encode::JISX0213'], ],
  		    'SHIFT_JISX0213'=> [['shift_jis-2004', 'Encode::ShiftJIS2004'], ],
  		    'EUC-KR'     => [['cp949'], ],      # Encode::KR
  		    'BIG5'       => [
  				     # ['big5plus',     'Encode::HanExtra'],
  				     # ['big5-2003',    'Encode::HanExtra'], 
  				     ['cp950'],         # Encode::TW
  				     # ['big5-1984',    'Encode::HanExtra'], 
  				    ],
  		    'TIS-620'    => [['cp874'], ],      # Encode::Byte
  		    'UTF-8'      => [['utf8'], ],       # Special name on Perl
  		},
  		'STANDARD' => {
  		    'ISO-8859-6-E'  => [['iso-8859-6'],],# Encode::Byte
  		    'ISO-8859-6-I'  => [['iso-8859-6'],],# ditto
  		    'ISO-8859-8-E'  => [['iso-8859-8'],],# Encode::Byte
  		    'ISO-8859-8-I'  => [['iso-8859-8'],],# ditto
  		    'GB18030'       => [['gb18030',     'Encode::HanExtra'], ],
  		    'ISO-2022-JP-2' => [['iso-2022-jp-2','Encode::ISO2022JP2'], ],
  		    'EUC-JISX0213'  => [['euc-jisx0213', 'Encode::JISX0213'], ],
  		    'ISO-2022-JP-3' => [['iso-2022-jp-3', 'Encode::JISX0213'], ],
  		    'EUC-JIS-2004'  => [['euc-jis-2004', 'Encode::JISX0213'], ],
  		    'ISO-2022-JP-2004' => [['iso-2022-jp-2004', 'Encode::JISX0213'], ],
  		    'SHIFT_JIS-2004'=> [['shift_jis-2004', 'Encode::ShiftJIS2004'], ],
  		    'EUC-TW'        => [['euc-tw',      'Encode::HanExtra'], ],
  		    'HZ-GB-2312'    => [['hz'], ],	# Encode::CN
  		    'TIS-620'       => [['tis620'], ],  # (note*)
  		    'UTF-16'        => [['x-utf16auto', 'MIME::Charset::UTF'],],
  		    'UTF-32'        => [['x-utf32auto', 'MIME::Charset::UTF'],],
  		    'GSM03.38'      => [['gsm0338'], ],	# Encode::GSM0338
  
  		    # (note*) ISO-8859-11 was not registered by IANA.
  		    # L<Encode> treats it as canonical name of ``tis-?620''.
  		},
  );
  
  # ISO-2022-* escape sequences etc. to detect charset from unencoded data.
  my @ESCAPE_SEQS = ( 
  		# ISO-2022-* sequences
  		   # escape seq, possible charset
  		   # Following sequences are commonly used.
  		   ["\033\$\@",	"ISO-2022-JP"],	# RFC 1468
  		   ["\033\$B",	"ISO-2022-JP"],	# ditto
  		   ["\033(J",	"ISO-2022-JP"],	# ditto
  		   ["\033(I",	"ISO-2022-JP"],	# ditto (nonstandard)
  		   ["\033\$(D",	"ISO-2022-JP"],	# RFC 2237 (note*)
  		   # Following sequences are less commonly used.
  		   ["\033.A",   "ISO-2022-JP-2"], # RFC 1554
  		   ["\033.F",   "ISO-2022-JP-2"], # ditto
  		   ["\033\$(C", "ISO-2022-JP-2"], # ditto
  		   ["\033\$(O",	"ISO-2022-JP-3"], # JIS X 0213:2000
  		   ["\033\$(P",	"ISO-2022-JP-2004"], # JIS X 0213:2000/2004
  		   ["\033\$(Q",	"ISO-2022-JP-2004"], # JIS X 0213:2004
  		   ["\033\$)C",	"ISO-2022-KR"],	# RFC 1557
  		   ["\033\$)A",	"ISO-2022-CN"], # RFC 1922
  		   ["\033\$A",	"ISO-2022-CN"], # ditto (nonstandard)
  		   ["\033\$)G",	"ISO-2022-CN"], # ditto
  		   ["\033\$*H",	"ISO-2022-CN"], # ditto
  		   # Other sequences will be used with appropriate charset
  		   # parameters, or hardly used.
  
  		   # note*: This RFC defines ISO-2022-JP-1, superset of 
  		   # ISO-2022-JP.  But that charset name is rarely used.
  		   # OTOH many of encoders for ISO-2022-JP recognize this
  		   # sequence so that comatibility with EUC-JP will be
  		   # guaranteed.
  
  		# Singlebyte 7-bit sequences
  		   # escape seq, possible charset
  		   ["\033e",	"GSM03.38"],	# ESTI GSM 03.38 (note*)
  		   ["\033\012",	"GSM03.38"],	# ditto
  		   ["\033<",	"GSM03.38"],	# ditto
  		   ["\033/",	"GSM03.38"],	# ditto
  		   ["\033>",	"GSM03.38"],	# ditto
  		   ["\033\024",	"GSM03.38"],	# ditto
  		   ["\033(",	"GSM03.38"],	# ditto
  		   ["\033\@",	"GSM03.38"],	# ditto
  		   ["\033)",	"GSM03.38"],	# ditto
  		   ["\033=",	"GSM03.38"],	# ditto
  
  		   # note*: This is not used for MIME message.
  		  );
  
  ######## Public Configuration Attributes ########
  
  $Config = {
      Detect7bit =>      'YES',
      Mapping =>         'EXTENDED',
      Replacement =>     'DEFAULT',
  };
  eval { require MIME::Charset::Defaults; };
  
  ######## Private Constants ########
  
  my $NON7BITRE = qr{
      [^\x01-\x7e]
  }x;
  
  my $NONASCIIRE = qr{
      [^\x09\x0a\x0d\x20\x21-\x7e]
  }x;
  
  my $ISO2022RE = qr{
      ISO-2022-.+
  }ix;
  
  my $ASCIITRANSRE = qr{
      HZ-GB-2312 | UTF-7
  }ix;
  
  
  ######## Public Functions ########
  
  =head2 Constructor
  
  =over
  
  =item $charset = MIME::Charset->new([CHARSET [, OPTS]])
  
  Create charset object.
  
  OPTS may accept following key-value pair.
  B<NOTE>:
  When Unicode/multibyte support is disabled (see L<"USE_ENCODE">),
  conversion will not be performed.  So this option do not have any effects.
  
  =over 4
  
  =item Mapping => MAPTYPE
  
  Whether to extend mappings actually used for charset names or not.
  C<"EXTENDED"> uses extended mappings.
  C<"STANDARD"> uses standardized strict mappings.
  Default is C<"EXTENDED">.
  
  =back
  
  =cut
  
  sub new {
      my $class = shift;
      my $charset = shift;
      return bless {}, $class unless $charset;
      return bless {}, $class if 75 < length $charset; # w/a for CPAN RT #65796.
      my %params = @_;
      my $mapping = uc($params{'Mapping'} || $Config->{Mapping});
  
      if ($charset =~ /\bhz.?gb.?2312$/i) {
  	# workaround: "HZ-GB-2312" mistakenly treated as "EUC-CN" by Encode
  	# (2.12).
  	$charset = "HZ-GB-2312";
      } elsif ($charset =~ /\btis-?620$/i) {
  	# workaround: "TIS620" treated as ISO-8859-11 by Encode.
  	# And "TIS-620" not known by some versions of Encode (cf.
  	# CPAN RT #20781).
  	$charset = "TIS-620";
      } else {
  	$charset = resolve_alias($charset) || $charset
      }
      $charset = $CHARSET_ALIASES{uc($charset)} || uc($charset);
      my ($henc, $benc, $outcset);
      my $spec = $CHARSETS{$charset};
      if ($spec) {
  	($henc, $benc, $outcset) =
  	    ($$spec[0], $$spec[1], USE_ENCODE? $$spec[2]: undef);
      } else {
  	($henc, $benc, $outcset) = ('S', 'B', undef);
      }
      my ($decoder, $encoder);
      if (USE_ENCODE) {
  	$decoder = _find_encoder($charset, $mapping);
  	$encoder = _find_encoder($outcset, $mapping);
      } else {
  	$decoder = $encoder = undef;
      }
  
      bless {
  	InputCharset => $charset,
  	Decoder => $decoder,
  	HeaderEncoding => $henc,
  	BodyEncoding => $benc,
  	OutputCharset => ($outcset || $charset),
  	Encoder => ($encoder || $decoder),
      }, $class;
  }
  
  my %encoder_cache = ();
  
  sub _find_encoder($$) {
      my $charset = uc(shift || "");
      return undef unless $charset;
      my $mapping = uc(shift);
      my ($spec, $name, $module, $encoder);
  
      local($@);
      $encoder = $encoder_cache{$charset, $mapping};
      return $encoder if ref $encoder;
  
      foreach my $m (('EXTENDED', 'STANDARD')) {
  	next if $m eq 'EXTENDED' and $mapping ne 'EXTENDED';
  	$spec = $ENCODERS{$m}->{$charset};
  	next unless $spec;
  	foreach my $s (@{$spec}) {
  	    ($name, $module) = @{$s};
  	    if ($module) {
  		next unless eval "require $module;";
  	    }
  	    $encoder = Encode::find_encoding($name);
  	    last if ref $encoder;
  	}
  	last if ref $encoder;
      }
      $encoder ||= Encode::find_encoding($charset);
      $encoder_cache{$charset, $mapping} = $encoder if $encoder;
      return $encoder;
  }
  
  =back
  
  =head2 Getting Information of Charsets
  
  =over
  
  =item $charset->body_encoding
  
  =item body_encoding CHARSET
  
  Get recommended transfer-encoding of CHARSET for message body.
  
  Returned value will be one of C<"B"> (BASE64), C<"Q"> (QUOTED-PRINTABLE),
  C<"S"> (shorter one of either) or
  C<undef> (might not be transfer-encoded; either 7BIT or 8BIT).  This may
  not be same as encoding for message header.
  
  =cut
  
  sub body_encoding($) {
      my $self = shift;
      return undef unless $self;
      $self = __PACKAGE__->new($self) unless ref $self;
      $self->{BodyEncoding};
  }
  
  =item $charset->as_string
  
  =item canonical_charset CHARSET
  
  Get canonical name for charset.
  
  =cut
  
  sub canonical_charset($) {
      my $self = shift;
      return undef unless $self;
      $self = __PACKAGE__->new($self) unless ref $self;
      $self->{InputCharset};
  }
  
  sub as_string($) {
      my $self = shift;
      $self->{InputCharset};
  }
  
  =item $charset->decoder
  
  Get L<"Encode::Encoding"> object to decode strings to Unicode by charset.
  If charset is not specified or not known by this module,
  undef will be returned.
  
  =cut
  
  sub decoder($) {
      my $self = shift;
      $self->{Decoder};
  }
  
  =item $charset->dup
  
  Get a copy of charset object.
  
  =cut
  
  sub dup($) {
      my $self = shift;
      my $obj = __PACKAGE__->new(undef);
      %{$obj} = %{$self};
      $obj;
  }
  
  =item $charset->encoder([CHARSET])
  
  Get L<"Encode::Encoding"> object to encode Unicode string using compatible
  charset recommended to be used for messages on Internet.
  
  If optional CHARSET is specified, replace encoder (and output charset
  name) of $charset object with those of CHARSET, therefore,
  $charset object will be a converter between original charset and
  new CHARSET.
  
  =cut
  
  sub encoder($$;) {
      my $self = shift;
      my $charset = shift;
      if ($charset) {
  	$charset = __PACKAGE__->new($charset) unless ref $charset;
  	$self->{OutputCharset} = $charset->{InputCharset};
  	$self->{Encoder} = $charset->{Decoder};
  	$self->{BodyEncoding} = $charset->{BodyEncoding};
  	$self->{HeaderEncoding} = $charset->{HeaderEncoding};
      }
      $self->{Encoder};
  }
  
  =item $charset->header_encoding
  
  =item header_encoding CHARSET
  
  Get recommended encoding scheme of CHARSET for message header.
  
  Returned value will be one of C<"B">, C<"Q">, C<"S"> (shorter one of either)
  or C<undef> (might not be encoded).  This may not be same as encoding
  for message body.
  
  =cut
  
  sub header_encoding($) {
      my $self = shift;
      return undef unless $self;
      $self = __PACKAGE__->new($self) unless ref $self;
      $self->{HeaderEncoding};
  }
  
  =item $charset->output_charset
  
  =item output_charset CHARSET
  
  Get a charset which is compatible with given CHARSET and is recommended
  to be used for MIME messages on Internet (if it is known by this module).
  
  When Unicode/multibyte support is disabled (see L<"USE_ENCODE">),
  this function will simply
  return the result of L<"canonical_charset">.
  
  =cut
  
  sub output_charset($) {
      my $self = shift;
      return undef unless $self;
      $self = __PACKAGE__->new($self) unless ref $self;
      $self->{OutputCharset};
  }
  
  =back
  
  =head2 Translating Text Data
  
  =over
  
  =item $charset->body_encode(STRING [, OPTS])
  
  =item body_encode STRING, CHARSET [, OPTS]
  
  Get converted (if needed) data of STRING and recommended transfer-encoding
  of that data for message body.  CHARSET is the charset by which STRING
  is encoded.
  
  OPTS may accept following key-value pairs.
  B<NOTE>:
  When Unicode/multibyte support is disabled (see L<"USE_ENCODE">),
  conversion will not be performed.  So these options do not have any effects.
  
  =over 4
  
  =item Detect7bit => YESNO
  
  Try auto-detecting 7-bit charset when CHARSET is not given.
  Default is C<"YES">.
  
  =item Replacement => REPLACEMENT
  
  Specifies error handling scheme.  See L<"Error Handling">.
  
  =back
  
  3-item list of (I<converted string>, I<charset for output>,
  I<transfer-encoding>) will be returned.
  I<Transfer-encoding> will be either C<"BASE64">, C<"QUOTED-PRINTABLE">,
  C<"7BIT"> or C<"8BIT">.  If I<charset for output> could not be determined
  and I<converted string> contains non-ASCII byte(s), I<charset for output> will
  be C<undef> and I<transfer-encoding> will be C<"BASE64">.
  I<Charset for output> will be C<"US-ASCII"> if and only if string does not
  contain any non-ASCII bytes.
  
  =cut
  
  sub body_encode {
      my $self = shift;
      my $text;
      if (ref $self) {
  	$text = shift;
      } else {
  	$text = $self;
  	$self = __PACKAGE__->new(shift);
      }
      my ($encoded, $charset) = $self->_text_encode($text, @_);
      return ($encoded, undef, 'BASE64')
  	unless $charset and $charset->{InputCharset};
      my $cset = $charset->{OutputCharset};
  
      # Determine transfer-encoding.
      my $enc = $charset->{BodyEncoding};
  
      if (!$enc and $encoded !~ /\x00/) {	# Eliminate hostile NUL character.
          if ($encoded =~ $NON7BITRE) {	# String contains 8bit char(s).
              $enc = '8BIT';
  	} elsif ($cset =~ /^($ISO2022RE|$ASCIITRANSRE)$/) {	# 7BIT.
              $enc = '7BIT';
          } else {			# Pure ASCII.
              $enc = '7BIT';
              $cset = 'US-ASCII';
          }
      } elsif ($enc eq 'S') {
  	$enc = _resolve_S($encoded, 1);
      } elsif ($enc eq 'B') {
          $enc = 'BASE64';
      } elsif ($enc eq 'Q') {
          $enc = 'QUOTED-PRINTABLE';
      } else {
          $enc = 'BASE64';
      }
      return ($encoded, $cset, $enc);
  }
  
  =item $charset->decode(STRING [,CHECK])
  
  Decode STRING to Unicode.
  
  B<Note>:
  When Unicode/multibyte support is disabled (see L<"USE_ENCODE">),
  this function will die.
  
  =cut
  
  sub decode($$$;) {
      my $self = shift;
      my $s = shift;
      my $check = shift || 0;
      $self->{Decoder}->decode($s, $check);
  }
  
  =item detect_7bit_charset STRING
  
  Guess 7-bit charset that may encode a string STRING.
  If STRING contains any 8-bit bytes, C<undef> will be returned.
  Otherwise, Default Charset will be returned for unknown charset.
  
  =cut
  
  sub detect_7bit_charset($) {
      return $DEFAULT_CHARSET unless &USE_ENCODE;
      my $s = shift;
      return $DEFAULT_CHARSET unless $s;
  
      # Non-7bit string
      return undef if $s =~ $NON7BITRE;
  
      # Try to detect 7-bit escape sequences.
      foreach (@ESCAPE_SEQS) {
  	my ($seq, $cset) = @$_;
  	if (index($s, $seq) >= 0) {
              my $decoder = __PACKAGE__->new($cset);
              next unless $decoder->{Decoder};
              eval {
  		my $dummy = $s;
  		$decoder->decode($dummy, FB_CROAK());
  	    };
  	    if ($@) {
  		next;
  	    }
  	    return $decoder->{InputCharset};
  	}
      }
  
      # How about HZ, VIQR, UTF-7, ...?
  
      return $DEFAULT_CHARSET;
  }
  
  sub _detect_7bit_charset {
      detect_7bit_charset(@_);
  }
  
  =item $charset->encode(STRING [, CHECK])
  
  Encode STRING (Unicode or non-Unicode) using compatible charset recommended
  to be used for messages on Internet (if this module knows it).
  Note that string will be decoded to Unicode then encoded even if compatible charset
  was equal to original charset.
  
  B<Note>:
  When Unicode/multibyte support is disabled (see L<"USE_ENCODE">),
  this function will die.
  
  =cut
  
  sub encode($$$;) {
      my $self = shift;
      my $s = shift;
      my $check = shift || 0;
  
      unless (is_utf8($s) or $s =~ /[^\x00-\xFF]/) {
  	$s = $self->{Decoder}->decode($s, ($check & 0x1)? FB_CROAK(): 0);
      }
      my $enc = $self->{Encoder}->encode($s, $check);
      Encode::_utf8_off($enc) if is_utf8($enc); # workaround for RT #35120
      $enc;
  }
  
  =item $charset->encoded_header_len(STRING [, ENCODING])
  
  =item encoded_header_len STRING, ENCODING, CHARSET
  
  Get length of encoded STRING for message header
  (without folding).
  
  ENCODING may be one of C<"B">, C<"Q"> or C<"S"> (shorter
  one of either C<"B"> or C<"Q">).
  
  =cut
  
  sub encoded_header_len($$$;) {
      my $self = shift;
      my ($encoding, $s);
      if (ref $self) {
  	$s = shift;
  	$encoding = uc(shift || $self->{HeaderEncoding});
      } else {
  	$s = $self;
  	$encoding = uc(shift);
  	$self  = shift;
  	$self = __PACKAGE__->new($self) unless ref $self;
      }
  
      #FIXME:$encoding === undef
  
      my $enclen;
      if ($encoding eq 'Q') {
          $enclen = _enclen_Q($s);
      } elsif ($encoding eq 'S' and _resolve_S($s) eq 'Q') {
  	$enclen = _enclen_Q($s);
      } else { # "B"
          $enclen = _enclen_B($s);
      }
  
      length($self->{OutputCharset})+$enclen+7;
  }
  
  sub _enclen_B($) {
      int((length(shift) + 2) / 3) * 4;
  }
  
  sub _enclen_Q($;$) {
      my $s = shift;
      my $in_body = shift;
      my @o;
      if ($in_body) {
  	@o = ($s =~ m{([^-\t\r\n !*+/0-9A-Za-z])}go);
      } else {
  	@o = ($s =~ m{([^- !*+/0-9A-Za-z])}gos);
      }
      length($s) + scalar(@o) * 2;
  }
  
  sub _resolve_S($;$) {
      my $s = shift;
      my $in_body = shift;
      my $e;
      if ($in_body) {
  	$e = scalar(() = $s =~ m{[^-\t\r\n !*+/0-9A-Za-z]}g);
  	return (length($s) + 8 < $e * 6) ? 'BASE64' : 'QUOTED-PRINTABLE';
      } else {
  	$e = scalar(() = $s =~ m{[^- !*+/0-9A-Za-z]}g);
  	return (length($s) + 8 < $e * 6) ? 'B' : 'Q';
      }
  }
  
  =item $charset->header_encode(STRING [, OPTS])
  
  =item header_encode STRING, CHARSET [, OPTS]
  
  Get converted (if needed) data of STRING and recommended encoding scheme of
  that data for message headers.  CHARSET is the charset by which STRING
  is encoded.
  
  OPTS may accept following key-value pairs.
  B<NOTE>:
  When Unicode/multibyte support is disabled (see L<"USE_ENCODE">),
  conversion will not be performed.  So these options do not have any effects.
  
  =over 4
  
  =item Detect7bit => YESNO
  
  Try auto-detecting 7-bit charset when CHARSET is not given.
  Default is C<"YES">.
  
  =item Replacement => REPLACEMENT
  
  Specifies error handling scheme.  See L<"Error Handling">.
  
  =back
  
  3-item list of (I<converted string>, I<charset for output>,
  I<encoding scheme>) will be returned.  I<Encoding scheme> will be
  either C<"B">, C<"Q"> or C<undef> (might not be encoded).
  If I<charset for output> could not be determined and I<converted string>
  contains non-ASCII byte(s), I<charset for output> will be C<"8BIT">
  (this is I<not> charset name but a special value to represent unencodable
  data) and I<encoding scheme> will be C<undef> (should not be encoded).
  I<Charset for output> will be C<"US-ASCII"> if and only if string does not
  contain any non-ASCII bytes.
  
  =cut
  
  sub header_encode {
      my $self = shift;
      my $text;
      if (ref $self) {
  	$text = shift;
      } else {
  	$text = $self;
  	$self = __PACKAGE__->new(shift);
      }
      my ($encoded, $charset) = $self->_text_encode($text, @_);
      return ($encoded, '8BIT', undef)
  	unless $charset and $charset->{InputCharset};
      my $cset = $charset->{OutputCharset};
  
      # Determine encoding scheme.
      my $enc = $charset->{HeaderEncoding};
  
      if (!$enc and $encoded !~ $NON7BITRE) {
  	unless ($cset =~ /^($ISO2022RE|$ASCIITRANSRE)$/) {	# 7BIT.
              $cset = 'US-ASCII';
          }
      } elsif ($enc eq 'S') {
  	$enc = _resolve_S($encoded);
      } elsif ($enc !~ /^[BQ]$/) {
          $enc = 'B';
      }
      return ($encoded, $cset, $enc);
  }
  
  sub _text_encode {
      my $charset = shift;
      my $s = shift;
      my %params = @_;
      my $replacement = uc($params{'Replacement'} || $Config->{Replacement});
      my $detect7bit = uc($params{'Detect7bit'} || $Config->{Detect7bit});
      my $encoding = $params{'Encoding'} ||
  	(exists $params{'Encoding'}? undef: 'A'); # undocumented
  
      if (!$encoding or $encoding ne 'A') { # no 7-bit auto-detection
  	$detect7bit = 'NO';
      }
      unless ($charset->{InputCharset}) {
  	if ($s =~ $NON7BITRE) {
  	    return ($s, undef);
  	} elsif ($detect7bit ne "NO") {
  	    $charset = __PACKAGE__->new(&detect_7bit_charset($s));
  	} else {
  	    $charset = __PACKAGE__->new($DEFAULT_CHARSET,
  					Mapping => 'STANDARD');
  	} 
      }
      if (!$encoding or $encoding ne 'A') { # no conversion
  	$charset = $charset->dup;
  	$charset->encoder($charset);
  	$charset->{HeaderEncoding} = $encoding;
  	$charset->{BodyEncoding} = $encoding;
      }
      my $check = ($replacement and $replacement =~ /^\d+$/)?
  	$replacement:
      {
  	'CROAK' => FB_CROAK(),
  	'STRICT' => FB_CROAK(),
  	'FALLBACK' => FB_CROAK(), # special
  	'PERLQQ' => FB_PERLQQ(),
  	'HTMLCREF' => FB_HTMLCREF(),
  	'XMLCREF' => FB_XMLCREF(),
      }->{$replacement || ""} || 0;
  
      # Encode data by output charset if required.  If failed, fallback to
      # fallback charset.
      my $encoded;
      if (is_utf8($s) or $s =~ /[^\x00-\xFF]/ or
  	($charset->{InputCharset} || "") ne ($charset->{OutputCharset} || "")) {
  	if ($check & 0x1) { # CROAK or FALLBACK
  	    eval {
  		$encoded = $s;
  		$encoded = $charset->encode($encoded, FB_CROAK());
  	    };
  	    if ($@) {
  		if ($replacement eq "FALLBACK" and $FALLBACK_CHARSET) {
  		    my $cset = __PACKAGE__->new($FALLBACK_CHARSET,
  						Mapping => 'STANDARD');
  		    # croak unknown charset
  		    croak "unknown charset ``$FALLBACK_CHARSET''"
  			unless $cset->{Decoder};
  		    # charset translation
  		    $charset = $charset->dup;
  		    $charset->encoder($cset);
  		    $encoded = $s;
  		    $encoded = $charset->encode($encoded, 0);
  		    # replace input & output charsets with fallback charset
  		    $cset->encoder($cset);
  		    $charset = $cset;
  		} else {
  		    $@ =~ s/ at .+$//;
  		    croak $@;
  		}
  	    }
  	} else {
  	    $encoded = $s;
  	    $encoded = $charset->encode($encoded, $check);
  	}
      } else {
          $encoded = $s;
      }
  
      if ($encoded !~ /$NONASCIIRE/) { # maybe ASCII
  	# check ``ASCII transformation'' charsets
  	if ($charset->{OutputCharset} =~ /^($ASCIITRANSRE)$/) {
  	    my $u = $encoded;
  	    if (USE_ENCODE) {
  		$u = $charset->encoder->decode($encoded); # dec. by output
  	    } elsif ($encoded =~ /[+~]/) { # workaround for pre-Encode env.
  		$u = "x$u";
  	    }
  	    if ($u eq $encoded) {
  		$charset = $charset->dup;
  		$charset->encoder($DEFAULT_CHARSET);
  	    }
  	} elsif ($charset->{OutputCharset} ne "US-ASCII") {
  	    $charset = $charset->dup;
  	    $charset->encoder($DEFAULT_CHARSET);
  	}
      }
  
      return ($encoded, $charset);
  }
  
  =item $charset->undecode(STRING [,CHECK])
  
  Encode Unicode string STRING to byte string by input charset of $charset.
  This is equivalent to C<$charset-E<gt>decoder-E<gt>encode()>.
  
  B<Note>:
  When Unicode/multibyte support is disabled (see L<"USE_ENCODE">),
  this function will die.
  
  =cut
  
  sub undecode($$$;) {
      my $self = shift;
      my $s = shift;
      my $check = shift || 0;
      my $enc = $self->{Decoder}->encode($s, $check);
      Encode::_utf8_off($enc); # workaround for RT #35120
      $enc;
  }
  
  =back
  
  =head2 Manipulating Module Defaults
  
  =over
  
  =item alias ALIAS [, CHARSET]
  
  Get/set charset alias for canonical names determined by
  L<"canonical_charset">.
  
  If CHARSET is given and isn't false, ALIAS will be assigned as an alias of
  CHARSET.  Otherwise, alias won't be changed.  In both cases,
  current charset name that ALIAS is assigned will be returned.
  
  =cut
  
  sub alias ($;$) {
      my $alias = uc(shift);
      my $charset = uc(shift);
  
      return $CHARSET_ALIASES{$alias} unless $charset;
  
      $CHARSET_ALIASES{$alias} = $charset;
      return $charset;
  }
  
  =item default [CHARSET]
  
  Get/set default charset.
  
  B<Default charset> is used by this module when charset context is
  unknown.  Modules using this module are recommended to use this
  charset when charset context is unknown or implicit default is
  expected.  By default, it is C<"US-ASCII">.
  
  If CHARSET is given and isn't false, it will be set to default charset.
  Otherwise, default charset won't be changed.  In both cases,
  current default charset will be returned.
  
  B<NOTE>: Default charset I<should not> be changed.
  
  =cut
  
  sub default(;$) {
      my $charset = &canonical_charset(shift);
  
      if ($charset) {
  	croak "Unknown charset '$charset'"
  	    unless resolve_alias($charset);
  	$DEFAULT_CHARSET = $charset;
      }
      return $DEFAULT_CHARSET;
  }
  
  =item fallback [CHARSET]
  
  Get/set fallback charset.
  
  B<Fallback charset> is used by this module when conversion by given
  charset is failed and C<"FALLBACK"> error handling scheme is specified.
  Modules using this module may use this charset as last resort of charset
  for conversion.  By default, it is C<"UTF-8">.
  
  If CHARSET is given and isn't false, it will be set to fallback charset.
  If CHARSET is C<"NONE">, fallback charset will be undefined.
  Otherwise, fallback charset won't be changed.  In any cases,
  current fallback charset will be returned.
  
  B<NOTE>: It I<is> useful that C<"US-ASCII"> is specified as fallback charset,
  since result of conversion will be readable without charset information.
  
  =cut
  
  sub fallback(;$) {
      my $charset = &canonical_charset(shift);
  
      if ($charset eq "NONE") {
  	$FALLBACK_CHARSET = undef;
      } elsif ($charset) {
  	croak "Unknown charset '$charset'"
  	    unless resolve_alias($charset);
  	$FALLBACK_CHARSET = $charset;
      }
      return $FALLBACK_CHARSET;
  }
  
  =item recommended CHARSET [, HEADERENC, BODYENC [, ENCCHARSET]]
  
  Get/set charset profiles.
  
  If optional arguments are given and any of them are not false, profiles
  for CHARSET will be set by those arguments.  Otherwise, profiles
  won't be changed.  In both cases, current profiles for CHARSET will be
  returned as 3-item list of (HEADERENC, BODYENC, ENCCHARSET).
  
  HEADERENC is recommended encoding scheme for message header.
  It may be one of C<"B">, C<"Q">, C<"S"> (shorter one of either) or
  C<undef> (might not be encoded).
  
  BODYENC is recommended transfer-encoding for message body.  It may be
  one of C<"B">, C<"Q">, C<"S"> (shorter one of either) or
  C<undef> (might not be transfer-encoded).
  
  ENCCHARSET is a charset which is compatible with given CHARSET and
  is recommended to be used for MIME messages on Internet.
  If conversion is not needed (or this module doesn't know appropriate
  charset), ENCCHARSET is C<undef>.
  
  B<NOTE>: This function in the future releases can accept more optional
  arguments (for example, properties to handle character widths, line folding
  behavior, ...).  So format of returned value may probably be changed.
  Use L<"header_encoding">, L<"body_encoding"> or L<"output_charset"> to get
  particular profile.
  
  =cut
  
  sub recommended ($;$;$;$) {
      my $charset = &canonical_charset(shift);
      my $henc = uc(shift) || undef;
      my $benc = uc(shift) || undef;
      my $cset = &canonical_charset(shift);
  
      croak "CHARSET is not specified" unless $charset;
      croak "Unknown header encoding" unless !$henc or $henc =~ /^[BQS]$/;
      croak "Unknown body encoding" unless !$benc or $benc =~ /^[BQ]$/;
  
      if ($henc or $benc or $cset) {
  	$cset = undef if $charset eq $cset;
  	my @spec = ($henc, $benc, USE_ENCODE? $cset: undef);
  	$CHARSETS{$charset} = \@spec;
  	return @spec;
      } else {
  	$charset = __PACKAGE__->new($charset) unless ref $charset;
  	return map { $charset->{$_} } qw(HeaderEncoding BodyEncoding
  					 OutputCharset);
      }
  }
  
  =back
  
  =head2 Constants
  
  =over
  
  =item USE_ENCODE
  
  Unicode/multibyte support flag.
  Non-empty string will be set when Unicode and multibyte support is enabled.
  Currently, this flag will be non-empty on Perl 5.7.3 or later and
  empty string on earlier versions of Perl.
  
  =back
  
  =head2 Error Handling
  
  L<"body_encode"> and L<"header_encode"> accept following C<Replacement>
  options:
  
  =over
  
  =item C<"DEFAULT">
  
  Put a substitution character in place of a malformed character.
  For UCM-based encodings, <subchar> will be used.
  
  =item C<"FALLBACK">
  
  Try C<"DEFAULT"> scheme using I<fallback charset> (see L<"fallback">).
  When fallback charset is undefined and conversion causes error,
  code will die on error with an error message.
  
  =item C<"CROAK">
  
  Code will die on error immediately with an error message.
  Therefore, you should trap the fatal error with eval{} unless you
  really want to let it die on error.
  Synonym is C<"STRICT">.
  
  =item C<"PERLQQ">
  
  =item C<"HTMLCREF">
  
  =item C<"XMLCREF">
  
  Use C<FB_PERLQQ>, C<FB_HTMLCREF> or C<FB_XMLCREF>
  scheme defined by L<Encode> module.
  
  =item numeric values
  
  Numeric values are also allowed.
  For more details see L<Encode/Handling Malformed Data>.
  
  =back
  
  If error handling scheme is not specified or unknown scheme is specified,
  C<"DEFAULT"> will be assumed.
  
  =head2 Configuration File
  
  Built-in defaults for option parameters can be overridden by configuration
  file: F<MIME/Charset/Defaults.pm>.
  For more details read F<MIME/Charset/Defaults.pm.sample>.
  
  =head1 VERSION
  
  Consult $VERSION variable.
  
  Development versions of this module may be found at
  L<http://hatuka.nezumi.nu/repos/MIME-Charset/>.
  
  =head2 Incompatible Changes
  
  =over 4
  
  =item Release 1.001
  
  =over 4
  
  =item *
  
  new() method returns an object when CHARSET argument is not specified.
  
  =back
  
  =item Release 1.005
  
  =over 4
  
  =item *
  
  Restrict characters in encoded-word according to RFC 2047 section 5 (3).
  This also affects return value of encoded_header_len() method.
  
  =back
  
  =item Release 1.008.2
  
  =over 4
  
  =item *
  
  body_encoding() method may also returns C<"S">.
  
  =item *
  
  Return value of body_encode() method for UTF-8 may include
  C<"QUOTED-PRINTABLE"> encoding item that in earlier versions was fixed to
  C<"BASE64">.
  
  =back
  
  =back
  
  =head1 SEE ALSO
  
  Multipurpose Internet Mail Extensions (MIME).
  
  =head1 AUTHOR
  
  Hatuka*nezumi - IKEDA Soji <hatuka(at)nezumi.nu>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2006-2013 Hatuka*nezumi - IKEDA Soji.
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  =cut
  
  1;
MIME_CHARSET

$fatpacked{"Mo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO';
  package Mo;
  $VERSION=0.39;
  no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.::.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};
MO

$fatpacked{"Mo/Golf.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_GOLF';
  ##
  # name:      Mo::Golf
  # abstract:  Module for Compacting Mo Modules
  # author:    Ingy dÃ¶t Net <ingy@ingy.net>
  # license:   perl
  # copyright: 2011
  # see:
  # - Mo
  
  use strict;
  use warnings;
  package Mo::Golf;
  
  our $VERSION=0.39;
  
  use PPI;
  
  # This is the mapping of common names to shorter forms that still make some
  # sense.
  my %short_names = (
      (
          map {($_, substr($_, 0, 1))}
          qw(
              args builder class default exports features
              generator import is_lazy method MoPKG name
              nonlazy_defaults options reftype self
          )
      ),
      build_subs => 'B',
      old_constructor => 'C',
      caller_pkg => 'P',
  );
  
  my %short_barewords = ( EAGERINIT => q{':E'}, NONLAZY => q{':N'} );
  
  my %hands_off = map {($_,1)} qw'&import *import';
  
  sub import {
      return unless @_ == 2 and $_[1] eq 'golf';
      binmode STDOUT;
      my $text = do { local $/; <> };
      print STDOUT golf( $text );
  };
  
  sub golf {
      my ( $text ) = @_;
  
      my $tree = PPI::Document->new( \$text );
  
      my %finder_subs = _finder_subs();
  
      my @order = qw( comments duplicate_whitespace whitespace trailing_whitespace );
  
      for my $name ( @order ) {
          my $elements = $tree->find( $finder_subs{$name} );
          die $@ if !defined $elements;
          $_->delete for @{ $elements || [] };
      }
  
      $tree->find( $finder_subs{$_} )
        for qw( del_superfluous_concat del_last_semicolon_in_block separate_version shorten_var_names shorten_barewords );
      die $@ if $@;
  
      for my $name ( 'double_semicolon' ) {
          my $elements = $tree->find( $finder_subs{$name} );
          die $@ if !defined $elements;
          $_->delete for @{ $elements || [] };
      }
  
      return $tree->serialize . "\n";
  }
  
  sub tok { "PPI::Token::$_[0]" }
  
  sub _finder_subs {
      return (
          comments => sub { $_[1]->isa( tok 'Comment' ) },
  
          duplicate_whitespace => sub {
              my ( $top, $current ) = @_;
              return 0 if !$current->isa( tok 'Whitespace' );
  
              $current->set_content(' ') if 1 < length $current->content;
  
              return 0 if !$current->next_token;
              return 0 if !$current->next_token->isa( tok 'Whitespace' );
              return 1;
          },
  
          whitespace => sub {
              my ( $top, $current ) = @_;
              return 0 if !$current->isa( tok 'Whitespace' );
              my $prev = $current->previous_token;
              my $next = $current->next_token;
  
              return 1 if $prev->isa( tok 'Number' ) and $next->isa( tok 'Operator' ) and $next->content =~ /^\W/; # my $P
              return 1 if $prev->isa( tok 'Word' )   and $next->isa( tok 'Operator' ) and $next->content =~ /^\W/; # my $P
              return 1 if $prev->isa( tok 'Symbol' ) and $next->isa( tok 'Operator' ) and $next->content =~ /^\W/; # $VERSION =  but not $v and
  
              return 1 if $prev->isa( tok 'Operator' ) and $next->isa( tok 'Quote::Single' ) and $next->content =~ /^\W/; # eq ''
              return 1 if $prev->isa( tok 'Operator' ) and $next->isa( tok 'Quote::Double' ) and $next->content =~ /^\W/; # eq ""
              return 1 if $prev->isa( tok 'Operator' ) and $next->isa( tok 'Symbol' )        and $next->content =~ /^\W/; # eq $v
              return 1 if $prev->isa( tok 'Operator' ) and $next->isa( tok 'Structure' )     and $next->content =~ /^\W/; # eq (
  
              return 1 if $prev->isa( tok 'Word' )       and $next->isa( tok 'Symbol' );           # my $P
              return 1 if $prev->isa( tok 'Word' )       and $next->isa( tok 'Structure' );        # sub {
              return 1 if $prev->isa( tok 'Word' )       and $next->isa( tok 'Quote::Double' );    # eval "
              return 1 if $prev->isa( tok 'Symbol' )     and $next->isa( tok 'Structure' );        # %a )
              return 1 if $prev->isa( tok 'ArrayIndex' ) and $next->isa( tok 'Operator' );         # $#_ ?
              return 1 if $prev->isa( tok 'Word' )       and $next->isa( tok 'Cast' );             # exists &$_
              return 0;
          },
  
          trailing_whitespace => sub {
              my ( $top, $current ) = @_;
              return 0 if !$current->isa( tok 'Whitespace' );
              my $prev = $current->previous_token;
  
              return 1 if $prev->isa( tok 'Structure' );                                           # ;[\n\s]
              return 1 if $prev->isa( tok 'Operator' ) and $prev->content =~ /\W$/;                # = 0.24
              return 1 if $prev->isa( tok 'Quote::Double' );                                       # " .
              return 1 if $prev->isa( tok 'Quote::Single' );                                       # ' }
  
              return 0;
          },
  
          double_semicolon => sub {
              my ( $top, $current ) = @_;
              return 0 if !$current->isa( tok 'Structure' );
              return 0 if $current->content ne ';';
  
              my $prev = $current->previous_token;
  
              return 0 if !$prev->isa( tok 'Structure' );
              return 0 if $prev->content ne ';';
  
              return 1;
          },
  
          del_last_semicolon_in_block => sub {
              my ( $top, $current ) = @_;
              return 0 if !$current->isa( 'PPI::Structure::Block' );
  
              my $last = $current->last_token;
  
              return 0 if !$last->isa( tok 'Structure' );
              return 0 if $last->content ne '}';
  
              my $maybe_semi = $last->previous_token;
  
              return 0 if !$maybe_semi->isa( tok 'Structure' );
              return 0 if $maybe_semi->content ne ';';
  
              $maybe_semi->delete;
  
              return 1;
          },
  
          del_superfluous_concat => sub {
              my ( $top, $current ) = @_;
              return 0 if !$current->isa( tok 'Operator' );
  
              my $prev = $current->previous_token;
              my $next = $current->next_token;
  
              return 0 if $current->content ne '.';
              return 0 if !$prev->isa( tok 'Quote::Double' );
              return 0 if !$next->isa( tok 'Quote::Double' );
  
              $current->delete;
              $prev->set_content( $prev->{separator} . $prev->string . $next->string . $prev->{separator} );
              $next->delete;
  
              return 1;
          },
  
          separate_version => sub {
              my ( $top, $current ) = @_;
              return 0 if !$current->isa( 'PPI::Statement' );
  
              my $first = $current->first_token;
              return 0 if $first->content ne '$VERSION';
  
              $current->$_( PPI::Token::Whitespace->new( "\n" ) ) for qw( insert_before insert_after );
  
              return 1;
          },
  
          shorten_var_names => sub {
              my ( $top, $current ) = @_;
              return 0 if !$current->isa( tok 'Symbol' );
  
              my $long_name = $current->canonical;
  
              return 1 if $hands_off{$long_name};
              (my $name = $long_name) =~ s/^([\$\@\%])// or die $long_name;
              my $sigil = $1;
              die "variable $long_name conflicts with shortened var name"
                  if grep {
                      $name eq $_
                  } values %short_names;
  
              my $short_name = $short_names{$name};
              $current->set_content( "$sigil$short_name" ) if $short_name;
  
              return 1;
          },
  
          shorten_barewords => sub {
              my ( $top, $current ) = @_;
              return 0 if !$current->isa( tok 'Word' );
  
              my $name = $current->content;
  
              die "bareword $name conflicts with shortened bareword"
                  if grep {
                      $name eq $_
                  } values %short_barewords;
  
              my $short_name = $short_barewords{$name};
              $current->set_content( $short_name ) if $short_name;
  
              return 1;
          },
      );
  }
  
  =head1 SYNOPSIS
  
      perl -MMo::Golf=golf < src/Mo/foo.pm > lib/Mo/foo.pm
  
  =head1 DESCRIPTION
  
  This is the module that is responsible for taking Mo code (which is
  documented and fairly readable) and reducing it to a single undecipherable
  line.
MO_GOLF

$fatpacked{"Mo/Inline.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_INLINE';
  ##
  # name:      Mo::Inline
  # abstract:  Inline Mo and Features into your package
  # author:    Ingy dÃ¶t Net <ingy@ingy.net>
  # license:   perl
  # copyright: 2011
  # see:
  # - Mo
  
  package Mo::Inline;
  use Mo;
  
  our $VERSION=0.39;
  
  use IO::All;
  
  my $matcher = qr/((?m:^#\s*use Mo(\s.*)?;.*\n))(?:#.*\n)*(?:.{400,}\n)?/;
  
  sub run {
      my $self = shift;
      my @files;
      if (not @_ and -d 'lib') {
          print "Searching the 'lib' directory for a Mo to inline:\n";
          @_ = 'lib';
      }
      if (not @_ or @_ == 1 and $_[0] =~ /^(?:-\?|-h|--help)$/) {
          print usage();
          return 0;
      }
      for my $name (@_) {
          die "No file or directory called '$name'"
              unless -e $name;
          die "'$name' is not a Perl module"
              if -f $name and $name !~ /\.pm$/;
          if (-f $name) {
              push @files, $name;
          }
          elsif (-d $name) {
              push @_, grep /\.pm$/, map { "$_" } io($name)->All_Files;
          }
      }
  
      die "No .pm files specified"
          unless @files;
  
      for my $file (@files) {
          my $text = io($file)->all;
          if ($text !~ $matcher) {
              print "Ignoring $file - No Mo to Inline!\n";
              next;
          }
          $self->inline($file, 1);
      }
  }
  
  sub inline {
      my ($self, $file, $noisy) = @_;
      my $text = io($file)->all;
      $text =~ s/$matcher/"$1" . &inliner($2)/eg;
      io($file)->print($text);
      print "Mo Inlined $file\n"
          if $noisy;
  }
  
  sub inliner {
      my $mo = shift;
      require Mo;
      my @features = grep {$_ ne 'qw'} ($mo =~ /(\w+)/g);
      for (@features) {
          eval "require Mo::$_; 1" or die $@;
      }
      my $inline = '';
      $inline .= $_ for map {
          my $module = $_;
          $module .= '.pm';
          my @lines = io($INC{$module})->chomp->getlines;
          $lines[-1];
      } ('Mo', map { s!::!/!g; "Mo/$_" } @features);
      return <<"...";
  #   The following line of code was produced from the previous line by
  #   Mo::Inline version $VERSION
  $inline\@f=qw[@features];use strict;use warnings;
  ...
  }
  
  sub usage {
      <<'...';
  Usage: mo-linline <perl module files or directories>
  
  ...
  }
  
  1;
  
  =head1 SYNOPSIS
  
  In your Mo module:
  
      # This is effectively your own private Mo(ose) setup
      package MyModule::Mo;
      # use Mo qw'build builder default import';
      1;
  
  From the command line:
  
      > mo-inline lib/MyModule/Mo.pm
  
  or:
  
      > mo-inline lib/
  
  or (if you are really lazy):
  
      > mo-inline
  
  Then from another module:
  
      package MyModule::Foo;
      use MyModule::Mo;       # gets build, builder and default automatically
  
  =head1 DESCRIPTION
  
  Mo is so small that you can easily inline it, along with any feature modules.
  Mo provides a script called C<mo-inline> that will do it for you.
  
  All you need to do is comment out the line that uses Mo, and run C<mo-inline>
  on the file. C<mo-inline> will find such comments and do the inlining for you.
  It will also replace any old inlined Mo with the latest version.
  
  What Mo could you possibly want?
  
  =head1 AUTOMATIC FEATURES
  
  By using the L<Mo::import> feature, all uses of your Mo class will turn on all
  the features you specified. You can override it if you want, but that will be
  the default.
  
  =head1 REAL WORLD EXAMPLES
  
  For real world examples of Mo inlined using C<mo-inline>, see L<YAML::Mo>,
  L<Pegex::Mo> and L<TestML::Mo>.
MO_INLINE

$fatpacked{"Mo/Moose.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_MOOSE';
  package Mo::Moose;$M="Mo::";
  $VERSION=0.39;
  *{$M.'Moose::e'}=sub{my($P,$e)=@_;$P=~s/::$//;%$e=(M=>1);require Moose;Moose->import({into=>$P});Moose::Util::MetaRole::apply_metaroles(for=>$P,class_metaroles=>{attribute=>['Attr::Trait']},)};BEGIN{package Attr::Trait;use Moose::Role;around _process_options=>sub{my$orig=shift;my$c=shift;my($n,$o)=@_;$o->{is}||='rw';$o->{lazy}||=1 if defined$o->{default}or defined$o->{builder};$c->$orig(@_)};$INC{'Attr/Trait.pm'}=1}
MO_MOOSE

$fatpacked{"Mo/Mouse.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_MOUSE';
  package Mo::Mouse;$M="Mo::";
  $VERSION=0.39;
  *{$M.'Mouse::e'}=sub{my($P,$e)=@_;$P=~s/::$//;%$e=(M=>1);require Mouse;require Mouse::Util::MetaRole;Mouse->import({into=>$P});Mouse::Util::MetaRole::apply_metaroles(for=>$P,class_metaroles=>{attribute=>['Attr::Trait']},)};BEGIN{package Attr::Trait;use Mouse::Role;around _process_options=>sub{my$orig=shift;my$c=shift;my($n,$o)=@_;$o->{is}||='rw';$o->{lazy}||=1 if defined$o->{default}or defined$o->{builder};$c->$orig(@_)};$INC{'Attr/Trait.pm'}=1}
MO_MOUSE

$fatpacked{"Mo/build.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_BUILD';
  package Mo::build;my$M="Mo::";
  $VERSION=0.39;
  *{$M.'build::e'}=sub{my($P,$e)=@_;$e->{new}=sub{$c=shift;my$s=&{$M.Object::new}($c,@_);my@B;do{@B=($c.::BUILD,@B)}while($c)=@{$c.::ISA};exists&$_&&&$_($s)for@B;$s}};
MO_BUILD

$fatpacked{"Mo/builder.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_BUILDER';
  package Mo::builder;my$M="Mo::";
  $VERSION=0.39;
  *{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=\&{$P.$b}and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};
MO_BUILDER

$fatpacked{"Mo/chain.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_CHAIN';
  package Mo::chain;my$M="Mo::";
  $VERSION=0.39;
  *{$M.'chain::e'}=sub{my($P,$e,$o)=@_;$o->{chain}=sub{my($m,$n,%a)=@_;$a{chain}or return$m;sub{$#_?($m->(@_),return$_[0]):$m->(@_)}}};
MO_CHAIN

$fatpacked{"Mo/coerce.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_COERCE';
  package Mo::coerce;my$M="Mo::";
  $VERSION=0.39;
  *{$M.'coerce::e'}=sub{my($P,$e,$o)=@_;$o->{coerce}=sub{my($m,$n,%a)=@_;$a{coerce}or return$m;sub{$#_?$m->($_[0],$a{coerce}->($_[1])):$m->(@_)}};my$C=$e->{new}||*{$M.Object::new}{CODE};$e->{new}=sub{my$s=$C->(@_);$s->$_($s->{$_})for keys%$s;$s}};
MO_COERCE

$fatpacked{"Mo/default.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_DEFAULT';
  package Mo::default;my$M="Mo::";
  $VERSION=0.39;
  *{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};
MO_DEFAULT

$fatpacked{"Mo/exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_EXPORTER';
  package Mo::exporter;my$M="Mo::";
  $VERSION=0.39;
  *{$M.'exporter::e'}=sub{my($P)=@_;if(@{$M.EXPORT}){*{$P.$_}=\&{$M.$_}for@{$M.EXPORT}}};
MO_EXPORTER

$fatpacked{"Mo/import.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_IMPORT';
  package Mo::import;my$M="Mo::";
  $VERSION=0.39;
  my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};
MO_IMPORT

$fatpacked{"Mo/importer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_IMPORTER';
  package Mo::importer;my$M="Mo::";
  $VERSION=0.39;
  *{$M.'importer::e'}=sub{my($P,$e,$o,$f)=@_;(my$pkg=$P)=~s/::$//;&{$P.'importer'}($pkg,@$f)if defined&{$P.'importer'}};
MO_IMPORTER

$fatpacked{"Mo/is.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_IS';
  package Mo::is;$M="Mo::";
  $VERSION=0.39;
  *{$M.'is::e'}=sub{my($P,$e,$o)=@_;$o->{is}=sub{my($m,$n,%a)=@_;$a{is}or return$m;sub{$#_&&$a{is}eq'ro'&&caller ne'Mo::coerce'?die$n.' is ro':$m->(@_)}}};
MO_IS

$fatpacked{"Mo/nonlazy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_NONLAZY';
  package Mo::nonlazy;my$M="Mo::";
  $VERSION=0.39;
  *{$M.'nonlazy::e'}=sub{${shift().':N'}=1};
MO_NONLAZY

$fatpacked{"Mo/option.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_OPTION';
  package Mo::option;my$M="Mo::";
  $VERSION=0.39;
  *{$M.'option::e'}=sub{my($P,$e,$o)=@_;$o->{option}=sub{my($m,$n,%a)=@_;$a{option}or return$m;my$n2=$n;*{$P."read_$n2"}=sub{$_[0]->{$n2}};sub{$#_?$m->(@_):$m->(@_,1);$_[0]}}};
MO_OPTION

$fatpacked{"Mo/required.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_REQUIRED';
  package Mo::required;my$M="Mo::";
  $VERSION=0.39;
  *{$M.'required::e'}=sub{my($P,$e,$o)=@_;$o->{required}=sub{my($m,$n,%a)=@_;if($a{required}){my$C=*{$P."new"}{CODE}||*{$M.Object::new}{CODE};no warnings 'redefine';*{$P."new"}=sub{my$s=$C->(@_);my%a=@_[1..$#_];die$n." required"if!exists$a{$n};$s}}$m}};
MO_REQUIRED

$fatpacked{"Mo/xs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MO_XS';
  package Mo::xs;my$M="Mo::";
  $VERSION=0.39;
  require Class::XSAccessor;*{$M.'xs::e'}=sub{my($P,$e,$o,$f)=@_;$P=~s/::$//;$e->{has}=sub{my($n,%a)=@_;Class::XSAccessor->import(class=>$P,accessors=>{$n=>$n})}if!grep!/^xs$/,@$f};
MO_XS

$fatpacked{"Module/Path/More.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_PATH_MORE';
  package Module::Path::More;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.28'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(module_path pod_path);
  
  my $SEPARATOR;
  
  our %SPEC;
  
  $SPEC{':package'} = {
      v => 1.1,
      summary => 'Get path to locally installed Perl module',
  };
  
  BEGIN {
      if ($^O =~ /^(dos|os2)/i) {
          $SEPARATOR = '\\';
      } elsif ($^O =~ /^MacOS/i) {
          $SEPARATOR = ':';
      } else {
          $SEPARATOR = '/';
      }
  }
  
  $SPEC{module_path} = {
      v => 1.1,
      summary => 'Get path to locally installed Perl module',
      description => <<'_',
  
  Search `@INC` (reference entries are skipped) and return path(s) to Perl module
  files with the requested name.
  
  This function is like the one from `Module::Path`, except with a different
  interface and more options (finding all matches instead of the first, the option
  of not absolutizing paths, finding `.pmc` & `.pod` files, finding module
  prefixes).
  
  _
      args => {
          module => {
              summary => 'Module name to search',
              schema  => 'str*',
              req     => 1,
              pos     => 0,
          },
          find_pm => {
              summary => 'Whether to find .pm files',
              schema  => 'bool',
              default => 1,
          },
          find_pmc => {
              summary => 'Whether to find .pmc files',
              schema  => 'bool',
              default => 1,
          },
          find_pod => {
              summary => 'Whether to find .pod files',
              schema  => 'bool',
              default => 0,
          },
          find_prefix => {
              summary => 'Whether to find module prefixes',
              schema  => 'bool',
              default => 0,
          },
          all => {
              summary => 'Return all results instead of just the first',
              schema  => 'bool',
              default => 0,
          },
          abs => {
              summary => 'Whether to return absolute paths',
              schema  => 'bool',
              default => 0,
          },
      },
      result => {
          schema => ['any' => of => ['str*', ['array*' => of => 'str*']]],
      },
      result_naked => 1,
  };
  sub module_path {
      my %args = @_;
  
      my $module = $args{module} or die "Please specify module";
  
      $args{abs}         //= 0;
      $args{all}         //= 0;
      $args{find_pm}     //= 1;
      $args{find_pmc}    //= 1;
      $args{find_pod}    //= 0;
      $args{find_prefix} //= 0;
  
      require Cwd if $args{abs};
  
      my @res;
      my $add = sub { push @res, $args{abs} ? Cwd::abs_path($_[0]) : $_[0] };
  
      my $relpath;
  
      ($relpath = $module) =~ s/::/$SEPARATOR/g;
      $relpath =~ s/\.(pm|pmc|pod)\z//i;
  
      foreach my $dir (@INC) {
          next if not defined($dir);
          next if ref($dir);
  
          my $prefix = $dir . $SEPARATOR . $relpath;
          if ($args{find_pmc}) {
              my $file = $prefix . ".pmc";
              if (-f $file) {
                  $add->($file);
                  last unless $args{all};
              }
          }
          if ($args{find_pm}) {
              my $file = $prefix . ".pm";
              if (-f $file) {
                  $add->($file);
                  last unless $args{all};
              }
          }
          if ($args{find_pod}) {
              my $file = $prefix . ".pod";
              if (-f $file) {
                  $add->($file);
                  last unless $args{all};
              }
          }
          if ($args{find_prefix}) {
              if (-d $prefix) {
                  $add->($prefix);
                  last unless $args{all};
              }
          }
      }
  
      if ($args{all}) {
          return \@res;
      } else {
          return @res ? $res[0] : undef;
      }
  }
  
  $SPEC{pod_path} = {
      v => 1.1,
      summary => 'Get path to locally installed POD',
      description => <<'_',
  
  This is a shortcut for:
  
      module_path(%args, find_pm=>0, find_pmc=>0, find_pod=>1, find_prefix=>0)
  
  _
      args => {
          module => {
              summary => 'Module name to search',
              schema  => 'str*',
              req     => 1,
              pos     => 0,
          },
          all => {
              summary => 'Return all results instead of just the first',
              schema  => 'bool',
              default => 0,
          },
          abs => {
              summary => 'Whether to return absolute paths',
              schema  => 'bool',
              default => 0,
          },
      },
      result => {
          schema => ['any' => of => ['str*', ['array*' => of => 'str*']]],
      },
      result_naked => 1,
  };
  sub pod_path {
      module_path(@_, find_pm=>0, find_pmc=>0, find_pod=>1, find_prefix=>0);
  }
  
  1;
  # ABSTRACT: Get path to locally installed Perl module
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Module::Path::More - Get path to locally installed Perl module
  
  =head1 VERSION
  
  This document describes version 0.28 of Module::Path::More (from Perl distribution Module-Path-More), released on 2015-04-15.
  
  =head1 SYNOPSIS
  
   use Module::Path::More qw(module_path pod_path);
  
   $path = module_path(module=>'Test::More');
   if (defined($path)) {
     print "Test::More found at $path\n";
   } else {
     print "Danger Will Robinson!\n";
   }
  
   # find all found modules, as well as .pmc and .pod files
   @path = module_path(module=>'Foo::Bar', all=>1, find_pmc=>1, find_pod=>1);
  
   # just a shortcut for module_path(module=>'Foo',
   #                                 find_pm=>0, find_pmc=>0, find_pod=>1);
   $path = pod_path(module=>'Foo');
  
  =head1 DESCRIPTION
  
  Module::Path::More provides a function, C<module_path()>, which will find where
  a module (or module prefix, or .pod file) is installed locally. (There is also
  another function C<pod_path()> which is just a convenience wrapper.)
  
  It works by looking in all the directories in @INC for an appropriately named
  file. If module is C<Foo::Bar>, will search for C<Foo/Bar.pm>, C<Foo/Bar.pmc>
  (if C<find_pmc> argument is true), C<Foo/Bar> directory (if C<find_prefix>
  argument is true), or C<Foo/Bar.pod> (if C<find_pod> argument is true).
  
  Caveats: Obviously this only works where the module you're after has its own
  C<.pm> file. If a file defines multiple packages, this won't work. This also
  won't find any modules that are being loaded in some special way, for example
  using a code reference in C<@INC>, as described in C<require> in L<perlfunc>.
  
  To check whether a module is available/loadable, it's generally better to use
  something like:
  
   if (eval { require Some::Module; 1 }) {
       # module is available
   }
  
  because this works with fatpacking or any other C<@INC> hook that might be
  installed. If you use:
  
   if (module_path(module => "Some::Module")) {
       # module is available
   }
  
  then it only works if the module is locatable in the filesystem. But on the
  other hand this method can avoid actual loading of the module.
  
  =head1 FUNCTIONS
  
  
  =head2 module_path(%args) -> str|array[str]
  
  Get path to locally installed Perl module.
  
  Search C<@INC> (reference entries are skipped) and return path(s) to Perl module
  files with the requested name.
  
  This function is like the one from C<Module::Path>, except with a different
  interface and more options (finding all matches instead of the first, the option
  of not absolutizing paths, finding C<.pmc> & C<.pod> files, finding module
  prefixes).
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<abs> => I<bool> (default: 0)
  
  Whether to return absolute paths.
  
  =item * B<all> => I<bool> (default: 0)
  
  Return all results instead of just the first.
  
  =item * B<find_pm> => I<bool> (default: 1)
  
  Whether to find .pm files.
  
  =item * B<find_pmc> => I<bool> (default: 1)
  
  Whether to find .pmc files.
  
  =item * B<find_pod> => I<bool> (default: 0)
  
  Whether to find .pod files.
  
  =item * B<find_prefix> => I<bool> (default: 0)
  
  Whether to find module prefixes.
  
  =item * B<module>* => I<str>
  
  Module name to search.
  
  =back
  
  Return value:  (str|array[str])
  
  
  =head2 pod_path(%args) -> str|array[str]
  
  Get path to locally installed POD.
  
  This is a shortcut for:
  
   module_path(%args, find_pm=>0, find_pmc=>0, find_pod=>1, find_prefix=>0)
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<abs> => I<bool> (default: 0)
  
  Whether to return absolute paths.
  
  =item * B<all> => I<bool> (default: 0)
  
  Return all results instead of just the first.
  
  =item * B<module>* => I<str>
  
  Module name to search.
  
  =back
  
  Return value:  (str|array[str])
  
  =head1 SEE ALSO
  
  L<Module::Path>. Module::Path::More is actually a fork of Module::Path.
  Module::Path::More contains features that are not (or have not been accepted) in
  the original module, namely: finding all matches instead of the first found
  match, and finding C<.pmc/.pod> in addition to .pm files. B<Note that the
  interface is different> (Module::Path::More accepts hash/named arguments) so the
  two modules are not drop-in replacements for each other. Also, note that by
  default Module::Path::More does B<not> do an C<abs_path()> to each file it
  finds. I think this module's choice (not doing abs_path) is a more sensible
  default, because usually there is no actual need to do so and doing abs_path()
  or resolving symlinks will sometimes fail or expose filesystem quirks that we
  might not want to deal with at all. However, if you want to do abs_path, you can
  do so by setting C<abs> option to true.
  
  Command-line utility is not included in this distribution, unlike L<mpath> in
  C<Module-Path>. However, you can use L<pmpath> from C<App-PMUtils> which uses
  this module.
  
  References:
  
  =over
  
  =item * L<https://github.com/neilbowers/Module-Path/issues/6>
  
  =item * L<https://github.com/neilbowers/Module-Path/issues/7>
  
  =item * L<https://github.com/neilbowers/Module-Path/issues/10>
  
  =item * L<https://rt.cpan.org/Public/Bug/Display.html?id=100979>
  
  =back
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Module-Path-More>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Module-Path-More>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Path-More>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
MODULE_PATH_MORE

$fatpacked{"Monkey/Patch/Action.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MONKEY_PATCH_ACTION';
  package Monkey::Patch::Action;
  
  use 5.010;
  use warnings;
  use strict;
  
  our $VERSION = '0.04'; # VERSION
  
  use Monkey::Patch::Action::Handle;
  
  use Exporter qw(import);
  our @EXPORT_OK = qw(patch_package);
  our %EXPORT_TAGS = (all => \@EXPORT_OK);
  
  sub patch_package {
      my ($package, $subname, $action, $code, @extra) = @_;
  
      die "Please specify action" unless $action;
      if ($action eq 'delete') {
          die "code not needed for 'delete' action" if $code;
      } else {
          die "Please specify code" unless $code;
      }
  
      my $name = "$package\::$subname";
      my $type;
      if ($action eq 'add') {
          die "Adding $name: must not already exist" if defined(&$name);
          $type = 'sub';
      } elsif ($action eq 'replace') {
          die "Replacing $name: must already exist" unless defined(&$name);
          $type = 'sub';
      } elsif ($action eq 'add_or_replace') {
          $type = 'sub';
      } elsif ($action eq 'wrap') {
          die "Wrapping $name: must already exist" unless defined(&$name);
          $type = 'wrap';
      } elsif ($action eq 'delete') {
          $type = 'delete';
      } else {
          die "Unknown action '$action', please use either ".
              "wrap/add/replace/add_or_replace/delete";
      }
  
      my @caller = caller(0);
  
      Monkey::Patch::Action::Handle->new(
          package => $package,
          subname => $subname,
          extra   => \@extra,
          patcher => \@caller,
          code    => $code,
  
          -type   => $type,
      );
  }
  
  1;
  # ABSTRACT: Wrap/add/replace/delete subs from other package (with restore)
  
  
  __END__
  =pod
  
  =head1 NAME
  
  Monkey::Patch::Action - Wrap/add/replace/delete subs from other package (with restore)
  
  =head1 VERSION
  
  version 0.04
  
  =head1 SYNOPSIS
  
   use Monkey::Patch::Action qw(patch_package);
  
   package Foo;
   sub sub1  { say "Foo's sub1" }
   sub sub2  { say "Foo's sub2, args=", join(",", @_) }
   sub meth1 { my $self = shift; say "Foo's meth1" }
  
   package Bar;
   our @ISA = qw(Foo);
  
   package main;
   my $h; # handle object
   my $foo = Foo->new;
   my $bar = Bar->new;
  
   # replacing a subroutine
   $h = patch_package('Foo', 'sub1', 'replace', sub { "qux" });
   Foo::sub1(); # says "qux"
   undef $h;
   Foo::sub1(); # says "Foo's sub1"
  
   # adding a subroutine
   $h = patch_package('Foo', 'sub3', 'add', sub { "qux" });
   Foo::sub3(); # says "qux"
   undef $h;
   Foo::sub3(); # dies
  
   # deleting a subroutine
   $h = patch_package('Foo', 'sub2', 'delete');
   Foo::sub2(); # dies
   undef $h;
   Foo::sub2(); # says "Foo's sub2, args="
  
   # wrapping a subroutine
   $h = patch_package('Foo', 'sub2', 'wrap',
       sub {
           my $ctx = shift;
           say "wrapping $ctx->{package}::$ctx->{subname}";
           $ctx->{orig}->(@_);
       }
   );
   Foo::sub2(1,2,3); # says "wrapping Foo::sub2" then "Foo's sub2, args=1,2,3"
   undef $h;
   Foo::sub2(1,2,3); # says "Foo's sub2, args=1,2,3"
  
   # stacking patches (note: can actually be unapplied in random order)
   my ($h2, $h3);
   $h  = patch_package('Foo', 'sub1', 'replace', sub { "qux" });
   Foo::sub1(); # says "qux"
   $h2 = patch_package('Foo', 'sub1', 'delete');
   Foo::sub1(); # dies
   $h3 = patch_package('Foo', 'sub1', 'replace', sub { "quux" });
   Foo::sub1(); # says "quux"
   undef $h3;
   Foo::sub1(); # dies
   undef $h2;
   Foo::sub1(); # says "qux"
   undef $h;
   Foo::sub1(); # says "Foo's sub1"
  
  =head1 DESCRIPTION
  
  Monkey-patching is the act of modifying a package at runtime: adding a
  subroutine/method, replacing/deleting/wrapping another, etc. Perl makes it easy
  to do that, for example:
  
   # add a subroutine
   *{"Target::sub1"} = sub { ... };
  
   # another way, can be done from any file
   package Target;
   sub sub2 { ... }
  
   # delete a subroutine
   undef *{"Target::sub3"};
  
  This module makes things even easier by helping you apply a stack of patches and
  unapply them later in flexible order.
  
  =head1 FUNCTIONS
  
  =head2 patch_package($package, $subname, $action, $code, @extra) => HANDLE
  
  Patch C<$package>'s subroutine named C<$subname>. C<$action> is either:
  
  =over 4
  
  =item * C<wrap>
  
  C<$subname> must already exist. C<code> is required.
  
  Your code receives a context hash as its first argument, followed by any
  arguments the subroutine would have normally gotten. Context hash contains:
  C<orig> (the original subroutine that is being wrapped), C<subname>, C<package>,
  C<extra>.
  
  =item * C<add>
  
  C<subname> must not already exist. C<code> is required.
  
  =item * C<replace>
  
  C<subname> must already exist. C<code> is required.
  
  =item * C<add_or_replace>
  
  C<code> is required.
  
  =item * C<delete>
  
  C<code> is not needed.
  
  =back
  
  Die on error.
  
  Function returns a handle object. As soon as you lose the value of the handle
  (by calling in void context, assigning over the variable, undeffing the
  variable, letting it go out of scope, etc), the patch is unapplied.
  
  Patches can be unapplied in random order, but unapplying a patch where the next
  patch is a wrapper can lead to an error. Example: first patch (P1) adds a
  subroutine and second patch (P2) wraps it. If P1 is unapplied before P2, the
  subroutine is now no longer there, and P2 no longer works. Unapplying P1 after
  P2 works, of course.
  
  =head1 FAQ
  
  =head2 Differences with Monkey::Patch?
  
  This module is based on the wonderful L<Monkey::Patch> by Paul Driver. The
  differences are:
  
  =over 4
  
  =item *
  
  This module adds the ability to add/replace/delete subroutines instead of just
  wrapping them.
  
  =item *
  
  Interface to patch_package() is slightly different (see previous item for the
  cause).
  
  =item *
  
  Using this module, the wrapper receives a context hash instead of just the
  original subroutine.
  
  =item *
  
  Monkey::Patch adds convenience for patching classes and objects. To keep things
  simple, no such convenience is currently provided by this module.
  C<patch_package()> *can* patch classes and objects as well (see the next FAQ
  entry).
  
  =back
  
  =head2 How to patch classes and objects?
  
  Patching a class is basically the same as patching any other package, since Perl
  implements a class with a package. One thing to note is that to call a parent's
  method inside your wrapper code, instead of:
  
   $self->SUPER::methname(...)
  
  you need to do something like:
  
   use SUPER;
   SUPER::find_parent(ref($self), 'methname')->methname(...)
  
  Patching an object is also basically patching a class/package, because Perl does
  not have per-object method like Ruby. But if you just want to provide a modified
  behavior for a certain object only, you can do something like:
  
   patch_package($package, $methname, 'wrap',
   sub {
       my $ctx = shift;
       my $self = shift;
  
       my $obj = $ctx->{extra}[0];
       no warnings 'numeric';
       if ($obj == $self) {
           # do stuff
       }
       $ctx->{orig}->(@_);
   }, $obj);
  
  =head1 SEE ALSO
  
  L<Monkey::Patch>
  
  =head1 AUTHOR
  
  Steven Haryanto <stevenharyanto@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2012 by Steven Haryanto.
  
  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
  
MONKEY_PATCH_ACTION

$fatpacked{"Monkey/Patch/Action/Handle.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MONKEY_PATCH_ACTION_HANDLE';
  package Monkey::Patch::Action::Handle;
  
  use 5.010;
  use strict;
  use warnings;
  
  use Scalar::Util qw(weaken);
  use Sub::Delete;
  
  our $VERSION = '0.04'; # VERSION
  
  my %stacks;
  
  sub __find_previous {
      my ($stack, $code) = @_;
      state $empty = sub {};
  
      for my $i (1..$#$stack) {
          if ($stack->[$i][1] == $code) {
              return $stack->[$i-1][2] // $stack->[$i-1][1];
          }
      }
      $empty;
  }
  
  sub new {
      my ($class, %args) = @_;
  
      my $type = $args{-type};
      delete $args{-type};
  
      my $code = $args{code};
  
      my $name = "$args{package}::$args{subname}";
      my $stack;
      if (!$stacks{$name}) {
          $stacks{$name} = [];
          push @{$stacks{$name}}, [sub => \&$name] if defined(&$name);
      }
      $stack = $stacks{$name};
  
      my $self = bless \%args, $class;
  
      no strict 'refs';
      no warnings 'redefine';
      if ($type eq 'sub') {
          push @$stack, [$type => $code];
          *$name = $code;
      } elsif ($type eq 'delete') {
          $code = sub {};
          $args{code} = $code;
          push @$stack, [$type, $code];
          delete_sub $name;
      } elsif ($type eq 'wrap') {
          weaken($self);
          my $wrapper = sub {
              my $ctx = {
                  package => $self->{package},
                  subname => $self->{subname},
                  extra   => $self->{extra},
                  orig    => __find_previous($stack, $self->{code}),
              };
              unshift @_, $ctx;
              goto &{$self->{code}};
          };
          push @$stack, [$type => $code => $wrapper];
          *$name = $wrapper;
      }
  
      $self;
  }
  
  sub DESTROY {
      my $self = shift;
  
      my $name  = "$self->{package}::$self->{subname}";
      my $stack = $stacks{$name};
      my $code  = $self->{code};
  
      for my $i (0..$#$stack) {
          if($stack->[$i][1] == $code) {
              if ($stack->[$i+1]) {
                  # check conflict
                  if ($stack->[$i+1][0] eq 'wrap' &&
                          ($i == 0 || $stack->[$i-1][0] eq 'delete')) {
                      my $p = $self->{patcher};
                      warn "Warning: unapplying patch to $name ".
                          "(applied in $p->[1]:$p->[2]) before a wrapping patch";
                  }
              }
  
              no strict 'refs';
              if ($i == @$stack-1) {
                  if ($i) {
                      no warnings 'redefine';
                      if ($stack->[$i-1][0] eq 'delete') {
                          delete_sub $name;
                      } else {
                          *$name = $stack->[$i-1][2] // $stack->[$i-1][1];
                      }
                  } else {
                      delete_sub $name;
                  }
              }
              splice @$stack, $i, 1;
              last;
          }
      }
  }
  
  1;
  
  
  __END__
  =pod
  
  =head1 NAME
  
  Monkey::Patch::Action::Handle
  
  =head1 VERSION
  
  version 0.04
  
  =for Pod::Coverage .*
  
  =head1 AUTHOR
  
  Steven Haryanto <stevenharyanto@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2012 by Steven Haryanto.
  
  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
  
MONKEY_PATCH_ACTION_HANDLE

$fatpacked{"PERLANCAR/File/HomeDir.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERLANCAR_FILE_HOMEDIR';
  package PERLANCAR::File::HomeDir;
  
  our $DATE = '2015-04-08'; # DATE
  our $VERSION = '0.02'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Exporter qw(import);
  our @EXPORT_OK = qw(
                         get_my_home_dir
                 );
  
  our $DIE_ON_FAILURE = 0;
  
  # borrowed from File::HomeDir, with some modifications
  sub get_my_home_dir {
      if ($^O eq 'MSWin32') {
          # File::HomeDir always uses exists($ENV{x}) first, does it want to avoid
          # accidentally creating env vars?
          return $ENV{HOME} if $ENV{HOME};
          return $ENV{USERPROFILE} if $ENV{USERPROFILE};
          return join($ENV{HOMEDRIVE}, "\\", $ENV{HOMEPATH})
              if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
      } else {
          return $ENV{HOME} if $ENV{HOME};
          my @pw = getpwuid($>);
          return $pw[7] if @pw;
      }
  
      if ($DIE_ON_FAILURE) {
          die "Can't get home directory";
      } else {
          return undef;
      }
  }
  
  1;
  # ABSTRACT: Lightweight way to get current user's home directory
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  PERLANCAR::File::HomeDir - Lightweight way to get current user's home directory
  
  =head1 VERSION
  
  This document describes version 0.02 of PERLANCAR::File::HomeDir (from Perl distribution PERLANCAR-File-HomeDir), released on 2015-04-08.
  
  =head1 SYNOPSIS
  
   use PERLANCAR::Home::Dir qw(get_my_home_dir);
  
   my $dir = get_my_home_dir();
  
  =head1 DESCRIPTION
  
  This is a (temporary?) module to get user's home directory. It is a lightweight
  version of L<File::HomeDir> with fewer OS support (only Windows and Unix) and
  fewer logic/heuristic.
  
  =head1 VARIABLES
  
  =head2 $DIE_ON_FAILURE => bool (default: 0)
  
  If set to true, will die on failure. Else, function usually return undef on
  failure.
  
  =head1 FUNCTIONS
  
  None are exported by default, but they are exportable.
  
  =head2 get_my_home_dir() => str
  
  Try several ways to get home directory. Return undef or die (depends on
  C<$DIE_ON_FAILURE>) if everything fails.
  
  =head1 SEE ALSO
  
  L<File::HomeDir>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/PERLANCAR-File-HomeDir>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-PERLANCAR-File-HomeDir>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=PERLANCAR-File-HomeDir>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERLANCAR_FILE_HOMEDIR

$fatpacked{"Params/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARAMS_UTIL';
  package Params::Util;
  
  =pod
  
  =head1 NAME
  
  Params::Util - Simple, compact and correct param-checking functions
  
  =head1 SYNOPSIS
  
    # Import some functions
    use Params::Util qw{_SCALAR _HASH _INSTANCE};
    
    # If you are lazy, or need a lot of them...
    use Params::Util ':ALL';
    
    sub foo {
        my $object  = _INSTANCE(shift, 'Foo') or return undef;
        my $image   = _SCALAR(shift)          or return undef;
        my $options = _HASH(shift)            or return undef;
        # etc...
    }
  
  =head1 DESCRIPTION
  
  C<Params::Util> provides a basic set of importable functions that makes
  checking parameters a hell of a lot easier
  
  While they can be (and are) used in other contexts, the main point
  behind this module is that the functions B<both> Do What You Mean,
  and Do The Right Thing, so they are most useful when you are getting
  params passed into your code from someone and/or somewhere else
  and you can't really trust the quality.
  
  Thus, C<Params::Util> is of most use at the edges of your API, where
  params and data are coming in from outside your code.
  
  The functions provided by C<Params::Util> check in the most strictly
  correct manner known, are documented as thoroughly as possible so their
  exact behaviour is clear, and heavily tested so make sure they are not
  fooled by weird data and Really Bad Things.
  
  To use, simply load the module providing the functions you want to use
  as arguments (as shown in the SYNOPSIS).
  
  To aid in maintainability, C<Params::Util> will B<never> export by
  default.
  
  You must explicitly name the functions you want to export, or use the
  C<:ALL> param to just have it export everything (although this is not
  recommended if you have any _FOO functions yourself with which future
  additions to C<Params::Util> may clash)
  
  =head1 FUNCTIONS
  
  =cut
  
  use 5.00503;
  use strict;
  require overload;
  require Exporter;
  require Scalar::Util;
  require DynaLoader;
  
  use vars qw{$VERSION @ISA @EXPORT_OK %EXPORT_TAGS};
  
  $VERSION   = '1.07';
  @ISA       = qw{
  	Exporter
  	DynaLoader
  };
  @EXPORT_OK = qw{
  	_STRING     _IDENTIFIER
  	_CLASS      _CLASSISA   _SUBCLASS  _DRIVER  _CLASSDOES
  	_NUMBER     _POSINT     _NONNEGINT
  	_SCALAR     _SCALAR0
  	_ARRAY      _ARRAY0     _ARRAYLIKE
  	_HASH       _HASH0      _HASHLIKE
  	_CODE       _CODELIKE
  	_INVOCANT   _REGEX      _INSTANCE  _INSTANCEDOES
  	_SET        _SET0
  	_HANDLE
  };
  %EXPORT_TAGS = ( ALL => \@EXPORT_OK );
  
  eval {
  	local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
  	bootstrap Params::Util $VERSION;
  	1;
  } unless $ENV{PERL_PARAMS_UTIL_PP};
  
  # Use a private pure-perl copy of looks_like_number if the version of
  # Scalar::Util is old (for whatever reason).
  my $SU = eval "$Scalar::Util::VERSION" || 0;
  if ( $SU >= 1.18 ) { 
  	Scalar::Util->import('looks_like_number');
  } else {
  	eval <<'END_PERL';
  sub looks_like_number {
  	local $_ = shift;
  
  	# checks from perlfaq4
  	return 0 if !defined($_);
  	if (ref($_)) {
  		return overload::Overloaded($_) ? defined(0 + $_) : 0;
  	}
  	return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
  	return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float
  	return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
  
  	0;
  }
  END_PERL
  }
  
  
  
  
  
  #####################################################################
  # Param Checking Functions
  
  =pod
  
  =head2 _STRING $string
  
  The C<_STRING> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a normal non-false string of non-zero length.
  
  Note that this will NOT do anything magic to deal with the special
  C<'0'> false negative case, but will return it.
  
    # '0' not considered valid data
    my $name = _STRING(shift) or die "Bad name";
    
    # '0' is considered valid data
    my $string = _STRING($_[0]) ? shift : die "Bad string";
  
  Please also note that this function expects a normal string. It does
  not support overloading or other magic techniques to get a string.
  
  Returns the string as a conveince if it is a valid string, or
  C<undef> if not.
  
  =cut
  
  eval <<'END_PERL' unless defined &_STRING;
  sub _STRING ($) {
  	(defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _IDENTIFIER $string
  
  The C<_IDENTIFIER> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a string that is a valid Perl identifier.
  
  Returns the string as a convenience if it is a valid identifier, or
  C<undef> if not.
  
  =cut
  
  eval <<'END_PERL' unless defined &_IDENTIFIER;
  sub _IDENTIFIER ($) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*\z/s) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _CLASS $string
  
  The C<_CLASS> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a string that is a valid Perl class.
  
  This function only checks that the format is valid, not that the
  class is actually loaded. It also assumes "normalised" form, and does
  not accept class names such as C<::Foo> or C<D'Oh>.
  
  Returns the string as a convenience if it is a valid class name, or
  C<undef> if not.
  
  =cut
  
  eval <<'END_PERL' unless defined &_CLASS;
  sub _CLASS ($) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _CLASSISA $string, $class
  
  The C<_CLASSISA> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a string that is a particularly class, or a subclass of it.
  
  This function checks that the format is valid and calls the -E<gt>isa
  method on the class name. It does not check that the class is actually
  loaded.
  
  It also assumes "normalised" form, and does
  not accept class names such as C<::Foo> or C<D'Oh>.
  
  Returns the string as a convenience if it is a valid class name, or
  C<undef> if not.
  
  =cut
  
  eval <<'END_PERL' unless defined &_CLASSISA;
  sub _CLASSISA ($$) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->isa($_[1])) ? $_[0] : undef;
  }
  END_PERL
  
  =head2 _CLASSDOES $string, $role
  
  This routine behaves exactly like C<L</_CLASSISA>>, but checks with C<< ->DOES
  >> rather than C<< ->isa >>.  This is probably only a good idea to use on Perl
  5.10 or later, when L<UNIVERSAL::DOES|UNIVERSAL::DOES/DOES> has been
  implemented.
  
  =cut
  
  eval <<'END_PERL' unless defined &_CLASSDOES;
  sub _CLASSDOES ($$) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->DOES($_[1])) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _SUBCLASS $string, $class
  
  The C<_SUBCLASS> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a string that is a subclass of a specified class.
  
  This function checks that the format is valid and calls the -E<gt>isa
  method on the class name. It does not check that the class is actually
  loaded.
  
  It also assumes "normalised" form, and does
  not accept class names such as C<::Foo> or C<D'Oh>.
  
  Returns the string as a convenience if it is a valid class name, or
  C<undef> if not.
  
  =cut
  
  eval <<'END_PERL' unless defined &_SUBCLASS;
  sub _SUBCLASS ($$) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0] ne $_[1] and $_[0]->isa($_[1])) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _NUMBER $scalar
  
  The C<_NUMBER> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a number. That is, it is defined and perl thinks it's a number.
  
  This function is basically a Params::Util-style wrapper around the
  L<Scalar::Util> C<looks_like_number> function.
  
  Returns the value as a convience, or C<undef> if the value is not a
  number.
  
  =cut
  
  eval <<'END_PERL' unless defined &_NUMBER;
  sub _NUMBER ($) {
  	( defined $_[0] and ! ref $_[0] and looks_like_number($_[0]) )
  	? $_[0]
  	: undef;
  }
  END_PERL
  
  =pod
  
  =head2 _POSINT $integer
  
  The C<_POSINT> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a positive integer (of any length).
  
  Returns the value as a convience, or C<undef> if the value is not a
  positive integer.
  
  The name itself is derived from the XML schema constraint of the same
  name.
  
  =cut
  
  eval <<'END_PERL' unless defined &_POSINT;
  sub _POSINT ($) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[1-9]\d*$/) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _NONNEGINT $integer
  
  The C<_NONNEGINT> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a non-negative integer (of any length). That is, a positive integer,
  or zero.
  
  Returns the value as a convience, or C<undef> if the value is not a
  non-negative integer.
  
  As with other tests that may return false values, care should be taken
  to test via "defined" in boolean validy contexts.
  
    unless ( defined _NONNEGINT($value) ) {
       die "Invalid value";
    }
  
  The name itself is derived from the XML schema constraint of the same
  name.
  
  =cut
  
  eval <<'END_PERL' unless defined &_NONNEGINT;
  sub _NONNEGINT ($) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^(?:0|[1-9]\d*)$/) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _SCALAR \$scalar
  
  The C<_SCALAR> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<SCALAR> reference, with content of non-zero length.
  
  For a version that allows zero length C<SCALAR> references, see
  the C<_SCALAR0> function.
  
  Returns the C<SCALAR> reference itself as a convenience, or C<undef>
  if the value provided is not a C<SCALAR> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_SCALAR;
  sub _SCALAR ($) {
  	(ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _SCALAR0 \$scalar
  
  The C<_SCALAR0> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<SCALAR0> reference, allowing content of zero-length.
  
  For a simpler "give me some content" version that requires non-zero
  length, C<_SCALAR> function.
  
  Returns the C<SCALAR> reference itself as a convenience, or C<undef>
  if the value provided is not a C<SCALAR> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_SCALAR0;
  sub _SCALAR0 ($) {
  	ref $_[0] eq 'SCALAR' ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _ARRAY $value
  
  The C<_ARRAY> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<ARRAY> reference containing B<at least> one element of any kind.
  
  For a more basic form that allows zero length ARRAY references, see
  the C<_ARRAY0> function.
  
  Returns the C<ARRAY> reference itself as a convenience, or C<undef>
  if the value provided is not an C<ARRAY> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_ARRAY;
  sub _ARRAY ($) {
  	(ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _ARRAY0 $value
  
  The C<_ARRAY0> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<ARRAY> reference, allowing C<ARRAY> references that contain no
  elements.
  
  For a more basic "An array of something" form that also requires at
  least one element, see the C<_ARRAY> function.
  
  Returns the C<ARRAY> reference itself as a convenience, or C<undef>
  if the value provided is not an C<ARRAY> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_ARRAY0;
  sub _ARRAY0 ($) {
  	ref $_[0] eq 'ARRAY' ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _ARRAYLIKE $value
  
  The C<_ARRAYLIKE> function tests whether a given scalar value can respond to
  array dereferencing.  If it can, the value is returned.  If it cannot,
  C<_ARRAYLIKE> returns C<undef>.
  
  =cut
  
  eval <<'END_PERL' unless defined &_ARRAYLIKE;
  sub _ARRAYLIKE {
  	(defined $_[0] and ref $_[0] and (
  		(Scalar::Util::reftype($_[0]) eq 'ARRAY')
  		or
  		overload::Method($_[0], '@{}')
  	)) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _HASH $value
  
  The C<_HASH> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<HASH> reference with at least one entry.
  
  For a version of this function that allows the C<HASH> to be empty,
  see the C<_HASH0> function.
  
  Returns the C<HASH> reference itself as a convenience, or C<undef>
  if the value provided is not an C<HASH> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_HASH;
  sub _HASH ($) {
  	(ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _HASH0 $value
  
  The C<_HASH0> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<HASH> reference, regardless of the C<HASH> content.
  
  For a simpler "A hash of something" version that requires at least one
  element, see the C<_HASH> function.
  
  Returns the C<HASH> reference itself as a convenience, or C<undef>
  if the value provided is not an C<HASH> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_HASH0;
  sub _HASH0 ($) {
  	ref $_[0] eq 'HASH' ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _HASHLIKE $value
  
  The C<_HASHLIKE> function tests whether a given scalar value can respond to
  hash dereferencing.  If it can, the value is returned.  If it cannot,
  C<_HASHLIKE> returns C<undef>.
  
  =cut
  
  eval <<'END_PERL' unless defined &_HASHLIKE;
  sub _HASHLIKE {
  	(defined $_[0] and ref $_[0] and (
  		(Scalar::Util::reftype($_[0]) eq 'HASH')
  		or
  		overload::Method($_[0], '%{}')
  	)) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _CODE $value
  
  The C<_CODE> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<CODE> reference.
  
  Returns the C<CODE> reference itself as a convenience, or C<undef>
  if the value provided is not an C<CODE> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_CODE;
  sub _CODE ($) {
  	ref $_[0] eq 'CODE' ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _CODELIKE $value
  
  The C<_CODELIKE> is the more generic version of C<_CODE>. Unlike C<_CODE>,
  which checks for an explicit C<CODE> reference, the C<_CODELIKE> function
  also includes things that act like them, such as blessed objects that
  overload C<'&{}'>.
  
  Please note that in the case of objects overloaded with '&{}', you will
  almost always end up also testing it in 'bool' context at some stage.
  
  For example:
  
    sub foo {
        my $code1 = _CODELIKE(shift) or die "No code param provided";
        my $code2 = _CODELIKE(shift);
        if ( $code2 ) {
             print "Got optional second code param";
        }
    }
  
  As such, you will most likely always want to make sure your class has
  at least the following to allow it to evaluate to true in boolean
  context.
  
    # Always evaluate to true in boolean context
    use overload 'bool' => sub () { 1 };
  
  Returns the callable value as a convenience, or C<undef> if the
  value provided is not callable.
  
  Note - This function was formerly known as _CALLABLE but has been renamed
  for greater symmetry with the other _XXXXLIKE functions.
  
  The use of _CALLABLE has been deprecated. It will continue to work, but
  with a warning, until end-2006, then will be removed.
  
  I apologise for any inconvenience caused.
  
  =cut
  
  eval <<'END_PERL' unless defined &_CODELIKE;
  sub _CODELIKE($) {
  	(
  		(Scalar::Util::reftype($_[0])||'') eq 'CODE'
  		or
  		Scalar::Util::blessed($_[0]) and overload::Method($_[0],'&{}')
  	)
  	? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _INVOCANT $value
  
  This routine tests whether the given value is a valid method invocant.
  This can be either an instance of an object, or a class name.
  
  If so, the value itself is returned.  Otherwise, C<_INVOCANT>
  returns C<undef>.
  
  =cut
  
  eval <<'END_PERL' unless defined &_INVOCANT;
  sub _INVOCANT($) {
  	(defined $_[0] and
  		(defined Scalar::Util::blessed($_[0])
  		or      
  		# We used to check for stash definedness, but any class-like name is a
  		# valid invocant for UNIVERSAL methods, so we stopped. -- rjbs, 2006-07-02
  		Params::Util::_CLASS($_[0]))
  	) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _INSTANCE $object, $class
  
  The C<_INSTANCE> function is intended to be imported into your package,
  and provides a convenient way to test for an object of a particular class
  in a strictly correct manner.
  
  Returns the object itself as a convenience, or C<undef> if the value
  provided is not an object of that type.
  
  =cut
  
  eval <<'END_PERL' unless defined &_INSTANCE;
  sub _INSTANCE ($$) {
  	(Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef;
  }
  END_PERL
  
  =head2 _INSTANCEDOES $object, $role
  
  This routine behaves exactly like C<L</_INSTANCE>>, but checks with C<< ->DOES
  >> rather than C<< ->isa >>.  This is probably only a good idea to use on Perl
  5.10 or later, when L<UNIVERSAL::DOES|UNIVERSAL::DOES/DOES> has been
  implemented.
  
  =cut
  
  eval <<'END_PERL' unless defined &_INSTANCEDOES;
  sub _INSTANCEDOES ($$) {
  	(Scalar::Util::blessed($_[0]) and $_[0]->DOES($_[1])) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _REGEX $value
  
  The C<_REGEX> function is intended to be imported into your package,
  and provides a convenient way to test for a regular expression.
  
  Returns the value itself as a convenience, or C<undef> if the value
  provided is not a regular expression.
  
  =cut
  
  eval <<'END_PERL' unless defined &_REGEX;
  sub _REGEX ($) {
  	(defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _SET \@array, $class
  
  The C<_SET> function is intended to be imported into your package,
  and provides a convenient way to test for set of at least one object of
  a particular class in a strictly correct manner.
  
  The set is provided as a reference to an C<ARRAY> of objects of the
  class provided.
  
  For an alternative function that allows zero-length sets, see the
  C<_SET0> function.
  
  Returns the C<ARRAY> reference itself as a convenience, or C<undef> if
  the value provided is not a set of that class.
  
  =cut
  
  eval <<'END_PERL' unless defined &_SET;
  sub _SET ($$) {
  	my $set = shift;
  	_ARRAY($set) or return undef;
  	foreach my $item ( @$set ) {
  		_INSTANCE($item,$_[0]) or return undef;
  	}
  	$set;
  }
  END_PERL
  
  =pod
  
  =head2 _SET0 \@array, $class
  
  The C<_SET0> function is intended to be imported into your package,
  and provides a convenient way to test for a set of objects of a
  particular class in a strictly correct manner, allowing for zero objects.
  
  The set is provided as a reference to an C<ARRAY> of objects of the
  class provided.
  
  For an alternative function that requires at least one object, see the
  C<_SET> function.
  
  Returns the C<ARRAY> reference itself as a convenience, or C<undef> if
  the value provided is not a set of that class.
  
  =cut
  
  eval <<'END_PERL' unless defined &_SET0;
  sub _SET0 ($$) {
  	my $set = shift;
  	_ARRAY0($set) or return undef;
  	foreach my $item ( @$set ) {
  		_INSTANCE($item,$_[0]) or return undef;
  	}
  	$set;
  }
  END_PERL
  
  =pod
  
  =head2 _HANDLE
  
  The C<_HANDLE> function is intended to be imported into your package,
  and provides a convenient way to test whether or not a single scalar
  value is a file handle.
  
  Unfortunately, in Perl the definition of a file handle can be a little
  bit fuzzy, so this function is likely to be somewhat imperfect (at first
  anyway).
  
  That said, it is implement as well or better than the other file handle
  detectors in existance (and we stole from the best of them).
  
  =cut
  
  # We're doing this longhand for now. Once everything is perfect,
  # we'll compress this into something that compiles more efficiently.
  # Further, testing file handles is not something that is generally
  # done millions of times, so doing it slowly is not a big speed hit.
  eval <<'END_PERL' unless defined &_HANDLE;
  sub _HANDLE {
  	my $it = shift;
  
  	# It has to be defined, of course
  	unless ( defined $it ) {
  		return undef;
  	}
  
  	# Normal globs are considered to be file handles
  	if ( ref $it eq 'GLOB' ) {
  		return $it;
  	}
  
  	# Check for a normal tied filehandle
  	# Side Note: 5.5.4's tied() and can() doesn't like getting undef
  	if ( tied($it) and tied($it)->can('TIEHANDLE') ) {
  		return $it;
  	}
  
  	# There are no other non-object handles that we support
  	unless ( Scalar::Util::blessed($it) ) {
  		return undef;
  	}
  
  	# Check for a common base classes for conventional IO::Handle object
  	if ( $it->isa('IO::Handle') ) {
  		return $it;
  	}
  
  
  	# Check for tied file handles using Tie::Handle
  	if ( $it->isa('Tie::Handle') ) {
  		return $it;
  	}
  
  	# IO::Scalar is not a proper seekable, but it is valid is a
  	# regular file handle
  	if ( $it->isa('IO::Scalar') ) {
  		return $it;
  	}
  
  	# Yet another special case for IO::String, which refuses (for now
  	# anyway) to become a subclass of IO::Handle.
  	if ( $it->isa('IO::String') ) {
  		return $it;
  	}
  
  	# This is not any sort of object we know about
  	return undef;
  }
  END_PERL
  
  =pod
  
  =head2 _DRIVER $string
  
    sub foo {
      my $class = _DRIVER(shift, 'My::Driver::Base') or die "Bad driver";
      ...
    }
  
  The C<_DRIVER> function is intended to be imported into your
  package, and provides a convenient way to load and validate
  a driver class.
  
  The most common pattern when taking a driver class as a parameter
  is to check that the name is a class (i.e. check against _CLASS)
  and then to load the class (if it exists) and then ensure that
  the class returns true for the isa method on some base driver name.
  
  Return the value as a convenience, or C<undef> if the value is not
  a class name, the module does not exist, the module does not load,
  or the class fails the isa test.
  
  =cut
  
  eval <<'END_PERL' unless defined &_DRIVER;
  sub _DRIVER ($$) {
  	(defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef;
  }
  END_PERL
  
  1;
  
  =pod
  
  =head1 TO DO
  
  - Add _CAN to help resolve the UNIVERSAL::can debacle
  
  - Would be even nicer if someone would demonstrate how the hell to
  build a Module::Install dist of the ::Util dual Perl/XS type. :/
  
  - Implement an assertion-like version of this module, that dies on
  error.
  
  - Implement a Test:: version of this module, for use in testing
  
  =head1 SUPPORT
  
  Bugs should be reported via the CPAN bug tracker at
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params-Util>
  
  For other issues, contact the author.
  
  =head1 AUTHOR
  
  Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  =head1 SEE ALSO
  
  L<Params::Validate>
  
  =head1 COPYRIGHT
  
  Copyright 2005 - 2012 Adam Kennedy.
  
  This program is free software; you can redistribute
  it and/or modify it under the same terms as Perl itself.
  
  The full text of the license can be found in the
  LICENSE file included with this module.
  
  =cut
PARAMS_UTIL

$fatpacked{"Perinci/Access/Lite.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_ACCESS_LITE';
  package Perinci::Access::Lite;
  
  our $DATE = '2015-01-22'; # DATE
  our $VERSION = '0.09'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Perinci::AccessUtil qw(strip_riap_stuffs_from_res);
  
  sub new {
      my ($class, %args) = @_;
      $args{riap_version} //= 1.1;
      bless \%args, $class;
  }
  
  # copy-pasted from SHARYANTO::Package::Util
  sub __package_exists {
      no strict 'refs';
  
      my $pkg = shift;
  
      return unless $pkg =~ /\A\w+(::\w+)*\z/;
      if ($pkg =~ s/::(\w+)\z//) {
          return !!${$pkg . "::"}{$1 . "::"};
      } else {
          return !!$::{$pkg . "::"};
      }
  }
  
  sub request {
      my ($self, $action, $url, $extra) = @_;
  
      #say "D:request($action => $url)";
  
      $extra //= {};
  
      my $v = $extra->{v} // 1.1;
      if ($v ne '1.1' && $v ne '1.2') {
          return [501, "Riap protocol not supported, must be 1.1 or 1.2"];
      }
  
      my $res;
      if ($url =~ m!\A(?:pl:)?/(\w+(?:/\w+)*)/(\w*)\z!) {
          my ($modpath, $func) = ($1, $2);
          (my $pkg = $modpath) =~ s!/!::!g;
          #say "D:modpath=$modpath, pkg=$pkg, package exists? ", __package_exists($pkg);
          # skip loading module if package already exists, e.g. 'main' (there is
          # no corresponding module) or packages from loaded modules
          my $pkg_exists = __package_exists($pkg);
          unless ($pkg_exists) {
              #say "D:Loading $pkg ...";
              eval { require "$modpath.pm" };
              return [500, "Can't load module $pkg: $@"] if $@;
          }
  
          if ($action eq 'list') {
              return [501, "Action 'list' not implemented for ".
                          "non-package entities"]
                  if length($func);
              no strict 'refs';
              my $spec = \%{"$pkg\::SPEC"};
              return [200, "OK (list)", [grep {/\A\w+\z/} sort keys %$spec]];
          } elsif ($action eq 'info') {
              my $data = {
                  uri => "$modpath/$func",
                  type => (!length($func) ? "package" :
                               $func =~ /\A\w+\z/ ? "function" :
                                   $func =~ /\A[\@\$\%]/ ? "variable" :
                                       "?"),
              };
              return [200, "OK (info)", $data];
          } elsif ($action eq 'meta' || $action eq 'call') {
              return [501, "Action 'call' not implemented for package entity"]
                  if !length($func) && $action eq 'call';
              my $meta;
              {
                  no strict 'refs';
                  if (length $func) {
                      $meta = ${"$pkg\::SPEC"}{$func}
                          or return [
                              500, "No metadata for '$url' (".
                                  ($pkg_exists ? "package '$pkg' exists, perhaps you mentioned '$pkg' somewhere without actually loading the module, or perhaps '$func' is a typo?" :
                                       "package '$pkg' doesn't exist, perhaps '$modpath' or '$func' is a typo?") .
                                  ")"];
                  } else {
                      $meta = ${"$pkg\::SPEC"}{':package'} // {v=>1.1};
                  }
                  $meta->{entity_v}    //= ${"$pkg\::VERSION"};
                  $meta->{entity_date} //= ${"$pkg\::DATE"};
              }
  
              require Perinci::Sub::Normalize;
              $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
              return [200, "OK ($action)", $meta] if $action eq 'meta';
  
              # form args (and add special args)
              my $args = { %{$extra->{args} // {}} }; # shallow copy
              if ($meta->{features} && $meta->{features}{progress}) {
                  require Progress::Any;
                  $args->{-progress} = Progress::Any->get_indicator;
              }
  
              # convert args
              my $aa = $meta->{args_as} // 'hash';
              my @args;
              if ($aa =~ /array/) {
                  require Perinci::Sub::ConvertArgs::Array;
                  my $convres = Perinci::Sub::ConvertArgs::Array::convert_args_to_array(
                      args => $args, meta => $meta,
                  );
                  return $convres unless $convres->[0] == 200;
                  if ($aa =~ /ref/) {
                      @args = ($convres->[2]);
                  } else {
                      @args = @{ $convres->[2] };
                  }
              } elsif ($aa eq 'hashref') {
                  @args = ({ %$args });
              } else {
                  # hash
                  @args = %$args;
              }
  
              # call!
              {
                  no strict 'refs';
                  $res = &{"$pkg\::$func"}(@args);
              }
  
              # add envelope
              if ($meta->{result_naked}) {
                  $res = [200, "OK (envelope added by ".__PACKAGE__.")", $res];
              }
  
              # add hint that result is binary
              if (defined $res->[2]) {
                  if ($meta->{result} && $meta->{result}{schema} &&
                          $meta->{result}{schema}[0] eq 'buf') {
                      $res->[3]{'x.hint.result_binary'} = 1;
                  }
              }
  
          } else {
              return [501, "Unknown/unsupported action '$action'"];
          }
      } elsif ($url =~ m!\Ahttps?:/(/?)!i) {
          my $is_unix = !$1;
          my $ht;
          require JSON;
          state $json = JSON->new->allow_nonref;
          if ($is_unix) {
              require HTTP::Tiny::UNIX;
              $ht = HTTP::Tiny::UNIX->new;
          } else {
              require HTTP::Tiny;
              $ht = HTTP::Tiny->new;
          }
          my %headers = (
              "x-riap-v" => $self->{riap_version},
              "x-riap-action" => $action,
              "x-riap-fmt" => "json",
              "content-type" => "application/json",
          );
          my $args = $extra->{args} // {};
          for (keys %$extra) {
              next if /\Aargs\z/;
              $headers{"x-riap-$_"} = $extra->{$_};
          }
          my $htres = $ht->post(
              $url, {
                  headers => \%headers,
                  content => $json->encode($args),
              });
          return [500, "Network error: $htres->{status} - $htres->{reason}"]
              if $htres->{status} != 200;
          return [500, "Server error: didn't return JSON (".$htres->{headers}{'content-type'}.")"]
              unless $htres->{headers}{'content-type'} eq 'application/json';
          return [500, "Server error: didn't return Riap 1.1 response (".$htres->{headers}{'x-riap-v'}.")"]
              unless $htres->{headers}{'x-riap-v'} =~ /\A1\.1(\.\d+)?\z/;
          $res = $json->decode($htres->{content});
      } else {
          return [501, "Unsupported scheme or bad URL '$url'"];
      }
  
      strip_riap_stuffs_from_res($res);
  }
  
  1;
  # ABSTRACT: A lightweight Riap client library
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Access::Lite - A lightweight Riap client library
  
  =head1 VERSION
  
  This document describes version 0.09 of Perinci::Access::Lite (from Perl distribution Perinci-Access-Lite), released on 2015-01-22.
  
  =head1 DESCRIPTION
  
  This module is a lightweight alternative to L<Perinci::Access>. It has less
  prerequisites but does fewer things. The things it supports:
  
  =over
  
  =item * Local (in-process) access to Perl modules and functions
  
  Currently only C<call>, C<meta>, and C<list> actions are implemented. Variables
  and other entities are not yet supported.
  
  The C<list> action only gathers keys from C<%SPEC> and do not yet list
  subpackages.
  
  =item * HTTP/HTTPS
  
  =item * HTTP over Unix socket
  
  =back
  
  Differences with Perinci::Access:
  
  =over
  
  =item * For network access, uses HTTP::Tiny module family instead of LWP
  
  This results in fewer dependencies.
  
  =item * No wrapping, no argument checking
  
  For 'pl' or schemeless URL, no wrapping (L<Perinci::Sub::Wrapper>) is done, only
  normalization (using L<Perinci::Sub::Normalize>).
  
  =item * No transaction or logging support
  
  =item * No support for some schemes
  
  This includes: Riap::Simple over pipe/TCP socket.
  
  =back
  
  =head1 ATTRIBUTES
  
  =head2 riap_version => float (default: 1.1)
  
  =head1 METHODS
  
  =head2 new(%attrs) => obj
  
  =head2 $pa->request($action, $url, $extra) => hash
  
  =head1 ADDED RESULT METADATA
  
  This class might add the following property/attribute in result metadata:
  
  =head2 x.hint.result_binary => bool
  
  If result's schema type is C<buf>, then this class will set this attribute to
  true, to give hints to result formatters.
  
  =head1 SEE ALSO
  
  L<Perinci::Access>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Access-Lite>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Access-Lite>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Access-Lite>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_ACCESS_LITE

$fatpacked{"Perinci/AccessUtil.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_ACCESSUTIL';
  package Perinci::AccessUtil;
  
  our $DATE = '2014-10-24'; # DATE
  our $VERSION = '0.05'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use MIME::Base64;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(insert_riap_stuffs_to_res
                      strip_riap_stuffs_from_res
                      decode_args_in_riap_req);
  
  sub insert_riap_stuffs_to_res {
      my ($res, $def_ver, $nmeta, $encode) = @_;
  
      $res->[3]{'riap.v'} //= $def_ver // 1.1;
      if ($res->[3]{'riap.v'} >= 1.2) {
          # do we need to base64-encode?
          {
              last unless $encode // 1;
              last if $res->[3]{'riap.result_encoding'};
              if ($nmeta) {
                  last unless $nmeta->{result}{schema} &&
                      $nmeta->{result}{schema}[0] eq 'buf';
              }
              last unless defined($res->[2]) && !ref($res->[2]) &&
                  $res->[2] =~ /[^\x20-\x7f]/;
              $res->[2] = encode_base64($res->[2]);
              $res->[3]{'riap.result_encoding'} = 'base64';
          }
      }
      $res;
  }
  
  sub strip_riap_stuffs_from_res {
      my $res = shift;
  
      my $ver = $res->[3]{'riap.v'} // 1.1;
      return [501, "Riap version returned by server ($ver) is not supported, ".
                  "only recognize v1.1 and v1.2"]
          unless $ver == 1.1 || $ver == 1.2;
  
      if ($ver >= 1.2) {
          # check and strip riap.*
          for my $k (keys %{$res->[3]}) {
              next unless $k =~ /\Ariap\./;
              my $val = $res->[3]{$k};
              if ($k eq 'riap.v') {
              } elsif ($k eq 'riap.result_encoding') {
                  return [501, "Unknown result_encoding returned by server ".
                              "($val), only base64 is supported"]
                      unless $val eq 'base64';
                  $res->[2] = decode_base64($res->[2]//'');
              } else {
                  return [501, "Unknown Riap attribute in result metadata ".
                              "returned by server ($k)"];
              }
              delete $res->[3]{$k};
          }
      }
  
      $res;
  }
  
  sub decode_args_in_riap_req {
      my $req = shift;
  
      my $v = $req->{v} // 1.1;
      if ($v >= 1.2) {
          if ($req->{args}) {
              my $args = $req->{args};
              for (keys %$args) {
                  next unless /\A(.+):base64\z/;
                  $args->{$1} = decode_base64($args->{$_});
                  delete $args->{$_};
              }
          }
      }
      $req;
  }
  
  1;
  # ABSTRACT: Utility module for Riap client/server
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::AccessUtil - Utility module for Riap client/server
  
  =head1 VERSION
  
  This document describes version 0.05 of Perinci::AccessUtil (from Perl distribution Perinci-AccessUtil), released on 2014-10-24.
  
  =head1 SYNOPSIS
  
   use Perinci::AccessUtil qw(
       strip_riap_stuffs_from_res
       insert_riap_stuffs_to_res
       decode_args_in_riap_req
   );
  
   strip_riap_stuffs_from_res([200,"OK",undef,{"riap.v"=>1.1}]); # => [200,"OK",undef]
   strip_riap_stuffs_from_res([200,"OK",undef,{"riap.foo"=>1}]); # => [501, "Unknown Riap attribute in result metadata: riap.foo"]
  
   insert_riap_stuffs_to_res([200,"OK",undef); # => [200,"OK",undef,{"riap.v"=>1.1}]
  
   decode_args_in_riap_req({v=>1.2, args=>{"a:base64"=>"AAAA"}}); # => {v=>1.2, args=>{a=>"\0\0\0"}}
  
  =head1 DESCRIPTION
  
  =head1 FUNCTIONS
  
  =head2 insert_riap_stuffs_to_res($envres[, $def_ver, $nmeta, $decode]) => array
  
  Starting in Riap protocol v1.2, server is required to return C<riap.v> in result
  metadata. This routine does just that. In addition to that, this routine also
  encodes result with base64 when necessary.
  
  This routine is used by Riap network server libraries, e.g.
  L<Perinci::Access::HTTP::Server> and L<Perinci::Access::Simple::Server>.
  
  =head2 strip_riap_stuffs_from_res($envres) => array
  
  Starting in Riap protocol v1.2, client is required to check and strip all
  C<riap.*> keys in result metadata (C<< $envres->[3] >>). This routine does just
  that. In addition, this routine also decode result if C<riap.result_encoding> is
  set, so the user already gets the decoded content.
  
  This routine is used by Riap client libraries, e.g. L<Perinci::Access::Lite>,
  L<Perinci::Access::Perl>, and L<Perinci::Access::HTTP::Client>,
  L<Perinci::Access::Simple::Client>.
  
  If there is no error, will return C<$envres> with all C<riap.*> keys already
  stripped. If there is an error, an error response will be returned instead.
  Either way, you can use the response returned by this function to user.
  
  =head2 decode_args_in_riap_req($req) => $req
  
  Replace C<ARGNAME:base64> keys in C<arg> in Riap request C<$req> with their
  decoded values. Only done when C<v> key is at least 1.2.
  
  This routine is used in Riap server libraries like in
  L<Perinci::Access::HTTP::Server> and Perinci::Access::Simple::Server::*.
  
  =head1 SEE ALSO
  
  L<Riap>, L<Perinci::Access>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-AccessUtil>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-AccessUtil-Check>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-AccessUtil>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
PERINCI_ACCESSUTIL

$fatpacked{"Perinci/CmdLine/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_CMDLINE_BASE';
  package Perinci::CmdLine::Base;
  
  our $DATE = '2015-04-12'; # DATE
  our $VERSION = '1.10'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  use Log::Any::IfLOG '$log';
  
  # this class can actually be a role instead of base class for pericmd &
  # pericmd-lite, but Mo is more lightweight than Role::Tiny (also R::T doesn't
  # have attributes), Role::Basic, or Moo::Role.
  
  BEGIN {
      if ($INC{'Perinci/CmdLine/Classic.pm'}) {
          require Moo; Moo->import;
      } else {
          require Mo; Mo->import(qw(build default));
      }
  }
  
  has actions => (is=>'rw');
  has common_opts => (is=>'rw');
  has completion => (is=>'rw');
  has default_subcommand => (is=>'rw');
  has get_subcommand_from_arg => (is=>'rw', default=>1);
  has description => (is=>'rw');
  has exit => (is=>'rw', default=>1);
  has formats => (is=>'rw');
  has pass_cmdline_object => (is=>'rw', default=>0);
  has per_arg_json => (is=>'rw');
  has per_arg_yaml => (is=>'rw');
  has program_name => (
      is=>'rw',
      default => sub {
          my $pn = $ENV{PERINCI_CMDLINE_PROGRAM_NAME};
          if (!defined($pn)) {
              $pn = $0; $pn =~ s!.+/!!;
          }
          $pn;
      });
  has riap_version => (is=>'rw', default=>1.1);
  has riap_client => (is=>'rw');
  has riap_client_args => (is=>'rw');
  has subcommands => (is=>'rw');
  has summary => (is=>'rw');
  has tags => (is=>'rw');
  has url => (is=>'rw');
  
  has read_env => (is=>'rw', default=>1);
  has env_name => (
      is => 'rw',
      default => sub {
          my $self = shift;
          __default_env_name($self->program_name);
      },
  );
  
  has read_config => (is=>'rw', default=>1);
  has config_filename => (is=>'rw');
  has config_dirs => (
      is=>'rw',
      default => sub {
          require Perinci::CmdLine::Util::Config;
          Perinci::CmdLine::Util::Config::get_default_config_dirs();
      },
  );
  
  has cleanser => (
      is => 'rw',
      lazy => 1,
      default => sub {
          require Data::Clean::JSON;
          Data::Clean::JSON->get_cleanser;
      },
  );
  
  # role: requires 'hook_after_get_meta'
  # role: requires 'hook_format_row'
  # role: requires 'default_prompt_template'
  
  # role: requires 'hook_before_run'
  # role: requires 'hook_before_read_config_file'
  # role: requires 'hook_after_read_config_file'
  # role: requires 'hook_after_parse_argv'
  # role: requires 'hook_before_action'
  # role: requires 'hook_after_action'
  # role: requires 'hook_format_result'
  # role: requires 'hook_display_result'
  # role: requires 'hook_after_run'
  
  # we put common stuffs here, but PC::Classic's final version will differ from
  # PC::Lite's in several aspects: translation, supported output formats,
  # PC::Classic currently adds some extra keys, some options are not added by
  # PC::Lite (e.g. history/undo stuffs).
  our %copts = (
  
      version => {
          getopt  => "version|v",
          summary => "Display program's version and exit",
          usage   => "--version (or -v)",
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{action} = 'version';
              $r->{skip_parse_subcommand_argv} = 1;
          },
      },
  
      help => {
          getopt  => 'help|h|?',
          summary => 'Display help message and exit',
          usage   => "--help (or -h, -?)",
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{action} = 'help';
              $r->{skip_parse_subcommand_argv} = 1;
          },
          order => 0, # high
      },
  
      format => {
          getopt  => 'format=s',
          summary => 'Choose output format, e.g. json, text',
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{format} = $val;
          },
          default => undef,
          tags => ['category:output'],
          is_settable_via_config => 1,
      },
      json => {
          getopt  => 'json',
          summary => 'Set output format to json',
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{format} = 'json';
          },
          tags => ['category:output'],
      },
  
      naked_res => {
          getopt  => 'naked-res!',
          summary => 'When outputing as JSON, strip result envelope',
          'summary.alt.bool.not' => 'When outputing as JSON, add result envelope',
          description => <<'_',
  
  By default, when outputing as JSON, the full enveloped result is returned, e.g.:
  
      [200,"OK",[1,2,3],{"func.extra"=>4}]
  
  The reason is so you can get the status (1st element), status message (2nd
  element) as well as result metadata/extra result (4th element) instead of just
  the result (3rd element). However, sometimes you want just the result, e.g. when
  you want to pipe the result for more post-processing. In this case you can use
  `--naked-res` so you just get:
  
      [1,2,3]
  
  _
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{naked_res} = $val ? 1:0;
          },
          default => 0,
          tags => ['category:output'],
          is_settable_via_config => 1,
      },
  
      subcommands => {
          getopt  => 'subcommands',
          summary => 'List available subcommands',
          usage   => "--subcommands",
          show_in_usage => sub {
              my ($self, $r) = @_;
              !$r->{subcommand_name};
          },
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{action} = 'subcommands';
              $r->{skip_parse_subcommand_argv} = 1;
          },
      },
  
      # 'cmd=SUBCOMMAND_NAME' can be used to select other subcommands when
      # default_subcommand is in effect.
      cmd => {
          getopt  => "cmd=s",
          summary => 'Select subcommand',
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{subcommand_name} = $val;
              $r->{subcommand_name_from} = '--cmd';
          },
          completion => sub {
              require Complete::Util;
              my %args = @_;
              my $cmdline = $args{cmdline};
              Complete::Util::complete_array_elem(
                  array => [keys %{ $cmdline->list_subcommands }],
                  word  => $args{word},
                  ci    => 1,
              );
          },
      },
  
      config_path => {
          getopt  => 'config-path=s@',
          schema  => ['array*', of => 'str*'],
          'x.schema.element_entity' => 'filename',
          summary => 'Set path to configuration file',
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{config_paths} //= [];
              push @{ $r->{config_paths} }, $val;
          },
          tags => ['category:configuration'],
      },
      no_config => {
          getopt  => 'no-config',
          summary => 'Do not use any configuration file',
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{read_config} = 0;
          },
          tags => ['category:configuration'],
      },
      no_env => {
          getopt  => 'no-env',
          summary => 'Do not read environment for default options',
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{read_env} = 0;
          },
          tags => ['category:environment'],
      },
      config_profile => {
          getopt  => 'config-profile=s',
          summary => 'Set configuration profile to use',
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{config_profile} = $val;
          },
          completion => sub {
              # return list of profiles in read config file
  
              my %args = @_;
              my $word    = $args{word} // '';
              my $cmdline = $args{cmdline};
              my $r       = $args{r};
  
              # we are not called from cmdline, bail (actually we might want to
              # return list of programs anyway, but we want to read the value of
              # bash_global_dir et al)
              return undef unless $cmdline;
  
              # since this is common option, at this point we haven't parsed
              # argument or even read config file. so we need to do that first.
              {
                  # this is not activated yet
                  $r->{read_config} = 1;
  
                  my $res = $cmdline->parse_argv($r);
                  #return undef unless $res->[0] == 200;
              }
  
              # we are not reading any config file, return empty list
              return [] unless $r->{config};
  
              my @profiles;
              for (keys %{$r->{config}}) {
                  if (length $r->{subcommand_name}) {
                      push @profiles, $1
                          if /\A\Q$r->{subcommand_name}\E \s+ profile=(.+)/x;
                  } else {
                      push @profiles, $1 if /\Aprofile=(.+)/;
                  }
              }
  
              require Complete::Util;
              Complete::Util::complete_array_elem(
                  array=>[sort @profiles], word=>$word, ci=>1);
          },
          tags => ['category:configuration'],
      },
  
      # since the cmdline opts is consumed, Log::Any::App doesn't see this. we
      # currently work around this via setting env.
      log_level => {
          getopt  => 'log-level=s',
          summary => 'Set log level',
          schema  => ['str*' => in => [
              qw/trace debug info warn warning error fatal/]],
          handler => sub {
              my ($go, $val, $r) = @_;
              $r->{log_level} = $val;
              $ENV{LOG_LEVEL} = $val;
          },
          is_settable_via_config => 1,
          tags => ['category:logging'],
      },
      trace => {
          getopt  => "trace",
          summary => "Set log level to trace",
          handler => sub {
              my ($go, $val, $r) = @_;
              $ENV{TRACE} = 1;
          },
          tags => ['category:logging'],
      },
      debug => {
          getopt  => "debug",
          summary => "Set log level to debug",
          handler => sub {
              my ($go, $val, $r) = @_;
              $ENV{DEBUG} = 1;
          },
          tags => ['category:logging'],
      },
      verbose => {
          getopt  => "verbose",
          summary => "Set log level to info",
          handler => sub {
              my ($go, $val, $r) = @_;
              $ENV{VERBOSE} = 1;
              $r->{_help_verbose} = 1;
          },
          tags => ['category:logging'],
      },
      quiet => {
          getopt  => "quiet",
          summary => "Set log level to quiet",
          handler => sub {
              my ($go, $val, $r) = @_;
              $ENV{QUIET} = 1;
          },
          tags => ['category:logging'],
      },
  
  );
  
  sub __default_env_name {
      my ($prog) = @_;
  
      for ($prog) {
          $_ //= "PROG"; # shouldn't happen
          $_ = uc($_);
          s/[^A-Z0-9]+/_/g;
      }
      "${prog}_OPT";
  }
  
  sub hook_before_run {}
  
  sub hook_before_read_config_file {}
  
  sub hook_after_read_config_file {}
  
  sub hook_before_action {}
  
  sub hook_after_action {}
  
  sub get_meta {
      my ($self, $r, $url) = @_;
  
      my $res = $self->riap_client->request(meta => $url);
      die $res unless $res->[0] == 200;
      my $meta = $res->[2];
      $r->{meta} = $meta;
      $log->tracef("[pericmd] Running hook_after_get_meta ...");
      $self->hook_after_get_meta($r);
      $meta;
  }
  
  sub get_program_and_subcommand_name {
      my ($self, $r) = @_;
      my $res = ($self->program_name // "") . " " .
          ($r->{subcommand_name} // "");
      $res =~ s/\s+$//;
      $res;
  }
  
  sub get_subcommand_data {
      my ($self, $name) = @_;
  
      my $scs = $self->subcommands;
      return undef unless $scs;
  
      if (ref($scs) eq 'CODE') {
          return $scs->($self, name=>$name);
      } else {
          return $scs->{$name};
      }
  }
  
  sub list_subcommands {
      my ($self) = @_;
      return $self->{_cache_subcommands} if $self->{_cache_subcommands};
  
      my $scs = $self->subcommands;
      my $res;
      if ($scs) {
          if (ref($scs) eq 'CODE') {
              $scs = $scs->($self);
              die [500, "BUG: Subcommands code didn't return a hashref"]
                  unless ref($scs) eq 'HASH';
          }
          $res = $scs;
      } else {
          $res = {};
      }
      $self->{_cache_subcommands} = $res;
      $res;
  }
  
  sub status2exitcode {
      my ($self, $status) = @_;
      return 0 if $status =~ /^2..|304/;
      $status - 300;
  }
  
  sub _detect_completion {
      my ($self, $r) = @_;
  
      if ($ENV{COMP_SHELL}) {
          $r->{shell} = $ENV{COMP_SHELL};
          return 1;
      } elsif ($ENV{COMP_LINE}) {
          $r->{shell} = 'bash';
          return 1;
      } elsif ($ENV{COMMAND_LINE}) {
          $r->{shell} = 'tcsh';
          return 1;
      }
  
      # assume default is bash
      $r->{shell} //= 'bash';
  
      0;
  }
  
  sub _read_env {
      my ($self, $r) = @_;
  
      return [] unless $self->read_env;
      my $env_name = $self->env_name;
      my $env = $ENV{$env_name};
      $log->tracef("[pericmd] Checking env %s: %s", $env_name, $env);
      return [] unless defined $env;
  
      # XXX is it "proper" to use Complete::* modules to parse cmdline, outside
      # the context of completion?
  
      my $words;
      if ($r->{shell} eq 'bash') {
          require Complete::Bash;
          ($words, undef) = @{ Complete::Bash::parse_cmdline($env, 0) };
      } elsif ($r->{shell} eq 'fish') {
          require Complete::Fish;
          ($words, undef) = @{ Complete::Fish::parse_cmdline($env) };
      } elsif ($r->{shell} eq 'tcsh') {
          require Complete::Tcsh;
          ($words, undef) = @{ Complete::Tcsh::parse_cmdline($env) };
      } elsif ($r->{shell} eq 'zsh') {
          require Complete::Zsh;
          ($words, undef) = @{ Complete::Zsh::parse_cmdline($env) };
      } else {
          die "Unsupported shell '$r->{shell}'";
      }
      $log->tracef("[pericmd] Words from env: %s", $words);
      $words;
  }
  
  sub do_completion {
      my ($self, $r) = @_;
  
      local $r->{in_completion} = 1;
  
      my ($words, $cword);
      if ($r->{shell} eq 'bash') {
          require Complete::Bash;
          ($words, $cword) = @{ Complete::Bash::parse_cmdline() };
      } elsif ($r->{shell} eq 'fish') {
          require Complete::Fish;
          ($words, $cword) = @{ Complete::Fish::parse_cmdline() };
      } elsif ($r->{shell} eq 'tcsh') {
          require Complete::Tcsh;
          ($words, $cword) = @{ Complete::Tcsh::parse_cmdline() };
      } elsif ($r->{shell} eq 'zsh') {
          require Complete::Zsh;
          ($words, $cword) = @{ Complete::Zsh::parse_cmdline() };
      } else {
          die "Unsupported shell '$r->{shell}'";
      }
  
      shift @$words; $cword--; # strip program name
  
      # @ARGV given by bash is messed up / different. during completion, we
      # get ARGV from parsing COMP_LINE/COMP_POINT.
      @ARGV = @$words;
  
      # check whether subcommand is defined. try to search from --cmd, first
      # command-line argument, or default_subcommand.
      $self->_parse_argv1($r);
  
      if ($r->{read_env}) {
          my $env_words = $self->_read_env($r);
          unshift @ARGV, @$env_words;
          $cword += @$env_words;
      }
  
      #$log->tracef("ARGV=%s", \@ARGV);
      #$log->tracef("words=%s", $words);
  
      # force format to text for completion, because user might type 'cmd --format
      # blah -^'.
      $r->{format} = 'text';
  
      my $scd = $r->{subcommand_data};
      my $meta = $self->get_meta($r, $scd->{url} // $self->{url});
  
      my $subcommand_name_from = $r->{subcommand_name_from} // '';
  
      require Perinci::Sub::Complete;
      my $compres = Perinci::Sub::Complete::complete_cli_arg(
          meta            => $meta, # must be normalized
          words           => $words,
          cword           => $cword,
          common_opts     => $self->common_opts,
          riap_server_url => $scd->{url},
          riap_uri        => undef,
          riap_client     => $self->riap_client,
          extras          => {r=>$r, cmdline=>$self},
          func_arg_starts_at => ($subcommand_name_from eq 'arg' ? 1:0),
          completion      => sub {
              my %args = @_;
              my $type = $args{type};
  
              # user specifies custom completion routine, so use that first
              if ($self->completion) {
                  my $res = $self->completion(%args);
                  return $res if $res;
              }
              # if subcommand name has not been supplied and we're at arg#0,
              # complete subcommand name
              if ($self->subcommands &&
                      $subcommand_name_from ne '--cmd' &&
                           $args{type} eq 'arg' && $args{argpos}==0) {
                  require Complete::Util;
                  return Complete::Util::complete_array_elem(
                      array => [keys %{ $self->list_subcommands }],
                      word  => $words->[$cword]);
              }
  
              # otherwise let periscomp do its thing
              return undef;
          },
      );
  
      my $formatted;
      if ($r->{shell} eq 'bash') {
          $formatted = Complete::Bash::format_completion(
              $compres, {word=>$words->[$cword]});
      } elsif ($r->{shell} eq 'fish') {
          $formatted = Complete::Fish::format_completion($compres);
      } elsif ($r->{shell} eq 'tcsh') {
          $formatted = Complete::Tcsh::format_completion($compres);
      } elsif ($r->{shell} eq 'zsh') {
          $formatted = Complete::Zsh::format_completion($compres);
      }
  
      [200, "OK", $formatted,
       # these extra result are for debugging
       {
           "func.words" => $words,
           "func.cword" => $cword,
           "cmdline.skip_format" => 1,
       }];
  }
  
  sub _read_config {
      require Perinci::CmdLine::Util::Config;
  
      my ($self, $r) = @_;
  
      $log->tracef("[pericmd] Finding config files ...");
      my $res = Perinci::CmdLine::Util::Config::read_config(
          config_paths    => $r->{config_paths},
          config_filename => $self->config_filename,
          config_dirs     => $self->config_dirs,
          program_name    => $self->program_name,
      );
      die $res unless $res->[0] == 200;
      $r->{config} = $res->[2];
      $r->{read_config_files} = $res->[3]{'func.read_files'};
      $log->tracef("[pericmd] Read config files: %s",
                   $r->{'read_config_files'});
  }
  
  sub _parse_argv1 {
      my ($self, $r) = @_;
  
      # parse common_opts which potentially sets subcommand
      {
          # one small downside for this is that we cannot do autoabbrev here,
          # because we're not yet specifying all options here.
  
          require Getopt::Long;
          my $old_go_conf = Getopt::Long::Configure(
              'pass_through', 'permute', 'no_ignore_case', 'no_auto_abbrev');
          my @go_spec;
          my $co = $self->common_opts // {};
          for my $k (keys %$co) {
              push @go_spec, $co->{$k}{getopt} => sub {
                  my ($go, $val) = @_;
                  $co->{$k}{handler}->($go, $val, $r);
              };
          }
          #$log->tracef("\@ARGV before parsing common opts: %s", \@ARGV);
          Getopt::Long::GetOptions(@go_spec);
          Getopt::Long::Configure($old_go_conf);
          #$log->tracef("\@ARGV after  parsing common opts: %s", \@ARGV);
      }
  
      # select subcommand and fill subcommand data
      {
          my $scn = $r->{subcommand_name};
          my $scn_from = $r->{subcommand_name_from};
          if (!defined($scn) && defined($self->{default_subcommand})) {
              # get from default_subcommand
              if ($self->get_subcommand_from_arg == 1) {
                  $scn = $self->{default_subcommand};
                  $scn_from = 'default_subcommand';
              } elsif ($self->get_subcommand_from_arg == 2 && !@ARGV) {
                  $scn = $self->{default_subcommand};
                  $scn_from = 'default_subcommand';
              }
          }
          if (!defined($scn) && $self->{subcommands} && @ARGV) {
              # get from first command-line arg
              if ($ARGV[0] =~ /\A-/) {
                  if ($r->{in_completion}) {
                      $scn = shift @ARGV;
                      $scn_from = 'arg';
                  } else {
                      die [400, "Unknown option: $ARGV[0]"];
                  }
              } else {
                  $scn = shift @ARGV;
                  $scn_from = 'arg';
              }
          }
  
          my $scd;
          if (defined $scn) {
              $scd = $self->get_subcommand_data($scn);
              unless ($r->{in_completion}) {
                  die [500, "Unknown subcommand: $scn"] unless $scd;
              }
          } elsif (!$r->{action} && $self->{subcommands}) {
              # program has subcommands but user doesn't specify any subcommand,
              # or specific action. display help instead.
              $r->{action} = 'help';
              $r->{skip_parse_subcommand_argv} = 1;
          } else {
              $scn = '';
              $scd = {
                  url => $self->url,
                  summary => $self->summary,
                  description => $self->description,
                  pass_cmdline_object => $self->pass_cmdline_object,
                  tags => $self->tags,
              };
          }
          $r->{subcommand_name} = $scn;
          $r->{subcommand_name_from} = $scn_from;
          $r->{subcommand_data} = $scd;
      }
  
      # also set dry-run on environment
      $r->{dry_run} = 1 if $ENV{DRY_RUN};
  
      $r->{_parse_argv1_done} = 1;
  }
  
  sub _parse_argv2 {
      require Perinci::CmdLine::Util::Config;
  
      my ($self, $r) = @_;
  
      my %args;
  
      if ($r->{read_env}) {
          my $env_words = $self->_read_env($r);
          unshift @ARGV, @$env_words;
      }
  
      # parse argv for per-subcommand command-line opts
      if ($r->{skip_parse_subcommand_argv}) {
          return [200, "OK (subcommand options parsing skipped)"];
      } else {
          my $scd = $r->{subcommand_data};
          my $meta = $self->get_meta($r, $scd->{url});
  
          # first fill in from subcommand specification
          if ($scd->{args}) {
              $args{$_} = $scd->{args}{$_} for keys %{ $scd->{args} };
          }
  
          # then read from configuration
          if ($r->{read_config}) {
  
              $log->tracef("[pericmd] Running hook_before_read_config_file ...");
              $self->hook_before_read_config_file($r);
  
              $self->_read_config($r);
  
              $log->tracef("[pericmd] Running hook_after_read_config_file ...");
              $self->hook_after_read_config_file($r);
  
              my $res = Perinci::CmdLine::Util::Config::get_args_from_config(
                  r                  => $r,
                  config             => $r->{config},
                  args               => \%args,
                  subcommand_name    => $r->{subcommand_name},
                  config_profile     => $r->{config_profile},
                  common_opts        => $self->common_opts,
                  meta               => $meta,
                  meta_is_normalized => 1,
              );
              die $res unless $res->[0] == 200;
              $log->tracef("[pericmd] args after reading config files: %s",
                           \%args);
              my $found = $res->[3]{'func.found'};
              if (defined($r->{config_profile}) && !$found &&
                      defined($r->{read_config_files}) &&
                          @{$r->{read_config_files}} &&
                              !$r->{ignore_missing_config_profile_section}) {
                  return [412, "Profile '$r->{config_profile}' not found ".
                              "in configuration file"];
              }
  
          }
  
          # finally get from argv
  
          # since get_args_from_argv() doesn't pass $r, we need to wrap it
          my $copts = $self->common_opts;
          my %old_handlers;
          for (keys %$copts) {
              my $h = $copts->{$_}{handler};
              $copts->{$_}{handler} = sub {
                  my ($go, $val) = @_;
                  $h->($go, $val, $r);
              };
              $old_handlers{$_} = $h;
          }
  
          my $has_cmdline_src;
          for my $ak (keys %{$meta->{args} // {}}) {
              my $av = $meta->{args}{$ak};
              if ($av->{cmdline_src}) {
                  $has_cmdline_src = 1;
                  last;
              }
              # this will probably be eventually checked by the rinci function's
              # schema: stream arguments need to have cmdline_src set to
              # stdin_or_file, stdin_or_files, stdin, or file.
              if ($av->{stream}) {
                  unless ($av->{cmdline_src} &&
                              $av->{cmdline_src} =~
                                  /\A(stdin|file|stdin_or_files?)\z/) {
                      die "BUG: stream argument '$ak' needs to have cmdline_src ".
                          "set to stdin, file, stdin_or_file, or stdin_or_files";
                  }
              }
          }
  
          require Perinci::Sub::GetArgs::Argv;
          my $ga_res = Perinci::Sub::GetArgs::Argv::get_args_from_argv(
              argv                => \@ARGV,
              args                => \%args,
              meta                => $meta,
              meta_is_normalized  => 1,
              allow_extra_elems   => $has_cmdline_src ? 1:0,
              per_arg_json        => $self->{per_arg_json},
              per_arg_yaml        => $self->{per_arg_yaml},
              common_opts         => $copts,
              strict              => $r->{in_completion} ? 0:1,
              on_missing_required_args => sub {
                  my %a = @_;
  
                  my ($an, $aa, $as) = ($a{arg}, $a{args}, $a{spec});
                  my $src = $as->{cmdline_src};
                  if ($src && $as->{req}) {
                      # don't complain, we will fill argument from other source
                      return 1;
                  } else {
                      # we have no other sources, so we complain about missing arg
                      return 0;
                  }
              },
          );
  
          return $ga_res unless $ga_res->[0] == 200;
  
          require Perinci::Sub::CoerceArgs;
          my $coerce_res = Perinci::Sub::CoerceArgs::coerce_args(
              meta                => $meta,
              meta_is_normalized  => 1,
              args                => $ga_res->[2],
          );
  
          return $coerce_res unless $coerce_res->[0] == 200;
  
          # restore
          for (keys %$copts) {
              $copts->{$_}{handler} = $old_handlers{$_};
          }
  
          return $ga_res;
      }
  }
  
  sub parse_argv {
      my ($self, $r) = @_;
  
      $log->tracef("[pericmd] Parsing \@ARGV: %s", \@ARGV);
  
      # we parse argv twice. the first parse is with common_opts only so we're
      # able to catch --help, --version, etc early without having to know about
      # subcommands. two reasons for this: sometimes we need to get subcommand
      # name *from* cmdline opts (e.g. --cmd) and thus it's a chicken-and-egg
      # problem. second, it's faster because we don't have to load Riap client and
      # request the meta through it (especially in the case of remote URL).
      #
      # the second parse is after ge get subcommand name and the function
      # metadata. we can parse the remaining argv to get function arguments.
      #
      # note that when doing completion we're not using this algorithem and only
      # parse argv once. this is to make completion work across common- and
      # per-subcommand opts, e.g. --he<tab> resulting in --help (common opt) as
      # well as --height (function argument).
  
      $self->_parse_argv1($r) unless $r->{_parse_argv1_done};
      $self->_parse_argv2($r);
  }
  
  sub __gen_iter {
      require Data::Sah::Util::Type;
  
      my ($fh, $sch, $argname) = @_;
      my $type = Data::Sah::Util::Type::get_type($sch);
  
      if (Data::Sah::Util::Type::is_simple($sch)) {
          return sub {
              # XXX this will be configurable later. currently by default reading
              # binary is per-64k while reading string is line-by-line.
              local $/ = \(64*1024) if $type eq 'buf';
  
              state $eof;
              return undef if $eof;
              my $l = <$fh>;
              unless (defined $l) {
                  $eof++; return undef;
              }
              $l;
          };
      } else {
          # expect JSON stream for non-simple types
          require JSON;
          state $json = JSON->new->allow_nonref;
          my $i = -1;
          return sub {
              state $eof;
              return undef if $eof;
              $i++;
              my $l = <$fh>;
              unless (defined $l) {
                  $eof++; return undef;
              }
              eval { $l = $json->decode($l) };
              if ($@) {
                  die "Invalid JSON in stream argument '$argname' record #$i: $@";
              }
              $l;
          };
      }
  }
  
  # parse cmdline_src argument spec properties for filling argument value from
  # file and/or stdin. currently does not support argument submetadata.
  sub parse_cmdline_src {
      my ($self, $r) = @_;
  
      my $action = $r->{action};
      my $meta   = $r->{meta};
  
      my $url = $r->{subcommand_data}{url} // $self->{url} // '';
      my $is_network = $url =~ m!^(https?|riap[^:]+):!;
  
      # handle cmdline_src
      if ($action eq 'call') {
          my $args_p = $meta->{args} // {};
          my $stdin_seen;
          for my $an (sort {
              my $csa  = $args_p->{$a}{cmdline_src};
              my $csb  = $args_p->{$b}{cmdline_src};
              my $posa = $args_p->{$a}{pos} // 9999;
              my $posb = $args_p->{$b}{pos} // 9999;
  
              # first, always put stdin_line before stdin / stdin_or_files
              (
                  !$csa || !$csb ? 0 :
                      $csa eq 'stdin_line' && $csb eq 'stdin_line' ? 0 :
                      $csa eq 'stdin_line' && $csb =~ /^(stdin|stdin_or_files?)/ ? -1 :
                      $csb eq 'stdin_line' && $csa =~ /^(stdin|stdin_or_files?)/ ? 1 : 0
              )
              ||
  
              # then order by pos
              ($posa <=> $posb)
  
              ||
              # then by name
              ($a cmp $b)
          } keys %$args_p) {
              #$log->tracef("TMP: handle cmdline_src for arg=%s", $an);
              my $as = $args_p->{$an};
              my $src = $as->{cmdline_src};
              my $type = $as->{schema}[0]
                  or die "BUG: No schema is defined for arg '$an'";
              # Riap::HTTP currently does not support streaming input
              my $do_stream = $as->{stream} && $url !~ /^https?:/;
              if ($src) {
                  die [531,
                       "Invalid 'cmdline_src' value for argument '$an': $src"]
                      unless $src =~ /\A(stdin|file|stdin_or_files?|stdin_line)\z/;
                  die [531,
                       "Sorry, argument '$an' is set cmdline_src=$src, but type ".
                           "is not str/buf/array, only those are supported now"]
                      unless $do_stream || $type =~ /\A(str|buf|array)\z/;
                  if ($src =~ /\A(stdin|stdin_or_files?)\z/) {
                      die [531, "Only one argument can be specified ".
                               "cmdline_src stdin/stdin_or_file/stdin_or_files"]
                          if $stdin_seen++;
                  }
                  my $is_ary = $type eq 'array';
                  if ($src eq 'stdin_line' && !exists($r->{args}{$an})) {
                      require Perinci::Object;
                      require Term::ReadKey;
                      my $prompt = Perinci::Object::rimeta($as)->langprop('cmdline_prompt') //
                          sprintf($self->default_prompt_template, $an);
                      print $prompt;
                      my $iactive = (-t STDOUT);
                      Term::ReadKey::ReadMode('noecho')
                            if $iactive && $as->{is_password};
                      chomp($r->{args}{$an} = <STDIN>);
                      do { print "\n"; Term::ReadKey::ReadMode(0) }
                          if $iactive && $as->{is_password};
                      $r->{args}{"-cmdline_src_$an"} = 'stdin_line';
                  } elsif ($src eq 'stdin' || $src eq 'file' &&
                          ($r->{args}{$an}//"") eq '-') {
                      die [400, "Argument $an must be set to '-' which means ".
                               "from stdin"]
                          if defined($r->{args}{$an}) &&
                              $r->{args}{$an} ne '-';
                      #$log->trace("Getting argument '$an' value from stdin ...");
                      $r->{args}{$an} = $do_stream ?
                          __gen_iter(\*STDIN, $as->{schema}, $an) :
                              $is_ary ? [<STDIN>] :
                                  do {local $/; ~~<STDIN>};
                      $r->{args}{"-cmdline_src_$an"} = 'stdin';
                  } elsif ($src eq 'stdin_or_file' || $src eq 'stdin_or_files') {
                      # push back argument value to @ARGV so <> can work to slurp
                      # all the specified files
                      local @ARGV = @ARGV;
                      unshift @ARGV, $r->{args}{$an}
                          if defined $r->{args}{$an};
  
                      # with stdin_or_file, we only accept one file
                      splice @ARGV, 1
                          if @ARGV > 1 && $src eq 'stdin_or_file';
  
                      #$log->tracef("Getting argument '$an' value from ".
                      #                 "$src, \@ARGV=%s ...", \@ARGV);
  
                      # perl doesn't seem to check files, so we check it here
                      for (@ARGV) {
                          next if $_ eq '-';
                          die [500, "Can't read file '$_': $!"] if !(-r $_);
                      }
  
                      $r->{args}{"-cmdline_srcfilenames_$an"} = [@ARGV];
                      $r->{args}{$an} = $do_stream ?
                          __gen_iter(\*ARGV, $as->{schema}, $an) :
                              $is_ary ? [<>] :
                                  do {local $/; ~~<>};
                      $r->{args}{"-cmdline_src_$an"} = $src;
                  } elsif ($src eq 'file') {
                      unless (exists $r->{args}{$an}) {
                          if ($as->{req}) {
                              die [400,
                                   "Please specify filename for argument '$an'"];
                          } else {
                              next;
                          }
                      }
                      die [400, "Please specify filename for argument '$an'"]
                          unless defined $r->{args}{$an};
                      #$log->trace("Getting argument '$an' value from ".
                      #                "file ...");
                      my $fh;
                      my $fname = $r->{args}{$an};
                      unless (open $fh, "<", $fname) {
                          die [500, "Can't open file '$fname' for argument '$an'".
                                   ": $!"];
                      }
                      $r->{args}{$an} = $do_stream ?
                          __gen_iter($fh, $as->{schema}, $an) :
                              $is_ary ? [<$fh>] :
                                  do { local $/; ~~<$fh> };
                      $r->{args}{"-cmdline_src_$an"} = 'file';
                      $r->{args}{"-cmdline_srcfilenames_$an"} = [$fname];
                  }
              }
  
              # encode to base64 if binary and we want to cross network (because
              # it's usually JSON)
              if ($self->riap_version == 1.2 && $is_network &&
                      defined($r->{args}{$an}) && $args_p->{$an}{schema} &&
                          $args_p->{$an}{schema}[0] eq 'buf' &&
                              !$r->{args}{"$an:base64"}) {
                  require MIME::Base64;
                  $r->{args}{"$an:base64"} =
                      MIME::Base64::encode_base64($r->{args}{$an}, "");
                  delete $r->{args}{$an};
              }
          } # for arg
      }
      #$log->tracef("args after cmdline_src is processed: %s", $r->{args});
  }
  
  # determine filehandle to output to (normally STDOUT, but we can also send to a
  # pager
  sub select_output_handle {
      my ($self, $r) = @_;
  
      my $resmeta = $r->{res}[3] // {};
  
      my $handle;
      if ($resmeta->{"cmdline.page_result"}) {
          require File::Which;
          my $pager = $resmeta->{"cmdline.pager"} //
              $ENV{PAGER};
          unless (defined $pager) {
              $pager = "less -FRSX" if File::Which::which("less");
          }
          unless (defined $pager) {
              $pager = "more" if File::Which::which("more");
          }
          unless (defined $pager) {
              die [500, "Can't determine PAGER"];
          }
          last unless $pager; # ENV{PAGER} can be set 0/'' to disable paging
          #$log->tracef("Paging output using %s", $pager);
          open $handle, "| $pager";
      }
      $handle //= \*STDOUT;
      $r->{output_handle} = $handle;
  }
  
  sub display_result {
      require Data::Sah::Util::Type;
  
      my ($self, $r) = @_;
  
      my $meta = $r->{meta};
      my $res = $r->{res};
      my $fres = $r->{fres};
      my $resmeta = $res->[3] // {};
  
      my $handle = $r->{output_handle};
  
      my $sch = $meta->{result}{schema};
      my $type = Data::Sah::Util::Type::get_type($sch) // '';
  
      if ($resmeta->{stream} // $meta->{result}{stream}) {
          my $x = $res->[2];
          if (ref($x) eq 'CODE') {
              if (Data::Sah::Util::Type::is_simple($sch)) {
                  while (defined(my $l = $x->())) {
                      print $l;
                      print "\n" unless $type eq 'buf';
                  }
              } else {
                  require JSON;
                  state $json = JSON->new->allow_nonref;
                  while (defined(my $rec = $x->())) {
                      print $json->encode($rec), "\n";
                  }
              }
          } else {
              die [500, "Invalid stream in result (not a coderef)"];
          }
      } else {
          print $handle $fres;
      }
  }
  
  sub run {
      my ($self) = @_;
      $log->tracef("[pericmd] -> run(), \@ARGV=%s", \@ARGV);
  
      my $co = $self->common_opts;
  
      my $r = {
          orig_argv   => [@ARGV],
          common_opts => $co,
      };
  
      # completion is special case, we delegate to do_completion()
      if ($self->_detect_completion($r)) {
          $r->{res} = $self->do_completion($r);
          goto FORMAT;
      }
  
      # set default from common options
      $r->{naked_res} = $co->{naked_res}{default} if $co->{naked_res};
      $r->{format}    = $co->{format}{default} if $co->{format};
  
      if ($self->read_config) {
          # note that we will be reading config file
          $r->{read_config} = 1;
      }
  
      if ($self->read_env) {
          # note that we will be reading env for default options
          $r->{read_env} = 1;
      }
  
      eval {
          $log->tracef("[pericmd] Running hook_before_run ...");
          $self->hook_before_run($r);
  
          my $parse_res = $self->parse_argv($r);
          if ($parse_res->[0] == 501) {
              # we'll need to send ARGV to the server, because it's impossible to
              # get args from ARGV (e.g. there's a cmdline_alias with CODE, which
              # has been transformed into string when crossing network boundary)
              $r->{send_argv} = 1;
          } elsif ($parse_res->[0] != 200) {
              die $parse_res;
          }
          $r->{parse_argv_res} = $parse_res;
          $r->{args} = $parse_res->[2] // {};
  
          # set defaults
          $r->{action} //= 'call';
  
          $log->tracef("[pericmd] Running hook_after_parse_argv ...");
          $self->hook_after_parse_argv($r);
  
          $self->parse_cmdline_src($r);
  
          #$log->tracef("TMP: parse_res: %s", $parse_res);
  
          my $missing = $parse_res->[3]{"func.missing_args"};
          die [400, "Missing required argument(s): ".join(", ", @$missing)]
              if $missing && @$missing;
  
          my $scd = $r->{subcommand_data};
          if ($scd->{pass_cmdline_object} // $self->pass_cmdline_object) {
              $r->{args}{-cmdline} = $self;
              $r->{args}{-cmdline_r} = $r;
          }
  
          $log->tracef("[pericmd] Running hook_before_action ...");
          $self->hook_before_action($r);
  
          my $meth = "action_$r->{action}";
          die [500, "Unknown action $r->{action}"] unless $self->can($meth);
          $log->tracef("[pericmd] Running %s() ...", $meth);
          $r->{res} = $self->$meth($r);
          #$log->tracef("[pericmd] res=%s", $r->{res}); #1
  
          $log->tracef("[pericmd] Running hook_after_action ...");
          $self->hook_after_action($r);
      };
      my $err = $@;
      if ($err || !$r->{res}) {
          if ($err) {
              $err =~ s/\n+$//;
              $err = [500, "Died: $err"] unless ref($err) eq 'ARRAY';
              $r->{res} = $err;
          } else {
              $r->{res} = [500, "Bug: no response produced"];
          }
      } elsif (ref($r->{res}) ne 'ARRAY') {
          $log->tracef("[pericmd] res=%s", $r->{res}); #2
          $r->{res} = [500, "Bug in program: result not an array"];
      } elsif (!$r->{res}[0] || $r->{res}[0] < 200 || $r->{res}[0] > 555) {
          $log->tracef("[pericmd] res=%s", $r->{res}); #3
          $r->{res} = [500, "Bug in program: invalid result status, ".
                           "must be 200 <= x <= 555"];
      }
      $r->{format} //= $r->{res}[3]{'cmdline.default_format'};
      $r->{format} //= $r->{meta}{'cmdline.default_format'};
      my $restore_orig_result;
      my $orig_result;
      if (exists $r->{res}[3]{'cmdline.result'}) {
          # temporarily change the result for formatting
          $restore_orig_result = 1;
          $orig_result = $r->{res}[2];
          $r->{res}[2] = $r->{res}[3]{'cmdline.result'};
      }
    FORMAT:
      if ($r->{res}[3]{'cmdline.skip_format'}) {
          $r->{fres} = $r->{res}[2];
      } elsif ($r->{res}[3]{stream} // $r->{meta}{result}{stream}) {
          # stream will be formatted as displayed by display_result()
      } else {
          $log->tracef("[pericmd] Running hook_format_result ...");
          $r->{fres} = $self->hook_format_result($r) // '';
      }
      $self->select_output_handle($r);
      $log->tracef("[pericmd] Running hook_display_result ...");
      $self->hook_display_result($r);
      $log->tracef("[pericmd] Running hook_after_run ...");
      $self->hook_after_run($r);
  
      if ($restore_orig_result) {
          $r->{res}[2] = $orig_result;
      }
  
      my $exitcode;
      if ($r->{res}[3] && defined($r->{res}[3]{'cmdline.exit_code'})) {
          $exitcode = $r->{res}[3]{'cmdline.exit_code'};
      } else {
          $exitcode = $self->status2exitcode($r->{res}[0]);
      }
      if ($self->exit) {
          $log->tracef("[pericmd] exit(%s)", $exitcode);
          exit $exitcode;
      } else {
          # so this can be tested
          $log->tracef("[pericmd] <- run(), exitcode=%s", $exitcode);
          $r->{res}[3]{'x.perinci.cmdline.base.exit_code'} = $exitcode;
          return $r->{res};
      }
  }
  
  1;
  # ABSTRACT: Base class for Perinci::CmdLine{Classic,::Lite}
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::CmdLine::Base - Base class for Perinci::CmdLine{Classic,::Lite}
  
  =head1 VERSION
  
  This document describes version 1.10 of Perinci::CmdLine::Base (from Perl distribution Perinci-CmdLine-Lite), released on 2015-04-12.
  
  =head1 DESCRIPTION
  
  =for Pod::Coverage ^(.+)$
  
  =head1 PROGRAM FLOW (NORMAL)
  
  If you execute C<run()>, this is what will happen, in order:
  
  =over
  
  =item * Detect if we are running under tab completion mode
  
  This is done by checking the existence of special environment varibles like
  C<COMP_LINE> or C<COMMAND_LINE> (tcsh). If yes, then jump to L</"PROGRAM FLOW
  (TAB COMPLETION)">. Otherwise, continue.
  
  =item * Run hook_before_run, if defined
  
  This hook (and every other hook) will be passed a single argument C<$r>, a hash
  that contains request data (see L</"REQUEST KEYS">).
  
  Some ideas that you can do in this hook: XXX.
  
  =item * Parse command-line arguments (@ARGV) and set C<action>
  
  If C<read_env> attribute is set to true, and there is environment variable
  defined to set default options (see documentation on L<read_env> and C<env_name>
  attributes) then the environment variable is parsed and prepended first to the
  command-line, so it can be parsed together. For example, if your program is
  called C<foo> and environment variable C<FOO_OPT> is set to C<--opt1 --opt2
  val>. When you execute:
  
   % foo --no-opt1 --trace 1 2
  
  then C<@ARGV> will be set to C<<('--opt1', '--opt2', 'val', '--no-opt1',
  '--trace', 1, 2)>>. This way, command-line arguments can have a higher
  precedence and override setting from the environment variable (in the example,
  C<--opt1> is negated by C<--no-opt1>).
  
  Currently, parsing is done in two steps. The first step is to extract subcommand
  name. Because we want to allow e.g. C<cmd --verbose subcmd> in addition to C<cmd
  subcmd> (that is, user is allowed to specify options before subcommand name) we
  cannot simply get subcommand name from the first element of C<@ARGV> but must
  parse command-line options. Also, we want to allow user specifying subcommand
  name from option C<cmd --cmd subcmd> because we want to support the notion of
  "default subcommand" (subcommand that takes effect if there is no subcommand
  specified).
  
  In the first step, since we do not know the subcommand yet, we only parse common
  options and strip them. Unknown options at this time will be passed through.
  
  If user specifies common option like C<--help> or <--version>, then action will
  be set to (respectively) C<help> and C<version> and the second step will be
  skipped. Otherwise we continue the the second step and action by default is set
  to C<call>.
  
  At the end of the first step, we already know the subcommand name (of course, if
  subcommand name is unknown, we exit with error) along with subcommand spec: its
  URL, per-subcommand settings, and so on (see the C<subcommands> attribute). If
  there are no subcommands, subcommand name is set to C<''> (empty string) and the
  subcommand spec is filled from the attributes, e.g. C<url>, C<summary>, <tags>,
  and so on.
  
  We then perform a C<meta> Riap request to the URL to get the Rinci metadata.
  After that, C<hook_after_get_meta> is run if provided. From the Rinci metadata
  we get list of arguments (the C<args> property). From this, we generate a spec
  of command-line options to feed to L<Getopt::Long>. There are some conversions
  being done, e.g. an argument called C<foo_bar> will become command-line option
  C<--foo-bar>. Command-line aliases from metadata are also added to the
  C<Getopt::Long> spec.
  
  It is also at this step that we read config file (if C<read_config> attribute is
  true). We run C<hook_before_read_config_file> first. Some ideas to do in this
  hook: setting default config profile.
  
  We then pass the spec to C<Getopt::Long::GetOptions>, we get function arguments.
  
  We then run C<hook_after_parse_argv>. Some ideas to do in this hook: XXX.
  
  Function arguments that are still missing can be filled from STDIN or files, if
  the metadata specifies C<cmdline_src> property (see L<Rinci::function> for more
  details).
  
  =item * Delegate to C<action_$action> method
  
  Before running the C<action_$action> method, C<hook_before_action> is called
  e.g. to allow changing/fixing action, last chance to check arguments, etc.
  
  After we get the action from the previous step, we delegate to separate
  C<action_$action> method (so there is C<action_version>, C<action_help>, and so
  on; and also C<action_call>). These methods also receive C<$r> as their argument
  and must return an enveloped result (see L<Rinci::function> for more details).
  
  Result is put in C<< $r->{res} >>.
  
  C<hook_after_action> is then called e.g. to preformat result.
  
  =item * Run hook_format_result
  
  Hook must set C<< $r->{fres} >> (formatted result).
  
  If result has C<cmdline.skip_format> result metadata property, then this step is
  skipped and C<< $r->{fres} >> is simply taken from C<< $r->{res}[2] >>.
  
  =item * Run hook_display_result
  
  This hook is used by XXX.
  
  =item * Run hook_after_run, if defined
  
  Some ideas to do in this hook: XXX.
  
  =item * Exit (or return result)
  
  If C<exit> attribute is true, will C<exit()> with the action's envelope result
  status. If status is 200, exit code is 0. Otherwise exit code is status minus
  300. So, a response C<< [501, "Not implemented"] >> will result in exit code of
  201.
  
  If C<exit> attribute is false, will simply return the action result (C<<
  $r->{res} >>). And will also set exit code in C<<
  $r->{res}[3]{'x.perinci.cmdline.base.exit_code'} >>.
  
  =back
  
  =head1 PROGRAM FLOW (TAB COMPLETION)
  
  If program is detected running in tab completion mode, there is some differences
  in the flow. First, C<@ARGV> is set from C<COMP_LINE> (or C<COMMAND_LINE>)
  environment variable. Afterwards, completion is done by calling
  L<Perinci::Sub::Complete>'s C<complete_cli_arg>.
  
  The result is then output to STDOUT (resume from Run hook_format_result step in
  the normal program flow).
  
  =head1 REQUEST KEYS
  
  The various values in the C<$r> hash/stash.
  
  =over
  
  =item * orig_argv => array
  
  Original C<@ARGV> at the beginning of C<run()>.
  
  =item * common_opts => hash
  
  Value of C<common_opts> attribute, for convenience.
  
  =item * action => str
  
  Selected action to use. Usually set from the common options.
  
  =item * format => str
  
  Selected format to use. Usually set from the common option C<--format>.
  
  =item * read_config => bool
  
  This is set in run() to signify that we have tried to read config file (this is
  set to true even though config file does not exist). This is never set to true
  when C<read_config> attribute is set, which means that we never try to read any
  config file.
  
  =item * read_env => bool
  
  This is set in run() to signify that we will try to read env for default
  options. This settng can be turned off e.g. in common option C<no_env>. This is
  never set to true when C<read_env> attribute is set to false, which means that
  we never try to read environment.
  
  =item * config => hash
  
  This is set in the routine that reads config file, containing the config hash.
  It might be an empty hash (if there is on config file to read), or a hash with
  sections as keys and hashrefs as values (configuration for each section). The
  data can be merged from several existing config files.
  
  =item * read_config_files => array
  
  This is set in the routine that reads config file, containing the list of config
  files actually read, in order.
  
  =item * config_paths => array of str
  
  =item * config_profile => str
  
  =item * parse_argv_res => array
  
  Enveloped result of C<parse_argv()>.
  
  =item * ignore_missing_config_profile_section => bool (default 1)
  
  This is checked in the parse_argv(). To aid error checking, when a user
  specifies a profile (e.g. via C<--config-profile FOO>) and config file exists
  but the said profile section is not found in the config file, an error is
  returned. This is to notify user that perhaps she mistypes the profile name.
  
  But this checking can be turned off with this setting. This is sometimes used
  when e.g. a subclass wants to pick a config profile automatically by setting C<<
  $r->{config_profile} >> somewhere before reading config file, but do not want to
  fail execution when config profile is not found. An example of code that does
  this is L<Perinci::CmdLine::fatten>.
  
  =item * subcommand_name => str
  
  Also set by C<parse_argv()>. The subcommand name in effect, either set
  explicitly by user using C<--cmd> or the first command-line argument, or set
  implicitly with the C<default_subcommand> attribute. Undef if there is no
  subcommand name in effect.
  
  =item * subcommand_name_from => str
  
  Also set by C<parse_argv()>. Tells how the C<subcommand_name> request key is
  set. Value is either C<--cmd> (if set through C<--cmd> common option), C<arg>
  (if set through first command-line argument), C<default_subcommand> (if set to
  C<default_subcommand> attribute), or undef if there is no subcommand_name set.
  
  =item * subcommand_data => hash
  
  Also set by C<parse_argv()>. Subcommand data, including its URL, summary (if
  exists), and so on. Note that if there is no subcommand, this will contain data
  for the main command, i.e. URL will be set from C<url> attribute, summary from
  C<summary> attribute, and so on. This is a convenient way to get what URL and
  summary to use, and so on.
  
  =item * skip_parse_subcommand_argv => bool
  
  Checked by C<parse_argv()>. Can be set to 1, e.g. in common option handler for
  C<--help> or C<--version> to skip parsing @ARGV for per-subcommand options.
  
  =item * args => hash
  
  Also taken from C<parse_argv()> result.
  
  =item * meta => hash
  
  Result of C<get_meta()>.
  
  =item * dry_run => bool
  
  Whether to pass C<-dry_run> special argument to function.
  
  =item * res => array
  
  Enveloped result of C<action_ACTION()>.
  
  =item * fres => str
  
  Result from C<hook_format_result()>.
  
  =item * output_handle => handle
  
  Set by select_output_handle() to choose output handle. Normally it's STDOUT but
  can also be pipe to pager (if paging is turned on).
  
  =item * naked_res => bool
  
  Set to true if user specifies C<--naked-res>.
  
  =back
  
  =head1 CONFIGURATION
  
  Configuration can be used to set function arguments as well as some common
  options.
  
  Configuration is currently in the L<IOD> (basically INI) format.
  
  By default these paths are searched: C<$HOME/.config/$prog_name.conf>,
  C<$HOME/$prog_name.conf>, C</etc/$prog_name.conf>. The location can be
  customized from command-line option C<--config-path>.
  
  All existing configuration files will be read in order, and the result merged if
  more than one files exist.
  
  Section names map to subcommand names. For application that does not have
  subcommand, you can put parameters outside any section, e.g.:
  
   param=val
   otherparam=val
   ...
  
  For application that has subcommands, put parameters inside section with the
  same name as the subcommand name:
  
   [subcommand1]
   param=val
   ...
  
   [subcommand2]
   param2=val
   ...
  
  Or you can also put some parameters outside the section which will be used for
  all subcommands:
  
   commonarg=val
  
   [subcommand1]
   param1=val
   ...
  
   [subcommand2]
   param2=val
   ...
  
  A configuration file can also have (multiple) profiles, to allow multiple
  configuration to be stored in a single file. Section names can have
  "profile=PROFILENAME" suffix to mark it as belonging to a certain profile.
  Parameters in sections with matching "profile=PROFILENAME" will be read.
  Parameters in sections without any profile names will still be read. Example:
  
   a=0
   b=0
   d=9
  
   [profile=p1]
   a=1
   b=2
  
   [profile=p2]
   a=10
   b=20
  
   [subcommand1 profile=p1]
   c=3
  
   [subcommand1 profile=p2]
   c=1
  
  If you run:
  
   % cmd subcommand1
  
  then your subcommand1 function will get: a=0, b=0, d=9.
  
   % cmd subcommand1 --config-profile p1
  
  then your subcommand1 function will get: a=1, b=2, c=3, d=9. If you run:
  
   % cmd subcommand1 --config-profile p2
  
  then your subcommand1 function will get: a=10, b=20, c=30, d=9.
  
  Parameter names map to function argument names or common option. If a common
  option name clashes with a function argument name, the function argument is
  accessible using the C<NAME.arg> syntax. For example, C<log_level> is a common
  option name. If your function also has a C<log_level> argument, to set this
  function argument, you write:
  
   log_level.arg=blah
  
  =head1 ATTRIBUTES
  
  =head2 actions => array
  
  Contains a list of known actions and their metadata. Keys should be action
  names, values should be metadata. Metadata is a hash containing these keys:
  
  =head2 common_opts => hash
  
  A hash of common options, which are command-line options that are not associated
  with any subcommand. Each option is itself a specification hash containing these
  keys:
  
  =over
  
  =item * category (str)
  
  Optional, for grouping options in help/usage message, defaults to C<Common
  options>.
  
  =item * getopt (str)
  
  Required, for Getopt::Long specification.
  
  =item * handler (code)
  
  Required, for Getopt::Long specification. Note that the handler will receive
  C<<($geopt, $val, $r)>> (an extra C<$r>).
  
  =item * usage (str)
  
  Optional, displayed in usage line in help/usage text.
  
  =item * summary (str)
  
  Optional, displayed in description of the option in help/usage text.
  
  =item * show_in_usage (bool or code, default: 1)
  
  A flag, can be set to 0 if we want to skip showing this option in usage in
  --help, to save some space. The default is to show all, except --subcommand when
  we are executing a subcommand (obviously).
  
  =item * show_in_options (bool or code, default: 1)
  
  A flag, can be set to 0 if we want to skip showing this option in options in
  --help. The default is to 0 for --help and --version in compact help. Or
  --subcommands, if we are executing a subcommand (obviously).
  
  =item * order (int)
  
  Optional, for ordering. Lower number means higher precedence, defaults to 1.
  
  =back
  
  A partial example from the default set by the framework:
  
   {
       help => {
           category        => 'Common options',
           getopt          => 'help|h|?',
           usage           => '--help (or -h, -?)',
           handler         => sub { ... },
           order           => 0,
           show_in_options => sub { $ENV{VERBOSE} },
       },
       format => {
           category    => 'Common options',
           getopt      => 'format=s',
           summary     => 'Choose output format, e.g. json, text',
           handler     => sub { ... },
       },
       undo => {
           category => 'Undo options',
           getopt   => 'undo',
           ...
       },
       ...
   }
  
  The default contains: help (getopt C<help|h|?>), version (getopt C<version|v>),
  action (getopt C<action>), format (getopt C<format=s>), format_options (getopt
  C<format-options=s>), json). If there are more than one subcommands, this will
  also be added: list (getopt C<list|l>). If dry-run is supported by function,
  there will also be: dry_run (getopt C<dry-run>). If undo is turned on, there
  will also be: undo (getopt C<undo>), redo (getopt C<redo>), history (getopt
  C<history>), clear_history (getopt C<clear-history>).
  
  Sometimes you do not want some options, e.g. to remove C<format> and
  C<format_options>:
  
   delete $cmd->common_opts->{format};
   delete $cmd->common_opts->{format_options};
   $cmd->run;
  
  Sometimes you want to rename some command-line options, e.g. to change version
  to use capital C<-V> instead of C<-v>:
  
   $cmd->common_opts->{version}{getopt} = 'version|V';
  
  Sometimes you want to add subcommands as common options instead. For example:
  
   $cmd->common_opts->{halt} = {
       category    => 'Server options',
       getopt      => 'halt',
       summary     => 'Halt the server',
       handler     => sub {
           my ($go, $val, $r) = @_;
           $r->{subcommand_name} = 'shutdown';
       },
   };
  
  This will make:
  
   % cmd --halt
  
  equivalent to executing the 'shutdown' subcommand:
  
   % cmd shutdown
  
  =head2 completion => code
  
  Will be passed to L<Perinci::Sub::Complete>'s C<complete_cli_arg()>. See its
  documentation for more details.
  
  =head2 default_subcommand => str
  
  Set subcommand to this if user does not specify which to use (either via first
  command-line argument or C<--cmd> option). See also: C<get_subcommand_from_arg>.
  
  =head2 get_subcommand_from_arg => int (default: 1)
  
  The default is 1, which is to get subcommand from the first command-line
  argument except when there is C<default_subcommand> defined. Other valid values
  are: 0 (not getting from first command-line argument), 2 (get from first
  command-line argument even though there is C<default_subcommand> defined).
  
  =head2 description => str
  
  =head2 exit => bool (default: 1)
  
  =head2 formats => array
  
  Available output formats.
  
  =head2 pass_cmdline_object => bool (default: 0)
  
  Whether to pass special argument C<-cmdline> containing the cmdline object to
  function. This can be overriden using the C<pass_cmdline_object> on a
  per-subcommand basis.
  
  In addition to C<-cmdline>, C<-cmdline_r> will also be passed, containing the
  C<$r> per-request stash/hash (see L</"REQUEST KEYS">).
  
  Passing the cmdline object can be useful, e.g. to call action_help(), to get the
  settings of the Perinci::CmdLine, etc.
  
  =head2 program_name => str
  
  Default is from PERINCI_CMDLINE_PROGRAM_NAME environment or from $0.
  
  =head2 riap_client => float (default: 1.1)
  
  Specify L<Riap> protocol version to use. Will be passed to C<riap_client_args>.
  
  =head2 riap_client => obj
  
  Set to L<Perinci::Access> (or compatible) instance. PC::Lite uses lighter
  version L<Perinci::Access::Lite>.
  
  =head2 riap_version => float (default: 1.1)
  
  Will be passed to Riap client constructor as well.
  
  =head2 riap_client_args => hash
  
  Arguments to pass to L<Perinci::Access> constructor. This is useful for passing
  e.g. HTTP basic authentication to Riap client
  (L<Perinci::Access::HTTP::Client>):
  
   riap_client_args => {handler_args => {user=>$USER, password=>$PASS}}
  
  =head2 subcommands => hash | code
  
  Should be a hash of subcommand specifications or a coderef.
  
  Each subcommand specification is also a hash(ref) and should contain these keys:
  
  =over
  
  =item * C<url> (str, required)
  
  Location of function (accessed via Riap).
  
  =item * C<summary> (str, optional)
  
  Will be retrieved from function metadata at C<url> if unset
  
  =item * C<description> (str, optional)
  
  Shown in verbose help message, if description from function metadata is unset.
  
  =item * C<tags> (array of str, optional)
  
  For grouping or categorizing subcommands, e.g. when displaying list of
  subcommands.
  
  =item * C<log_any_app> (bool, optional)
  
  Whether to load Log::Any::App, default is true. For subcommands that need fast
  startup you can try turning this off for said subcommands. See L</"LOGGING"> for
  more details.
  
  =item * C<use_utf8> (bool, optional)
  
  Whether to issue L<< binmode(STDOUT, ":utf8") >>. See L</"LOGGING"> for more
  details.
  
  =item * C<undo> (bool, optional)
  
  Can be set to 0 to disable transaction for this subcommand; this is only
  relevant when C<undo> attribute is set to true.
  
  =item * C<show_in_help> (bool, optional, default 1)
  
  If you have lots of subcommands, and want to show only some of them in --help
  message, set this to 0 for subcommands that you do not want to show.
  
  =item * C<pass_cmdline_object> (bool, optional, default 0)
  
  To override C<pass_cmdline_object> attribute on a per-subcommand basis.
  
  =item * C<args> (hash, optional)
  
  If specified, will send the arguments (as well as arguments specified via the
  command-line). This can be useful for a function that serves more than one
  subcommand, e.g.:
  
   subcommands => {
       sub1 => {
           summary => 'Subcommand one',
           url     => '/some/func',
           args    => {flag=>'one'},
       },
       sub2 => {
           summary => 'Subcommand two',
           url     => '/some/func',
           args    => {flag=>'two'},
       },
   }
  
  In the example above, both subcommand C<sub1> and C<sub2> point to function at
  C</some/func>. But the function can differentiate between the two via the
  C<flag> argument being sent.
  
   % cmdprog sub1 --foo 1 --bar 2
   % cmdprog sub2 --foo 2
  
  In the first invocation, function will receive arguments C<< {foo=>1, bar=>2,
  flag=>'one'} >> and for the second: C<< {foo=>2, flag=>'two'} >>.
  
  =back
  
  Subcommands can also be a coderef, for dynamic list of subcommands. The coderef
  will be called as a method with hash arguments. It can be called in two cases.
  First, if called without argument C<name> (usually when doing --subcommands) it
  must return a hashref of subcommand specifications. If called with argument
  C<name> it must return subcommand specification for subcommand with the
  requested name only.
  
  =head2 summary => str
  
  =head2 tags => array of str
  
  =head2 url => str
  
  Required if you only want to run one function. URL should point to a function
  entity.
  
  Alternatively you can provide multiple functions from which the user can select
  using the first argument (see B<subcommands>).
  
  =head2 read_env => bool (default: 1)
  
  Whether to read environment variable for default options.
  
  =head2 env_name => str
  
  Environment name to read default options from. Default is from program name,
  upper-cased, sequences of dashes/nonalphanums replaced with a single underscore,
  plus a C<_OPT> suffix. So if your program name is called C<cpandb-cpanmeta> the
  default environment name is C<CPANDB_CPANMETA_OPT>.
  
  =head2 read_config => bool (default: 1)
  
  Whether to read configuration files.
  
  =head2 config_dirs => array of str
  
  Which directories to look for configuration file. The default is to look at the
  user's home and then system location. On Unix, it's C<< [ "$ENV{HOME}/.config",
  $ENV{HOME}, "/etc"] >>. If $ENV{HOME} is empty, getpwuid() is used to get home
  directory entry.
  
  =head2 config_filename => str
  
  Configuration filename. The default is C<< program_name . ".conf" >>. For
  example, if your program is named C<foo-bar>, config_filename will be
  C<foo-bar.conf>.
  
  =head1 METHODS
  
  =head2 $cmd->run() => ENVRES
  
  The main method to run your application. See L</"PROGRAM FLOW"> for more details
  on what this method does.
  
  =head2 $cmd->do_completion() => ENVRES
  
  Called by run().
  
  =head2 $cmd->parse_argv() => ENVRES
  
  Called by run().
  
  =head2 $cmd->get_meta($r, $url) => ENVRES
  
  Called by parse_argv() or do_completion(). Subclass has to implement this.
  
  =head1 HOOKS
  
  All hooks will receive the argument C<$r>, a per-request hash/stash. The list
  below is by order of calling.
  
  =head2 $cmd->hook_before_run($r)
  
  Called at the start of C<run()>. Can be used to set some initial values of other
  C<$r> keys. Or setup the logger.
  
  =head2 $cmd->hook_before_read_config_file($r)
  
  Only called when C<read_config> attribute is true.
  
  =head2 $cmd->hook_after_read_config_file($r)
  
  Only called when C<read_config> attribute is true.
  
  =head2 $cmd->hook_after_get_meta($r)
  
  Called after the C<get_meta> method gets function metadata, which normally
  happens during parsing argument, because parsing function arguments require the
  metadata (list of arguments, etc).
  
  PC:Lite as well as PC:Classic use this hook to insert a common option
  C<--dry-run> if function metadata expresses that function supports dry-run mode.
  
  PC:Lite also checks the C<deps> property here. PC:Classic doesn't do this
  because it uses function wrapper (L<Perinci::Sub::Wrapper>) which does this.
  
  =head2 $cmd->hook_after_parse_argv($r)
  
  Called after C<run()> calls C<parse_argv()> and before it checks the result.
  C<$r->{parse_argv_res}> will contain the result of C<parse_argv()>. The hook
  gets a chance to, e.g. fill missing arguments from other source.
  
  Note that for sources specified in the C<cmdline_src> property, this base class
  will do the filling in after running this hook, so no need to do that here.
  
  PC:Lite uses this hook to give default values to function arguments C<<
  $r->{args} >> from the Rinci metadata. PC:Classic doesn't do this because it
  uses function wrapper (L<Perinci::Sub::Wrapper>) which will do this as well as
  some other stuffs (validate function arguments, etc).
  
  =head2 $cmd->hook_before_action($r)
  
  Called before calling the C<action_ACTION> method. Some ideas to do in this
  hook: modifying action to run (C<< $r->{action} >>), last check of arguments
  (C<< $r->{args} >>) before passing them to function.
  
  PC:Lite uses this hook to validate function arguments. PC:Classic does not do
  this because it uses function wrapper which already does this.
  
  =head2 $cmd->hook_after_action($r)
  
  Called after calling C<action_ACTION> method. Some ideas to do in this hook:
  preformatting result (C<< $r->{res} >>).
  
  =head2 $cmd->hook_format_result($r)
  
  The hook is supposed to format result in C<$res->{res}> (an array).
  
  All direct subclasses of PC:Base do the formatting here.
  
  =head2 $cmd->hook_display_result($r)
  
  The hook is supposed to display the formatted result (stored in C<$r->{fres}>)
  to STDOUT. But in the case of streaming output, this hook can also set it up.
  
  All direct subclasses of PC:Base do the formatting here.
  
  =head2 $cmd->hook_after_run($r)
  
  Called at the end of C<run()>, right before it exits (if C<exit> attribute is
  true) or returns C<$r->{res}>. The hook has a chance to modify exit code or
  result.
  
  =head1 SPECIAL ARGUMENTS
  
  Below is list of special arguments that may be passed to your function by the
  framework. Per L<Rinci> specification, these are prefixed by C<-> (dash).
  
  =head2 -dry_run => bool
  
  Only when in dry run mode, to notify function that we are in dry run mode.
  
  =head2 -cmdline => obj
  
  Only when C<pass_cmdline_object> attribute is set to true. This can be useful
  for the function to know about various stuffs, by probing the framework object.
  
  =head2 -cmdline_r => hash
  
  Only when C<pass_cmdline_object> attribute is set to true. Contains the C<$r>
  per-request hash/stash. This can be useful for the function to know about
  various stuffs, e.g. parsed configuration data, etc.
  
  =head2 -cmdline_src_ARGNAME => str
  
  This will be set if argument is retrieved from C<file>, C<stdin>,
  C<stdin_or_file>, C<stdin_or_files>, or C<stdin_line>.
  
  =head2 -cmdline_srcfilenames_ARGNAME => array
  
  An extra information if argument value is retrieved from file(s), so the
  function can know the filename(s).
  
  =head1 METADATA PROPERTY ATTRIBUTE
  
  This module observes the following Rinci metadata property attributes:
  
  =head2 cmdline.default_format => STR
  
  Set default output format (if user does not specify via --format command-line
  option).
  
  =head1 RESULT METADATA
  
  This module interprets the following result metadata property/attribute:
  
  =head2 attribute: cmdline.exit_code => int
  
  Instruct to use this exit code, instead of using (function status - 300).
  
  =head2 attribute: cmdline.result => any
  
  Replace result. Can be useful for example in this case:
  
   sub is_palindrome {
       my %args = @_;
       my $str = $args{str};
       my $is_palindrome = $str eq reverse($str);
       [200, "OK", $is_palindrome,
        {"cmdline.result" => ($is_palindrome ? "Palindrome" : "Not palindrome")}];
   }
  
  When called as a normal function we return boolean value. But as a CLI, we
  display a more user-friendly message.
  
  =head2 attribute: cmdline.default_format => str
  
  Default format to use. Can be useful when you want to display the result using a
  certain format by default, but still allows user to override the default.
  
  =head2 attribute: cmdline.page_result => bool
  
  If you want to filter the result through pager (currently defaults to
  C<$ENV{PAGER}> or C<less -FRSX>), you can set C<cmdline.page_result> in result
  metadata to true.
  
  For example:
  
   $SPEC{doc} = { ... };
   sub doc {
       ...
       [200, "OK", $doc, {"cmdline.page_result"=>1}];
   }
  
  =head2 attribute: cmdline.pager => STR
  
  Instruct to use specified pager instead of C<$ENV{PAGER}> or the default C<less>
  or C<more>.
  
  =head2 attribute: cmdline.skip_format => bool (default: 0)
  
  When we want the command-line framework to just print the result without any
  formatting.
  
  =head2 attribute: x.perinci.cmdline.base.exit_code => int
  
  This is added by this module, so exit code can be tested.
  
  =head1 ENVIRONMENT
  
  =over
  
  =item * PAGER => str
  
  Like in other programs, can be set to select the pager program (when
  C<cmdline.page_result> result metadata is active). Can also be set to C<''> or
  C<0> to explicitly disable paging even though C<cmd.page_result> result metadata
  is active.
  
  =item * PERINCI_CMDLINE_PROGRAM_NAME => STR
  
  Can be used to set CLI program name.
  
  =back
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-CmdLine-Lite>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-CmdLine-Lite>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-CmdLine-Lite>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_CMDLINE_BASE

$fatpacked{"Perinci/CmdLine/Help.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_CMDLINE_HELP';
  package Perinci::CmdLine::Help;
  
  our $DATE = '2015-04-11'; # DATE
  our $VERSION = '0.06'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(gen_help);
  
  our %SPEC;
  
  $SPEC{gen_help} = {
      v => 1.1,
      summary => 'Generate help message for Perinci::CmdLine-based app',
      args => {
          program_name => {
              schema => 'str*',
              req => 1,
          },
          program_summary => {
              schema => 'str*',
          },
          subcommands => {
              schema => 'hash',
          },
          meta => {
              summary => 'Function metadata, must be normalized',
              schema => 'hash*',
              req => 1,
          },
          common_opts => {
              schema => 'hash*',
              default => {},
          },
          per_arg_json => {
              schema => 'bool*',
          },
          per_arg_yaml => {
              schema => 'bool*',
          },
      },
  };
  sub gen_help {
      my %args = @_;
  
      my $meta = $args{meta};
      my $common_opts = $args{common_opts} // {};
  
      my @help;
  
      # summary
      my $progname = $args{program_name};
      push @help, $progname;
      {
          my $sum = $args{program_summary} // $meta->{summary};
          last unless $sum;
          push @help, " - ", $sum, "\n";
      }
  
      my $clidocdata;
  
      # usage
      push @help, "\nUsage:\n";
      {
          for (sort {
              ($common_opts->{$a}{order} // 99) <=>
                  ($common_opts->{$b}{order} // 99) ||
                      $a cmp $b
              } keys %$common_opts) {
              my $co = $common_opts->{$_};
              next unless $co->{usage};
              push @help, "  $progname $co->{usage}\n";
          }
  
          require Perinci::Sub::To::CLIDocData;
          my $res = Perinci::Sub::To::CLIDocData::gen_cli_doc_data_from_meta(
              meta => $meta, meta_is_normalized => 1,
              common_opts  => $common_opts,
              per_arg_json => $args{per_arg_json},
              per_arg_yaml => $args{per_arg_yaml},
          );
          die [500, "gen_cli_doc_data_from_meta failed: ".
                   "$res->[0] - $res->[1]"] unless $res->[0] == 200;
          $clidocdata = $res->[2];
          my $usage = $clidocdata->{usage_line};
          $usage =~ s/\[\[prog\]\]/$progname/;
          push @help, "  $usage\n";
      }
  
      # subcommands
      {
          my $subcommands = $args{subcommands} or last;
          push @help, "\nSubcommands:\n";
          if (keys(%$subcommands) >= 12) {
              # comma-separated list
              no warnings 'once';
              require Text::Wrap;
              local $Text::Wrap::columns = $ENV{COLUMNS} // 80;
              push @help, Text::Wrap::wrap(
                  "  ", "  ", join(", ", sort keys %$subcommands)), "\n";
          } else {
              for my $sc_name (sort keys %$subcommands) {
                  my $sc_spec = $subcommands->{$sc_name};
                  next unless $sc_spec->{show_in_help} //1;
                  push @help, "  $sc_name\n";
              }
          }
      }
  
      # example
      {
          # XXX categorize too, like options
          last unless @{ $clidocdata->{examples} };
          push @help, "\nExamples:\n";
          my $i = 0;
          my $egs = $clidocdata->{examples};
          for my $eg (@$egs) {
              $i++;
              my $cmdline = $eg->{cmdline};
              $cmdline =~ s/\[\[prog\]\]/$progname/;
              push @help, "  $eg->{summary}:\n" if $eg->{summary};
              push @help, "  % $cmdline\n";
              push @help, "\n" if $eg->{summary} && $i < @$egs;
          }
      }
  
      # description
      {
          my $desc = $args{program_description} // $meta->{description};
          last unless $desc;
          $desc =~ s/\A\n+//;
          $desc =~ s/\n+\z//;
          push @help, "\n", $desc, "\n" if $desc =~ /\S/;
      }
  
      # options
      {
          require Data::Dmp;
  
          my $opts = $clidocdata->{opts};
          last unless keys %$opts;
  
          # find all the categories
          my %options_by_cat; # val=[options...]
          for (keys %$opts) {
              push @{ $options_by_cat{$opts->{$_}{category}} }, $_;
          }
  
          my $cats_spec = $clidocdata->{option_categories};
          for my $cat (sort {
              ($cats_spec->{$a}{order} // 50) <=> ($cats_spec->{$b}{order} // 50)
                  || $a cmp $b }
                           keys %options_by_cat) {
              # find the longest option
              my @opts = sort {length($b)<=>length($a)}
                  @{ $options_by_cat{$cat} };
              my $len = length($opts[0]);
              # sort again by name
              @opts = sort {
                  (my $a_without_dash = $a) =~ s/^-+//;
                  (my $b_without_dash = $b) =~ s/^-+//;
                  lc($a) cmp lc($b);
              } @opts;
              push @help, "\n$cat:\n";
              for my $opt (@opts) {
                  my $ospec = $opts->{$opt};
                  my $arg_spec = $ospec->{arg_spec};
                  my $is_bool = $arg_spec->{schema} &&
                      $arg_spec->{schema}[0] eq 'bool';
                  my $show_default = exists($ospec->{default}) &&
                      !$is_bool && !$ospec->{is_base64} &&
                          !$ospec->{is_json} && !$ospec->{is_yaml} &&
                              !$ospec->{is_alias};
  
                  my $add_sum = '';
                  if ($ospec->{is_base64}) {
                      $add_sum = " (base64-encoded)";
                  } elsif ($ospec->{is_json}) {
                      $add_sum = " (JSON-encoded)";
                  } elsif ($ospec->{is_yaml}) {
                      $add_sum = " (YAML-encoded)";
                  }
  
                  my $argv = '';
                  if (!$ospec->{main_opt} && defined($ospec->{pos})) {
                      if ($ospec->{greedy}) {
                          $argv = " (=arg[$ospec->{pos}-])";
                      } else {
                          $argv = " (=arg[$ospec->{pos}])";
                      }
                  }
  
                  my $cmdline_src = '';
                  if (!$ospec->{main_opt} && defined($arg_spec->{cmdline_src})) {
                      $cmdline_src = " (or from $arg_spec->{cmdline_src})";
                      $cmdline_src =~ s!_or_!/!g;
                  }
  
                  push @help, sprintf(
                      "  %-${len}s  %s%s%s%s%s\n",
                      $opt,
                      $ospec->{summary}//'',
                      $add_sum,
                      $argv,
                      $cmdline_src,
                      ($show_default && defined($ospec->{default}) ?
                           " [".Data::Dmp::dmp($ospec->{default})."]":""),
  
                  );
              }
          }
      }
  
      [200, "OK", join("", @help)];
  }
  
  1;
  # ABSTRACT: Generate help message for Perinci::CmdLine-based app
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::CmdLine::Help - Generate help message for Perinci::CmdLine-based app
  
  =head1 VERSION
  
  This document describes version 0.06 of Perinci::CmdLine::Help (from Perl distribution Perinci-CmdLine-Help), released on 2015-04-11.
  
  =head1 DESCRIPTION
  
  Currently used by L<Perinci::CmdLine::Lite> and L<App::riap>. Eventually I want
  L<Perinci::CmdLine> to use this also (needs prettier and more sophisticated
  formatting options first though).
  
  =head1 FUNCTIONS
  
  
  =head2 gen_help(%args) -> [status, msg, result, meta]
  
  Generate help message for Perinci::CmdLine-based app.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<common_opts> => I<hash> (default: {})
  
  =item * B<meta>* => I<hash>
  
  Function metadata, must be normalized.
  
  =item * B<per_arg_json> => I<bool>
  
  =item * B<per_arg_yaml> => I<bool>
  
  =item * B<program_name>* => I<str>
  
  =item * B<program_summary> => I<str>
  
  =item * B<subcommands> => I<hash>
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  =for Pod::Coverage ^()$
  
  =head1 SEE ALSO
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-CmdLine-Help>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-CmdLine-Help>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-CmdLine-Help>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_CMDLINE_HELP

$fatpacked{"Perinci/CmdLine/Lite.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_CMDLINE_LITE';
  package Perinci::CmdLine::Lite;
  
  our $DATE = '2015-04-12'; # DATE
  our $VERSION = '1.10'; # VERSION
  
  use 5.010001;
  # use strict; # already enabled by Mo
  # use warnings; # already enabled by Mo
  use Log::Any::IfLOG '$log';
  
  use List::Util qw(first);
  use Mo qw(build default);
  #use Moo;
  extends 'Perinci::CmdLine::Base';
  
  # when debugging, use this instead of the above because Mo doesn't give clear
  # error message if base class has errors.
  #use parent 'Perinci::CmdLine::Base';
  
  has default_prompt_template => (
      is=>'rw',
      default => 'Enter %s: ',
  );
  has log => (
      is=>'rw',
      default => sub {
          if (defined $ENV{LOG}) {
              return $ENV{LOG};
          } elsif ($ENV{LOG_LEVEL} && $ENV{LOG_LEVEL} =~ /^(off|none)$/) {
              return 0;
          } elsif ($ENV{LOG_LEVEL} || $ENV{TRACE} || $ENV{DEBUG} ||
                       $ENV{VERBOSE} || $ENV{QUIET}) {
              return 0;
          }
          0;
      },
  );
  has log_level => (
      is=>'rw',
      default => sub {
          if ($ENV{LOG_LEVEL}) {
              return $ENV{LOG_LEVEL};
          } elsif ($ENV{TRACE}) {
              return 'trace';
          } elsif ($ENV{DEBUG}) {
              return 'debug';
          } elsif ($ENV{VERBOSE}) {
              return 'info';
          } elsif ($ENV{QUIET}) {
              return 'error';
          }
          'warning';
      },
  );
  
  my $formats = [qw/text text-simple text-pretty json json-pretty/];
  
  sub BUILD {
      my ($self, $args) = @_;
  
      if (!$self->{riap_client}) {
          require Perinci::Access::Lite;
          my %rcargs = (
              riap_version => $self->{riap_version} // 1.1,
              %{ $self->{riap_client_args} // {} },
          );
          $self->{riap_client} = Perinci::Access::Lite->new(%rcargs);
      }
  
      if (!$self->{actions}) {
          $self->{actions} = {
              call => {},
              version => {},
              subcommands => {},
              help => {},
          };
      }
  
      my $_t = sub {
          no warnings;
          my $co_name = shift;
          my $href = $Perinci::CmdLine::Base::copts{$co_name};
          %$href;
      };
  
      if (!$self->{common_opts}) {
          my $copts = {};
  
          $copts->{version}   = { $_t->('version'), };
          $copts->{help}      = { $_t->('help'), };
          $copts->{format}    = {
              $_t->('format'),
              schema => ['str*' => in => $formats],
          };
          $copts->{json}      = { $_t->('json'), };
          $copts->{naked_res} = { $_t->('naked_res'), };
          if ($self->subcommands) {
              $copts->{subcommands} = { $_t->('subcommands'), };
          }
          if ($self->default_subcommand) {
              $copts->{cmd} = { $_t->('cmd') };
          }
          if ($self->read_config) {
              $copts->{config_path}    = { $_t->('config_path') };
              $copts->{no_config}      = { $_t->('no_config') };
              $copts->{config_profile} = { $_t->('config_profile') };
          }
          if ($self->read_env) {
              $copts->{no_env} = { $_t->('no_env') };
          }
          if ($self->log) {
              $copts->{log_level} = { $_t->('log_level'), };
              $copts->{trace}     = { $_t->('trace'), };
              $copts->{debug}     = { $_t->('debug'), };
              $copts->{verbose}   = { $_t->('verbose'), };
              $copts->{quiet}     = { $_t->('quiet'), };
          }
          $self->{common_opts} = $copts;
      }
  
      $self->{formats} //= $formats;
  
      $self->{per_arg_json} //= 1;
  }
  
  my $setup_progress;
  sub _setup_progress_output {
      my $self = shift;
  
      return unless $ENV{PROGRESS} // (-t STDOUT);
  
      require Progress::Any::Output;
      Progress::Any::Output->set("TermProgressBarColor");
      $setup_progress = 1;
  }
  
  sub _unsetup_progress_output {
      my $self = shift;
  
      return unless $setup_progress;
      my $out = $Progress::Any::outputs{''}[0];
      $out->cleanup if $out->can("cleanup");
      $setup_progress = 0;
  }
  
  sub hook_after_parse_argv {
      my ($self, $r) = @_;
  
      # since unlike Perinci::CmdLine, we don't wrap the function (where the
      # wrapper assigns default values for arguments), we must do it here
      # ourselves.
      my $ass  = $r->{meta}{args} // {};
      my $args = $r->{args};
      for (keys %$ass) {
          next if exists $args->{$_};
          my $as = $ass->{$_};
          if (exists $as->{default}) {
              $args->{$_} = $as->{default};
          } elsif ($as->{schema} && exists $as->{schema}[1]{default}) {
              $args->{$_} = $as->{schema}[1]{default};
          }
      }
  
      # set up log adapter
      if ($self->log) {
          require Log::Any::Adapter;
          Log::Any::Adapter->set(
              'ScreenColoredLevel',
              min_level => $r->{log_level} // $self->log_level,
              formatter => sub { $self->program_name . ": $_[1]" },
          );
      }
  }
  
  sub hook_before_action {
      my ($self, $r) = @_;
  
      # validate arguments using schema from metadata
    VALIDATE_ARGS:
      {
          # unless we're feeding the arguments to function, don't bother
          # validating arguments
          last unless $r->{action} eq 'call';
  
          my $meta = $r->{meta};
  
          # function is probably already wrapped
          last if $meta->{'x.perinci.sub.wrapper.logs'} &&
              (grep { $_->{validate_args} }
               @{ $meta->{'x.perinci.sub.wrapper.logs'} });
  
          require Data::Sah;
  
          # to be cheap, we simply use "$ref" as key as cache key. to be proper,
          # it should be hash of serialized content.
          my %validators; # key = "$schema"
  
          for my $arg (sort keys %{ $meta->{args} // {} }) {
              next unless exists($r->{args}{$arg});
  
              # we don't support validation of input stream because this must be
              # done after each 'get item' (but periswrap does)
              next if $meta->{args}{$arg}{stream};
  
              my $schema = $meta->{args}{$arg}{schema};
              next unless $schema;
              unless ($validators{"$schema"}) {
                  my $v = Data::Sah::gen_validator($schema, {
                      return_type => 'str',
                      schema_is_normalized => 1,
                  });
                  $validators{"$schema"} = $v;
              }
              my $res = $validators{"$schema"}->($r->{args}{$arg});
              if ($res) {
                  die [400, "Argument '$arg' fails validation: $res"];
              }
          }
      }
  }
  
  sub __json {
      state $json = do {
          require JSON;
          JSON->new->canonical(1)->allow_nonref;
      };
      $json;
  }
  
  sub __gen_table {
      my ($data, $header_row, $resmeta, $is_pretty) = @_;
  
      $resmeta //= {};
  
      my @columns;
      if ($header_row) {
          @columns = @{$data->[0]};
      } else {
          @columns = map {"col$_"} 0..@{$data->[0]}-1;
      }
  
      my $column_orders; # e.g. [col2, col1, col3, ...]
    SET_COLUMN_ORDERS: {
  
          # find column orders from 'table_column_orders' in result metadata (or
          # from env)
          my $tcos;
          if ($ENV{FORMAT_PRETTY_TABLE_COLUMN_ORDERS}) {
              $tcos = __json->decode($ENV{FORMAT_PRETTY_TABLE_COLUMN_ORDERS});
          } elsif (my $rfos = ($resmeta->{'cmdline.format_options'} //
                                   $resmeta->{format_options})) {
              my $rfo = $rfos->{'text-pretty'} // $rfos->{text} // $rfos->{any};
              if ($rfo) {
                  $tcos = $rfo->{table_column_orders};
              }
          }
          if ($tcos) {
              # find an entry in tcos that @columns contains all the columns of
            COLS:
              for my $cols (@$tcos) {
                  for my $col (@$cols) {
                      next COLS unless first {$_ eq $col} @columns;
                  }
                  $column_orders = $cols;
                  last SET_COLUMN_ORDERS;
              }
          }
  
          # find column orders from table spec
          $column_orders = $resmeta->{'table.fields'};
      }
  
      # reorder each row according to requested column order
      if ($column_orders) {
          require List::MoreUtils;
  
          # 0->2, 1->0, ... (map column position from unordered to ordered)
          my @map0 = sort {
              my $idx_a = List::MoreUtils::firstidx(sub {$_ eq $a->[1]},
                                                    @$column_orders) // 9999;
              my $idx_b = List::MoreUtils::firstidx(sub {$_ eq $b->[1]},
                                                    @$column_orders) // 9999;
              $idx_a <=> $idx_b || $a->[1] cmp $b->[1];
          } map {[$_, $columns[$_]]} 0..@columns-1;
          #use DD; dd \@map0;
          my @map;
          for (0..@map0-1) {
              $map[$_] = $map0[$_][0];
          }
          #use DD; dd \@map;
          my $newdata = [];
          for my $row (@$data) {
              my @newrow;
              for (0..@map-1) { $newrow[$_] = $row->[$map[$_]] }
              push @$newdata, \@newrow;
          }
          $data = $newdata;
      }
  
      if ($is_pretty) {
          require Text::Table::Tiny;
          Text::Table::Tiny::table(rows=>$data, header_row=>$header_row) . "\n";
      } else {
          no warnings 'uninitialized';
          shift @$data if $header_row;
          join("", map {join("\t", @$_)."\n"} @$data);
      }
  }
  
  sub hook_format_result {
      my ($self, $r) = @_;
  
      my $res    = $r->{res};
      my $format = $r->{format} // 'text';
      my $meta   = $r->{meta};
  
      if ($format =~ /\Atext(-simple|-pretty)?\z/) {
          my $is_pretty = $format eq 'text-pretty' ? 1 :
              $format eq 'text-simple' ? 0 : (-t STDOUT);
          no warnings 'uninitialized';
          if ($res->[0] !~ /^(2|304)/) {
              my $fres = "ERROR $res->[0]: $res->[1]";
              if (my $prev = $res->[3]{prev}) {
                  $fres .= " ($prev->[0]: $prev->[1])";
              }
              return "$fres\n";
          } elsif ($res->[3] && $res->[3]{"x.hint.result_binary"}) {
              return $res->[2];
          } else {
              require Data::Check::Structure;
              my $data = $res->[2];
              my $max = 5;
              if (!ref($data)) {
                  $data //= "";
                  $data .= "\n" unless !length($data) || $data =~ /\n\z/;
                  return $data;
              } elsif (ref($data) eq 'ARRAY' && !@$data) {
                  return "";
              } elsif (Data::Check::Structure::is_aos($data, {max=>$max})) {
                  return join("", map {"$_\n"} @$data);
              } elsif (Data::Check::Structure::is_aoaos($data, {max=>$max})) {
                  return __gen_table($data, 0, $res->[3], $is_pretty);
              } elsif (Data::Check::Structure::is_hos($data, {max=>$max})) {
                  $data = [map {[$_, $data->{$_}]} sort keys %$data];
                  unshift @$data, ["key", "value"];
                  return __gen_table($data, 1, $res->[3], $is_pretty);
              } elsif (Data::Check::Structure::is_aohos($data, {max=>$max})) {
                  # collect all mentioned fields
                  my %fieldnames;
                  for my $row (@$data) {
                      $fieldnames{$_}++ for keys %$row;
                  }
                  my @fieldnames = sort keys %fieldnames;
                  my $newdata = [];
                  for my $row (@$data) {
                      push @$newdata, [map {$row->{$_}} @fieldnames];
                  }
                  unshift @$newdata, \@fieldnames;
                  return __gen_table($newdata, 1, $res->[3], $is_pretty);
              } else {
                  $format = 'json-pretty';
              }
          }
      }
  
      $res = $res->[2] if $r->{naked_res};
  
      warn "Unknown format '$format', fallback to json-pretty"
          unless $format =~ /\Ajson(-pretty)?\z/;
      $self->cleanser->clean_in_place($res);
      if ($format eq 'json') {
          return __json->encode($res) . "\n";
      } else {
          return __json->canonical(1)->pretty->encode($res);
      }
  }
  
  sub hook_format_row {
      my ($self, $r, $row) = @_;
  
      if (ref($row) eq 'ARRAY') {
          return join("\t", @$row) . "\n";
      } else {
          return ($row // "") . "\n";
      }
  }
  
  sub hook_display_result {
      my ($self, $r) = @_;
      $self->display_result($r);
  }
  
  sub hook_after_run {
      my ($self, $r) = @_;
      $self->_unsetup_progress_output;
  }
  
  sub hook_after_get_meta {
      my ($self, $r) = @_;
  
      require Perinci::Object;
      if (Perinci::Object::risub($r->{meta})->can_dry_run) {
          $self->common_opts->{dry_run} = {
              getopt  => 'dry-run',
              summary => "Run in simulation mode (also via DRY_RUN=1)",
              handler => sub {
                  my ($go, $val, $r) = @_;
                  $log->debugf("[pericmd] Dry-run mode is activated");
                  $r->{dry_run} = 1;
                  #$ENV{VERBOSE} = 1;
              },
          };
      }
  
      # check deps property. XXX this should be done only when we don't wrap
      # subroutine, because Perinci::Sub::Wrapper already checks the deps
      # property.
      if ($r->{meta}{deps}) {
          require Perinci::Sub::DepChecker;
          my $res = Perinci::Sub::DepChecker::check_deps($r->{meta}{deps});
          if ($res) {
              die [412, "Dependency failed: $res"];
          }
      }
  }
  
  sub action_subcommands {
      my ($self, $r) = @_;
  
      if (!$self->subcommands) {
          say "There are no subcommands.";
          return 0;
      }
  
      say "Available subcommands:";
      my $scs = $self->list_subcommands;
      my $longest = 6;
      for (keys %$scs) { my $l = length; $longest = $l if $l > $longest }
      [200, "OK",
       join("",
            (map { sprintf("  %-${longest}s  %s\n",$_,$scs->{$_}{summary}//"") }
                 sort keys %$scs),
        )];
  }
  
  sub action_version {
      my ($self, $r) = @_;
  
      my $meta = $r->{meta} = $self->get_meta($r, $self->url);
  
      [200, "OK",
       join("",
            $self->get_program_and_subcommand_name($r),
            " version ", ($meta->{entity_v} // "?"),
            ($meta->{entity_date} ? " ($meta->{entity_date})" : ''),
            "\n",
            "  ", __PACKAGE__,
            " version ", ($Perinci::CmdLine::Lite::VERSION // "?"),
            ($Perinci::CmdLine::Lite::DATE ?
                 " ($Perinci::CmdLine::Lite::DATE)":''),
        )];
  }
  
  sub action_help {
      require Perinci::CmdLine::Help;
  
      my ($self, $r) = @_;
  
      my @help;
      my $scn    = $r->{subcommand_name};
      my $scd    = $r->{subcommand_data};
  
      # XXX use 'delete local' when we bump minimal perl to 5.12
      my $common_opts = { %{$self->common_opts} };
      # hide usage '--subcommands' if we have subcommands but user has specified a
      # subcommand to use
      my $has_sc_no_sc = $self->subcommands && !length($r->{subcommand_name});
      delete $common_opts->{subcommands} if $self->subcommands && !$has_sc_no_sc;
  
      my $meta = $self->get_meta($r, $scd->{url} // $self->{url});
  
      my $res = Perinci::CmdLine::Help::gen_help(
          program_name => $self->get_program_and_subcommand_name($r),
          program_summary => ($scd ? $scd->{summary}:undef ) // $meta->{summary},
          program_description => $scd ? $scd->{description} : undef,
          meta => $meta,
          subcommands => $has_sc_no_sc ? $self->list_subcommands : undef,
          common_opts => $common_opts,
          per_arg_json => $self->per_arg_json,
          per_arg_yaml => $self->per_arg_yaml,
      );
  
      $res->[3]{"cmdline.skip_format"} = 1;
      $res;
  }
  
  sub action_call {
      my ($self, $r) = @_;
  
      my %extra;
      if ($r->{send_argv}) {
          $log->tracef("[pericmd] Sending argv to server: %s", $extra{argv});
          $extra{argv} = $r->{orig_argv};
      } else {
          my %extra_args;
          $extra_args{-dry_run} = 1 if $r->{dry_run};
          $extra{args} = {%extra_args, %{$r->{args}}};
      }
  
      $extra{stream_arg} = 1 if $r->{stream_arg};
  
      my $url = $r->{subcommand_data}{url};
  
      # currently we don't log args because it's potentially large
      $log->tracef("[pericmd] Riap request: action=call, url=%s", $url);
  
      #$log->tracef("TMP: extra=%s", \%extra);
  
      # setup output progress indicator
      if ($r->{meta}{features}{progress}) {
          $self->_setup_progress_output;
      }
  
      $self->riap_client->request(
          call => $url, \%extra);
  }
  
  1;
  # ABSTRACT: A lightweight Rinci/Riap-based command-line application framework
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::CmdLine::Lite - A lightweight Rinci/Riap-based command-line application framework
  
  =head1 VERSION
  
  This document describes version 1.10 of Perinci::CmdLine::Lite (from Perl distribution Perinci-CmdLine-Lite), released on 2015-04-12.
  
  =head1 SYNOPSIS
  
  In C<gen-random-num> script:
  
   use Perinci::CmdLine::Lite;
  
   our %SPEC;
  
   $SPEC{gen_random_num} = {
       v => 1.1,
       summary => 'Generate some random numbers',
       args => {
           count => {
               summary => 'How many numbers to generate',
               schema => ['int*' => min=>0],
               default => 1,
               cmdline_aliases=>{n=>{}},
               req => 1,
               pos => 0,
           },
           min => {
               summary => 'Lower limit of random number',
               schema => 'float*',
               default => 0,
           },
           max => {
               summary => 'Upper limit of random number',
               schema => 'float*',
               default => 1,
           },
       },
       result_naked => 1,
   };
   sub gen_random_num {
       my %args = @_;
  
       my @res;
       for (1..$args{count}) {
           push @res, $args{min} + rand()*($args{max}-$args{min});
       }
       \@res;
   }
  
   Perinci::CmdLine::Lite->new(url => '/main/gen_random_num')->run;
  
  Run your script:
  
   % ./gen-random-num
   0.999473691060306
  
   % ./gen-random-num --min 1 --max 10 5
   1.27390166158969
   1.69077475473679
   8.97748327778684
   5.86943773494068
   8.34341298182493
  
  JSON output support out of the box:
  
   % ./gen-random-num -n3 --json
   [200,"OK (envelope added by Perinci::Access::Lite)",[0.257073684902029,0.393782991540746,0.848740540017513],{}]
  
  Automatic help message:
  
   % ./gen-random-num -h
   gen-random-num - Generate some random numbers
  
   Usage:
     gen-random-num --help (or -h, -?)
     gen-random-num --version (or -v)
     gen-random-num [options] [count]
   Options:
     --config-path=s     Set path to configuration file
     --config-profile=s  Set configuration profile to use
     --count=i, -n       How many numbers to generate (=arg[0]) [1]
     --format=s          Choose output format, e.g. json, text [undef]
     --help, -h, -?      Display this help message
     --json              Set output format to json
     --max=f             Upper limit of random number [1]
     --min=f             Lower limit of random number [0]
     --naked-res         When outputing as JSON, strip result envelope [0]
     --no-config         Do not use any configuration file
     --version, -v
  
  Automatic configuration file support:
  
   % cat ~/gen-random-num.conf
   count=5
   max=0.01
  
   % ./gen-random-num
   0.00105268954838724
   0.00701443611501844
   0.0021247476506154
   0.00813872824513005
   0.00752832346491306
  
  Automatic tab completion support:
  
   % complete -C gen-random-num gen-random-num
   % gen-random-num --mi<tab>
  
  See the manual for details on other available features (subcommands, automatic
  formatting of data structures, automatic schema validation, dry-run mode,
  automatic POD generation, remote function support, automatic CLI generation,
  automatic --version, automatic HTTP API, undo/transactions, configurable output
  format, logging, progress bar, colors/Unicode, and more).
  
  =head1 DESCRIPTION
  
  Perinci::CmdLine is a command-line application framework. It allows you to
  create full-featured CLI applications easily and quickly.
  
  See L<Perinci::CmdLine::Manual> for more details.
  
  There is also a blog post series on Perinci::CmdLine tutorial:
  L<https://perlancar.wordpress.com/category/pericmd-tut/>
  
  Perinci::CmdLine::Lite is the default backend implementation. You normally
  should use L<Perinci::CmdLine::Any> instead to be able to switch backend on the
  fly.
  
  =for Pod::Coverage ^(BUILD|get_meta|hook_.+|action_.+)$
  
  =head1 REQUEST KEYS
  
  All those supported by L<Perinci::CmdLine::Base>, plus:
  
  =over
  
  =back
  
  =head1 ATTRIBUTES
  
  All the attributes of L<Perinci::CmdLine::Base>, plus:
  
  =head2 log => bool (default: from env or 0)
  
  Whether to enable logging. This currently means setting up L<Log::Any::Adapter>
  to display logging (set in C<hook_after_parse_argv>, so tab completion skips
  this step). To produce log, you use L<Log::Any> in your code.
  
  The default is off. If you set LOG=1 or LOG_LEVEL or TRACE/DEBUG/VERBOSE/QUIET,
  then the default will be on. It defaults to off if you set LOG=0 or
  LOG_LEVEL=off.
  
  =head2 log_level => str (default: from env, or 'warning')
  
  Set default log level. The default can also be set via
  LOG_LEVEL/TRACE/DEBUG/VERBOSE/QUIET.
  
  =head1 METHODS
  
  All the methods of L<Perinci::CmdLine::Base>, plus:
  
  =head1 ENVIRONMENT
  
  All the environment variables that L<Perinci::CmdLine::Base> supports, plus:
  
  =head2 DEBUG
  
  Set log level to 'debug'.
  
  =head2 VERBOSE
  
  Set log level to 'info'.
  
  =head2 QUIET
  
  Set log level to 'error'.
  
  =head2 TRACE
  
  Set log level to 'trace'.
  
  =head2 LOG_LEVEL
  
  Set log level.
  
  =head2 PROGRESS => BOOL
  
  Explicitly turn the progress bar on/off.
  
  =head2 FORMAT_PRETTY_TABLE_COLUMN_ORDERS => array (json)
  
  Set the default of C<table_column_orders> in C<format_options> in result
  metadata, similar to what's implemented in L<Perinci::Result::Format> and
  L<Data::Format::Pretty::Console>.
  
  =head1 RESULT METADATA
  
  All those supported by L<Perinci::CmdLine::Base>, plus:
  
  =head2 x.hint.result_binary => bool
  
  If set to true, then when formatting to C<text> formats, this class won't print
  any newline to keep the data being printed unmodified.
  
  =head1 SEE ALSO
  
  L<Perinci::CmdLine::Any>, L<Perinci::CmdLine::Classic>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-CmdLine-Lite>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-CmdLine-Lite>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-CmdLine-Lite>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_CMDLINE_LITE

$fatpacked{"Perinci/CmdLine/Util/Config.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_CMDLINE_UTIL_CONFIG';
  package Perinci::CmdLine::Util::Config;
  
  our $DATE = '2015-04-12'; # DATE
  our $VERSION = '1.10'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Log::Any::IfLOG '$log';
  
  use PERLANCAR::File::HomeDir qw(get_my_home_dir);
  
  our %SPEC;
  
  $SPEC{get_default_config_dirs} = {
      v => 1.1,
      args => {},
  };
  sub get_default_config_dirs {
      my @dirs;
      local $PERLANCAR::File::HomeDir::DIE_ON_FAILURE = 1;
      my $home = get_my_home_dir();
      if ($^O eq 'MSWin32') {
          push @dirs, $home;
      } else {
          push @dirs, "$home/.config", $home, "/etc";
      }
      \@dirs;
  }
  
  $SPEC{read_config} = {
      v => 1.1,
      args => {
          config_paths => {},
          config_filenames => {},
          config_dirs => {},
          program_name => {},
      },
  };
  sub read_config {
      require Config::IOD::Reader;
  
      my %args = @_;
  
      my $config_dirs = $args{config_dirs} // get_default_config_dirs();
  
      my $paths;
      if ($args{config_paths}) {
          $paths = $args{config_paths};
      } else {
          my $name = $args{config_filename} //
              $args{program_name} . ".conf";
          for my $dir (@$config_dirs) {
              my $path = "$dir/" . $name;
              push @$paths, $path if -e $path;
          }
      }
  
      my $reader = Config::IOD::Reader->new;
      my %res;
      my @read;
      for my $path (@$paths) {
          my $hoh = $reader->read_file($path);
          push @read, $path;
          for my $section (keys %$hoh) {
              my $hash = $hoh->{$section};
              for (keys %$hash) {
                  $res{$section}{$_} = $hash->{$_};
              }
          }
      }
      [200, "OK", \%res, {'func.read_files' => \@read}];
  }
  
  $SPEC{get_args_from_config} = {
      v => 1.1,
      args => {
          r => {},
          config => {},
          args => {},
          subcommand_name => {},
          config_profile => {},
          common_opts => {},
          meta => {},
          meta_is_normalized => {},
      },
  };
  sub get_args_from_config {
      my %fargs = @_;
  
      my $r       = $fargs{r};
      my $conf    = $fargs{config};
      my $scn     = $fargs{subcommand_name} // '';
      my $profile = $fargs{config_profile};
      my $args    = $fargs{args} // {};
      my $copts   = $fargs{common_opts};
      my $meta    = $fargs{meta};
      my $found;
  
      unless ($fargs{meta_is_normalized}) {
          require Perinci::Sub::Normalize;
          $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
      }
  
      # put GLOBAL before all other sections
      my @sections = sort {
          ($a eq 'GLOBAL' ? 0:1) <=> ($b eq 'GLOBAL' ? 0:1) ||
              $a cmp $b
          } keys %$conf;
  
      my %seen_profiles; # for debugging message
      for my $section (@sections) {
          my ($sect_scn, $sect_profile);
          if ($section =~ /\Aprofile=(.*)\z/) {
              $sect_scn = 'GLOBAL';
              $sect_profile = $1;
          } elsif ($section =~ /\A\S+\z/) {
              $sect_scn = $section;
          } elsif ($section =~ /\A(\S+)\s+profile=(.*)\z/) {
              $sect_scn = $1;
              $sect_profile = $2;
          } else {
              die [412, "Error in config file: invalid section name ".
                       "'$section', please use subcommand name + optional ".
                           "' profile=PROFILE' only"];
          }
          $seen_profiles{$sect_profile}++ if defined $sect_profile;
          if (length $scn) {
              next if $sect_scn ne 'GLOBAL' && $sect_scn ne $scn;
          } else {
              next if $sect_scn ne 'GLOBAL';
          }
          if (defined $profile) {
              next if defined($sect_profile) && $sect_profile ne $profile;
              $found++ if defined($sect_profile) && $sect_profile eq $profile;
          } else {
              next if defined($sect_profile);
          }
  
          my $as = $meta->{args} // {};
          for my $k (keys %{ $conf->{$section} }) {
              my $v = $conf->{$section}{$k};
              if ($copts->{$k} && $copts->{$k}{is_settable_via_config}) {
                  my $sch = $copts->{$k}{schema};
                  if ($sch) {
                      require Data::Sah::Normalize;
                      $sch = Data::Sah::Normalize::normalize_schema($sch);
                      # since IOD might return a scalar or an array (depending on
                      # whether there is a single param=val or multiple param=
                      # lines), we need to arrayify the value if the argument is
                      # expected to be an array.
                      if (ref($v) ne 'ARRAY' && $sch->[0] eq 'array') {
                          $v = [$v];
                      }
                  }
                  $copts->{$k}{handler}->(undef, $v, $r);
              } else {
                  # when common option clashes with function argument name, user
                  # can use NAME.arg to refer to function argument.
                  $k =~ s/\.arg\z//;
  
                  # since IOD might return a scalar or an array (depending on
                  # whether there is a single param=val or multiple param= lines),
                  # we need to arrayify the value if the argument is expected to
                  # be an array.
                  if (ref($v) ne 'ARRAY' && $as->{$k} && $as->{$k}{schema} &&
                          $as->{$k}{schema}[0] eq 'array') {
                      $v = [$v];
                  }
                  $args->{$k} = $v;
              }
          }
      }
      $log->tracef("[pericmd] Seen config profiles: %s",
                   [sort keys %seen_profiles]);
  
      [200, "OK", $args, {'func.found'=>$found}];
  }
  
  1;
  # ABSTRACT: Utility routines related to config files
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::CmdLine::Util::Config - Utility routines related to config files
  
  =head1 VERSION
  
  This document describes version 1.10 of Perinci::CmdLine::Util::Config (from Perl distribution Perinci-CmdLine-Lite), released on 2015-04-12.
  
  =head1 FUNCTIONS
  
  
  =head2 get_args_from_config(%args) -> [status, msg, result, meta]
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<args> => I<any>
  
  =item * B<common_opts> => I<any>
  
  =item * B<config> => I<any>
  
  =item * B<config_profile> => I<any>
  
  =item * B<meta> => I<any>
  
  =item * B<meta_is_normalized> => I<any>
  
  =item * B<r> => I<any>
  
  =item * B<subcommand_name> => I<any>
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 get_default_config_dirs() -> [status, msg, result, meta]
  
  No arguments.
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 read_config(%args) -> [status, msg, result, meta]
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<config_dirs> => I<any>
  
  =item * B<config_filenames> => I<any>
  
  =item * B<config_paths> => I<any>
  
  =item * B<program_name> => I<any>
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-CmdLine-Lite>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-CmdLine-Lite>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-CmdLine-Lite>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_CMDLINE_UTIL_CONFIG

$fatpacked{"Perinci/CmdLine/pause.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_CMDLINE_PAUSE';
  package Perinci::CmdLine::pause;
  
  # DATE
  # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use Log::Any::IfLOG qw($log);
  
  use parent qw(Perinci::CmdLine::Lite);
  
  use PERLANCAR::File::HomeDir qw(get_my_home_dir);
  
  sub hook_after_read_config_file {
      my ($self, $r) = @_;
  
      return unless $self->read_config;
      return if $r->{read_config_files} && @{$r->{read_config_files}};
  
      my $path = get_my_home_dir() . "/.pause";
      return unless -f $path;
  
      open my($fh), "<", $path or die [500, "Can't read $path: $!"];
      $log->tracef("[pericmd-pause] Reading %s ...", $path);
      $r->{read_config_files} = [$path];
      while (<$fh>) {
          if (/^user\s+(.+)/) { $r->{config}{GLOBAL}{username} = $1 }
          elsif (/^password\s+(.+)/) { $r->{config}{GLOBAL}{password} = $1 }
      }
  }
  
  1;
  # ABSTRACT: Perinci::CmdLine::Lite subclass for pause
  
  =head1 DESCRIPTION
  
  This class adds a hook_after_read_config_file to read L<CPAN::Uploader>'s config
  file in C<~/.pause>. Encrypted C<.pause> is not supported.
PERINCI_CMDLINE_PAUSE

$fatpacked{"Perinci/Object.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_OBJECT';
  package Perinci::Object;
  
  our $DATE = '2014-12-11'; # DATE
  our $VERSION = '0.21'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA    = qw(Exporter);
  our @EXPORT = qw(rimeta risub rivar ripkg envres envresmulti riresmeta);
  
  sub rimeta {
      require Perinci::Object::Metadata;
      Perinci::Object::Metadata->new(@_);
  }
  
  sub risub {
      require Perinci::Object::Function;
      Perinci::Object::Function->new(@_);
  }
  
  sub rivar {
      require Perinci::Object::Variable;
      Perinci::Object::Variable->new(@_);
  }
  
  sub ripkg {
      require Perinci::Object::Package;
      Perinci::Object::Package->new(@_);
  }
  
  sub envres {
      require Perinci::Object::EnvResult;
      Perinci::Object::EnvResult->new(@_);
  }
  
  sub envresmulti {
      require Perinci::Object::EnvResultMulti;
      Perinci::Object::EnvResultMulti->new(@_);
  }
  
  sub riresmeta {
      require Perinci::Object::ResMeta;
      Perinci::Object::ResMeta->new(@_);
  }
  
  1;
  # ABSTRACT: Object-oriented interface for Rinci metadata
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Object - Object-oriented interface for Rinci metadata
  
  =head1 VERSION
  
  This document describes version 0.21 of Perinci::Object (from Perl distribution Perinci-Object), released on 2014-12-11.
  
  =head1 SYNOPSIS
  
   use Perinci::Object; # automatically exports risub(), rivar(), ripkg(),
                        # envres(), envresmulti(), riresmeta()
   use Data::Dump; # for dd()
  
   # OO interface to function metadata.
  
   my $risub = risub {
       v => 1.1,
       summary => 'Calculate foo and bar',
       "summary.alt.lang.id_ID" => 'Menghitung foo dan bar',
       args => { a1 => { schema => 'int*' }, a2 => { schema => 'str' } },
       features => { pure=>1 },
   };
   dd $risub->type,                                 # "function"
      $risub->v,                                    # 1.1
      $risub->arg('a1'),                            # { schema=>'int*' }
      $risub->arg('a3'),                            # undef
      $risub->feature('pure'),                      # 1
      $risub->feature('foo'),                       # undef
      $risub->langprop('summary'),                  # 'Calculate foo and bar'
      $risub->langprop({lang=>'id_ID'}, 'summary'), # 'Menghitung foo dan bar'
  
   # setting arg and property
   $risub->arg('a3', 'array');  # will actually fail for 1.0 metadata
   $risub->feature('foo', 2);   # ditto
  
   # OO interface to variable metadata
  
   my $rivar = rivar { ... };
  
   # OO interface to package metadata
  
   my $ripkg = ripkg { ... };
  
   # OO interface to enveloped result
  
   my $envres = envres [200, "OK", [1, 2, 3]];
   dd $envres->is_success, # 1
      $envres->status,     # 200
      $envres->message,    # "OK"
      $envres->result,     # [1, 2, 3]
      $envres->meta;       # undef
  
   # setting status, message, result, extra
   $envres->status(404);
   $envres->message('Not found');
   $envres->result(undef);
   $envres->meta({errno=>-100});
  
   # OO interface to function/method result metadata
   my $riresmeta = riresmeta { ... };
  
   # an example of using riresmulti()
   sub myfunc {
       ...
  
       my $envres = envresmulti();
  
       # add result for each item
       $envres->add_result(200, "OK", {item_id=>1});
       $envres->add_result(202, "OK", {item_id=>2, note=>"blah"});
       $envres->add_result(404, "Not found", {item_id=>3});
       ...
  
       # finally, return the result
       return $envres->as_struct;
   }
  
  =head1 DESCRIPTION
  
  L<Rinci> works using pure data structures, but sometimes it's convenient to have
  an object-oriented interface (wrapper) for those data. This module provides just
  that.
  
  =head1 FUNCTIONS
  
  =head2 rimeta $meta => OBJECT
  
  Exported by default. A shortcut for Perinci::Object::Metadata->new($meta).
  
  =head2 risub $meta => OBJECT
  
  Exported by default. A shortcut for Perinci::Object::Function->new($meta).
  
  =head2 rivar $meta => OBJECT
  
  Exported by default. A shortcut for Perinci::Object::Variable->new($meta).
  
  =head2 ripkg $meta => OBJECT
  
  Exported by default. A shortcut for Perinci::Object::Package->new($meta).
  
  =head2 envres $res => OBJECT
  
  Exported by default. A shortcut for Perinci::Object::EnvResult->new($res).
  
  =head2 envresmulti $res => OBJECT
  
  Exported by default. A shortcut for Perinci::Object::EnvResultMulti->new($res).
  
  =head2 riresmeta $resmeta => OBJECT
  
  Exported by default. A shortcut for Perinci::Object::ResMeta->new($res).
  
  =head1 SEE ALSO
  
  L<Rinci>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Object>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Object>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Object>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
PERINCI_OBJECT

$fatpacked{"Perinci/Object/EnvResult.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_OBJECT_ENVRESULT';
  package Perinci::Object::EnvResult;
  
  our $DATE = '2014-12-11'; # DATE
  our $VERSION = '0.21'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  sub new {
      my ($class, $res) = @_;
      $res //= [0, "", undef];
      my $obj = \$res;
      bless $obj, $class;
  }
  
  sub new_ok {
      my $class = shift;
      my $res = [200, "OK"];
      if (@_) {
          push @$res, $_[0];
      }
      $class->new($res);
  }
  
  sub status {
      my ($self, $new) = @_;
      if (defined $new) {
          die "Status must be an integer between 100 and 555" unless
              int($new) eq $new && $new >= 100 && $new <= 555;
          my $old = ${$self}->[0];
          ${$self}->[0] = $new;
          return $old;
      }
      ${$self}->[0];
  }
  
  sub message {
      my ($self, $new) = @_;
      if (defined $new) {
          die "Extra must be a string" if ref($new);
          my $old = ${$self}->[1];
          ${$self}->[1] = $new;
          return $old;
      }
      ${$self}->[1];
  }
  
  # avoid 'result' as this is ambiguous (the enveloped one? the naked one?). even
  # avoid 'enveloped' (the payload being enveloped? the enveloped result
  # (envelope+result inside)?)
  
  sub payload {
      my ($self, $new) = @_;
      if (defined $new) {
          my $old = ${$self}->[2];
          ${$self}->[2] = $new;
          return $old;
      }
      ${$self}->[2];
  }
  
  sub meta {
      my ($self, $new) = @_;
      if (defined $new) {
          die "Extra must be a hashref" unless ref($new) eq 'HASH';
          my $old = ${$self}->[3];
          ${$self}->[3] = $new;
          return $old;
      }
      ${$self}->[3];
  }
  
  sub is_success {
      my ($self) = @_;
      my $status = ${$self}->[0];
      $status >= 200 && $status <= 299;
  }
  
  sub as_struct {
      my ($self) = @_;
      ${$self};
  }
  
  1;
  # ABSTRACT: Represent enveloped result
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Object::EnvResult - Represent enveloped result
  
  =head1 VERSION
  
  This document describes version 0.21 of Perinci::Object::EnvResult (from Perl distribution Perinci-Object), released on 2014-12-11.
  
  =head1 SYNOPSIS
  
   use Perinci::Object::EnvResult;
   use Data::Dump; # for dd()
  
   my $envres = Perinci::Object::EnvResult->new([200, "OK", [1, 2, 3]]);
   dd $envres->is_success, # 1
      $envres->status,     # 200
      $envres->message,    # "OK"
      $envres->payload,    # [1, 2, 3]
      $envres->meta,       # undef
      $envres->as_struct;  # [200, "OK", [1, 2, 3]]
  
   # setting status, message, result, extra
   $envres->status(404);
   $envres->message('Not found');
   $envres->payload(undef);
   $envres->meta({errno=>-100});
  
   # shortcut: create a new OK result ([200, "OK"] or [200, "OK", $payload])
   $envres = Perinci::Object::EnvResult->new_ok();
   $envres = Perinci::Object::EnvResult->new_ok(42);
  
  =head1 DESCRIPTION
  
  This class provides an object-oriented interface for enveloped result (see
  L<Rinci::function> for more details).
  
  =head1 METHODS
  
  =head2 new($res) => OBJECT
  
  Create a new object from $res enveloped result array.
  
  =head2 new_ok([ $actual_res ]) => OBJECT
  
  Shortcut for C<< new([200,"OK",$actual_res]) >>, or just C<< new([200,"OK"]) >>
  if C<$actual_res> is not specified.
  
  =head2 $envres->status
  
  Get or set status (the 1st element).
  
  =head2 $envres->message
  
  Get or set message (the 2nd element).
  
  =head2 $envres->payload
  
  Get or set the actual payload (the 3rd element).
  
  =head2 $envres->meta
  
  Get or set result metadata (the 4th element).
  
  =head2 $envres->as_struct
  
  Return the represented data structure.
  
  =head2 $envres->is_success
  
  True if status is between 200-299.
  
  =head1 SEE ALSO
  
  L<Perinci::Object>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Object>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Object>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Object>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
PERINCI_OBJECT_ENVRESULT

$fatpacked{"Perinci/Object/EnvResultMulti.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_OBJECT_ENVRESULTMULTI';
  package Perinci::Object::EnvResultMulti;
  
  our $DATE = '2014-12-11'; # DATE
  our $VERSION = '0.21'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use parent qw(Perinci::Object::EnvResult);
  
  sub new {
      my ($class, $res) = @_;
      $res //= [200, "Success/no items"];
      my $obj = \$res;
      bless $obj, $class;
  }
  
  sub add_result {
      my ($self, $status, $message, $extra) = @_;
      my $num_ok  = 0;
      my $num_nok = 0;
  
      push @{ ${$self}->[3]{results} },
          {%{ $extra // {} }, status=>$status, message=>$message};
      for (@{ ${$self}->[3]{results} // [] }) {
          if ($_->{status} =~ /\A(2|304)/) {
              $num_ok++;
          } else {
              $num_nok++;
          }
      }
      if ($num_ok) {
          if ($num_nok) {
              ${$self}->[0] = 207;
              ${$self}->[1] = "Partial success";
          } else {
              ${$self}->[0] = 200;
              ${$self}->[1] = "All success";
          }
      } else {
          ${$self}->[0] = $status;
          ${$self}->[1] = $message;
      }
  }
  
  1;
  # ABSTRACT: Represent enveloped result (multistatus)
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Object::EnvResultMulti - Represent enveloped result (multistatus)
  
  =head1 VERSION
  
  This document describes version 0.21 of Perinci::Object::EnvResultMulti (from Perl distribution Perinci-Object), released on 2014-12-11.
  
  =head1 SYNOPSIS
  
   use Perinci::Object::EnvResultMulti;
   use Data::Dump; # for dd()
  
   sub myfunc {
       ...
  
       # if unspecified, the default status will be [200, "Success/no items"]
       my $envres = Perinci::Object::EnvResultMulti->new;
  
       # then you can add result for each item
       $envres->add_result(200, "OK", {item_id=>1});
       $envres->add_result(202, "OK", {item_id=>2, note=>"blah"});
       $envres->add_result(404, "Not found", {item_id=>3});
       ...
  
       # if you add a success status, the overall status will still be 200
  
       # if you add a non-success staus, the overall status will be 207, or
       # the non-success status (if no success has been added)
  
       # finally, return the result
       return $envres->as_struct;
  
       # the result from the above will be: [207, "Partial success", undef,
       # {results => [
       #     {success=>200, message=>"OK", item_id=>1},
       #     {success=>201, message=>"OK", item_id=>2, note=>"blah"},
       #     {success=>404, message=>"Not found", item_id=>3},
       # ]}]
   } # myfunc
  
  =head1 DESCRIPTION
  
  This class is a subclass of L<Perinci::Object::EnvResult> and provide a
  convenience method when you want to use multistatus/detailed per-item results
  (specified in L<Rinci> 1.1.63: C<results> result metadata property). In this
  case, response status can be 200, 207, or non-success. As you add more per-item
  results, this class will set/update the overall response status for you.
  
  =head1 METHODS
  
  =head2 new($res) => OBJECT
  
  Create a new object from C<$res> enveloped result array. If C<$res> is not
  specified, the default is C<< [200, "Success/no items"] >>.
  
  =head2 $envres->add_result($status, $message, \%extra)
  
  Add an item result.
  
  =head1 SEE ALSO
  
  L<Perinci::Object>
  
  L<Perinci::Object::EnvResult>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Object>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Object>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Object>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
PERINCI_OBJECT_ENVRESULTMULTI

$fatpacked{"Perinci/Object/Function.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_OBJECT_FUNCTION';
  package Perinci::Object::Function;
  
  our $DATE = '2014-12-11'; # DATE
  our $VERSION = '0.21'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use parent qw(Perinci::Object::Metadata);
  
  sub type { "function" }
  
  # convenience for accessing features property
  sub feature {
      my $self = shift;
      my $name = shift;
      if (@_) {
          die "1.0 can't set feature" if $self->v eq 1.0;
          my $value = shift;
          ${$self}->{features} //= {};
          my $old = ${$self}->{features}{$name};
          ${$self}->{features}{$name} = $value;
          return $old;
      } else {
          ${$self}->{features}{$name};
      }
  }
  
  sub features {
      my $self = shift;
      ${$self}->{features} // {};
  }
  
  # transaction can be used to emulate dry run, by calling with -tx_action =>
  # 'check_state' only
  sub can_dry_run {
      my $self = shift;
      my $ff = ${$self}->{features} // {};
      $ff->{dry_run} // $ff->{tx} && $ff->{tx}{v} == 2;
  }
  
  # convenience for accessing args property
  sub arg {
      my $self = shift;
      my $name = shift;
      if (@_) {
          die "1.0 can't set arg" if $self->v eq 1.0;
          my $value = shift;
          ${$self}->{args} //= {};
          my $old = ${$self}->{args}{$name};
          ${$self}->{args}{$name} = $value;
          return $old;
      } else {
          ${$self}->{args}{$name};
      }
  }
  
  1;
  # ABSTRACT: Represent function metadata
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Object::Function - Represent function metadata
  
  =head1 VERSION
  
  This document describes version 0.21 of Perinci::Object::Function (from Perl distribution Perinci-Object), released on 2014-12-11.
  
  =head1 SYNOPSIS
  
   use Perinci::Object;
  
   $SPEC{foo} = {
       v        => 1.1,
       args     => { b => {schema=>'int', req=>0} },
       features => {idempotent=>1},
   };
   my $risub = risub $SPEC{foo};
   print $risub->feature('idempotent'), # 1
         $risub->arg('b')->{req},       # 0
         $risub->arg('a');              # undef
  
  =head1 DESCRIPTION
  
  This class provides an object-oriented interface for function metadata.
  
  =head1 METHODS
  
  =head2 new($meta) => OBJECT
  
  Create a new object from $meta. If $meta is undef, creates an empty metadata.
  
  =head2 $risub->type => str
  
  Will return C<function>.
  
  =head2 $risub->features => HASH
  
  Return the C<features> property.
  
  =head2 $risub->feature(NAME[, VALUE])
  
  Get or set named feature (B<features> property in metadata). If a feature
  doesn't exist, undef will be returned.
  
  =head2 $risub->can_dry_run => BOOL
  
  Check whether function can do dry run, either from the C<dry_run> feature, or
  from the C<tx> feature. (Transaction can be used to emulate dry run, by calling
  the function with C<< -tx_action => 'check_state' >> only.)
  
  =head2 $risub->arg(NAME[, VALUE])
  
  Get or set argument (B<args> property in metadata). If an argument doesn't
  exist, undef will be returned.
  
  =head1 SEE ALSO
  
  L<Perinci::Object>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Object>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Object>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Object>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
PERINCI_OBJECT_FUNCTION

$fatpacked{"Perinci/Object/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_OBJECT_METADATA';
  package Perinci::Object::Metadata;
  
  our $DATE = '2014-12-11'; # DATE
  our $VERSION = '0.21'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  use String::Trim::More qw(trim_blank_lines);
  
  sub new {
      my ($class, $meta) = @_;
      $meta //= {};
      my $obj = \$meta;
      bless $obj, $class;
  }
  
  sub v {
      my $self = shift;
      ${$self}->{v} // 1.0;
  }
  
  sub type {
      die "BUG: type() must be subclassed";
  }
  
  sub as_struct {
      my $self = shift;
      ${$self};
  }
  
  sub langprop {
      my $self = shift;
      my $opts;
      if (ref($_[0]) eq 'HASH') {
          $opts = shift;
      } else {
          $opts = {};
      }
      my $prop = shift;
  
      my $deflang = ${$self}->{default_lang} // "en_US";
      my $olang   = $opts->{lang} || $ENV{LANGUAGE} || $ENV{LANG} || $deflang;
      $olang =~ s/\W.+//; # change "en_US.UTF-8" to "en_US"
      (my $olang2 = $olang) =~ s/\A([a-z]{2})_[A-Z]{2}\z/$1/; # change "en_US" to "en"
      my $mark    = $opts->{mark_different_lang} // 1;
      #print "deflang=$deflang, olang=$olang, mark_different_lang=$mark\n";
  
      my @k;
      if ($olang eq $deflang) {
          @k = ([$olang, $prop, 0]);
      } else {
          @k = (
              [$olang, "$prop.alt.lang.$olang", 0],
              ([$olang2, "$prop.alt.lang.$olang2", 0]) x !!($olang2 ne $olang),
              [$deflang, $prop, $mark],
          );
      }
  
      my $v;
    GET:
      for my $k (@k) {
          #print "k=".join(", ", @$k)."\n";
          $v = ${$self}->{$k->[1]};
          if (defined $v) {
              if ($k->[2]) {
                  my $has_nl = $v =~ s/\n\z//;
                  $v = "{$k->[0] $v}" . ($has_nl ? "\n" : "");
              }
              $v = trim_blank_lines($v);
              last GET;
          }
      }
  
      if (@_) {
          # set value
          ${$self}->{$k[0][1]} = $_[0];
      }
  
      $v;
  }
  
  sub name {
      my $self = shift;
      my $opts;
      if (@_ && ref($_[0]) eq 'HASH') {
          $opts = shift;
      } else {
          $opts = {};
      }
      $self->langprop($opts, "name", @_);
  }
  
  sub caption {
      my $self = shift;
      my $opts;
      if (@_ && ref($_[0]) eq 'HASH') {
          $opts = shift;
      } else {
          $opts = {};
      }
      $self->langprop($opts, "caption", @_);
  }
  
  sub summary {
      my $self = shift;
      my $opts;
      if (@_ && ref($_[0]) eq 'HASH') {
          $opts = shift;
      } else {
          $opts = {};
      }
      $self->langprop($opts, "summary", @_);
  }
  
  sub description {
      my $self = shift;
      my $opts;
      if (@_ && ref($_[0]) eq 'HASH') {
          $opts = shift;
      } else {
          $opts = {};
      }
      $self->langprop($opts, "description", @_);
  }
  
  1;
  # ABSTRACT: Base class for Perinci::Object metadata classes
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Object::Metadata - Base class for Perinci::Object metadata classes
  
  =head1 VERSION
  
  This document describes version 0.21 of Perinci::Object::Metadata (from Perl distribution Perinci-Object), released on 2014-12-11.
  
  =head1 METHODS
  
  =head2 new => obj
  
  Constructor.
  
  =head2 v => float
  
  Get version.
  
  =head2 as_struct => hash
  
  Get underlying data structure.
  
  =head2 type => str
  
  Return type (e.g. C<function>, C<package>).
  
  =head2 langprop([ \%opts, ]$prop[, $new_value])
  
  Get or set property value in the specified language (i.e., either in C<prop> or
  C<prop.alt.lang.XXX> properties).
  
  Known options:
  
  =over 4
  
  =item * lang => STR
  
  Defaults to metadata's C<default_lang> (which in turns default to C<en_US> if
  unspecified).
  
  =item * mark_different_lang => BOOL (defaults to 1)
  
  If set to true, text with different language than the language requested will be
  marked, e.g. C<"I love you"> requested in Indonesian language where the value
  for that language is unavailable will result in C<"{en_US I love you}"> being
  returned.
  
  =back
  
  =head2 name([ $new_value ]) => $value
  
  Get or set C<name> property. Will call C<langprop()>.
  
  =head2 summary([ $new_value ]) => $value
  
  Get or set C<summary> property. Will call C<langprop()>.
  
  =head2 description([ $new_value ]) => $value
  
  Get or set C<description> property. Will call C<langprop()>.
  
  =head2 caption([ $new_value ]) => $value
  
  Get or set C<caption> property. Will call C<langprop()>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Object>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Object>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Object>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
PERINCI_OBJECT_METADATA

$fatpacked{"Perinci/Object/Package.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_OBJECT_PACKAGE';
  package Perinci::Object::Package;
  
  our $DATE = '2014-12-11'; # DATE
  our $VERSION = '0.21'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use parent qw(Perinci::Object::Metadata);
  
  sub type { "package" }
  
  1;
  # ABSTRACT: Represent package metadata
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Object::Package - Represent package metadata
  
  =head1 VERSION
  
  This document describes version 0.21 of Perinci::Object::Package (from Perl distribution Perinci-Object), released on 2014-12-11.
  
  =head1 METHODS
  
  =head2 $ripkg->type => str
  
  Will return C<package>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Object>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Object>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Object>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
PERINCI_OBJECT_PACKAGE

$fatpacked{"Perinci/Object/ResMeta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_OBJECT_RESMETA';
  package Perinci::Object::ResMeta;
  
  our $DATE = '2014-12-11'; # DATE
  our $VERSION = '0.21'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use parent qw(Perinci::Object::Metadata);
  
  sub type { "resmeta" }
  
  1;
  # ABSTRACT: Represent function/method result metadata
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Object::ResMeta - Represent function/method result metadata
  
  =head1 VERSION
  
  This document describes version 0.21 of Perinci::Object::ResMeta (from Perl distribution Perinci-Object), released on 2014-12-11.
  
  =head1 METHODS
  
  =head2 $riresmeta->type => str
  
  Will return C<resmeta>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Object>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Object>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Object>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
PERINCI_OBJECT_RESMETA

$fatpacked{"Perinci/Object/Variable.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_OBJECT_VARIABLE';
  package Perinci::Object::Variable;
  
  our $DATE = '2014-12-11'; # DATE
  our $VERSION = '0.21'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use parent qw(Perinci::Object::Metadata);
  
  sub type { "variable" }
  
  1;
  # ABSTRACT: Represent variable metadata
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Object::Variable - Represent variable metadata
  
  =head1 VERSION
  
  This document describes version 0.21 of Perinci::Object::Variable (from Perl distribution Perinci-Object), released on 2014-12-11.
  
  =head1 METHODS
  
  =head2 $rivar->type => str
  
  Will return C<variable>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Object>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Object>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Object>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
PERINCI_OBJECT_VARIABLE

$fatpacked{"Perinci/Sub/ArgEntity.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_ARGENTITY';
  package Perinci::Sub::ArgEntity;
  
  our $DATE = '2015-03-01'; # DATE
  our $VERSION = '0.01'; # VERSION
  
  1;
  # ABSTRACT: Convention for Perinci::Sub::ArgEntity::* modules
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::ArgEntity - Convention for Perinci::Sub::ArgEntity::* modules
  
  =head1 VERSION
  
  This document describes version 0.01 of Perinci::Sub::ArgEntity (from Perl distribution Perinci-Sub-ArgEntity), released on 2015-03-01.
  
  =head1 SYNOPSIS
  
  In your L<Rinci> function metadata:
  
   {
       v => 1.1,
       summary => 'Some function',
       args => {
           file => {
               # specification for 'file' argument
               schema  => 'str*',
               'x.schema.entity' => 'filename',
           },
           url => {
               # specification for 'url' argument
               schema  => ['array*', of => 'str*'],
               'x.schema.element_entity' => 'riap_url',
           },
       },
   }
  
  Now in command-line application:
  
   % myprog --file <tab>
  
  will use completion routine from function C<complete_arg_val> in module
  L<Perinci::Sub::ArgEntity::filename>, while:
  
   % myprog --url <tab>
  
  will use element completion routine from function C<complete_arg_val> in module
  L<Perinci::Sub::ArgEntity::riap_url>.
  
  =head1 DESCRIPTION
  
  The namespace C<Perinci::Sub::ArgEntity::*> is used to put data and routine
  related to certain types (entities) of function arguments.
  
  =head2 Completion
  
  The idea is: instead of having to put completion routine (coderef) directly in
  argument specification, like:
  
   file => {
       # specification for 'file' argument
       schema  => 'str*',
       completion => \&Complete::Util::complete_file,
   },
  
  you just specify the argument as being of a certain entity using the attribute
  C<x.schema.entity>:
  
   file => {
       # specification for 'file' argument
       schema  => 'str*',
       'x.schema.entity' => 'filename',
   },
  
  and module like L<Perinci::Sub::Complete> will search the appropriate completion
  routine (if any) for your argument. In this case, it will search for the module
  named C<Perinci::Sub::ArgEntity::> + I<entity_name> and then look up the
  function C<complete_arg_val>.
  
  Note that aside from completion, there are other uses for the C<x.schema.entity>
  attribute, e.g. in help message generation, etc. More things will be formally
  specified in the future.
  
  =head1 SEE ALSO
  
  L<Rinci>, L<Rinci::function>
  
  L<Complete>, L<Perinci::Sub::Complete>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-ArgEntity>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-ArgEntity>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-ArgEntity>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_SUB_ARGENTITY

$fatpacked{"Perinci/Sub/CoerceArgs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_COERCEARGS';
  package Perinci::Sub::CoerceArgs;
  
  our $DATE = '2015-03-28'; # DATE
  our $VERSION = '0.01'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         coerce_args
                 );
  
  our %SPEC;
  
  # a cheap Module::Load
  #sub _require_class {
  #    my $class = shift;
  #    (my $class_pm = $class) =~ s!::!/!g; $class_pm .= ".pm";
  #    require $class_pm;
  #}
  
  $SPEC{coerce_args} = {
      v           => 1.1,
      summary     => 'Coerce arguments',
      description => <<'_',
  
  This routine can be used when function arguments are retrieved from strings,
  like from command-line arguments in CLI application (see
  `Perinci::CmdLine::Lite` or `Perinci::CmdLine::Classic`) or from web form
  variables in web application (see `Borang`). For convenience, object or complex
  data structure can be converted from string (e.g. `DateTime` object from strings
  like `2015-03-27` or epoch integer). And filters can be applied to
  clean/preprocess the string (e.g. remove leading/trailing blanks) beforehand.
  
  _
      args => {
          meta => {
              summary => 'Rinci function metadata',
              schema  => 'hash*',
              req     => 1,
          },
          meta_is_normalized => {
              schema => 'bool*',
          },
          args => {
              summary => 'Reference to hash which store the arguments',
              schema  => 'hash*',
          },
      },
  };
  sub coerce_args {
      my %fargs = @_;
  
      my $meta = $fargs{meta} or return [400, "Please specify meta"];
      unless ($fargs{meta_is_normalized}) {
          require Perinci::Sub::Normalize;
          $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
      }
      my $args = $fargs{args};
  
      for my $arg_name (keys %$args) {
          my $val = $args->{$arg_name};
          next unless defined($val) && !ref($val);
          my $arg_spec = $meta->{args}{$arg_name};
          next unless $arg_spec;
  
          if (my $filters = $arg_spec->{filters}) {
              for my $filter (@$filters) {
                  if (ref($filter) eq 'CODE') {
                      $val = $filter->($val);
                  } elsif ($filter eq 'trim') {
                      $val =~ s/\A\s+//s;
                      $val =~ s/\s+\z//s;
                  } elsif ($filter eq 'ltrim') {
                      $val =~ s/\s+\z//s;
                  } elsif ($filter eq 'rtrim') {
                      $val =~ s/\A\s+//s;
                  } else {
                      return [400, "Unknown filter '$filter' ".
                                  "for argument '$arg_name'"];
                  }
              }
              $args->{$arg_name} = $val if @$filters;
          }
  
          if (my $schema = $arg_spec->{schema}) {
              if ($schema->[0] eq 'obj') {
                  my $class = $schema->[1]{isa} // '';
                  # convert DateTime object from epoch/some formatted string
                  if ($class eq 'DateTime') {
                      if ($val =~ /\A\d{8,}\z/) {
                          require DateTime;
                          $args->{$arg_name} = DateTime->from_epoch(
                              epoch => $val,
                              time_zone => $ENV{TZ} // "UTC",
                          );
                      } elsif ($val =~ m!\A
                                         (\d{4})[/-](\d{1,2})[/-](\d{1,2})
                                         (?:[ Tt](\d{1,2}):(\d{1,2}):(\d{1,2}))?
                                         \z!x) {
                          require DateTime;
                          $args->{$arg_name} = DateTime->new(
                              year => $1, month => $2, day => $3,
                              hour => $4 // 0,
                              minute => $4 // 0,
                              second => $4 // 0,
                              time_zone => $ENV{TZ} // "UTC",
                          );
                      } else {
                          return [400, "Can't coerce DateTime object " .
                                      "'$arg_name' from '$args->{$arg_name}'"];
                      }
                  } elsif ($class eq 'Time::Moment') {
                      # XXX just use Time::Moment's from_string()?
                      if ($val =~ /\A\d{8,}\z/) {
                          require Time::Moment;
                          $args->{$arg_name} = Time::Moment->from_epoch($val);
                      } elsif ($val =~ m!\A
                                         (\d{4})[/-](\d{1,2})[/-](\d{1,2})
                                         (?:[ Tt](\d{1,2}):(\d{1,2}):(\d{1,2}))?
                                         \z!x) {
                          # XXX parse time zone offset
                          require Time::Moment;
                          $args->{$arg_name} = Time::Moment->new(
                              year => $1, month => $2, day => $3,
                              hour => $4 // 0,
                              minute => $4 // 0,
                              second => $4 // 0,
                          );
                      } else {
                          return [400, "Can't coerce Time::Moment object " .
                                      "'$arg_name' from '$args->{$arg_name}'"];
                      }
                  }
              }
          } # has schema
      }
  
      [200, "OK", $args];
  }
  
  1;
  # ABSTRACT: Coerce arguments
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::CoerceArgs - Coerce arguments
  
  =head1 VERSION
  
  This document describes version 0.01 of Perinci::Sub::CoerceArgs (from Perl distribution Perinci-Sub-CoerceArgs), released on 2015-03-28.
  
  =head1 SYNOPSIS
  
   use Perinci::Sub::CoerceArgs qw(coerce_args);
  
   my $res = coerce_args(meta=>$meta, args=>$args, ...);
  
  =head1 DESCRIPTION
  
  I expect this to be a temporary solution until L<Data::Sah> or
  L<Perinci::Sub::Wrapper> has this functionality.
  
  =head1 FUNCTIONS
  
  
  =head2 coerce_args(%args) -> [status, msg, result, meta]
  
  Coerce arguments.
  
  This routine can be used when function arguments are retrieved from strings,
  like from command-line arguments in CLI application (see
  C<Perinci::CmdLine::Lite> or C<Perinci::CmdLine::Classic>) or from web form
  variables in web application (see C<Borang>). For convenience, object or complex
  data structure can be converted from string (e.g. C<DateTime> object from strings
  like C<2015-03-27> or epoch integer). And filters can be applied to
  clean/preprocess the string (e.g. remove leading/trailing blanks) beforehand.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<args> => I<hash>
  
  Reference to hash which store the arguments.
  
  =item * B<meta>* => I<hash>
  
  Rinci function metadata.
  
  =item * B<meta_is_normalized> => I<bool>
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-CoerceArgs>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-CoerceArgs>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-CoerceArgs>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_SUB_COERCEARGS

$fatpacked{"Perinci/Sub/Complete.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_COMPLETE';
  package Perinci::Sub::Complete;
  
  our $DATE = '2015-04-09'; # DATE
  our $VERSION = '0.78'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  use experimental 'smartmatch';
  use Log::Any::IfLOG '$log';
  
  use Complete;
  use Complete::Util qw(hashify_answer complete_array_elem combine_answers);
  use Perinci::Sub::Util qw(gen_modified_sub);
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(
                         complete_from_schema
                         complete_arg_val
                         complete_arg_elem
                         complete_cli_arg
                 );
  our %SPEC;
  
  $SPEC{':package'} = {
      v => 1.1,
      summary => 'Complete command-line argument using Rinci metadata',
  };
  
  my %common_args_riap = (
      riap_client => {
          summary => 'Optional, to perform complete_arg_val to the server',
          schema  => 'obj*',
          description => <<'_',
  
  When the argument spec in the Rinci metadata contains `completion` key, this
  means there is custom completion code for that argument. However, if retrieved
  from a remote server, sometimes the `completion` key no longer contains the code
  (it has been cleansed into a string). Moreover, the completion code needs to run
  on the server.
  
  If supplied this argument and te `riap_server_url` argument, the function will
  try to request to the server (via Riap request `complete_arg_val`). Otherwise,
  the function will just give up/decline completing.
  
  _
          },
      riap_server_url => {
          summary => 'Optional, to perform complete_arg_val to the server',
          schema  => 'str*',
          description => <<'_',
  
  See the `riap_client` argument.
  
  _
      },
      riap_uri => {
          summary => 'Optional, to perform complete_arg_val to the server',
          schema  => 'str*',
          description => <<'_',
  
  See the `riap_client` argument.
  
  _
      },
  );
  
  $SPEC{complete_from_schema} = {
      v => 1.1,
      summary => 'Complete a value from schema',
      description => <<'_',
  
  Employ some heuristics to complete a value from Sah schema. For example, if
  schema is `[str => in => [qw/new open resolved rejected/]]`, then we can
  complete from the `in` clause. Or for something like `[int => between => [1,
  20]]` we can complete using values from 1 to 20.
  
  _
      args => {
          schema => {
              summary => 'Must be normalized',
              req => 1,
          },
          word => {
              schema => [str => default => ''],
              req => 1,
          },
          ci => {
              schema => 'bool',
          },
      },
  };
  sub complete_from_schema {
      my %args = @_;
      my $sch  = $args{schema}; # must be normalized
      my $word = $args{word} // "";
      my $ci   = $args{ci} // $Complete::OPT_CI;
  
      my $fres;
      $log->tracef("[comp][periscomp] entering complete_from_schema, word=<%s>, schema=%s", $word, $sch);
  
      my ($type, $cs) = @{$sch};
  
      my $static;
      my $words;
      eval {
          if ($cs->{is} && !ref($cs->{is})) {
              $log->tracef("[comp][periscomp] adding completion from 'is' clause");
              push @$words, $cs->{is};
              $static++;
              return; # from eval. there should not be any other value
          }
          if ($cs->{in}) {
              $log->tracef("[comp][periscomp] adding completion from 'in' clause");
              push @$words, grep {!ref($_)} @{ $cs->{in} };
              $static++;
              return; # from eval. there should not be any other value
          }
          if ($type eq 'any') {
              # because currently Data::Sah::Normalize doesn't recursively
              # normalize schemas in 'of' clauses, etc.
              require Data::Sah::Normalize;
              if ($cs->{of} && @{ $cs->{of} }) {
                  $fres = combine_answers(
                      grep { defined } map {
                          complete_from_schema(
                              schema=>Data::Sah::Normalize::normalize_schema($_),
                              word => $word,
                              ci => $ci,
                          )
                      } @{ $cs->{of} }
                  );
                  goto RETURN_RES; # directly return result
              }
          }
          if ($type eq 'bool') {
              $log->tracef("[comp][periscomp] adding completion from possible values of bool");
              push @$words, 0, 1;
              $static++;
              return; # from eval
          }
          if ($type eq 'int') {
              my $limit = 100;
              if ($cs->{between} &&
                      $cs->{between}[0] - $cs->{between}[0] <= $limit) {
                  $log->tracef("[comp][periscomp] adding completion from 'between' clause");
                  push @$words, $cs->{between}[0] .. $cs->{between}[1];
                  $static++;
              } elsif ($cs->{xbetween} &&
                           $cs->{xbetween}[0] - $cs->{xbetween}[0] <= $limit) {
                  $log->tracef("[comp][periscomp] adding completion from 'xbetween' clause");
                  push @$words, $cs->{xbetween}[0]+1 .. $cs->{xbetween}[1]-1;
                  $static++;
              } elsif (defined($cs->{min}) && defined($cs->{max}) &&
                           $cs->{max}-$cs->{min} <= $limit) {
                  $log->tracef("[comp][periscomp] adding completion from 'min' & 'max' clauses");
                  push @$words, $cs->{min} .. $cs->{max};
                  $static++;
              } elsif (defined($cs->{min}) && defined($cs->{xmax}) &&
                           $cs->{xmax}-$cs->{min} <= $limit) {
                  $log->tracef("[comp][periscomp] adding completion from 'min' & 'xmax' clauses");
                  push @$words, $cs->{min} .. $cs->{xmax}-1;
                  $static++;
              } elsif (defined($cs->{xmin}) && defined($cs->{max}) &&
                           $cs->{max}-$cs->{xmin} <= $limit) {
                  $log->tracef("[comp][periscomp] adding completion from 'xmin' & 'max' clauses");
                  push @$words, $cs->{xmin}+1 .. $cs->{max};
                  $static++;
              } elsif (defined($cs->{xmin}) && defined($cs->{xmax}) &&
                           $cs->{xmax}-$cs->{xmin} <= $limit) {
                  $log->tracef("[comp][periscomp] adding completion from 'xmin' & 'xmax' clauses");
                  push @$words, $cs->{xmin}+1 .. $cs->{xmax}-1;
                  $static++;
              } elsif (length($word) && $word !~ /\A-?\d*\z/) {
                  $log->tracef("[comp][periscomp] word not an int");
                  $words = [];
              } else {
                  # do a digit by digit completion
                  $words = [];
                  for my $sign ("", "-") {
                      for ("", 0..9) {
                          my $i = $sign . $word . $_;
                          next unless length $i;
                          next unless $i =~ /\A-?\d+\z/;
                          next if $i eq '-0';
                          next if $i =~ /\A-?0\d/;
                          next if $cs->{between} &&
                              ($i < $cs->{between}[0] ||
                                   $i > $cs->{between}[1]);
                          next if $cs->{xbetween} &&
                              ($i <= $cs->{xbetween}[0] ||
                                   $i >= $cs->{xbetween}[1]);
                          next if defined($cs->{min} ) && $i <  $cs->{min};
                          next if defined($cs->{xmin}) && $i <= $cs->{xmin};
                          next if defined($cs->{max} ) && $i >  $cs->{max};
                          next if defined($cs->{xmin}) && $i >= $cs->{xmax};
                          push @$words, $i;
                      }
                  }
                  $words = [sort @$words];
              }
              return; # from eval
          }
          if ($type eq 'float') {
              if (length($word) && $word !~ /\A-?\d*(\.\d*)?\z/) {
                  $log->tracef("[comp][periscomp] word not a float");
                  $words = [];
              } else {
                  $words = [];
                  for my $sig ("", "-") {
                      for ("", 0..9,
                           ".0",".1",".2",".3",".4",".5",".6",".7",".8",".9") {
                          my $f = $sig . $word . $_;
                          next unless length $f;
                          next unless $f =~ /\A-?\d+(\.\d+)?\z/;
                          next if $f eq '-0';
                          next if $f =~ /\A-?0\d\z/;
                          next if $cs->{between} &&
                              ($f < $cs->{between}[0] ||
                                   $f > $cs->{between}[1]);
                          next if $cs->{xbetween} &&
                              ($f <= $cs->{xbetween}[0] ||
                                   $f >= $cs->{xbetween}[1]);
                          next if defined($cs->{min} ) && $f <  $cs->{min};
                          next if defined($cs->{xmin}) && $f <= $cs->{xmin};
                          next if defined($cs->{max} ) && $f >  $cs->{max};
                          next if defined($cs->{xmin}) && $f >= $cs->{xmax};
                          push @$words, $f;
                      }
                  }
              }
              return; # from eval
          }
      }; # eval
  
      $log->tracef("[periscomp] complete_from_schema died: %s", $@) if $@;
  
      goto RETURN_RES unless $words;
      $fres = hashify_answer(
          complete_array_elem(array=>$words, word=>$word, ci=>$ci),
          {static=>$static && $word eq '' ? 1:0},
      );
  
    RETURN_RES:
      $log->tracef("[comp][periscomp] leaving complete_from_schema, result=%s", $fres);
      $fres;
  }
  
  $SPEC{complete_arg_val} = {
      v => 1.1,
      summary => 'Given argument name and function metadata, complete value',
      description => <<'_',
  
  Will attempt to complete using the completion routine specified in the argument
  specification (the `completion` property, or in the case of `complete_arg_elem`
  function, the `element_completion` property), or if that is not specified, from
  argument's schema using `complete_from_schema`.
  
  Completion routine will get `%args`, with the following keys:
  
  * `word` (str, the word to be completed)
  * `ci` (bool, whether string matching should be case-insensitive)
  * `arg` (str, the argument name which value is currently being completed)
  * `index (int, only for the `complete_arg_elem` function, the index in the
     argument array that is currently being completed, starts from 0)
  * `args` (hash, the argument hash to the function, so far)
  
  as well as extra keys from `extras` (but these won't overwrite the above
  standard keys).
  
  Completion routine should return a completion answer structure (described in
  `Complete`) which is either a hash or an array. The simplest form of answer is
  just to return an array of strings. Completion routine can also return undef to
  express declination.
  
  _
      args => {
          meta => {
              summary => 'Rinci function metadata, must be normalized',
              schema => 'hash*',
              req => 1,
          },
          arg => {
              summary => 'Argument name',
              schema => 'str*',
              req => 1,
          },
          word => {
              summary => 'Word to be completed',
              schema => ['str*', default => ''],
          },
          ci => {
              summary => 'Whether to be case-insensitive',
              schema => ['bool*'],
          },
          args => {
              summary => 'Collected arguments so far, '.
                  'will be passed to completion routines',
              schema  => 'hash',
          },
          extras => {
              summary => 'Add extra arguments to completion routine',
              schema  => 'hash',
              description => <<'_',
  
  The keys from this `extras` hash will be merged into the final `%args` passed to
  completion routines. Note that standard keys like `word`, `cword`, `ci`, and so
  on as described in the function description will not be overwritten by this.
  
  _
          },
  
          %common_args_riap,
      },
      result_naked => 1,
      result => {
          schema => 'array', # XXX of => str*
      },
  };
  sub complete_arg_val {
      my %args = @_;
  
      $log->tracef("[comp][periscomp] entering complete_arg_val, arg=<%s>", $args{arg});
      my $fres;
  
      my $extras = $args{extras} // {};
  
      my $meta = $args{meta} or do {
          $log->tracef("[comp][periscomp] meta is not supplied, declining");
          goto RETURN_RES;
      };
      my $arg  = $args{arg} or do {
          $log->tracef("[comp][periscomp] arg is not supplied, declining");
          goto RETURN_RES;
      };
      my $ci   = $args{ci} // $Complete::OPT_CI;
      my $word = $args{word} // '';
  
      # XXX reject if meta's v is not 1.1
  
      my $args_prop = $meta->{args} // {};
      my $arg_spec = $args_prop->{$arg} or do {
          $log->tracef("[comp][periscomp] arg '$arg' is not specified in meta, declining");
          goto RETURN_RES;
      };
  
      my $static;
      eval { # completion sub can die, etc.
  
          my $comp;
        GET_COMP_ROUTINE:
          {
              $comp = $arg_spec->{completion};
              if ($comp) {
                  $log->tracef("[comp][periscomp] using arg completion routine from 'completion' property");
                  last GET_COMP_ROUTINE;
              }
              my $xcomp = $arg_spec->{'x.completion'};
              if ($xcomp) {
                  require Module::Path::More;
                  my $mod = "Perinci::Sub::XCompletion::$xcomp->[0]";
                  if (Module::Path::More::module_path(module=>$mod)) {
                      $log->tracef("[comp][periscomp] loading module %s ...", $mod);
                      my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm";
                      require $mod_pm;
                      my $fref = \&{"$mod\::gen_completion"};
                      $comp = $fref->(%{ $xcomp->[1] });
                  }
                  if ($comp) {
                      $log->tracef("[comp][periscomp] using arg completion routine from 'x.completion' attribute");
                      last GET_COMP_ROUTINE;
                  }
              }
              my $ent = $arg_spec->{'x.schema.entity'};
              if ($ent) {
                  require Module::Path::More;
                  my $mod = "Perinci::Sub::ArgEntity::$ent";
                  if (Module::Path::More::module_path(module=>$mod)) {
                      $log->tracef("[comp][periscomp] loading module %s ...", $mod);
                      my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm";
                      require $mod_pm;
                      if (defined &{"$mod\::complete_arg_val"}) {
                          $log->tracef("[comp][periscomp] using arg completion routine from complete_arg_val() from %s", $mod);
                          $comp = \&{"$mod\::complete_arg_val"};
                          last GET_COMP_ROUTINE;
                      }
                  }
              }
          } # GET_COMP_ROUTINE
  
          if ($comp) {
              if (ref($comp) eq 'CODE') {
                  $log->tracef("[comp][periscomp] invoking arg completion routine");
                  $fres = $comp->(
                      %$extras,
                      word=>$word, ci=>$ci, arg=>$arg, args=>$args{args});
                  return; # from eval
              } elsif (ref($comp) eq 'ARRAY') {
                  # this is deprecated but will be supported for some time
                  $log->tracef("[comp][periscomp] using array specified in arg completion routine: %s", $comp);
                  $fres = complete_array_elem(
                      array=>$comp, word=>$word, ci=>$ci);
                  $static++;
                  return; # from eval
              }
  
              $log->tracef("[comp][periscomp] arg spec's 'completion' property is not a coderef or arrayref");
              if ($args{riap_client} && $args{riap_server_url}) {
                  $log->tracef("[comp][periscomp] trying to perform complete_arg_val request to Riap server");
                  my $res = $args{riap_client}->request(
                      complete_arg_val => $args{riap_server_url},
                      {(uri=>$args{riap_uri}) x !!defined($args{riap_uri}),
                       arg=>$arg, word=>$word, ci=>$ci},
                  );
                  if ($res->[0] != 200) {
                      $log->tracef("[comp][periscomp] Riap request failed (%s), declining", $res);
                      return; # from eval
                  }
                  $fres = $res->[2];
                  return; # from eval
              }
  
              $log->tracef("[comp][periscomp] declining");
              return; # from eval
          }
  
          my $sch = $arg_spec->{schema};
          unless ($sch) {
              $log->tracef("[comp][periscomp] arg spec does not specify schema, declining");
              return; # from eval
          };
  
          # XXX normalize schema if not normalized
  
          $fres = complete_from_schema(schema=>$sch, word=>$word, ci=>$ci);
      };
      $log->debug("[comp][periscomp] completion died: $@") if $@;
      unless ($fres) {
          $log->tracef("[comp][periscomp] no completion from metadata possible, declining");
          goto RETURN_RES;
      }
  
      $fres = hashify_answer($fres);
      $fres->{static} //= $static && $word eq '' ? 1:0;
    RETURN_RES:
      $log->tracef("[comp][periscomp] leaving complete_arg_val, result=%s", $fres);
      $fres;
  }
  
  gen_modified_sub(
      output_name  => 'complete_arg_elem',
      install_sub  => 0,
      base_name    => 'complete_arg_val',
      summary      => 'Given argument name and function metadata, '.
          'complete array element',
      add_args     => {
          index => {
              summary => 'Index of element to complete',
              schema  => [int => min => 0],
          },
      },
  );
  sub complete_arg_elem {
      require Data::Sah::Normalize;
  
      my %args = @_;
  
      my $fres;
  
      $log->tracef("[comp][periscomp] entering complete_arg_elem, arg=<%s>, index=<%d>",
                   $args{arg}, $args{index});
  
      my $extras = $args{extras} // {};
  
      my $ourextras = {arg=>$args{arg}, args=>$args{args}};
  
      my $meta = $args{meta} or do {
          $log->tracef("[comp][periscomp] meta is not supplied, declining");
          goto RETURN_RES;
      };
      my $arg  = $args{arg} or do {
          $log->tracef("[comp][periscomp] arg is not supplied, declining");
          goto RETURN_RES;
      };
      defined(my $index = $args{index}) or do {
          $log->tracef("[comp][periscomp] index is not supplied, declining");
          goto RETURN_RES;
      };
      my $ci   = $args{ci} // $Complete::OPT_CI;
      my $word = $args{word} // '';
  
      # XXX reject if meta's v is not 1.1
  
      my $args_prop = $meta->{args} // {};
      my $arg_spec = $args_prop->{$arg} or do {
          $log->tracef("[comp][periscomp] arg '$arg' is not specified in meta, declining");
          goto RETURN_RES;
      };
  
      my $static;
      eval { # completion sub can die, etc.
  
          my $elcomp;
        GET_ELCOMP_ROUTINE:
          {
              $elcomp = $arg_spec->{element_completion};
              if ($elcomp) {
                  $log->tracef("[comp][periscomp] using arg element completion routine from 'element_completion' property");
                  last GET_ELCOMP_ROUTINE;
              }
              my $xelcomp = $arg_spec->{'x.element_completion'};
              if ($xelcomp) {
                 require Module::Path::More;
                  my $mod = "Perinci::Sub::XCompletion::$xelcomp->[0]";
                  if (Module::Path::More::module_path(module=>$mod)) {
                      $log->tracef("[comp][periscomp] loading module %s ...", $mod);
                      my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm";
                      require $mod_pm;
                      my $fref = \&{"$mod\::gen_completion"};
                      $elcomp = $fref->(%{ $xelcomp->[1] });
                  }
                  if ($elcomp) {
                      $log->tracef("[comp][periscomp] using arg element completion routine from 'x.element_completion' attribute");
                      last GET_ELCOMP_ROUTINE;
                  }
              }
              my $ent = $arg_spec->{'x.schema.element_entity'};
              if ($ent) {
                  require Module::Path::More;
                  my $mod = "Perinci::Sub::ArgEntity::$ent";
                  if (Module::Path::More::module_path(module=>$mod)) {
                      $log->tracef("[comp][periscomp] loading module %s ...", $mod);
                      my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm";
                      require $mod_pm;
                      if (defined &{"$mod\::complete_arg_val"}) {
                          $log->tracef("[comp][periscomp] using arg element completion routine from complete_arg_val() from %s", $mod);
                          $elcomp = \&{"$mod\::complete_arg_val"};
                          last GET_ELCOMP_ROUTINE;
                      }
                  }
              }
          } # GET_ELCOMP_ROUTINE
  
          $ourextras->{index} = $index;
          if ($elcomp) {
              if (ref($elcomp) eq 'CODE') {
                  $log->tracef("[comp][periscomp] invoking arg element completion routine");
                  $fres = $elcomp->(
                      %$extras,
                      %$ourextras,
                      word=>$word, ci=>$ci);
                  return; # from eval
              } elsif (ref($elcomp) eq 'ARRAY') {
                  $log->tracef("[comp][periscomp] using array specified in arg element completion routine: %s", $elcomp);
                  $fres = complete_array_elem(
                      array=>$elcomp, word=>$word, ci=>$ci);
                  $static = $word eq '';
              }
  
              $log->tracef("[comp][periscomp] arg spec's 'element_completion' property is not a coderef or ".
                               "arrayref");
              if ($args{riap_client} && $args{riap_server_url}) {
                  $log->tracef("[comp][periscomp] trying to perform complete_arg_elem request to Riap server");
                  my $res = $args{riap_client}->request(
                      complete_arg_elem => $args{riap_server_url},
                      {(uri=>$args{riap_uri}) x !!defined($args{riap_uri}),
                       arg=>$arg, args=>$args{args}, word=>$word, ci=>$ci,
                       index=>$index},
                  );
                  if ($res->[0] != 200) {
                      $log->tracef("[comp][periscomp] Riap request failed (%s), declining", $res);
                      return; # from eval
                  }
                  $fres = $res->[2];
                  return; # from eval
              }
  
              $log->tracef("[comp][periscomp] declining");
              return; # from eval
          }
  
          my $sch = $arg_spec->{schema};
          unless ($sch) {
              $log->tracef("[comp][periscomp] arg spec does not specify schema, declining");
              return; # from eval
          };
  
          # XXX normalize if not normalized
  
          my ($type, $cs) = @{ $sch };
          if ($type ne 'array') {
              $log->tracef("[comp][periscomp] can't complete element for non-array");
              return; # from eval
          }
  
          unless ($cs->{of}) {
              $log->tracef("[comp][periscomp] schema does not specify 'of' clause, declining");
              return; # from eval
          }
  
          # normalize subschema because normalize_schema (as of 0.01) currently
          # does not do it yet
          my $elsch = Data::Sah::Normalize::normalize_schema($cs->{of});
  
          $fres = complete_from_schema(schema=>$elsch, word=>$word, ci=>$ci);
      };
      $log->debug("[comp][periscomp] completion died: $@") if $@;
      unless ($fres) {
          $log->tracef("[comp][periscomp] no completion from metadata possible, declining");
          goto RETURN_RES;
      }
  
      $fres = hashify_answer($fres);
      $fres->{static} //= $static && $word eq '' ? 1:0;
    RETURN_RES:
      $log->tracef("[comp][periscomp] leaving complete_arg_elem, result=%s", $fres);
      $fres;
  }
  
  $SPEC{complete_cli_arg} = {
      v => 1.1,
      summary => 'Complete command-line argument using Rinci function metadata',
      description => <<'_',
  
  This routine uses `Perinci::Sub::GetArgs::Argv` to generate `Getopt::Long`
  specification from arguments list in Rinci function metadata and common options.
  Then, it will use `Complete::Getopt::Long` to complete option names, option
  values, as well as arguments.
  
  _
      args => {
          meta => {
              summary => 'Rinci function metadata',
              schema => 'hash*',
              req => 1,
          },
          words => {
              summary => 'Command-line arguments',
              schema => ['array*' => {of=>'str*'}],
              req => 1,
          },
          cword => {
              summary => 'On which argument cursor is located (zero-based)',
              schema => 'int*',
              req => 1,
          },
          completion => {
              summary => 'Supply custom completion routine',
              description => <<'_',
  
  If supplied, instead of the default completion routine, this code will be called
  instead. Will receive all arguments that `Complete::Getopt::Long` will pass, and
  additionally:
  
  * `arg` (str, the name of function argument)
  * `args` (hash, the function arguments formed so far)
  * `index` (int, if completing argument element value)
  
  _
              schema => 'code*',
          },
          per_arg_json => {
              summary => 'Will be passed to Perinci::Sub::GetArgs::Argv',
              schema  => 'bool',
          },
          per_arg_yaml => {
              summary => 'Will be passed to Perinci::Sub::GetArgs::Argv',
              schema  => 'bool',
          },
          common_opts => {
              summary => 'Common options',
              description => <<'_',
  
  A hash where the values are hashes containing these keys: `getopt` (Getopt::Long
  option specification), `handler` (Getopt::Long handler). Will be passed to
  `get_args_from_argv()`. Example:
  
      {
          help => {
              getopt  => 'help|h|?',
              handler => sub { ... },
              summary => 'Display help and exit',
          },
          version => {
              getopt  => 'version|v',
              handler => sub { ... },
              summary => 'Display version and exit',
          },
      }
  
  _
              schema => ['hash*'],
          },
          extras => {
              summary => 'Add extra arguments to completion routine',
              schema  => 'hash',
              description => <<'_',
  
  The keys from this `extras` hash will be merged into the final `%args` passed to
  completion routines. Note that standard keys like `word`, `cword`, `ci`, and so
  on as described in the function description will not be overwritten by this.
  
  _
          },
          func_arg_starts_at => {
              schema  => 'int*',
              default => 0,
              description => <<'_',
  
  This is a (temporary?) workaround for Perinci::CmdLine. In an application with
  subcommands (e.g. `cmd --verbose subcmd arg0 arg1 ...`), then `words` will still
  contain the subcommand name. Positional function arguments then start at 1 not
  0. This option allows offsetting function arguments.
  
  _
          },
          %common_args_riap,
      },
      result_naked => 1,
      result => {
          schema => 'hash*',
          description => <<'_',
  
  You can use `format_completion` function in `Complete::Bash` module to format
  the result of this function for bash.
  
  _
      },
  };
  sub complete_cli_arg {
      require Complete::Getopt::Long;
      require Perinci::Sub::GetArgs::Argv;
  
      my %args   = @_;
      my $meta   = $args{meta} or die "Please specify meta";
      my $words  = $args{words} or die "Please specify words";
      my $cword  = $args{cword}; defined($cword) or die "Please specify cword";
      my $copts  = $args{common_opts} // {};
      my $comp   = $args{completion};
      my $extras = {
          %{ $args{extras} // {} },
          words => $args{words},
          cword => $args{cword},
      };
  
      my $fname = __PACKAGE__ . "::complete_cli_arg"; # XXX use __SUB__
      my $fres;
  
      my $word   = $words->[$cword];
      my $args_prop = $meta->{args} // {};
  
      $log->tracef('[comp][periscomp] entering %s(), words=%s, cword=%d, word=<%s>',
                   $fname, $words, $cword, $word);
  
      my $genres = Perinci::Sub::GetArgs::Argv::gen_getopt_long_spec_from_meta(
          meta         => $meta,
          common_opts  => $copts,
          per_arg_json => $args{per_arg_json},
          per_arg_yaml => $args{per_arg_yaml},
          ignore_converted_code => 1,
      );
      die "Can't generate getopt spec from meta: $genres->[0] - $genres->[1]"
          unless $genres->[0] == 200;
      my $gospec = $genres->[2];
      my $specmeta = $genres->[3]{'func.specmeta'};
  
      my $gares = Perinci::Sub::GetArgs::Argv::get_args_from_argv(
          argv   => [@$words],
          meta   => $meta,
          strict => 0,
      );
  
      my $copts_by_ospec = {};
      for (keys %$copts) { $copts_by_ospec->{$copts->{$_}{getopt}}=$copts->{$_} }
  
      my $compgl_comp = sub {
          $log->tracef("[comp][periscomp] entering completion routine (that we supply to Complete::Getopt::Long)");
          my %cargs = @_;
          my $type  = $cargs{type};
          my $ospec = $cargs{ospec} // '';
          my $word  = $cargs{word};
          my $ci    = $cargs{ci} // $Complete::OPT_CI;
  
          my $fres;
  
          my %rargs = (
              riap_server_url => $args{riap_server_url},
              riap_uri        => $args{riap_uri},
              riap_client     => $args{riap_client},
          );
  
          if (my $sm = $specmeta->{$ospec}) {
              $cargs{type} = 'optval';
              if ($sm->{arg}) {
                  $log->tracef("[comp][periscomp] completing option value for a known function argument, arg=<%s>, ospec=<%s>", $sm->{arg}, $ospec);
                  $cargs{arg} = $sm->{arg};
                  my $arg_spec = $args_prop->{$sm->{arg}} or goto RETURN_RES;
                  if ($comp) {
                      $log->tracef("[comp][periscomp] invoking routine supplied from 'completion' argument");
                      my $compres;
                      eval { $compres = $comp->(%cargs) };
                      $log->debug("[comp][periscomp] completion died: $@") if $@;
                      $log->tracef("[comp][periscomp] result from 'completion' routine: %s", $compres);
                      if ($compres) {
                          $fres = $compres;
                          goto RETURN_RES;
                      }
                  }
                  if ($ospec =~ /\@$/) {
                      $fres = complete_arg_elem(
                          meta=>$meta, arg=>$sm->{arg}, args=>$gares->[2],
                          word=>$word, index=>$cargs{nth}, # XXX correct index
                          extras=>$extras, %rargs);
                      goto RETURN_RES;
                  } else {
                      $fres = complete_arg_val(
                          meta=>$meta, arg=>$sm->{arg}, args=>$gares->[2],
                          word=>$word, extras=>$extras, %rargs);
                      goto RETURN_RES;
                  }
              } else {
                  $log->tracef("[comp][periscomp] completing option value for a common option, ospec=<%s>", $ospec);
                  $cargs{arg}  = undef;
                  my $codata = $copts_by_ospec->{$ospec};
                  if ($comp) {
                      $log->tracef("[comp][periscomp] invoking routine supplied from 'completion' argument");
                      my $res;
                      eval { $res = $comp->(%cargs) };
                      $log->debug("[comp][periscomp] completion died: $@") if $@;
                      if ($res) {
                          $fres = $res;
                          goto RETURN_RES;
                      }
                  }
                  if ($codata->{completion}) {
                      $cargs{arg}  = undef;
                      $log->tracef("[comp][periscomp] completing with common option's 'completion' property");
                      my $res;
                      eval { $res = $codata->{completion}->(%cargs) };
                      $log->debug("[comp][periscomp] completion died: $@") if $@;
                      if ($res) {
                          $fres = $res;
                          goto RETURN_RES;
                      }
                  }
                  if ($codata->{schema}) {
                      require Data::Sah::Normalize;
                      my $nsch = Data::Sah::Normalize::normalize_schema(
                          $codata->{schema});
                      $log->tracef("[comp][periscomp] completing with common option's schema");
                      $fres = complete_from_schema(
                          schema => $nsch, word=>$word, ci=>$ci);
                      goto RETURN_RES;
                  }
                  goto RETURN_RES;
              }
          } elsif ($type eq 'arg') {
              $log->tracef("[comp][periscomp] completing argument #%d", $cargs{argpos});
              $cargs{type} = 'arg';
  
              my $pos = $cargs{argpos};
              my $fasa = $args{func_arg_starts_at} // 0;
  
              # find if there is a non-greedy argument with the exact position
              for my $an (keys %$args_prop) {
                  my $arg_spec = $args_prop->{$an};
                  next unless !$arg_spec->{greedy} &&
                      defined($arg_spec->{pos}) && $arg_spec->{pos} == $pos - $fasa;
                  $log->tracef("[comp][periscomp] this argument position is for non-greedy function argument <%s>", $an);
                  $cargs{arg} = $an;
                  if ($comp) {
                      $log->tracef("[comp][periscomp] invoking routine supplied from 'completion' argument");
                      my $res;
                      eval { $res = $comp->(%cargs) };
                      $log->debug("[comp][periscomp] completion died: $@") if $@;
                      if ($res) {
                          $fres = $res;
                          goto RETURN_RES;
                      }
                  }
                  $fres = complete_arg_val(
                      meta=>$meta, arg=>$an, args=>$gares->[2],
                      word=>$word, extras=>$extras, %rargs);
                  goto RETURN_RES;
              }
  
              # find if there is a greedy argument which takes elements at that
              # position
              for my $an (sort {
                  ($args_prop->{$b}{pos} // 9999) <=> ($args_prop->{$a}{pos} // 9999)
              } keys %$args_prop) {
                  my $arg_spec = $args_prop->{$an};
                  next unless $arg_spec->{greedy} &&
                      defined($arg_spec->{pos}) && $arg_spec->{pos} <= $pos - $fasa;
                  my $index = $pos - $fasa - $arg_spec->{pos};
                  $cargs{arg} = $an;
                  $cargs{index} = $index;
                  $log->tracef("[comp][periscomp] this position is for greedy function argument <%s>'s element[%d]", $an, $index);
                  if ($comp) {
                      $log->tracef("[comp][periscomp] invoking routine supplied from 'completion' argument");
                      my $res;
                      eval { $res = $comp->(%cargs) };
                      $log->debug("[comp][periscomp] completion died: $@") if $@;
                      if ($res) {
                          $fres = $res;
                          goto RETURN_RES;
                      }
                  }
                  $fres = complete_arg_elem(
                      meta=>$meta, arg=>$an, args=>$gares->[2],
                      word=>$word, index=>$index, extras=>$extras, %rargs);
                  goto RETURN_RES;
              }
  
              $log->tracef("[comp][periscomp] there is no matching function argument at this position");
              if ($comp) {
                  $log->tracef("[comp][periscomp] invoking routine supplied from 'completion' argument");
                  my $res;
                  eval { $res = $comp->(%cargs) };
                  $log->debug("[comp][periscomp] completion died: $@") if $@;
                  if ($res) {
                      $fres = $res;
                      goto RETURN_RES;
                  }
              }
              goto RETURN_RES;
          } else {
              $log->tracef("[comp][periscomp] completing option value for an unknown/ambiguous option, declining ...");
              # decline because there's nothing in Rinci metadata that can aid us
              goto RETURN_RES;
          }
        RETURN_RES:
          $log->tracef("[comp][periscomp] leaving completion routine (that we supply to Complete::Getopt::Long)");
          $fres;
      }; # completion routine
  
      $fres = Complete::Getopt::Long::complete_cli_arg(
          getopt_spec => $gospec,
          words       => $words,
          cword       => $cword,
          completion  => $compgl_comp,
          extras      => $extras,
      );
  
    RETURN_RES:
      $log->tracef('[comp][periscomp] leaving %s(), result=%s',
                   $fname, $fres);
      $fres;
  }
  
  1;
  # ABSTRACT: Complete command-line argument using Rinci metadata
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::Complete - Complete command-line argument using Rinci metadata
  
  =head1 VERSION
  
  This document describes version 0.78 of Perinci::Sub::Complete (from Perl distribution Perinci-Sub-Complete), released on 2015-04-09.
  
  =head1 SYNOPSIS
  
  See L<Perinci::CmdLine> or L<Perinci::CmdLine::Lite> or L<App::riap> which use
  this module.
  
  =head1 DESCRIPTION
  
  =head1 FUNCTIONS
  
  
  =head2 complete_arg_elem(%args) -> array
  
  Given argument name and function metadata, complete array element.
  
  Will attempt to complete using the completion routine specified in the argument
  specification (the C<completion> property, or in the case of C<complete_arg_elem>
  function, the C<element_completion> property), or if that is not specified, from
  argument's schema using C<complete_from_schema>.
  
  Completion routine will get C<%args>, with the following keys:
  
  =over
  
  =item * C<word> (str, the word to be completed)
  
  =item * C<ci> (bool, whether string matching should be case-insensitive)
  
  =item * C<arg> (str, the argument name which value is currently being completed)
  
  =item * C<index (int, only for the>complete_arg_elem` function, the index in the
  argument array that is currently being completed, starts from 0)
  
  =item * C<args> (hash, the argument hash to the function, so far)
  
  =back
  
  as well as extra keys from C<extras> (but these won't overwrite the above
  standard keys).
  
  Completion routine should return a completion answer structure (described in
  C<Complete>) which is either a hash or an array. The simplest form of answer is
  just to return an array of strings. Completion routine can also return undef to
  express declination.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<arg>* => I<str>
  
  Argument name.
  
  =item * B<args> => I<hash>
  
  Collected arguments so far, will be passed to completion routines.
  
  =item * B<ci> => I<bool>
  
  Whether to be case-insensitive.
  
  =item * B<extras> => I<hash>
  
  Add extra arguments to completion routine.
  
  The keys from this C<extras> hash will be merged into the final C<%args> passed to
  completion routines. Note that standard keys like C<word>, C<cword>, C<ci>, and so
  on as described in the function description will not be overwritten by this.
  
  =item * B<index> => I<int>
  
  Index of element to complete.
  
  =item * B<meta>* => I<hash>
  
  Rinci function metadata, must be normalized.
  
  =item * B<riap_client> => I<obj>
  
  Optional, to perform complete_arg_val to the server.
  
  When the argument spec in the Rinci metadata contains C<completion> key, this
  means there is custom completion code for that argument. However, if retrieved
  from a remote server, sometimes the C<completion> key no longer contains the code
  (it has been cleansed into a string). Moreover, the completion code needs to run
  on the server.
  
  If supplied this argument and te C<riap_server_url> argument, the function will
  try to request to the server (via Riap request C<complete_arg_val>). Otherwise,
  the function will just give up/decline completing.
  
  =item * B<riap_server_url> => I<str>
  
  Optional, to perform complete_arg_val to the server.
  
  See the C<riap_client> argument.
  
  =item * B<riap_uri> => I<str>
  
  Optional, to perform complete_arg_val to the server.
  
  See the C<riap_client> argument.
  
  =item * B<word> => I<str> (default: "")
  
  Word to be completed.
  
  =back
  
  Return value:  (array)
  
  
  =head2 complete_arg_val(%args) -> array
  
  Given argument name and function metadata, complete value.
  
  Will attempt to complete using the completion routine specified in the argument
  specification (the C<completion> property, or in the case of C<complete_arg_elem>
  function, the C<element_completion> property), or if that is not specified, from
  argument's schema using C<complete_from_schema>.
  
  Completion routine will get C<%args>, with the following keys:
  
  =over
  
  =item * C<word> (str, the word to be completed)
  
  =item * C<ci> (bool, whether string matching should be case-insensitive)
  
  =item * C<arg> (str, the argument name which value is currently being completed)
  
  =item * C<index (int, only for the>complete_arg_elem` function, the index in the
  argument array that is currently being completed, starts from 0)
  
  =item * C<args> (hash, the argument hash to the function, so far)
  
  =back
  
  as well as extra keys from C<extras> (but these won't overwrite the above
  standard keys).
  
  Completion routine should return a completion answer structure (described in
  C<Complete>) which is either a hash or an array. The simplest form of answer is
  just to return an array of strings. Completion routine can also return undef to
  express declination.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<arg>* => I<str>
  
  Argument name.
  
  =item * B<args> => I<hash>
  
  Collected arguments so far, will be passed to completion routines.
  
  =item * B<ci> => I<bool>
  
  Whether to be case-insensitive.
  
  =item * B<extras> => I<hash>
  
  Add extra arguments to completion routine.
  
  The keys from this C<extras> hash will be merged into the final C<%args> passed to
  completion routines. Note that standard keys like C<word>, C<cword>, C<ci>, and so
  on as described in the function description will not be overwritten by this.
  
  =item * B<meta>* => I<hash>
  
  Rinci function metadata, must be normalized.
  
  =item * B<riap_client> => I<obj>
  
  Optional, to perform complete_arg_val to the server.
  
  When the argument spec in the Rinci metadata contains C<completion> key, this
  means there is custom completion code for that argument. However, if retrieved
  from a remote server, sometimes the C<completion> key no longer contains the code
  (it has been cleansed into a string). Moreover, the completion code needs to run
  on the server.
  
  If supplied this argument and te C<riap_server_url> argument, the function will
  try to request to the server (via Riap request C<complete_arg_val>). Otherwise,
  the function will just give up/decline completing.
  
  =item * B<riap_server_url> => I<str>
  
  Optional, to perform complete_arg_val to the server.
  
  See the C<riap_client> argument.
  
  =item * B<riap_uri> => I<str>
  
  Optional, to perform complete_arg_val to the server.
  
  See the C<riap_client> argument.
  
  =item * B<word> => I<str> (default: "")
  
  Word to be completed.
  
  =back
  
  Return value:  (array)
  
  
  =head2 complete_cli_arg(%args) -> hash
  
  Complete command-line argument using Rinci function metadata.
  
  This routine uses C<Perinci::Sub::GetArgs::Argv> to generate C<Getopt::Long>
  specification from arguments list in Rinci function metadata and common options.
  Then, it will use C<Complete::Getopt::Long> to complete option names, option
  values, as well as arguments.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<common_opts> => I<hash>
  
  Common options.
  
  A hash where the values are hashes containing these keys: C<getopt> (Getopt::Long
  option specification), C<handler> (Getopt::Long handler). Will be passed to
  C<get_args_from_argv()>. Example:
  
   {
       help => {
           getopt  => 'help|h|?',
           handler => sub { ... },
           summary => 'Display help and exit',
       },
       version => {
           getopt  => 'version|v',
           handler => sub { ... },
           summary => 'Display version and exit',
       },
   }
  
  =item * B<completion> => I<code>
  
  Supply custom completion routine.
  
  If supplied, instead of the default completion routine, this code will be called
  instead. Will receive all arguments that C<Complete::Getopt::Long> will pass, and
  additionally:
  
  =over
  
  =item * C<arg> (str, the name of function argument)
  
  =item * C<args> (hash, the function arguments formed so far)
  
  =item * C<index> (int, if completing argument element value)
  
  =back
  
  =item * B<cword>* => I<int>
  
  On which argument cursor is located (zero-based).
  
  =item * B<extras> => I<hash>
  
  Add extra arguments to completion routine.
  
  The keys from this C<extras> hash will be merged into the final C<%args> passed to
  completion routines. Note that standard keys like C<word>, C<cword>, C<ci>, and so
  on as described in the function description will not be overwritten by this.
  
  =item * B<func_arg_starts_at> => I<int> (default: 0)
  
  This is a (temporary?) workaround for Perinci::CmdLine. In an application with
  subcommands (e.g. C<cmd --verbose subcmd arg0 arg1 ...>), then C<words> will still
  contain the subcommand name. Positional function arguments then start at 1 not
  0. This option allows offsetting function arguments.
  
  =item * B<meta>* => I<hash>
  
  Rinci function metadata.
  
  =item * B<per_arg_json> => I<bool>
  
  Will be passed to Perinci::Sub::GetArgs::Argv.
  
  =item * B<per_arg_yaml> => I<bool>
  
  Will be passed to Perinci::Sub::GetArgs::Argv.
  
  =item * B<riap_client> => I<obj>
  
  Optional, to perform complete_arg_val to the server.
  
  When the argument spec in the Rinci metadata contains C<completion> key, this
  means there is custom completion code for that argument. However, if retrieved
  from a remote server, sometimes the C<completion> key no longer contains the code
  (it has been cleansed into a string). Moreover, the completion code needs to run
  on the server.
  
  If supplied this argument and te C<riap_server_url> argument, the function will
  try to request to the server (via Riap request C<complete_arg_val>). Otherwise,
  the function will just give up/decline completing.
  
  =item * B<riap_server_url> => I<str>
  
  Optional, to perform complete_arg_val to the server.
  
  See the C<riap_client> argument.
  
  =item * B<riap_uri> => I<str>
  
  Optional, to perform complete_arg_val to the server.
  
  See the C<riap_client> argument.
  
  =item * B<words>* => I<array[str]>
  
  Command-line arguments.
  
  =back
  
  Return value:  (hash)
  
  
  You can use C<format_completion> function in C<Complete::Bash> module to format
  the result of this function for bash.
  
  
  =head2 complete_from_schema(%args) -> [status, msg, result, meta]
  
  Complete a value from schema.
  
  Employ some heuristics to complete a value from Sah schema. For example, if
  schema is C<< [str =E<gt> in =E<gt> [qw/new open resolved rejected/]] >>, then we can
  complete from the C<in> clause. Or for something like C<< [int =E<gt> between =E<gt> [1,
  20]] >> we can complete using values from 1 to 20.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<ci> => I<bool>
  
  =item * B<schema>* => I<any>
  
  Must be normalized.
  
  =item * B<word>* => I<str> (default: "")
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  =for Pod::Coverage ^(.+)$
  
  =head1 SEE ALSO
  
  L<Complete>, L<Complete::Getopt::Long>
  
  L<Perinci::CmdLine>, L<Perinci::CmdLine::Lite>, L<App::riap>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Complete>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-Complete>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Complete>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_SUB_COMPLETE

$fatpacked{"Perinci/Sub/ConvertArgs/Argv.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_CONVERTARGS_ARGV';
  package Perinci::Sub::ConvertArgs::Argv;
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(convert_args_to_argv);
  
  our $VERSION = '0.04'; # VERSION
  
  our %SPEC;
  
  sub _json {
      require JSON;
      state $json = JSON->new->allow_nonref;
      $json->encode($_[0]);
  }
  
  sub _encode {
      ref($_[0]) ? _json($_[0]) : $_[0];
  }
  
  $SPEC{convert_args_to_argv} = {
      v => 1.1,
      summary => 'Convert hash arguments to command-line options (and arguments)',
      description => <<'_',
  
  Convert hash arguments to command-line arguments. This is the reverse of
  `Perinci::Sub::GetArgs::Argv::get_args_from_argv`.
  
  Note: currently the function expects schemas in metadata to be normalized
  already.
  
  _
      args => {
          args => {req=>1, schema=>'hash*', pos=>0},
          meta => {req=>0, schema=>'hash*', pos=>1},
          use_pos => {
              summary => 'Whether to use positional arguments',
              schema  => 'bool',
              description => <<'_',
  
  For example, given this metadata:
  
      {
          v => 1.1,
          args => {
            arg1 => {pos=>0, req=>1},
            arg2 => {pos=>1},
            arg3 => {},
          },
      }
  
  then under `use_pos=0` the hash `{arg1=>1, arg2=>2, arg3=>'a b'}` will be
  converted to `['--arg1', 1, '--arg2', 2, '--arg3', 'a b']`. Meanwhile if
  `use_pos=1` the same hash will be converted to `[1, 2, '--arg3', 'a b']`.
  
  _
          },
      },
  };
  sub convert_args_to_argv {
      my %fargs = @_;
  
      my $iargs = $fargs{args} or return [400, "Please specify args"];
      my $meta  = $fargs{meta} // {v=>1.1};
      my $args_prop = $meta->{args} // {};
  
      my $v = $meta->{v} // 1.0;
      return [412, "Sorry, only metadata version 1.1 is supported (yours: $v)"]
          unless $v == 1.1;
  
      my @argv;
      my %iargs = %$iargs; # copy 'coz we will delete them one by one as we fill
  
      if ($fargs{use_pos}) {
          for (sort {$args_prop->{$a}{pos} <=> $args_prop->{$b}{pos}}
                   grep {defined $args_prop->{$_}{pos}} keys %iargs) {
              $argv[ $args_prop->{$_}{pos} ] = _encode($iargs{$_});
              delete $iargs{$_};
          }
      }
  
      for (sort keys %iargs) {
          my $is_bool = $args_prop->{$_}{schema} &&
              $args_prop->{$_}{schema}[0] eq 'bool';
          my $opt = $_; $opt =~ s/_/-/g;
          my $dashopt = length($opt) > 1 ? "--$opt" : "-$opt";
          if ($is_bool) {
              if ($iargs{$_}) {
                  push @argv, $dashopt;
              } else {
                  push @argv, "--no$opt";
              }
          } else {
              if (ref $iargs{$_}) {
                  push @argv, "$dashopt-json", _encode($iargs{$_});
              } else {
                  push @argv, $dashopt, "$iargs{$_}";
              }
          }
      }
      [200, "OK", \@argv];
  }
  
  1;
  #ABSTRACT: Convert hash arguments to command-line options (and arguments)
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::ConvertArgs::Argv - Convert hash arguments to command-line options (and arguments)
  
  =head1 VERSION
  
  This document describes version 0.04 of Perinci::Sub::ConvertArgs::Argv (from Perl distribution Perinci-Sub-ConvertArgs-Argv), released on 2014-07-18.
  
  =head1 SYNOPSIS
  
   use Perinci::Sub::ConvertArgs::Argv qw(convert_args_to_argv);
  
   my $res = convert_args_to_argv(args=>\%args, meta=>$meta, ...);
  
  =head1 FUNCTIONS
  
  
  =head2 convert_args_to_argv(%args) -> [status, msg, result, meta]
  
  Convert hash arguments to command-line options (and arguments).
  
  Convert hash arguments to command-line arguments. This is the reverse of
  C<Perinci::Sub::GetArgs::Argv::get_args_from_argv>.
  
  Note: currently the function expects schemas in metadata to be normalized
  already.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<args>* => I<hash>
  
  =item * B<meta> => I<hash>
  
  =item * B<use_pos> => I<bool>
  
  Whether to use positional arguments.
  
  For example, given this metadata:
  
      {
          v => 1.1,
          args => {
            arg1 => {pos=>0, req=>1},
            arg2 => {pos=>1},
            arg3 => {},
          },
      }
  
  then under C<use_pos=0> the hash C<{arg1=>1, arg2=>2, arg3=>'a b'}> will be
  converted to C<['--arg1', 1, '--arg2', 2, '--arg3', 'a b']>. Meanwhile if
  C<use_pos=1> the same hash will be converted to C<[1, 2, '--arg3', 'a b']>.
  
  =back
  
  Return value:
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
   (any)
  
  =head1 TODO
  
  Option to use/prefer cmdline_aliases.
  
  =head1 SEE ALSO
  
  L<Perinci::CmdLine>, which uses this module for presenting command-line
  examples.
  
  L<Perinci::Sub::GetArgs::Argv> which does the reverse: converting command-line
  arguments to hash.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-ConvertArgs-Argv>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Perinci-Sub-ConvertArgs-Argv>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-ConvertArgs-Argv>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  Steven Haryanto <stevenharyanto@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Steven Haryanto.
  
  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
PERINCI_SUB_CONVERTARGS_ARGV

$fatpacked{"Perinci/Sub/ConvertArgs/Array.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_CONVERTARGS_ARRAY';
  package Perinci::Sub::ConvertArgs::Array;
  
  our $DATE = '2014-07-18'; # DATE
  our $VERSION = '0.06'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(convert_args_to_array);
  
  our %SPEC;
  
  $SPEC{convert_args_to_array} = {
      v => 1.1,
      summary => 'Convert hash arguments to array',
      description => <<'_',
  
  Using information in 'args' property (particularly the 'pos' and 'greedy' of
  each argument spec), convert hash arguments to array.
  
  Example:
  
      my $meta = {
          v => 1.1,
          summary => 'Multiply 2 numbers (a & b)',
          args => {
              a => ['num*' => {arg_pos=>0}],
              b => ['num*' => {arg_pos=>1}],
          }
      }
  
  then 'convert_args_to_array(args=>{a=>2, b=>3}, meta=>$meta)' will produce:
  
      [200, "OK", [2, 3]]
  
  _
      args => {
          args => {req=>1, schema=>'hash*', pos=>0},
          meta => {req=>1, schema=>'hash*', pos=>1},
      },
  };
  sub convert_args_to_array {
      my %input_args   = @_;
      my $args         = $input_args{args} or return [400, "Please specify args"];
      my $meta         = $input_args{meta} or return [400, "Please specify meta"];
      my $args_prop    = $meta->{args} // {};
  
      my $v = $meta->{v} // 1.0;
      return [412, "Sorry, only metadata version 1.1 is supported (yours: $v)"]
          unless $v == 1.1;
  
      #$log->tracef("-> convert_args_to_array(), args=%s", $args);
  
      my @array;
  
      while (my ($k, $v) = each %$args) {
          my $as = $args_prop->{$k};
          return [412, "Argument $k: Not specified in args property"] unless $as;
          my $pos = $as->{pos};
          return [412, "Argument $k: No pos specified in arg spec"]
              unless defined $pos;
          if ($as->{greedy}) {
              $v = [$v] if ref($v) ne 'ARRAY';
              # splice can't work if $pos is beyond array's length
              for (@array .. $pos-1) {
                  $array[$_] = undef;
              }
              splice @array, $pos, 0, @$v;
          } else {
              $array[$pos] = $v;
          }
      }
      [200, "OK", \@array];
  }
  
  1;
  #ABSTRACT: Convert hash arguments to array
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::ConvertArgs::Array - Convert hash arguments to array
  
  =head1 VERSION
  
  This document describes version 0.06 of Perinci::Sub::ConvertArgs::Array (from Perl distribution Perinci-Sub-ConvertArgs-Array), released on 2014-07-18.
  
  =head1 SYNOPSIS
  
   use Perinci::Sub::ConvertArgs::Array qw(convert_args_to_array);
  
   my $res = convert_args_to_array(args=>\%args, meta=>$meta, ...);
  
  =head1 DESCRIPTION
  
  This module provides convert_args_to_array() (and
  gencode_convert_args_to_array(), upcoming). This module is used by, among
  others, L<Perinci::Sub::Wrapper>.
  
  =head1 FUNCTIONS
  
  None are exported by default, but they are exportable.
  
  
  =head2 convert_args_to_array(%args) -> [status, msg, result, meta]
  
  Convert hash arguments to array.
  
  Using information in 'args' property (particularly the 'pos' and 'greedy' of
  each argument spec), convert hash arguments to array.
  
  Example:
  
      my $meta = {
          v => 1.1,
          summary => 'Multiply 2 numbers (a & b)',
          args => {
              a => ['num*' => {arg_pos=>0}],
              b => ['num*' => {arg_pos=>1}],
          }
      }
  
  then 'convertI<args>to_array(args=>{a=>2, b=>3}, meta=>$meta)' will produce:
  
      [200, "OK", [2, 3]]
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<args>* => I<hash>
  
  =item * B<meta>* => I<hash>
  
  =back
  
  Return value:
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
   (any)
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-ConvertArgs-Array>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Perinci-Sub-ConvertArgs-Array>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-ConvertArgs-Array>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  Steven Haryanto <stevenharyanto@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Steven Haryanto.
  
  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
PERINCI_SUB_CONVERTARGS_ARRAY

$fatpacked{"Perinci/Sub/GetArgs/Argv.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_GETARGS_ARGV';
  package Perinci::Sub::GetArgs::Argv;
  
  our $DATE = '2015-04-02'; # DATE
  our $VERSION = '0.65'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Data::Sah::Normalize qw(normalize_schema);
  use Getopt::Long::Negate::EN qw(negations_for_option);
  use Getopt::Long::Util qw(parse_getopt_long_opt_spec);
  use List::Util qw(first);
  use Perinci::Sub::GetArgs::Array qw(get_args_from_array);
  use Perinci::Sub::Util qw(err);
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         gen_getopt_long_spec_from_meta
                         get_args_from_argv
                 );
  
  our %SPEC;
  
  $SPEC{':package'} = {
      v => 1.1,
      summary => 'Get subroutine arguments from command line arguments (@ARGV)',
  };
  
  my $re_simple_scalar = qr/^(str|num|int|float|bool|buf|re)$/;
  
  # retun ($success?, $errmsg, $res)
  sub _parse_json {
      my $str = shift;
  
      state $json = do {
          require JSON;
          JSON->new->allow_nonref;
      };
  
      # to rid of those JSON::XS::Boolean objects which currently choke
      # Data::Sah-generated validator code. in the future Data::Sah can be
      # modified to handle those, or we use a fork of JSON::XS which doesn't
      # produce those in the first place (probably only when performance is
      # critical).
      state $cleanser = do {
          require Data::Clean::FromJSON;
          Data::Clean::FromJSON->get_cleanser;
      };
  
      my $res;
      eval { $res = $json->decode($str); $cleanser->clean_in_place($res) };
      my $e = $@;
      return (!$e, $e, $res);
  }
  
  sub _parse_yaml {
      no warnings 'once';
      require YAML::Syck;
  
      my $str = shift;
  
      local $YAML::Syck::ImplicitTyping = 1;
      my $res;
      eval { $res = YAML::Syck::Load($str) };
      my $e = $@;
      return (!$e, $e, $res);
  }
  
  sub _arg2opt {
      my $opt = shift;
      $opt =~ s/[^A-Za-z0-9-]+/-/g; # foo.bar_baz becomes --foo-bar-baz
      $opt;
  }
  
  # return one or more triplets of Getopt::Long option spec, its parsed structure,
  # and extra stuffs. we do this to avoid having to call
  # parse_getopt_long_opt_spec().
  sub _opt2ospec {
      my ($opt, $schema, $arg_spec) = @_;
      my $type = $schema->[0];
      my $cs   = $schema->[1];
      my $is_array_of_simple_scalar = $type eq 'array' &&
          $cs->{of} && $cs->{of}[0] =~ $re_simple_scalar;
      if ($is_array_of_simple_scalar && $arg_spec && $arg_spec->{'x.name.is_plural'}) {
          if ($arg_spec->{'x.name.singular'}) {
              $opt = $arg_spec->{'x.name.singular'};
          } else {
              require Lingua::EN::PluralToSingular;
              $opt = Lingua::EN::PluralToSingular::to_singular($opt);
          }
      }
      if ($type eq 'bool') {
          if (length($opt) == 1 || $cs->{is}) {
              # single-letter option like -b doesn't get --nob.
              # [bool=>{is=>1}] also means it's a flag and should not get
              # --nofoo.
              return ($opt, {opts=>[$opt]});
          } else {
              my @res;
              my @negs = negations_for_option($opt);
              push @res, $opt, {opts=>[$opt]}, {is_neg=>0, neg_opts=>\@negs};
              for (@negs) {
                  push @res, $_, {opts=>[$_]}, {is_neg=>1, pos_opts=>[$opt]};
              }
              return @res;
          }
      } elsif ($type eq 'buf') {
          return (
              "$opt=s", {opts=>[$opt], desttype=>"", type=>"s"}, undef,
              "$opt-base64=s", {opts=>["$opt-base64"], desttype=>"", type=>"s"}, {is_base64=>1},
          );
      } else {
          my $t = ($type eq 'int' ? 'i' : $type eq 'float' ? 'f' :
                       $is_array_of_simple_scalar ? 's@' : 's');
          return ("$opt=$t", {opts=>[$opt], desttype=>"", type=>$t});
      }
  }
  
  sub _args2opts {
      my %args = @_;
  
      my $argprefix        = $args{argprefix};
      my $parent_args      = $args{parent_args};
      my $meta             = $args{meta};
      my $seen_opts        = $args{seen_opts};
      my $seen_common_opts = $args{seen_common_opts};
      my $seen_func_opts   = $args{seen_func_opts};
      my $rargs            = $args{rargs};
      my $go_spec          = $args{go_spec};
      my $specmeta         = $args{specmeta};
  
      my $args_prop = $meta->{args} // {};
  
      for my $arg (keys %$args_prop) {
          my $fqarg    = "$argprefix$arg";
          my $arg_spec = $args_prop->{$arg};
          my $sch      = $arg_spec->{schema} // ['any', {}];
          my $type     = $sch->[0] // '';
          my $cs       = $sch->[1] // {};
  
          # XXX normalization of 'of' clause should've been handled by sah itself
          if ($type eq 'array' && $cs->{of}) {
              $cs->{of} = normalize_schema($cs->{of});
          }
          my $opt = _arg2opt($fqarg);
          if ($seen_opts->{$opt}) {
              my $i = 1;
              my $opt2;
              while (1) {
                  $opt2 = "$opt-arg" . ($i > 1 ? $i : '');
                  last unless $seen_opts->{$opt2};
                  $i++;
              }
              $opt = $opt2;
          }
  
          my $is_simple_scalar = $type =~ $re_simple_scalar;
          my $is_array_of_simple_scalar = $type eq 'array' &&
              $cs->{of} && $cs->{of}[0] =~ $re_simple_scalar;
  
          my $stash = {};
  
          # why we use coderefs here? due to Getopt::Long's behavior. when
          # @ARGV=qw() and go_spec is ('foo=s' => \$opts{foo}) then %opts will
          # become (foo=>undef). but if go_spec is ('foo=s' => sub { $opts{foo} =
          # $_[1] }) then %opts will become (), which is what we prefer, so we can
          # later differentiate "unspecified" (exists($opts{foo}) == false) and
          # "specified as undef" (exists($opts{foo}) == true but
          # defined($opts{foo}) == false).
  
          my $handler = sub {
              my ($val, $val_set);
  
              # how many times have been called for this argument?
              my $num_called = ++$stash->{called}{$arg};
  
              # hashify rargs till the end of the handler scope if it happens to
              # be an array (this is the case when we want to fill values using
              # element_meta).
              my $rargs = do {
                  if (ref($rargs) eq 'ARRAY') {
                      $rargs->[$num_called-1] //= {};
                      $rargs->[$num_called-1];
                  } else {
                      $rargs;
                  }
              };
  
              if ($is_array_of_simple_scalar) {
                  $rargs->{$arg} //= [];
                  $val_set = 1; $val = $_[1];
                  push @{ $rargs->{$arg} }, $val;
              } elsif ($is_simple_scalar) {
                  $val_set = 1; $val = $_[1];
                  $rargs->{$arg} = $val;
              } else {
                  {
                      my ($success, $e, $decoded);
                      ($success, $e, $decoded) = _parse_json($_[1]);
                      if ($success) {
                          $val_set = 1; $val = $decoded;
                          $rargs->{$arg} = $val;
                          last;
                      }
                      ($success, $e, $decoded) = _parse_yaml($_[1]);
                      if ($success) {
                          $val_set = 1; $val = $decoded;
                          $rargs->{$arg} = $val;
                          last;
                      }
                      die "Invalid YAML/JSON in arg '$fqarg'";
                  }
              }
              if ($val_set && $arg_spec->{cmdline_on_getopt}) {
                  $arg_spec->{cmdline_on_getopt}->(
                      arg=>$arg, fqarg=>$fqarg, value=>$val, args=>$rargs,
                      opt=>$opt,
                  );
              }
          }; # handler
  
          my @triplets = _opt2ospec($opt, $sch, $arg_spec);
          my $aliases_processed;
          while (my ($ospec, $parsed, $extra) = splice @triplets, 0, 3) {
              $extra //= {};
              if ($extra->{is_neg}) {
                  $go_spec->{$ospec} = sub { $handler->($_[0], 0) };
              } elsif (defined $extra->{is_neg}) {
                  $go_spec->{$ospec} = sub { $handler->($_[0], 1) };
              } elsif ($extra->{is_base64}) {
                  $go_spec->{$ospec} = sub {
                      require MIME::Base64;
                      my $decoded = MIME::Base64::decode($_[1]);
                      $handler->($_[0], $decoded);
                  };
              } else {
                  $go_spec->{$ospec} = $handler;
              }
  
              $specmeta->{$ospec} = {arg=>$arg, fqarg=>$fqarg, parsed=>$parsed, %$extra};
              for (@{ $parsed->{opts} }) {
                  $seen_opts->{$_}++; $seen_func_opts->{$_} = $fqarg;
              }
  
              if ($parent_args->{per_arg_json} && $type !~ $re_simple_scalar) {
                  my $jopt = "$opt-json";
                  if ($seen_opts->{$jopt}) {
                      warn "Clash of option: $jopt, not added";
                  } else {
                      my $jospec = "$jopt=s";
                      my $parsed = {type=>"s", opts=>[$jopt]};
                      $go_spec->{$jospec} = sub {
                          my ($success, $e, $decoded);
                          ($success, $e, $decoded) = _parse_json($_[1]);
                          if ($success) {
                              $rargs->{$arg} = $decoded;
                          } else {
                              die "Invalid JSON in option --$jopt: $_[1]: $e";
                          }
                      };
                      $specmeta->{$jospec} = {arg=>$arg, fqarg=>$fqarg, is_json=>1, parsed=>$parsed, %$extra};
                      $seen_opts->{$jopt}++; $seen_func_opts->{$jopt} = $fqarg;
                  }
              }
              if ($parent_args->{per_arg_yaml} && $type !~ $re_simple_scalar) {
                  my $yopt = "$opt-yaml";
                  if ($seen_opts->{$yopt}) {
                      warn "Clash of option: $yopt, not added";
                  } else {
                      my $yospec = "$yopt=s";
                      my $parsed = {type=>"s", opts=>[$yopt]};
                      $go_spec->{$yospec} = sub {
                          my ($success, $e, $decoded);
                          ($success, $e, $decoded) = _parse_yaml($_[1]);
                          if ($success) {
                              $rargs->{$arg} = $decoded;
                          } else {
                              die "Invalid YAML in option --$yopt: $_[1]: $e";
                          }
                      };
                      $specmeta->{$yospec} = {arg=>$arg, fqarg=>$fqarg, is_yaml=>1, parsed=>$parsed, %$extra};
                      $seen_opts->{$yopt}++; $seen_func_opts->{$yopt} = $fqarg;
                  }
              }
  
              # parse argv_aliases
              if ($arg_spec->{cmdline_aliases} && !$aliases_processed++) {
                  for my $al (keys %{$arg_spec->{cmdline_aliases}}) {
                      my $alspec = $arg_spec->{cmdline_aliases}{$al};
                      my $alsch = $alspec->{schema} //
                          $alspec->{is_flag} ? [bool=>{req=>1,is=>1}] : $sch;
                      my $altype = $alsch->[0];
                      my $alopt = _arg2opt("$argprefix$al");
                      if ($seen_opts->{$alopt}) {
                          warn "Clash of cmdline_alias option $al";
                          next;
                      }
                      my $alcode = $alspec->{code};
                      my $alospec;
                      my $parsed;
                      if ($alcode && $alsch->[0] eq 'bool') {
                          # bool --alias doesn't get --noalias if has code
                          $alospec = $alopt; # instead of "$alopt!"
                          $parsed = {opts=>[$alopt]};
                      } else {
                          ($alospec, $parsed) = _opt2ospec($alopt, $alsch);
                      }
  
                      if ($alcode) {
                          if ($alcode eq 'CODE') {
                              if ($parent_args->{ignore_converted_code}) {
                                  $alcode = sub {};
                              } else {
                                  return [
                                      501,
                                      join("",
                                           "Code in cmdline_aliases for arg $fqarg ",
                                           "got converted into string, probably ",
                                           "because of JSON/YAML transport"),
                                  ];
                              }
                          }
                          # alias handler
                          $go_spec->{$alospec} = sub {
  
                              # do the same like in arg handler
                              my $num_called = ++$stash->{called}{$arg};
                              my $rargs = do {
                                  if (ref($rargs) eq 'ARRAY') {
                                      $rargs->[$num_called-1] //= {};
                                      $rargs->[$num_called-1];
                                  } else {
                                      $rargs;
                                  }
                              };
  
                              $alcode->($rargs, $_[1]);
                          };
                      } else {
                          $go_spec->{$alospec} = $handler;
                      }
                      $specmeta->{$alospec} = {
                          alias     => $al,
                          is_alias  => 1,
                          alias_for => $ospec,
                          arg       => $arg,
                          fqarg     => $fqarg,
                          is_code   => $alcode ? 1:0,
                          parsed    => $parsed,
                          %$extra,
                      };
                      push @{$specmeta->{$ospec}{($alcode ? '':'non').'code_aliases'}},
                          $alospec;
                      $seen_opts->{$alopt}++; $seen_func_opts->{$alopt} = $fqarg;
                  }
              } # cmdline_aliases
  
              # submetadata
              if ($arg_spec->{meta}) {
                  $rargs->{$arg} = {};
                  my $res = _args2opts(
                      %args,
                      argprefix => "$argprefix$arg\::",
                      meta      => $arg_spec->{meta},
                      rargs     => $rargs->{$arg},
                  );
                  return $res if $res;
              }
  
              # element submetadata
              if ($arg_spec->{element_meta}) {
                  $rargs->{$arg} = [];
                  my $res = _args2opts(
                      %args,
                      argprefix => "$argprefix$arg\::",
                      meta      => $arg_spec->{element_meta},
                      rargs     => $rargs->{$arg},
                  );
                  return $res if $res;
              }
          } # for ospec triplet
  
      } # for arg
  
      undef;
  }
  
  $SPEC{gen_getopt_long_spec_from_meta} = {
      v           => 1.1,
      summary     => 'Generate Getopt::Long spec from Rinci function metadata',
      description => <<'_',
  
  This routine will produce a `Getopt::Long` specification from Rinci function
  metadata, as well as some more data structure in the result metadata to help
  producing a command-line help/usage message.
  
  Function arguments will be mapped to command-line options with the same name,
  with non-alphanumeric characters changed to `-` (`-` is preferred over `_`
  because it lets user avoid pressing Shift on popular keyboards). For example:
  `file_size` becomes `file-size`, `file_size.max` becomes `file-size-max`. If
  function argument option name clashes with command-line option or another
  existing option, it will be renamed to `NAME-arg` (or `NAME-arg2` and so on).
  For example: `help` will become `help-arg` (if `common_opts` contains `help`,
  that is).
  
  Each command-line alias (`cmdline_aliases` property) in the argument
  specification will also be added as command-line option, except if it clashes
  with an existing option, in which case this function will warn and skip adding
  the alias. For more information about `cmdline_aliases`, see `Rinci::function`.
  
  For arguments with type of `bool`, Getopt::Long will by default also
  automatically recognize `--noNAME` or `--no-NAME` in addition to `--name`. So
  this function will also check those names for clashes.
  
  For arguments with type array of simple scalar, `--NAME` can be specified more
  than once to append to the array.
  
  If `per_arg_json` setting is active, and argument's schema is not a "required
  simple scalar" (e.g. an array, or a nullable string), then `--NAME-json` will
  also be added to let users input undef (through `--NAME-json null`) or a
  non-scalar value (e.g. `--NAME-json '[1,2,3]'`). If this name conflicts with
  another existing option, a warning will be displayed and the option will not be
  added.
  
  If `per_arg_yaml` setting is active, and argument's schema is not a "required
  simple scalar" (e.g. an array, or a nullable string), then `--NAME-yaml` will
  also be added to let users input undef (through `--NAME-yaml '~'`) or a
  non-scalar value (e.g. `--NAME-yaml '[foo, bar]'`). If this name conflicts with
  another existing option, a warning will be displayed and the option will not be
  added. YAML can express a larger set of values, e.g. binary data, circular
  references, etc.
  
  Will produce a hash (Getopt::Long spec), with `func.specmeta`, `func.opts`,
  `func.common_opts`, `func.func_opts` that contain extra information
  (`func.specmeta` is a hash of getopt spec name and a hash of extra information
  while `func.*opts` lists all used option names).
  
  _
      args => {
          meta => {
              summary => 'Rinci function metadata',
              schema  => 'hash*',
              req     => 1,
          },
          meta_is_normalized => {
              schema => 'bool*',
          },
          args => {
              summary => 'Reference to hash which will store the result',
              schema  => 'hash*',
          },
          common_opts => {
              summary => 'Common options',
              description => <<'_',
  
  A hash where the values are hashes containing these keys: `getopt` (Getopt::Long
  option specification), `handler` (Getopt::Long handler). Will be passed to
  `get_args_from_argv()`. Example:
  
      {
          help => {
              getopt  => 'help|h|?',
              handler => sub { ... },
              summary => 'Display help and exit',
          },
          version => {
              getopt  => 'version|v',
              handler => sub { ... },
              summary => 'Display version and exit',
          },
      }
  
  _
              schema => ['hash*'],
          },
          per_arg_json => {
              summary => 'Whether to add --NAME-json for non-simple arguments',
              schema  => 'bool',
              default => 0,
              description => <<'_',
  
  Will also interpret command-line arguments as JSON if assigned to function
  arguments, if arguments' schema is not simple scalar.
  
  _
          },
          per_arg_yaml => {
              summary => 'Whether to add --NAME-yaml for non-simple arguments',
              schema  => 'bool',
              default => 0,
              description => <<'_',
  
  Will also interpret command-line arguments as YAML if assigned to function
  arguments, if arguments' schema is not simple scalar.
  
  _
          },
          ignore_converted_code => {
              summary => 'Whether to ignore coderefs converted to string',
              schema => 'bool',
              default => 0,
              description => <<'_',
  
  Across network through JSON encoding, coderef in metadata (e.g. in
  `cmdline_aliases` property) usually gets converted to string `CODE`. In some
  cases, like for tab completion, this is pretty harmless so you can turn this
  option on. For example, in the case of `cmdline_aliases`, the effect is just
  that command-line aliases code are not getting executed, but this is usually
  okay.
  
  _
          },
      },
  };
  sub gen_getopt_long_spec_from_meta {
      my %fargs = @_;
  
      my $meta       = $fargs{meta} or return [400, "Please specify meta"];
      unless ($fargs{meta_is_normalized}) {
          require Perinci::Sub::Normalize;
          $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
      }
      my $co           = $fargs{common_opts} // {};
      my $per_arg_yaml = $fargs{per_arg_yaml} // 0;
      my $per_arg_json = $fargs{per_arg_json} // 0;
      my $ignore_converted_code = $fargs{ignore_converted_code};
      my $rargs        = $fargs{args} // {};
  
      my %go_spec;
      my %specmeta; # key = option spec, val = hash of extra info
      my %seen_opts;
      my %seen_common_opts;
      my %seen_func_opts;
  
      for my $k (keys %$co) {
          my $v = $co->{$k};
          my $ospec   = $v->{getopt};
          my $handler = $v->{handler};
          my $res = parse_getopt_long_opt_spec($ospec)
              or return [400, "Can't parse common opt spec '$ospec'"];
          $go_spec{$ospec} = $handler;
          $specmeta{$ospec} = {common_opt=>$k, arg=>undef, parsed=>$res};
          for (@{ $res->{opts} }) {
              return [412, "Clash of common opt '$_'"] if $seen_opts{$_};
              $seen_opts{$_}++; $seen_common_opts{$_} = $ospec;
              if ($res->{is_neg}) {
                  $seen_opts{"no$_"}++ ; $seen_common_opts{"no$_"}  = $ospec;
                  $seen_opts{"no-$_"}++; $seen_common_opts{"no-$_"} = $ospec;
              }
          }
      }
  
      my $res = _args2opts(
          argprefix        => "",
          parent_args      => \%fargs,
          meta             => $meta,
          seen_opts        => \%seen_opts,
          seen_common_opts => \%seen_common_opts,
          seen_func_opts   => \%seen_func_opts,
          rargs            => $rargs,
          go_spec          => \%go_spec,
          specmeta         => \%specmeta,
      );
      return $res if $res;
  
      my $opts        = [sort(map {length($_)>1 ? "--$_":"-$_"} keys %seen_opts)];
      my $common_opts = [sort(map {length($_)>1 ? "--$_":"-$_"} keys %seen_common_opts)];
      my $func_opts   = [sort(map {length($_)>1 ? "--$_":"-$_"} keys %seen_func_opts)];
      my $opts_by_common = {};
      for my $k (keys %$co) {
          my $v = $co->{$k};
          my $ospec = $v->{getopt};
          my @opts;
          for (keys %seen_common_opts) {
              next unless $seen_common_opts{$_} eq $ospec;
              push @opts, (length($_)>1 ? "--$_":"-$_");
          }
          $opts_by_common->{$ospec} = [sort @opts];
      }
  
      my $opts_by_arg = {};
      for (keys %seen_func_opts) {
          my $fqarg = $seen_func_opts{$_};
          push @{ $opts_by_arg->{$fqarg} }, length($_)>1 ? "--$_":"-$_";
      }
      for (keys %$opts_by_arg) {
          $opts_by_arg->{$_} = [sort @{ $opts_by_arg->{$_} }];
      }
  
      [200, "OK", \%go_spec,
       {
           "func.specmeta"       => \%specmeta,
           "func.opts"           => $opts,
           "func.common_opts"    => $common_opts,
           "func.func_opts"      => $func_opts,
           "func.opts_by_arg"    => $opts_by_arg,
           "func.opts_by_common" => $opts_by_common,
       }];
  }
  
  $SPEC{get_args_from_argv} = {
      v => 1.1,
      summary => 'Get subroutine arguments (%args) from command-line arguments '.
          '(@ARGV)',
      description => <<'_',
  
  Using information in Rinci function metadata's `args` property, parse command
  line arguments `@argv` into hash `%args`, suitable for passing into subroutines.
  
  Currently uses Getopt::Long's GetOptions to do the parsing.
  
  As with GetOptions, this function modifies its `argv` argument, so you might
  want to copy the original `argv` first (or pass a copy instead) if you want to
  preserve the original.
  
  See also: gen_getopt_long_spec_from_meta() which is the routine that generates
  the specification.
  
  _
      args => {
          argv => {
              schema => ['array*' => {
                  of => 'str*',
              }],
              description => 'If not specified, defaults to @ARGV',
          },
          args => {
              summary => 'Specify input args, with some arguments preset',
              schema  => ['hash'],
          },
          meta => {
              schema => ['hash*' => {}],
              req => 1,
          },
          meta_is_normalized => {
              summary => 'Can be set to 1 if your metadata is normalized, '.
                  'to avoid duplicate effort',
              schema => 'bool',
              default => 0,
          },
          strict => {
              schema => ['bool' => {default=>1}],
              summary => 'Strict mode',
              description => <<'_',
  
  If set to 0, will still return parsed argv even if there are parsing errors
  (reported by Getopt::Long). If set to 1 (the default), will die upon error.
  
  Normally you would want to use strict mode, for more error checking. Setting off
  strict is used by, for example, Perinci::Sub::Complete during completion where
  the command-line might still be incomplete.
  
  Should probably be named `ignore_errors`. :-)
  
  _
          },
          per_arg_yaml => {
              schema => ['bool' => {default=>0}],
              summary => 'Whether to recognize --ARGNAME-yaml',
              description => <<'_',
  
  This is useful for example if you want to specify a value which is not
  expressible from the command-line, like 'undef'.
  
      % script.pl --name-yaml '~'
  
  See also: per_arg_json. You should enable just one instead of turning on both.
  
  _
          },
          per_arg_json => {
              schema => ['bool' => {default=>0}],
              summary => 'Whether to recognize --ARGNAME-json',
              description => <<'_',
  
  This is useful for example if you want to specify a value which is not
  expressible from the command-line, like 'undef'.
  
      % script.pl --name-json 'null'
  
  But every other string will need to be quoted:
  
      % script.pl --name-json '"foo"'
  
  See also: per_arg_yaml. You should enable just one instead of turning on both.
  
  _
          },
          common_opts => {
              summary => 'Common options',
              description => <<'_',
  
  A hash where the values are hashes containing these keys: `getopt` (Getopt::Long
  option specification), `handler` (Getopt::Long handler). Will be passed to
  `get_args_from_argv()`. Example:
  
      {
          help => {
              getopt  => 'help|h|?',
              handler => sub { ... },
              summary => 'Display help and exit',
          },
          version => {
              getopt  => 'version|v',
              handler => sub { ... },
              summary => 'Display version and exit',
          },
      }
  
  _
              schema => ['hash*'],
          },
          allow_extra_elems => {
              schema => ['bool' => {default=>0}],
              summary => 'Allow extra/unassigned elements in argv',
              description => <<'_',
  
  If set to 1, then if there are array elements unassigned to one of the
  arguments, instead of generating an error, this function will just ignore them.
  
  This option will be passed to Perinci::Sub::GetArgs::Array's allow_extra_elems.
  
  _
          },
          on_missing_required_args => {
              schema => 'code',
              summary => 'Execute code when there is missing required args',
              description => <<'_',
  
  This can be used to give a chance to supply argument value from other sources if
  not specified by command-line options. Perinci::CmdLine, for example, uses this
  hook to supply value from STDIN or file contents (if argument has `cmdline_src`
  specification key set).
  
  This hook will be called for each missing argument. It will be supplied hash
  arguments: (arg => $the_missing_argument_name, args =>
  $the_resulting_args_so_far, spec => $the_arg_spec).
  
  The hook can return true if it succeeds in making the missing situation
  resolved. In this case, this function will not report the argument as missing.
  
  _
          },
          ignore_converted_code => {
              summary => 'Whether to ignore coderefs converted to string',
              schema => 'bool',
              default => 0,
              description => <<'_',
  
  Across network through JSON encoding, coderef in metadata (e.g. in
  `cmdline_aliases` property) usually gets converted to string `CODE`. In some
  cases, like for tab completion, this is harmless so you can turn this option on.
  
  _
          },
      },
      result => {
          description => <<'_',
  
  Error codes:
  
  * 400 - Error in Getopt::Long option specification, e.g. in common_opts.
  
  * 500 - failure in GetOptions, meaning argv is not valid according to metadata
    specification (only if 'strict' mode is enabled).
  
  * 501 - coderef in cmdline_aliases got converted into a string, probably because
    the metadata was transported (e.g. through Riap::HTTP/Riap::Simple).
  
  _
      },
  };
  sub get_args_from_argv {
      require Getopt::Long;
  
      my %fargs = @_;
      my $argv       = $fargs{argv} // \@ARGV;
      my $meta       = $fargs{meta} or return [400, "Please specify meta"];
      unless ($fargs{meta_is_normalized}) {
          require Perinci::Sub::Normalize;
          $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
      }
      my $strict            = $fargs{strict} // 1;
      my $common_opts       = $fargs{common_opts} // {};
      my $per_arg_yaml      = $fargs{per_arg_yaml} // 0;
      my $per_arg_json      = $fargs{per_arg_json} // 0;
      my $allow_extra_elems = $fargs{allow_extra_elems} // 0;
      my $on_missing        = $fargs{on_missing_required_args};
      my $ignore_converted_code = $fargs{ignore_converted_code};
      #$log->tracef("-> get_args_from_argv(), argv=%s", $argv);
  
      # to store the resulting args
      my $rargs = $fargs{args} // {};
  
      # 1. first we generate Getopt::Long spec
      my $genres = gen_getopt_long_spec_from_meta(
          meta => $meta, meta_is_normalized => 1,
          args => $rargs,
          common_opts  => $common_opts,
          per_arg_json => $per_arg_json,
          per_arg_yaml => $per_arg_yaml,
          ignore_converted_code => $ignore_converted_code,
      );
      return err($genres->[0], "Can't generate Getopt::Long spec", $genres)
          if $genres->[0] != 200;
      my $go_spec = $genres->[2];
  
      # 2. then we run GetOptions to fill $rargs from command-line opts
      #$log->tracef("GetOptions spec: %s", \@go_spec);
      {
          local $SIG{__WARN__} = sub{} if !$strict;
          my $old_go_conf = Getopt::Long::Configure(
              $strict ? "no_pass_through" : "pass_through",
              "no_ignore_case", "permute", "bundling", "no_getopt_compat");
          my $res = Getopt::Long::GetOptionsFromArray($argv, %$go_spec);
          Getopt::Long::Configure($old_go_conf);
          unless ($res) {
              return [500, "GetOptions failed"] if $strict;
          }
      }
  
      # 3. then we try to fill $rargs from remaining command-line arguments (for
      # args which have 'pos' spec specified)
  
      my $args_prop = $meta->{args};
  
      if (@$argv) {
          my $res = get_args_from_array(
              array=>$argv, meta => $meta,
              meta_is_normalized => 1,
              allow_extra_elems => $allow_extra_elems,
          );
          if ($res->[0] != 200 && $strict) {
              return err(500, "Get args from array failed", $res);
          } elsif ($strict && $res->[0] != 200) {
              return err("Can't get args from argv", $res);
          } elsif ($res->[0] == 200) {
              my $pos_args = $res->[2];
              for my $name (keys %$pos_args) {
                  my $arg_spec = $args_prop->{$name};
                  my $val      = $pos_args->{$name};
                  if (exists $rargs->{$name}) {
                      return [400, "You specified option --$name but also ".
                                  "argument #".$arg_spec->{pos}] if $strict;
                  }
                  my $type = $arg_spec->{schema}[0];
                  my $cs   = $arg_spec->{schema}[1];
                  my $is_simple_scalar = $type =~ $re_simple_scalar;
                  my $is_array_of_simple_scalar = $type eq 'array' &&
                      $cs->{of} && $cs->{of}[0] =~ $re_simple_scalar;
  
                  if ($arg_spec->{greedy} && ref($val) eq 'ARRAY' &&
                          !$is_array_of_simple_scalar) {
                      my $i = 0;
                      for (@$val) {
                        TRY_PARSING_AS_JSON_YAML:
                          {
                              my ($success, $e, $decoded);
                              if ($per_arg_json) {
                                  ($success, $e, $decoded) = _parse_json($_);
                                  if ($success) {
                                      $_ = $decoded;
                                      last TRY_PARSING_AS_JSON_YAML;
                                  } else {
                                      warn "Failed trying to parse argv #$i as JSON: $e";
                                  }
                              }
                              if ($per_arg_yaml) {
                                  ($success, $e, $decoded) = _parse_yaml($_);
                                  if ($success) {
                                      $_ = $decoded;
                                      last TRY_PARSING_AS_JSON_YAML;
                                  } else {
                                      warn "Failed trying to parse argv #$i as YAML: $e";
                                  }
                              }
                          }
                          $i++;
                      }
                  }
                  if (!$arg_spec->{greedy} && !$is_simple_scalar) {
                    TRY_PARSING_AS_JSON_YAML:
                      {
                          my ($success, $e, $decoded);
                          if ($per_arg_json) {
                              ($success, $e, $decoded) = _parse_json($val);
                              if ($success) {
                                  $val = $decoded;
                                  last TRY_PARSING_AS_JSON_YAML;
                              } else {
                                  warn "Failed trying to parse argv #$arg_spec->{pos} as JSON: $e";
                              }
                          }
                          if ($per_arg_yaml) {
                              ($success, $e, $decoded) = _parse_yaml($val);
                              if ($success) {
                                  $val = $decoded;
                                  last TRY_PARSING_AS_JSON_YAML;
                              } else {
                                  warn "Failed trying to parse argv #$arg_spec->{pos} as YAML: $e";
                              }
                          }
                      }
                  }
                  $rargs->{$name} = $val;
                  # we still call cmdline_on_getopt for this
                  if ($arg_spec->{cmdline_on_getopt}) {
                      if ($arg_spec->{greedy}) {
                          $arg_spec->{cmdline_on_getopt}->(
                              arg=>$name, fqarg=>$name, value=>$_, args=>$rargs,
                              opt=>undef, # this marks that value is retrieved from cmdline arg
                          ) for @$val;
                      } else {
                          $arg_spec->{cmdline_on_getopt}->(
                              arg=>$name, fqarg=>$name, value=>$val, args=>$rargs,
                              opt=>undef, # this marks that value is retrieved from cmdline arg
                          );
                      }
                  }
              }
          }
      }
  
      # 4. check missing required args
  
      my %missing_args;
      for my $arg (keys %$args_prop) {
          my $arg_spec = $args_prop->{$arg};
          if (!exists($rargs->{$arg})) {
              next unless $arg_spec->{req};
              # give a chance to hook to set missing arg
              if ($on_missing) {
                  next if $on_missing->(arg=>$arg, args=>$rargs, spec=>$arg_spec);
              }
              next if exists $rargs->{$arg};
              $missing_args{$arg} = 1;
          }
      }
  
      # 5. check 'deps', currently we only support 'arg' dep type
      {
          last unless $strict;
  
          for my $arg (keys %$args_prop) {
              my $arg_spec = $args_prop->{$arg};
              next unless exists $rargs->{$arg};
              next unless $arg_spec->{deps};
              my $dep_arg = $arg_spec->{deps}{arg};
              next unless $dep_arg;
              return [400, "You specify '$arg', but don't specify '$dep_arg' ".
                          "(upon which '$arg' depends)"]
                  unless exists $rargs->{$dep_arg};
          }
      }
  
      # 5. check 'args_groups'
      {
          last unless $strict;
  
          last unless $meta->{args_groups};
          my @specified_args = sort keys %$rargs;
          for my $group_spec (@{ $meta->{args_groups} }) {
              my $group_args = $group_spec->{args};
              next unless @$group_args > 1;
              my $rel = $group_spec->{rel};
              my @args_in_group = grep {my $arg = $_; first {$_ eq $arg} @$group_args} @specified_args;
              if ($rel eq 'one_of') {
                  next unless @args_in_group;
                  if (@args_in_group > 1) {
                      my $first_arg = shift @args_in_group;
                      return [
                          400, join(
                              "",
                              "You specify '$first_arg', but also specify ",
                              join(", ", map {"'$_'"} @args_in_group),
                              " (only one can be specified)",
                          )];
                  }
              } elsif ($rel eq 'all') {
                  next unless @args_in_group;
                  if (@args_in_group < @$group_args) {
                      my @missing = grep {my $arg = $_; !(first {$_ eq $arg} @specified_args)} @$group_args;
                      return [
                          400, join(
                              "",
                              "You specify ",
                              join(", ", map {"'$_'"} @args_in_group),
                              ", but don't specify ",
                              join(", ", map {"'$_'"} @missing),
                              " (they must all be specified together)",
                          )];
                  }
              } else {
                  die "BUG: Unknown rel '$rel' in args_groups" .
                      ", only one_of/all is supported";
              }
          }
      }
  
      #$log->tracef("<- get_args_from_argv(), args=%s, remaining argv=%s",
      #             $rargs, $argv);
      [200, "OK", $rargs, {
          "func.missing_args" => [sort keys %missing_args],
          "func.gen_getopt_long_spec_result" => $genres,
      }];
  }
  
  1;
  # ABSTRACT: Get subroutine arguments from command line arguments (@ARGV)
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::GetArgs::Argv - Get subroutine arguments from command line arguments (@ARGV)
  
  =head1 VERSION
  
  This document describes version 0.65 of Perinci::Sub::GetArgs::Argv (from Perl distribution Perinci-Sub-GetArgs-Argv), released on 2015-04-02.
  
  =head1 SYNOPSIS
  
   use Perinci::Sub::GetArgs::Argv;
  
   my $res = get_args_from_argv(argv=>\@ARGV, meta=>$meta, ...);
  
  =head1 DESCRIPTION
  
  This module provides C<get_args_from_argv()>, which parses command line
  arguments (C<@ARGV>) into subroutine arguments (C<%args>). This module is used
  by L<Perinci::CmdLine>. For explanation on how command-line options are
  processed, see Perinci::CmdLine's documentation.
  
  =head1 FUNCTIONS
  
  
  =head2 gen_getopt_long_spec_from_meta(%args) -> [status, msg, result, meta]
  
  Generate Getopt::Long spec from Rinci function metadata.
  
  This routine will produce a C<Getopt::Long> specification from Rinci function
  metadata, as well as some more data structure in the result metadata to help
  producing a command-line help/usage message.
  
  Function arguments will be mapped to command-line options with the same name,
  with non-alphanumeric characters changed to C<-> (C<-> is preferred over C<_>
  because it lets user avoid pressing Shift on popular keyboards). For example:
  C<file_size> becomes C<file-size>, C<file_size.max> becomes C<file-size-max>. If
  function argument option name clashes with command-line option or another
  existing option, it will be renamed to C<NAME-arg> (or C<NAME-arg2> and so on).
  For example: C<help> will become C<help-arg> (if C<common_opts> contains C<help>,
  that is).
  
  Each command-line alias (C<cmdline_aliases> property) in the argument
  specification will also be added as command-line option, except if it clashes
  with an existing option, in which case this function will warn and skip adding
  the alias. For more information about C<cmdline_aliases>, see C<Rinci::function>.
  
  For arguments with type of C<bool>, Getopt::Long will by default also
  automatically recognize C<--noNAME> or C<--no-NAME> in addition to C<--name>. So
  this function will also check those names for clashes.
  
  For arguments with type array of simple scalar, C<--NAME> can be specified more
  than once to append to the array.
  
  If C<per_arg_json> setting is active, and argument's schema is not a "required
  simple scalar" (e.g. an array, or a nullable string), then C<--NAME-json> will
  also be added to let users input undef (through C<--NAME-json null>) or a
  non-scalar value (e.g. C<--NAME-json '[1,2,3]'>). If this name conflicts with
  another existing option, a warning will be displayed and the option will not be
  added.
  
  If C<per_arg_yaml> setting is active, and argument's schema is not a "required
  simple scalar" (e.g. an array, or a nullable string), then C<--NAME-yaml> will
  also be added to let users input undef (through C<--NAME-yaml '~'>) or a
  non-scalar value (e.g. C<--NAME-yaml '[foo, bar]'>). If this name conflicts with
  another existing option, a warning will be displayed and the option will not be
  added. YAML can express a larger set of values, e.g. binary data, circular
  references, etc.
  
  Will produce a hash (Getopt::Long spec), with C<func.specmeta>, C<func.opts>,
  C<func.common_opts>, C<func.func_opts> that contain extra information
  (C<func.specmeta> is a hash of getopt spec name and a hash of extra information
  while C<func.*opts> lists all used option names).
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<args> => I<hash>
  
  Reference to hash which will store the result.
  
  =item * B<common_opts> => I<hash>
  
  Common options.
  
  A hash where the values are hashes containing these keys: C<getopt> (Getopt::Long
  option specification), C<handler> (Getopt::Long handler). Will be passed to
  C<get_args_from_argv()>. Example:
  
   {
       help => {
           getopt  => 'help|h|?',
           handler => sub { ... },
           summary => 'Display help and exit',
       },
       version => {
           getopt  => 'version|v',
           handler => sub { ... },
           summary => 'Display version and exit',
       },
   }
  
  =item * B<ignore_converted_code> => I<bool> (default: 0)
  
  Whether to ignore coderefs converted to string.
  
  Across network through JSON encoding, coderef in metadata (e.g. in
  C<cmdline_aliases> property) usually gets converted to string C<CODE>. In some
  cases, like for tab completion, this is pretty harmless so you can turn this
  option on. For example, in the case of C<cmdline_aliases>, the effect is just
  that command-line aliases code are not getting executed, but this is usually
  okay.
  
  =item * B<meta>* => I<hash>
  
  Rinci function metadata.
  
  =item * B<meta_is_normalized> => I<bool>
  
  =item * B<per_arg_json> => I<bool> (default: 0)
  
  Whether to add --NAME-json for non-simple arguments.
  
  Will also interpret command-line arguments as JSON if assigned to function
  arguments, if arguments' schema is not simple scalar.
  
  =item * B<per_arg_yaml> => I<bool> (default: 0)
  
  Whether to add --NAME-yaml for non-simple arguments.
  
  Will also interpret command-line arguments as YAML if assigned to function
  arguments, if arguments' schema is not simple scalar.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 get_args_from_argv(%args) -> [status, msg, result, meta]
  
  Get subroutine arguments (%args) from command-line arguments (@ARGV).
  
  Using information in Rinci function metadata's C<args> property, parse command
  line arguments C<@argv> into hash C<%args>, suitable for passing into subroutines.
  
  Currently uses Getopt::Long's GetOptions to do the parsing.
  
  As with GetOptions, this function modifies its C<argv> argument, so you might
  want to copy the original C<argv> first (or pass a copy instead) if you want to
  preserve the original.
  
  See also: gen_getopt_long_spec_from_meta() which is the routine that generates
  the specification.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<allow_extra_elems> => I<bool> (default: 0)
  
  Allow extra/unassigned elements in argv.
  
  If set to 1, then if there are array elements unassigned to one of the
  arguments, instead of generating an error, this function will just ignore them.
  
  This option will be passed to Perinci::Sub::GetArgs::Array's allow_extra_elems.
  
  =item * B<args> => I<hash>
  
  Specify input args, with some arguments preset.
  
  =item * B<argv> => I<array[str]>
  
  If not specified, defaults to @ARGV
  
  =item * B<common_opts> => I<hash>
  
  Common options.
  
  A hash where the values are hashes containing these keys: C<getopt> (Getopt::Long
  option specification), C<handler> (Getopt::Long handler). Will be passed to
  C<get_args_from_argv()>. Example:
  
   {
       help => {
           getopt  => 'help|h|?',
           handler => sub { ... },
           summary => 'Display help and exit',
       },
       version => {
           getopt  => 'version|v',
           handler => sub { ... },
           summary => 'Display version and exit',
       },
   }
  
  =item * B<ignore_converted_code> => I<bool> (default: 0)
  
  Whether to ignore coderefs converted to string.
  
  Across network through JSON encoding, coderef in metadata (e.g. in
  C<cmdline_aliases> property) usually gets converted to string C<CODE>. In some
  cases, like for tab completion, this is harmless so you can turn this option on.
  
  =item * B<meta>* => I<hash>
  
  =item * B<meta_is_normalized> => I<bool> (default: 0)
  
  Can be set to 1 if your metadata is normalized, to avoid duplicate effort.
  
  =item * B<on_missing_required_args> => I<code>
  
  Execute code when there is missing required args.
  
  This can be used to give a chance to supply argument value from other sources if
  not specified by command-line options. Perinci::CmdLine, for example, uses this
  hook to supply value from STDIN or file contents (if argument has C<cmdline_src>
  specification key set).
  
  This hook will be called for each missing argument. It will be supplied hash
  arguments: (arg => $the_missing_argument_name, args =>
  $the_resulting_args_so_far, spec => $the_arg_spec).
  
  The hook can return true if it succeeds in making the missing situation
  resolved. In this case, this function will not report the argument as missing.
  
  =item * B<per_arg_json> => I<bool> (default: 0)
  
  Whether to recognize --ARGNAME-json.
  
  This is useful for example if you want to specify a value which is not
  expressible from the command-line, like 'undef'.
  
   % script.pl --name-json 'null'
  
  But every other string will need to be quoted:
  
   % script.pl --name-json '"foo"'
  
  See also: per_arg_yaml. You should enable just one instead of turning on both.
  
  =item * B<per_arg_yaml> => I<bool> (default: 0)
  
  Whether to recognize --ARGNAME-yaml.
  
  This is useful for example if you want to specify a value which is not
  expressible from the command-line, like 'undef'.
  
   % script.pl --name-yaml '~'
  
  See also: per_arg_json. You should enable just one instead of turning on both.
  
  =item * B<strict> => I<bool> (default: 1)
  
  Strict mode.
  
  If set to 0, will still return parsed argv even if there are parsing errors
  (reported by Getopt::Long). If set to 1 (the default), will die upon error.
  
  Normally you would want to use strict mode, for more error checking. Setting off
  strict is used by, for example, Perinci::Sub::Complete during completion where
  the command-line might still be incomplete.
  
  Should probably be named C<ignore_errors>. :-)
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  Error codes:
  
  =over
  
  =item * 400 - Error in Getopt::Long option specification, e.g. in common_opts.
  
  =item * 500 - failure in GetOptions, meaning argv is not valid according to metadata
  specification (only if 'strict' mode is enabled).
  
  =item * 501 - coderef in cmdline_aliases got converted into a string, probably because
  the metadata was transported (e.g. through Riap::HTTP/Riap::Simple).
  
  =back
  
  =head1 FAQ
  
  =head1 SEE ALSO
  
  L<Perinci>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-GetArgs-Argv>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-GetArgs-Argv>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-GetArgs-Argv>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_SUB_GETARGS_ARGV

$fatpacked{"Perinci/Sub/GetArgs/Array.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_GETARGS_ARRAY';
  package Perinci::Sub::GetArgs::Array;
  
  use 5.010001;
  use strict;
  use warnings;
  #use Log::Any '$log';
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(get_args_from_array);
  
  our $VERSION = '0.14'; # VERSION
  
  our %SPEC;
  
  $SPEC{get_args_from_array} = {
      v => 1.1,
      summary => 'Get subroutine arguments (%args) from array',
      description => <<'_',
  
  Using information in metadata's `args` property (particularly the `pos` and
  `greedy` arg type clauses), extract arguments from an array into a hash
  `\%args`, suitable for passing into subs.
  
  Example:
  
      my $meta = {
          v => 1.1,
          summary => 'Multiply 2 numbers (a & b)',
          args => {
              a => {schema=>'num*', pos=>0},
              b => {schema=>'num*', pos=>1},
          }
      }
  
  then `get_args_from_array(array=>[2, 3], meta=>$meta)` will produce:
  
      [200, "OK", {a=>2, b=>3}]
  
  _
      args => {
          array => {
              schema => ['array*' => {}],
              req => 1,
              description => <<'_',
  
  NOTE: array will be modified/emptied (elements will be taken from the array as
  they are put into the resulting args). Copy your array first if you want to
  preserve its content.
  
  _
          },
          meta => {
              schema => ['hash*' => {}],
              req => 1,
          },
          meta_is_normalized => {
              summary => 'Can be set to 1 if your metadata is normalized, '.
                  'to avoid duplicate effort',
              schema => 'bool',
              default => 0,
          },
          allow_extra_elems => {
              schema => ['bool' => {default=>0}],
              summary => 'Allow extra/unassigned elements in array',
              description => <<'_',
  
  If set to 1, then if there are array elements unassigned to one of the arguments
  (due to missing `pos`, for example), instead of generating an error, the
  function will just ignore them.
  
  _
          },
      },
  };
  sub get_args_from_array {
      my %fargs = @_;
      my $ary  = $fargs{array} or return [400, "Please specify array"];
      my $meta = $fargs{meta} or return [400, "Please specify meta"];
      unless ($fargs{meta_is_normalized}) {
          require Perinci::Sub::Normalize;
          $meta = Perinci::Sub::Normalize::normalize_function_metadata(
              $meta);
      }
      my $allow_extra_elems = $fargs{allow_extra_elems} // 0;
  
      my $rargs = {};
  
      my $args_p = $meta->{args} // {};
      for my $i (reverse 0..@$ary-1) {
          #$log->tracef("i=$i");
          while (my ($a, $as) = each %$args_p) {
              my $o = $as->{pos};
              if (defined($o) && $o == $i) {
                  if ($as->{greedy}) {
                      my $type = $as->{schema}[0];
                      my @elems = splice(@$ary, $i);
                      if ($type eq 'array') {
                          $rargs->{$a} = \@elems;
                      } else {
                          $rargs->{$a} = join " ", @elems;
                      }
                      #$log->tracef("assign %s to arg->{$a}", $rargs->{$a});
                  } else {
                      $rargs->{$a} = splice(@$ary, $i, 1);
                      #$log->tracef("assign %s to arg->{$a}", $rargs->{$a});
                  }
              }
          }
      }
  
      return [400, "There are extra, unassigned elements in array: [".
                  join(", ", @$ary)."]"] if @$ary && !$allow_extra_elems;
  
      [200, "OK", $rargs];
  }
  
  1;
  #ABSTRACT: Get subroutine arguments from array
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::GetArgs::Array - Get subroutine arguments from array
  
  =head1 VERSION
  
  This document describes version 0.14 of Perinci::Sub::GetArgs::Array (from Perl distribution Perinci-Sub-GetArgs-Array), released on 2014-07-08.
  
  =head1 SYNOPSIS
  
   use Perinci::Sub::GetArgs::Array;
  
   my $res = get_args_from_array(array=>\@ary, meta=>$meta, ...);
  
  =head1 DESCRIPTION
  
  This module provides get_args_from_array(). This module is used by, among
  others, L<Perinci::Sub::GetArgs::Argv>.
  
  =head1 FUNCTIONS
  
  
  =head2 get_args_from_array(%args) -> [status, msg, result, meta]
  
  Get subroutine arguments (%args) from array.
  
  Using information in metadata's C<args> property (particularly the C<pos> and
  C<greedy> arg type clauses), extract arguments from an array into a hash
  C<\%args>, suitable for passing into subs.
  
  Example:
  
      my $meta = {
          v => 1.1,
          summary => 'Multiply 2 numbers (a & b)',
          args => {
              a => {schema=>'num*', pos=>0},
              b => {schema=>'num*', pos=>1},
          }
      }
  
  then C<get_args_from_array(array=>[2, 3], meta=>$meta)> will produce:
  
      [200, "OK", {a=>2, b=>3}]
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<allow_extra_elems> => I<bool> (default: 0)
  
  Allow extra/unassigned elements in array.
  
  If set to 1, then if there are array elements unassigned to one of the arguments
  (due to missing C<pos>, for example), instead of generating an error, the
  function will just ignore them.
  
  =item * B<array>* => I<array>
  
  NOTE: array will be modified/emptied (elements will be taken from the array as
  they are put into the resulting args). Copy your array first if you want to
  preserve its content.
  
  =item * B<meta>* => I<hash>
  
  =item * B<meta_is_normalized> => I<bool> (default: 0)
  
  Can be set to 1 if your metadata is normalized, to avoid duplicate effort.
  
  =back
  
  Return value:
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  =head1 TODO
  
  I am not particularly happy with the duplication of functionality between this
  and the 'args_as' handler in L<Perinci::Sub::Wrapper>. But the later is a code
  to generate code, so I guess it's not so bad for now.
  
  =head1 SEE ALSO
  
  L<Perinci>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-GetArgs-Array>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Perinci-Sub-GetArgs-Array>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-GetArgs-Array>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  Steven Haryanto <stevenharyanto@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Steven Haryanto.
  
  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
PERINCI_SUB_GETARGS_ARRAY

$fatpacked{"Perinci/Sub/Normalize.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_NORMALIZE';
  package Perinci::Sub::Normalize;
  
  our $DATE = '2015-01-07'; # DATE
  our $VERSION = '0.09'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         normalize_function_metadata
                 );
  
  use Sah::Schema::Rinci;
  my $sch = $Sah::Schema::Rinci::SCHEMAS{rinci_function}
      or die "BUG: Rinci schema structure changed (1)";
  my $sch_proplist = $sch->[1]{_prop}
      or die "BUG: Rinci schema structure changed (2)";
  
  sub _normalize{
      my ($meta, $ver, $opts, $proplist, $nmeta, $prefix, $modprefix) = @_;
  
      my $opt_aup = $opts->{allow_unknown_properties};
      my $opt_nss = $opts->{normalize_sah_schemas};
      my $opt_rip = $opts->{remove_internal_properties};
  
      if (defined $ver) {
          defined($meta->{v}) && $meta->{v} eq $ver
              or die "$prefix: Metadata version must be $ver";
      }
  
    KEY:
      for my $k (keys %$meta) {
  
          # strip attributes prefixed with _ (e.g. args._comment)
          if ($k =~ /\.(\w+)\z/) {
              my $attr = $1;
              unless ($attr =~ /\A_/ && $opt_rip) {
                  $nmeta->{$k} = $meta->{$k};
              }
              next KEY;
          }
  
          my $prop = $k;
          my $prop_proplist = $proplist->{$prop};
          if ($prop =~ /\A_/) {
              unless ($opt_rip) {
                  $nmeta->{$prop} = $meta->{$k};
              }
              next KEY;
          }
          # try to load module that declare new props first
          if (!$opt_aup && !$prop_proplist) {
              if ($prop =~ /\A[A-Za-z][A-Za-z0-9_]*\z/) {
                  $modprefix //= $prefix;
                  my $mod = "Perinci/Sub/Property$modprefix/$prop.pm";
                  eval { require $mod };
                  # hide technical error message from require()
                  if ($@) {
                      die "Unknown property '$prefix/$prop' (and couldn't ".
                          "load property module '$mod'): $@" if $@;
                  }
                  $prop_proplist = $proplist->{$prop};
              }
              die "Unknown property '$prefix/$prop'"
                  unless $prop_proplist;
          }
          if ($prop_proplist && $prop_proplist->{_prop}) {
              die "Property '$prefix/$prop' must be a hash"
                  unless ref($meta->{$k}) eq 'HASH';
              $nmeta->{$k} = {};
              _normalize(
                  $meta->{$k},
                  $prop_proplist->{_ver},
                  $opts,
                  $prop_proplist->{_prop},
                  $nmeta->{$k},
                  "$prefix/$prop",
              );
          } elsif ($prop_proplist && $prop_proplist->{_elem_prop}) {
              die "Property '$prefix/$prop' must be an array"
                  unless ref($meta->{$k}) eq 'ARRAY';
              $nmeta->{$k} = [];
              my $i = 0;
              for (@{ $meta->{$k} }) {
                  my $href = {};
                  if (ref($_) eq 'HASH') {
                      _normalize(
                          $_,
                          $prop_proplist->{_ver},
                          $opts,
                          $prop_proplist->{_elem_prop},
                          $href,
                          "$prefix/$prop/$i",
                      );
                      push @{ $nmeta->{$k} }, $href;
                  } else {
                      push @{ $nmeta->{$k} }, $_;
                  }
                  $i++;
              }
          } elsif ($prop_proplist && $prop_proplist->{_value_prop}) {
              die "Property '$prefix/$prop' must be a hash"
                  unless ref($meta->{$k}) eq 'HASH';
              $nmeta->{$k} = {};
              for (keys %{ $meta->{$k} }) {
                  $nmeta->{$k}{$_} = {};
                  die "Property '$prefix/$prop/$_' must be a hash"
                      unless ref($meta->{$k}{$_}) eq 'HASH';
                  _normalize(
                      $meta->{$k}{$_},
                      $prop_proplist->{_ver},
                      $opts,
                      $prop_proplist->{_value_prop},
                      $nmeta->{$k}{$_},
                      "$prefix/$prop/$_",
                      ($prop eq 'args' ? "$prefix/arg" : undef),
                  );
              }
          } else {
              if ($k eq 'schema' && $opt_nss) { # XXX currently hardcoded
                  require Data::Sah::Normalize;
                  $nmeta->{$k} = Data::Sah::Normalize::normalize_schema(
                      $meta->{$k});
              } else {
                  $nmeta->{$k} = $meta->{$k};
              }
          }
      }
  
      $nmeta;
  }
  
  sub normalize_function_metadata {
      my ($meta, $opts) = @_;
  
      $opts //= {};
  
      $opts->{allow_unknown_properties}    //= 0;
      $opts->{normalize_sah_schemas}       //= 1;
      $opts->{remove_internal_properties}  //= 0;
  
      _normalize($meta, 1.1, $opts, $sch_proplist, {}, '');
  }
  
  1;
  # ABSTRACT: Normalize Rinci function metadata
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::Normalize - Normalize Rinci function metadata
  
  =head1 VERSION
  
  This document describes version 0.09 of Perinci::Sub::Normalize (from Perl distribution Perinci-Sub-Normalize), released on 2015-01-07.
  
  =head1 SYNOPSIS
  
   use Perinci::Sub::Normalize qw(normalize_function_metadata);
  
   my $nmeta = normalize_function_metadata($meta);
  
  =head1 FUNCTIONS
  
  =head2 normalize_function_metadata($meta, \%opts) => HASH
  
  Normalize and check L<Rinci> function metadata C<$meta>. Return normalized
  metadata, which is a shallow copy of C<$meta>. Die on error.
  
  Available options:
  
  =over
  
  =item * allow_unknown_properties => BOOL (default: 0)
  
  If set to true, will die if there are unknown properties.
  
  =item * normalize_sah_schemas => BOOL (default: 1)
  
  By default, L<Sah> schemas e.g. in C<result/schema> or C<args/*/schema> property
  is normalized using L<Data::Sah>'s C<normalize_schema>. Set this to 0 if you
  don't want this.
  
  =item * remove_internal_properties => BOOL (default: 0)
  
  If set to 1, all properties and attributes starting with underscore (C<_>) with
  will be stripped. According to L<DefHash> specification, they are ignored and
  usually contain notes/comments/extra information.
  
  =back
  
  =head1 SEE ALSO
  
  L<Rinci::function>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Normalize>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-Normalize>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Normalize>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_SUB_NORMALIZE

$fatpacked{"Perinci/Sub/To/CLIDocData.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_TO_CLIDOCDATA';
  package Perinci::Sub::To::CLIDocData;
  
  our $DATE = '2015-04-07'; # DATE
  our $VERSION = '0.20'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Perinci::Object;
  use Perinci::Sub::Util qw(err);
  
  our %SPEC;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(gen_cli_doc_data_from_meta);
  
  sub _has_cats {
      for my $spec (@{ $_[0] }) {
          for (@{ $spec->{tags} // [] }) {
              my $tag_name = ref($_) ? $_->{name} : $_;
              if ($tag_name =~ /^category:/) {
                  return 1;
              }
          }
      }
      0;
  }
  
  sub _add_category_from_spec {
      my ($cats_spec, $thing, $spec, $noun, $has_cats) = @_;
      my $cat;
      my $raw_cat = '';
      my $order;
      for (@{ $spec->{tags} // [] }) {
          my $tag_name = ref($_) ? $_->{name} : $_;
          if ($tag_name =~ /^category:(.+)/) {
              $raw_cat = $1;
  
              $cat = ucfirst($1);
              $cat =~ s/-/ /g;
              $cat .= " " . $noun;
              $order = 50;
              last;
          }
      }
      $cat //= $has_cats ? "Other $noun" : ucfirst($noun); # XXX translatable?
      $order //= 99;
      $thing->{category} = $cat;
      $cats_spec->{$cat}{order} //= $order;
  }
  
  sub _add_default_from_arg_spec {
      my ($opt, $arg_spec) = @_;
      if (exists $arg_spec->{default}) {
          $opt->{default} = $arg_spec->{default};
      } elsif ($arg_spec->{schema} && exists($arg_spec->{schema}[1]{default})) {
          $opt->{default} = $arg_spec->{schema}[1]{default};
      }
  }
  
  sub _dash_prefix {
      length($_[0]) > 1 ? "--$_[0]" : "-$_[0]";
  }
  
  sub _fmt_opt {
      my $spec = shift;
      my @ospecs = @_;
      my @res;
      my $i = 0;
      for my $ospec (@ospecs) {
          my $j = 0;
          my $parsed = $ospec->{parsed};
          for (@{ $parsed->{opts} }) {
              my $opt = _dash_prefix($_);
              if ($i==0 && $j==0) {
                  if ($parsed->{type}) {
                      if ($spec->{'x.schema.entity'}) {
                          $opt .= "=".$spec->{'x.schema.entity'};
                      } elsif ($spec->{'x.schema.element_entity'}) {
                          $opt .= "=".$spec->{'x.schema.element_entity'};
                      } else {
                          $opt .= "=$parsed->{type}";
                      }
                  }
                  # mark required option with a '*'
                  $opt .= "*" if $spec->{req} && !$ospec->{is_base64} &&
                      !$ospec->{is_json} && !$ospec->{is_yaml};
              }
              push @res, $opt;
              $j++;
          }
          $i++;
      }
      join ", ", @res;
  }
  
  $SPEC{gen_cli_doc_data_from_meta} = {
      v => 1.1,
      summary => 'From Rinci function metadata, generate structure convenient '.
          'for producing CLI documentation (help/usage/POD)',
      description => <<'_',
  
  This function calls `Perinci::Sub::GetArgs::Argv`'s
  `gen_getopt_long_spec_from_meta()` (or receive its result as an argument, if
  passed, to avoid calling the function twice) and post-processes it: produce
  command usage line, format the options, include information from metadata, group
  the options by category. It also selects examples in the `examples` property
  which are applicable to CLI environment and format them.
  
  The resulting data structure is convenient to use when one wants to produce a
  documentation for CLI program (including help/usage message and POD).
  
  _
      args => {
          meta => {
              schema => 'hash*', # XXX rifunc
              req => 1,
              pos => 0,
          },
          meta_is_normalized => {
              schema => 'bool*',
          },
          common_opts => {
              summary => 'Will be passed to gen_getopt_long_spec_from_meta()',
              schema  => 'hash*',
          },
          ggls_res => {
              summary => 'Full result from gen_getopt_long_spec_from_meta()',
              schema  => 'array*', # XXX envres
              description => <<'_',
  
  If you already call `Perinci::Sub::GetArgs::Argv`'s
  `gen_getopt_long_spec_from_meta()`, you can pass the _full_ enveloped result
  here, to avoid calculating twice. What will be useful for the function is the
  extra result in result metadata (`func.*` keys in `$res->[3]` hash).
  
  _
          },
          per_arg_json => {
              schema => 'bool',
              summary => 'Pass per_arg_json=1 to Perinci::Sub::GetArgs::Argv',
          },
          per_arg_yaml => {
              schema => 'bool',
              summary => 'Pass per_arg_json=1 to Perinci::Sub::GetArgs::Argv',
          },
          lang => {
              schema => 'str*',
          },
      },
      result => {
          schema => 'hash*',
      },
  };
  sub gen_cli_doc_data_from_meta {
      require Getopt::Long::Negate::EN;
  
      my %args = @_;
  
      my $lang = $args{lang};
      my $meta = $args{meta} or return [400, 'Please specify meta'];
      my $common_opts = $args{common_opts};
      unless ($args{meta_is_normalized}) {
          require Perinci::Sub::Normalize;
          $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
      }
      my $ggls_res = $args{ggls_res} // do {
          require Perinci::Sub::GetArgs::Argv;
          Perinci::Sub::GetArgs::Argv::gen_getopt_long_spec_from_meta(
              meta=>$meta, meta_is_normalized=>1, common_opts=>$common_opts,
              per_arg_json => $args{per_arg_json},
              per_arg_yaml => $args{per_arg_yaml},
          );
      };
      $ggls_res->[0] == 200 or return $ggls_res;
  
      my $args_prop = $meta->{args} // {};
      my $clidocdata = {
          option_categories => {},
          example_categories => {},
      };
  
      # generate usage line
      {
          my @args;
          my %args_prop = %$args_prop; # copy because we want to iterate & delete
          my $max_pos = -1;
          for (values %args_prop) {
              $max_pos = $_->{pos}
                  if defined($_->{pos}) && $_->{pos} > $max_pos;
          }
          my $pos = 0;
          while ($pos <= $max_pos) {
              my ($arg, $arg_spec);
              for (keys %args_prop) {
                  $arg_spec = $args_prop{$_};
                  if (defined($arg_spec->{pos}) && $arg_spec->{pos}==$pos) {
                      $arg = $_;
                      last;
                  }
              }
              $pos++;
              next unless defined($arg);
              if ($arg_spec->{req}) {
                  push @args, "<$arg>";
              } else {
                  push @args, "[$arg]";
              }
              $args[-1] .= "..." if $arg_spec->{greedy};
              delete $args_prop{$arg};
          }
          unshift @args, "[options]" if keys(%args_prop) || keys(%$common_opts); # XXX translatable?
          $clidocdata->{usage_line} = "[[prog]]".
              (@args ? " ".join(" ", @args) : "");
      }
  
      # generate list of options
      my %opts;
      {
          my $ospecs = $ggls_res->[3]{'func.specmeta'};
          # separate groupable aliases because they will be merged with the
          # argument options
          my (@k, @k_aliases);
        OSPEC1:
          for (sort keys %$ospecs) {
              my $ospec = $ospecs->{$_};
              {
                  last unless $ospec->{is_alias};
                  next if $ospec->{is_code};
                  my $arg_spec = $args_prop->{$ospec->{arg}};
                  my $alias_spec = $arg_spec->{cmdline_aliases}{$ospec->{alias}};
                  next if $alias_spec->{summary};
                  push @k_aliases, $_;
                  next OSPEC1;
              }
              push @k, $_;
          }
  
          my %negs; # key=arg, only show one negation form for each arg option
  
        OSPEC2:
          while (@k) {
              my $k = shift @k;
              my $ospec = $ospecs->{$k};
              my $opt;
              my $optkey;
  
              if ($ospec->{is_alias} || defined($ospec->{arg})) {
                  my $arg_spec;
                  my $alias_spec;
  
                  if ($ospec->{is_alias}) {
                      # non-groupable alias
  
                      $arg_spec = $args_prop->{ $ospec->{arg} };
                      $alias_spec = $arg_spec->{cmdline_aliases}{$ospec->{alias}};
                      my $rimeta = rimeta($alias_spec);
                      $optkey = _fmt_opt($arg_spec, $ospec);
                      $opt = {
                          opt_parsed => $ospec->{parsed},
                          orig_opt => $k,
                          is_alias => 1,
                          alias_for => $ospec->{alias_for},
                          summary => $rimeta->langprop({lang=>$lang}, 'summary') //
                              "Alias for "._dash_prefix($ospec->{parsed}{opts}[0]),
                          description =>
                              $rimeta->langprop({lang=>$lang}, 'description'),
                      };
                  } else {
                      # an option for argument
  
                      $arg_spec = $args_prop->{$ospec->{arg}};
                      my $rimeta = rimeta($arg_spec);
                      $opt = {
                          opt_parsed => $ospec->{parsed},
                          orig_opt => $k,
                      };
  
                      # for bool, only display either the positive (e.g. --bool)
                      # or the negative (e.g. --nobool) depending on the default
                      if (defined($ospec->{is_neg})) {
                          my $default = $arg_spec->{default} //
                              $arg_spec->{schema}[1]{default};
                          next OSPEC2 if  $default && !$ospec->{is_neg};
                          next OSPEC2 if !$default &&  $ospec->{is_neg};
                          if ($ospec->{is_neg}) {
                              next OSPEC2 if $negs{$ospec->{arg}}++;
                          }
                      }
  
                      if ($ospec->{is_neg}) {
                          # for negative option, use negative summary instead of
                          # regular (positive sentence) summary
                          $opt->{summary} =
                              $rimeta->langprop({lang=>$lang}, 'summary.alt.bool.not');
                      } elsif (defined $ospec->{is_neg}) {
                          # for boolean option which we show the positive, show
                          # the positive summary if available
                          $opt->{summary} =
                              $rimeta->langprop({lang=>$lang}, 'summary.alt.bool.yes') //
                                  $rimeta->langprop({lang=>$lang}, 'summary');
                      } elsif (($ospec->{parsed}{type}//'') eq 's@') {
                          # for array of string that can be specified via multiple
                          # --opt, show singular version of summary if available.
                          # otherwise show regular summary.
                          $opt->{summary} =
                              $rimeta->langprop({lang=>$lang}, 'summary.alt.plurality.singular') //
                                  $rimeta->langprop({lang=>$lang}, 'summary');
                      } else {
                          $opt->{summary} =
                              $rimeta->langprop({lang=>$lang}, 'summary');
                      }
                      $opt->{description} =
                          $rimeta->langprop({lang=>$lang}, 'description');
  
                      # find aliases that can be grouped together with this option
                      my @aliases;
                      my $j = $#k_aliases;
                      while ($j >= 0) {
                          my $aospec = $ospecs->{ $k_aliases[$j] };
                          {
                              last unless $aospec->{arg} eq $ospec->{arg};
                              push @aliases, $aospec;
                              splice @k_aliases, $j, 1;
                          }
                          $j--;
                      }
  
                      $optkey = _fmt_opt($arg_spec, $ospec, @aliases);
                  }
  
                  $opt->{arg_spec} = $arg_spec;
                  $opt->{alias_spec} = $alias_spec if $alias_spec;
  
                  # include keys from func.specmeta
                  for (qw/arg fqarg is_base64 is_json is_yaml/) {
                      $opt->{$_} = $ospec->{$_} if defined $ospec->{$_};
                  }
  
                  # include keys from arg_spec
                  for (qw/req pos greedy is_password links tags/) {
                      $opt->{$_} = $arg_spec->{$_} if defined $arg_spec->{$_};
                  }
  
                  _add_category_from_spec($clidocdata->{option_categories},
                                          $opt, $arg_spec, "options", 1);
                  _add_default_from_arg_spec($opt, $arg_spec);
  
              } else {
                  # option from common_opts
  
                  my $spec = $common_opts->{$ospec->{common_opt}};
  
                  # for bool, only display either the positive (e.g. --bool)
                  # or the negative (e.g. --nobool) depending on the default
                  my $show_neg = $ospec->{parsed}{is_neg} && $spec->{default};
  
                  local $ospec->{parsed}{opts} = do {
                      # XXX check if it's single-letter, get first
                      # non-single-letter
                      my @opts = Getopt::Long::Negate::EN::negations_for_option(
                          $ospec->{parsed}{opts}[0]);
                      [ $opts[0] ];
                  } if $show_neg;
  
                  $optkey = _fmt_opt($spec, $ospec);
                  my $rimeta = rimeta($spec);
                  $opt = {
                      opt_parsed => $ospec->{parsed},
                      orig_opt => $k,
                      common_opt => $ospec->{common_opt},
                      common_opt_spec => $spec,
                      summary => $show_neg ?
                          $rimeta->langprop({lang=>$lang}, 'summary.alt.bool.not') :
                              $rimeta->langprop({lang=>$lang}, 'summary'),
                      (schema => $spec->{schema}) x !!$spec->{schema},
                      ('x.schema.entity' => $spec->{'x.schema.entity'}) x !!$spec->{'x.schema.entity'},
                      ('x.schema.element_entity' => $spec->{'x.schema.element_entity'}) x !!$spec->{'x.schema.element_entity'},
                      description =>
                          $rimeta->langprop({lang=>$lang}, 'description'),
                      (default => $spec->{default}) x !!(exists($spec->{default}) && !$show_neg),
                  };
  
                  _add_category_from_spec($clidocdata->{option_categories},
                                          $opt, $spec, "options", 1);
  
              }
  
              $opts{$optkey} = $opt;
          }
  
          # link ungrouped alias to its main opt
        OPT1:
          for my $k (keys %opts) {
              my $opt = $opts{$k};
              next unless $opt->{is_alias} || $opt->{is_base64} ||
                  $opt->{is_json} || $opt->{is_yaml};
              for my $k2 (keys %opts) {
                  my $arg_opt = $opts{$k2};
                  next if $arg_opt->{is_alias} || $arg_opt->{is_base64} ||
                      $arg_opt->{is_json} || $arg_opt->{is_yaml};
                  next unless defined($arg_opt->{arg}) &&
                      $arg_opt->{arg} eq $opt->{arg};
                  $opt->{main_opt} = $k2;
                  next OPT1;
              }
          }
  
      }
      $clidocdata->{opts} = \%opts;
  
      # filter and format examples
      my @examples;
      {
          my $examples = $meta->{examples} // [];
          my $has_cats = _has_cats($examples);
  
          for my $eg (@$examples) {
              my $rimeta = rimeta($eg);
              my $argv;
              my $cmdline;
              if (defined($eg->{src})) {
                  # we only show shell command examples
                  if ($eg->{src_plang} =~ /^(sh|bash)$/) {
                      $cmdline = $eg->{src};
                  } else {
                      next;
                  }
              } else {
                  require String::ShellQuote;
                  if ($eg->{argv}) {
                      $argv = $eg->{argv};
                  } else {
                      require Perinci::Sub::ConvertArgs::Argv;
                      my $res = Perinci::Sub::ConvertArgs::Argv::convert_args_to_argv(
                          args => $eg->{args}, meta => $meta);
                      return err($res, 500, "Can't convert args to argv")
                          unless $res->[0] == 200;
                      $argv = $res->[2];
                  }
                  $cmdline = "[[prog]]";
                  for my $arg (@$argv) {
                      $arg = String::ShellQuote::shell_quote($arg);
                      $cmdline .= " $arg"; # XXX markup with color?
                  }
              }
              my $egdata = {
                  cmdline      => $cmdline,
                  summary      => $rimeta->langprop({lang=>$lang}, 'summary'),
                  description  => $rimeta->langprop({lang=>$lang}, 'description'),
                  example_spec => $eg,
              };
              # XXX show result from $eg
              _add_category_from_spec($clidocdata->{example_categories},
                                      $egdata, $eg, "examples", $has_cats);
              push @examples, $egdata;
          }
      }
      $clidocdata->{examples} = \@examples;
  
      [200, "OK", $clidocdata];
  }
  
  1;
  # ABSTRACT: From Rinci function metadata, generate structure convenient for producing CLI documentation (help/usage/POD)
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::To::CLIDocData - From Rinci function metadata, generate structure convenient for producing CLI documentation (help/usage/POD)
  
  =head1 VERSION
  
  This document describes version 0.20 of Perinci::Sub::To::CLIDocData (from Perl distribution Perinci-Sub-To-CLIDocData), released on 2015-04-07.
  
  =head1 SYNOPSIS
  
   use Perinci::Sub::To::CLIDocData qw(gen_cli_doc_data_from_meta);
   my $clidocdata = gen_cli_doc_data_from_meta(meta => $meta);
  
  Sample function metadata (C<$meta>):
  
   {
     args => {
       bool1 => {
                  cmdline_aliases => { z => { summary => "This is summary for option `-z`" } },
                  schema => "bool",
                  summary => "Another bool option",
                  tags => ["category:cat1"],
                },
       flag1 => {
                  cmdline_aliases => { f => {} },
                  schema => ["bool", "is", 1],
                  tags => ["category:cat1"],
                },
       str1  => {
                  pos => 0,
                  req => 1,
                  schema => "str*",
                  summary => "A required option as well as positional argument",
                },
     },
     examples => [
       {
         argv    => ["a value", "--bool1"],
         summary => "Summary for an example",
         test    => 0,
       },
     ],
     summary => "Function summary",
     v => 1.1,
   }
  
  Sample result:
  
   do {
     my $a = [
       200,
       "OK",
       {
         example_categories => { Examples => { order => 99 } },
         examples => [
           {
             category     => "Examples",
             cmdline      => "[[prog]] 'a value' --bool1",
             description  => undef,
             example_spec => {
                               argv    => ["'a value'", "--bool1"],
                               summary => "Summary for an example",
                               test    => 0,
                             },
             summary      => "Summary for an example",
           },
         ],
         option_categories => {
           "Cat1 options"  => { order => 50 },
           "Other options" => { order => 99 },
         },
         opts => {
           "--bool1" => {
             arg         => "bool1",
             arg_spec    => {
                              cmdline_aliases => { z => { summary => "This is summary for option `-z`" } },
                              schema => ["bool", {}, {}],
                              summary => "Another bool option",
                              tags => ["category:cat1"],
                            },
             category    => "Cat1 options",
             description => undef,
             fqarg       => "bool1",
             opt_parsed  => { opts => ["bool1"] },
             orig_opt    => "bool1",
             summary     => "Another bool option",
             tags        => 'fix',
           },
           "--flag1, -f" => {
             arg         => "flag1",
             arg_spec    => {
                              cmdline_aliases => { f => {} },
                              schema => ["bool", { is => 1 }, {}],
                              tags => ["category:cat1"],
                            },
             category    => "Cat1 options",
             description => undef,
             fqarg       => "flag1",
             opt_parsed  => { opts => ["flag1"] },
             orig_opt    => "flag1",
             summary     => undef,
             tags        => 'fix',
           },
           "--str1=s*" => {
             arg => "str1",
             arg_spec => {
               pos => 0,
               req => 1,
               schema => ["str", { req => 1 }, {}],
               summary => "A required option as well as positional argument",
             },
             category => "Other options",
             description => undef,
             fqarg => "str1",
             opt_parsed => { desttype => "", opts => ["str1"], type => "s" },
             orig_opt => "str1=s",
             pos => 0,
             req => 1,
             summary => "A required option as well as positional argument",
           },
           "-z" => {
             alias_for   => "bool1",
             alias_spec  => 'fix',
             arg         => "bool1",
             arg_spec    => 'fix',
             category    => "Cat1 options",
             description => undef,
             fqarg       => "bool1",
             is_alias    => 1,
             main_opt    => "--bool1",
             opt_parsed  => { opts => ["z"] },
             orig_opt    => "z",
             summary     => "This is summary for option `-z`",
             tags        => 'fix',
           },
         },
         usage_line => "[[prog]] [options] <str1>",
       },
     ];
     $a->[2]{opts}{"--bool1"}{tags} = $a->[2]{opts}{"--bool1"}{arg_spec}{tags};
     $a->[2]{opts}{"--flag1, -f"}{tags} = $a->[2]{opts}{"--flag1, -f"}{arg_spec}{tags};
     $a->[2]{opts}{"-z"}{alias_spec} = $a->[2]{opts}{"--bool1"}{arg_spec}{cmdline_aliases}{z};
     $a->[2]{opts}{"-z"}{arg_spec} = $a->[2]{opts}{"--bool1"}{arg_spec};
     $a->[2]{opts}{"-z"}{tags} = $a->[2]{opts}{"--bool1"}{arg_spec}{tags};
     $a;
   }
  
  For a more complete sample, see function metadata for C<demo_cli_opts> in
  L<Perinci::Examples::CLI>.
  
  =head1 SEE ALSO
  
  L<Perinci::CmdLine>, L<Perinci::CmdLine::Lite>
  
  L<Pod::Weaver::Plugin::Rinci>
  
  =head1 FUNCTIONS
  
  
  =head2 gen_cli_doc_data_from_meta(%args) -> [status, msg, result, meta]
  
  From Rinci function metadata, generate structure convenient for producing CLI documentation (help/usage/POD).
  
  This function calls C<Perinci::Sub::GetArgs::Argv>'s
  C<gen_getopt_long_spec_from_meta()> (or receive its result as an argument, if
  passed, to avoid calling the function twice) and post-processes it: produce
  command usage line, format the options, include information from metadata, group
  the options by category. It also selects examples in the C<examples> property
  which are applicable to CLI environment and format them.
  
  The resulting data structure is convenient to use when one wants to produce a
  documentation for CLI program (including help/usage message and POD).
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<common_opts> => I<hash>
  
  Will be passed to gen_getopt_long_spec_from_meta().
  
  =item * B<ggls_res> => I<array>
  
  Full result from gen_getopt_long_spec_from_meta().
  
  If you already call C<Perinci::Sub::GetArgs::Argv>'s
  C<gen_getopt_long_spec_from_meta()>, you can pass the I<full> enveloped result
  here, to avoid calculating twice. What will be useful for the function is the
  extra result in result metadata (C<func.*> keys in C<< $res-E<gt>[3] >> hash).
  
  =item * B<lang> => I<str>
  
  =item * B<meta>* => I<hash>
  
  =item * B<meta_is_normalized> => I<bool>
  
  =item * B<per_arg_json> => I<bool>
  
  Pass per_arg_json=1 to Perinci::Sub::GetArgs::Argv.
  
  =item * B<per_arg_yaml> => I<bool>
  
  Pass per_arg_json=1 to Perinci::Sub::GetArgs::Argv.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (hash)
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-To-CLIDocData>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-To-CLIOptSpec>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-To-CLIDocData>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_SUB_TO_CLIDOCDATA

$fatpacked{"Perinci/Sub/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_UTIL';
  package Perinci::Sub::Util;
  
  our $DATE = '2015-01-04'; # DATE
  our $VERSION = '0.41'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         err
                         caller
                         gen_modified_sub
                         warn_err
                         die_err
                 );
  
  our %SPEC;
  
  $SPEC{':package'} = {
      v => 1.1,
      summary => 'Helper when writing functions',
  };
  
  our $STACK_TRACE;
  our @_c; # to store temporary celler() result
  our $_i; # temporary variable
  sub err {
      require Scalar::Util;
  
      # get information about caller
      my @caller = CORE::caller(1);
      if (!@caller) {
          # probably called from command-line (-e)
          @caller = ("main", "-e", 1, "program");
      }
  
      my ($status, $msg, $meta, $prev);
  
      for (@_) {
          my $ref = ref($_);
          if ($ref eq 'ARRAY') { $prev = $_ }
          elsif ($ref eq 'HASH') { $meta = $_ }
          elsif (!$ref) {
              if (Scalar::Util::looks_like_number($_)) {
                  $status = $_;
              } else {
                  $msg = $_;
              }
          }
      }
  
      $status //= 500;
      $msg  //= "$caller[3] failed";
      $meta //= {};
      $meta->{prev} //= $prev if $prev;
  
      # put information on who produced this error and where/when
      if (!$meta->{logs}) {
  
          # should we produce a stack trace?
          my $stack_trace;
          {
              no warnings;
              # we use Carp::Always as a sign that user wants stack traces
              last unless $STACK_TRACE // $INC{"Carp/Always.pm"};
              # stack trace is already there in previous result's log
              last if $prev && ref($prev->[3]) eq 'HASH' &&
                  ref($prev->[3]{logs}) eq 'ARRAY' &&
                      ref($prev->[3]{logs}[0]) eq 'HASH' &&
                          $prev->[3]{logs}[0]{stack_trace};
              $stack_trace = [];
              $_i = 1;
              while (1) {
                  {
                      package DB;
                      @_c = CORE::caller($_i);
                      if (@_c) {
                          $_c[4] = [@DB::args];
                      }
                  }
                  last unless @_c;
                  push @$stack_trace, [@_c];
                  $_i++;
              }
          }
          push @{ $meta->{logs} }, {
              type    => 'create',
              time    => time(),
              package => $caller[0],
              file    => $caller[1],
              line    => $caller[2],
              func    => $caller[3],
              ( stack_trace => $stack_trace ) x !!$stack_trace,
          };
      }
  
      #die;
      [$status, $msg, undef, $meta];
  }
  
  sub caller {
      my $n0 = shift;
      my $n  = $n0 // 0;
  
      my $pkg = $Perinci::Sub::Wrapper::default_wrapped_package //
          'Perinci::Sub::Wrapped';
  
      my @r;
      my $i =  0;
      my $j = -1;
      while ($i <= $n+1) { # +1 for this sub itself
          $j++;
          @r = CORE::caller($j);
          last unless @r;
          if ($r[0] eq $pkg && $r[1] =~ /^\(eval /) {
              next;
          }
          $i++;
      }
  
      return unless @r;
      return defined($n0) ? @r : $r[0];
  }
  
  $SPEC{gen_modified_sub} = {
      v => 1.1,
      summary => 'Generate modified metadata (and subroutine) based on another',
      description => <<'_',
  
  Often you'll want to create another sub (and its metadata) based on another, but
  with some modifications, e.g. add/remove/rename some arguments, change summary,
  add/remove some properties, and so on.
  
  Instead of cloning the Rinci metadata and modify it manually yourself, this
  routine provides some shortcuts.
  
  You can specify base sub/metadata using `base_name` (string, subroutine name,
  either qualified or not) or `base_code` (coderef) + `base_meta` (hash).
  
  _
      args => {
          base_name => {
              summary => 'Subroutine name (either qualified or not)',
              schema => 'str*',
              description => <<'_',
  
  If not qualified with package name, will be searched in the caller's package.
  Rinci metadata will be searched in `%SPEC` package variable.
  
  Alternatively, you can also specify `base_code` and `base_meta`.
  
  _
          },
          base_code => {
              summary => 'Base subroutine code',
              schema  => 'code*',
              description => <<'_',
  
  If you specify this, you'll also need to specify `base_meta`.
  
  Alternatively, you can specify `base_name` instead, to let this routine search
  the base subroutine from existing Perl package.
  
  _
          },
          base_meta => {
              summary => 'Base Rinci metadata',
              schema  => 'hash*', # XXX defhash/rifunc
          },
          output_name => {
              summary => 'Where to install the modified sub',
              schema  => 'str*',
              description => <<'_',
  
  Subroutine will be put in the specified name. If the name is not qualified with
  package name, will use caller's package. If no `output_code` is specified, the
  base subroutine reference will be assigned here.
  
  Note that this argument is optional.
  
  _
          },
          output_code => {
              summary => 'Code for the modified sub',
              schema  => 'code*',
              description => <<'_',
  
  If not specified will use `base_code` (which will then be required).
  
  _
          },
          summary => {
              summary => 'Summary for the mod subroutine',
              schema  => 'str*',
          },
          description => {
              summary => 'Description for the mod subroutine',
              schema  => 'str*',
          },
          remove_args => {
              summary => 'List of arguments to remove',
              schema  => 'array*',
          },
          add_args => {
              summary => 'Arguments to add',
              schema  => 'hash*',
          },
          replace_args => {
              summary => 'Arguments to add',
              schema  => 'hash*',
          },
          rename_args => {
              summary => 'Arguments to rename',
              schema  => 'hash*',
          },
          modify_args => {
              summary => 'Arguments to modify',
              description => <<'_',
  
  For each argument you can specify a coderef. The coderef will receive the
  argument ($arg_spec) and is expected to modify the argument specification.
  
  _
              schema  => 'hash*',
          },
          modify_meta => {
              summary => 'Specify code to modify metadata',
              schema  => 'code*',
              description => <<'_',
  
  Code will be called with arguments ($meta) where $meta is the cloned Rinci
  metadata.
  
  _
          },
          install_sub => {
              schema  => 'bool',
              default => 1,
          },
      },
      result => {
          schema => ['hash*' => {
              keys => {
                  code => ['code*'],
                  meta => ['hash*'], # XXX defhash/risub
              },
          }],
      },
  };
  sub gen_modified_sub {
      require Function::Fallback::CoreOrPP;
  
      my %args = @_;
  
      # get base code/meta
      my ($base_code, $base_meta);
      if ($args{base_name}) {
          my ($pkg, $leaf);
          if ($args{base_name} =~ /(.+)::(.+)/) {
              ($pkg, $leaf) = ($1, $2);
          } else {
              $pkg  = CORE::caller();
              $leaf = $args{base_name};
          }
          no strict 'refs';
          $base_code = \&{"$pkg\::$leaf"};
          $base_meta = ${"$pkg\::SPEC"}{$leaf};
          die "Can't find Rinci metadata for $pkg\::$leaf" unless $base_meta;
      } elsif ($args{base_meta}) {
          $base_meta = $args{base_meta};
          $base_code = $args{base_code}
              or die "Please specify base_code";
      } else {
          die "Please specify base_name or base_code+base_meta";
      }
  
      my $output_meta = Function::Fallback::CoreOrPP::clone($base_meta);
      my $output_code = $args{output_code} // $base_code;
  
      # modify metadata
      for (qw/summary description/) {
          $output_meta->{$_} = $args{$_} if $args{$_};
      }
      if ($args{remove_args}) {
          delete $output_meta->{args}{$_} for @{ $args{remove_args} };
      }
      if ($args{add_args}) {
          for my $k (keys %{ $args{add_args} }) {
              my $v = $args{add_args}{$k};
              die "Can't add arg '$k' in mod sub: already exists"
                  if $output_meta->{args}{$k};
              $output_meta->{args}{$k} = $v;
          }
      }
      if ($args{replace_args}) {
          for my $k (keys %{ $args{replace_args} }) {
              my $v = $args{replace_args}{$k};
              die "Can't replace arg '$k' in mod sub: doesn't exist"
                  unless $output_meta->{args}{$k};
              $output_meta->{args}{$k} = $v;
          }
      }
      if ($args{rename_args}) {
          for my $old (keys %{ $args{rename_args} }) {
              my $new = $args{rename_args}{$old};
              my $as = $output_meta->{args}{$old};
              die "Can't rename arg '$old' in mod sub: doesn't exist" unless $as;
              die "Can't rename arg '$old'->'$new' in mod sub: ".
                  "new name already exist" if $output_meta->{args}{$new};
              $output_meta->{args}{$new} = $as;
              delete $output_meta->{args}{$old};
          }
      }
      if ($args{modify_args}) {
          for (keys %{ $args{modify_args} }) {
              $args{modify_args}{$_}->($output_meta->{args}{$_});
          }
      }
      if ($args{modify_meta}) {
          $args{modify_meta}->($output_meta);
      }
  
      # install
      if ($args{output_name}) {
          my ($pkg, $leaf);
          if ($args{output_name} =~ /(.+)::(.+)/) {
              ($pkg, $leaf) = ($1, $2);
          } else {
              $pkg  = CORE::caller();
              $leaf = $args{output_name};
          }
          no strict 'refs';
          no warnings 'redefine';
          *{"$pkg\::$leaf"}       = $output_code if $args{install_sub} // 1;
          ${"$pkg\::SPEC"}{$leaf} = $output_meta;
      }
  
      [200, "OK", {code=>$output_code, meta=>$output_meta}];
  }
  
  # TODO: for simpler cases (e.g. only remove some arguments, or preset some
  # arguments), create more convenient helper, e.g.
  #
  # gen_curried_sub('list_users', {is_suspended=>1}, ?'list_suspended_users'); # equivalent to remove args => ['is_suspended'] and create a wrapper that calls list_users with is_suspended=>1
  
  sub warn_err {
      require Carp;
  
      my $res = err(@_);
      Carp::carp("ERROR $res->[0]: $res->[1]");
  }
  
  sub die_err {
      require Carp;
  
      my $res = err(@_);
      Carp::croak("ERROR $res->[0]: $res->[1]");
  }
  
  1;
  # ABSTRACT: Helper when writing functions
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::Util - Helper when writing functions
  
  =head1 VERSION
  
  This document describes version 0.41 of Perinci::Sub::Util (from Perl distribution Perinci-Sub-Util), released on 2015-01-04.
  
  =head1 SYNOPSIS
  
  Example for err() and caller():
  
   use Perinci::Sub::Util qw(err caller);
  
   sub foo {
       my %args = @_;
       my $res;
  
       my $caller = caller();
  
       $res = bar(...);
       return err($err, 500, "Can't foo") if $res->[0] != 200;
  
       [200, "OK"];
   }
  
  Example for gen_modified_sub():
  
   use Perinci::Sub::Util qw(gen_modified_sub);
  
   $SPEC{list_users} = {
       v => 1.1,
       args => {
           search => {},
           is_suspended => {},
       },
   };
   sub list_users { ... }
  
   gen_modified_sub(
       output_name => 'list_suspended_users',
       base_name   => 'list_users',
       remove_args => ['is_suspended'],
       output_code => sub {
           list_users(@_, is_suspended=>1);
       },
   );
  
  Example for die_err() and warn_err():
  
   use Perinci::Sub::Util qw(warn_err die_err);
   warn_err(403, "Forbidden");
   die_err(403, "Forbidden");
  
  =head1 FUNCTIONS
  
  =head2 caller([ $n ])
  
  Just like Perl's builtin caller(), except that this one will ignore wrapper code
  in the call stack. You should use this if your code is potentially wrapped. See
  L<Perinci::Sub::Wrapper> for more details.
  
  =head2 err(...) => ARRAY
  
  Experimental.
  
  Generate an enveloped error response (see L<Rinci::function>). Can accept
  arguments in an unordered fashion, by utilizing the fact that status codes are
  always integers, messages are strings, result metadata are hashes, and previous
  error responses are arrays. Error responses also seldom contain actual result.
  Status code defaults to 500, status message will default to "FUNC failed". This
  function will also fill the information in the C<logs> result metadata.
  
  Examples:
  
   err();    # => [500, "FUNC failed", undef, {...}];
   err(404); # => [404, "FUNC failed", undef, {...}];
   err(404, "Not found"); # => [404, "Not found", ...]
   err("Not found", 404); # => [404, "Not found", ...]; # order doesn't matter
   err([404, "Prev error"]); # => [500, "FUNC failed", undef,
                             #     {logs=>[...], prev=>[404, "Prev error"]}]
  
  Will put C<stack_trace> in logs only if C<Carp::Always> module is loaded.
  
  =head2 warn_err(...)
  
  This is a shortcut for:
  
   $res = err(...);
   warn "ERROR $res->[0]: $res->[1]";
  
  =head2 die_err(...)
  
  This is a shortcut for:
  
   $res = err(...);
   die "ERROR $res->[0]: $res->[1]";
  
  
  =head2 gen_modified_sub(%args) -> [status, msg, result, meta]
  
  Generate modified metadata (and subroutine) based on another.
  
  Often you'll want to create another sub (and its metadata) based on another, but
  with some modifications, e.g. add/remove/rename some arguments, change summary,
  add/remove some properties, and so on.
  
  Instead of cloning the Rinci metadata and modify it manually yourself, this
  routine provides some shortcuts.
  
  You can specify base sub/metadata using C<base_name> (string, subroutine name,
  either qualified or not) or C<base_code> (coderef) + C<base_meta> (hash).
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<add_args> => I<hash>
  
  Arguments to add.
  
  =item * B<base_code> => I<code>
  
  Base subroutine code.
  
  If you specify this, you'll also need to specify C<base_meta>.
  
  Alternatively, you can specify C<base_name> instead, to let this routine search
  the base subroutine from existing Perl package.
  
  =item * B<base_meta> => I<hash>
  
  Base Rinci metadata.
  
  =item * B<base_name> => I<str>
  
  Subroutine name (either qualified or not).
  
  If not qualified with package name, will be searched in the caller's package.
  Rinci metadata will be searched in C<%SPEC> package variable.
  
  Alternatively, you can also specify C<base_code> and C<base_meta>.
  
  =item * B<description> => I<str>
  
  Description for the mod subroutine.
  
  =item * B<install_sub> => I<bool> (default: 1)
  
  =item * B<modify_args> => I<hash>
  
  Arguments to modify.
  
  For each argument you can specify a coderef. The coderef will receive the
  argument ($arg_spec) and is expected to modify the argument specification.
  
  =item * B<modify_meta> => I<code>
  
  Specify code to modify metadata.
  
  Code will be called with arguments ($meta) where $meta is the cloned Rinci
  metadata.
  
  =item * B<output_code> => I<code>
  
  Code for the modified sub.
  
  If not specified will use C<base_code> (which will then be required).
  
  =item * B<output_name> => I<str>
  
  Where to install the modified sub.
  
  Subroutine will be put in the specified name. If the name is not qualified with
  package name, will use caller's package. If no C<output_code> is specified, the
  base subroutine reference will be assigned here.
  
  Note that this argument is optional.
  
  =item * B<remove_args> => I<array>
  
  List of arguments to remove.
  
  =item * B<rename_args> => I<hash>
  
  Arguments to rename.
  
  =item * B<replace_args> => I<hash>
  
  Arguments to add.
  
  =item * B<summary> => I<str>
  
  Summary for the mod subroutine.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (hash)
  =head1 FAQ
  
  =head2 What if I want to put result ($res->[2]) into my result with err()?
  
  You can do something like this:
  
   my $err = err(...) if ERROR_CONDITION;
   $err->[2] = SOME_RESULT;
   return $err;
  
  =head1 SEE ALSO
  
  L<Perinci>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Util>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Perinci-Sub-Util>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Util>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_SUB_UTIL

$fatpacked{"Perinci/Sub/Util/ResObj.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_UTIL_RESOBJ';
  package Perinci::Sub::Util::ResObj;
  
  our $DATE = '2015-01-04'; # DATE
  our $VERSION = '0.41'; # VERSION
  
  use Carp;
  use overload
      q("") => sub {
          my $res = shift; "ERROR $err->[0]: $err->[1]\n" . Carp::longmess();
      };
  
  1;
  # ABSTRACT: An object that represents enveloped response suitable for die()-ing
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::Util::ResObj - An object that represents enveloped response suitable for die()-ing
  
  =head1 VERSION
  
  This document describes version 0.41 of Perinci::Sub::Util::ResObj (from Perl distribution Perinci-Sub-Util), released on 2015-01-04.
  
  =head1 SYNOPSIS
  
  Currently unused. See L<Perinci::Sub::Util>'s C<warn_err> and C<die_err>
  instead.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Util>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Perinci-Sub-Util>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Util>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_SUB_UTIL_RESOBJ

$fatpacked{"Perinci/Sub/Util/Sort.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PERINCI_SUB_UTIL_SORT';
  package Perinci::Sub::Util::Sort;
  
  our $DATE = '2015-01-04'; # DATE
  our $VERSION = '0.41'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         sort_args
                 );
  
  our %SPEC;
  
  sub sort_args {
      my $args = shift;
      sort {
          (($args->{$a}{pos} // 9999) <=> ($args->{$b}{pos} // 9999)) ||
              $a cmp $b
          } keys %$args;
  }
  
  1;
  # ABSTRACT: Sort routines
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Perinci::Sub::Util::Sort - Sort routines
  
  =head1 VERSION
  
  This document describes version 0.41 of Perinci::Sub::Util::Sort (from Perl distribution Perinci-Sub-Util), released on 2015-01-04.
  
  =head1 SYNOPSIS
  
   use Perinci::Sub::Util::Sort qw(sort_args);
  
   my $meta = {
       v => 1.1,
       args => {
           a1 => { pos=>0 },
           a2 => { pos=>1 },
           opt1 => {},
           opt2 => {},
       },
   };
   my @args = sort_args($meta->{args}); # ('a1','a2','opt1','opt2')
  
  =head1 FUNCTIONS
  
  =head2 sort_args(\%args) => LIST
  
  Sort argument in args property by pos, then by name.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Util>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Perinci-Sub-Util>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Util>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PERINCI_SUB_UTIL_SORT

$fatpacked{"Progress/Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PROGRESS_ANY';
  package Progress::Any;
  
  our $DATE = '2015-01-27'; # DATE
  our $VERSION = '0.20'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Time::Duration qw();
  use Time::HiRes qw(time);
  
  sub import {
      my ($self, @args) = @_;
      my $caller = caller();
      for (@args) {
          if ($_ eq '$progress') {
              my $progress = $self->get_indicator(task => '');
              {
                  no strict 'refs';
                  my $v = "$caller\::progress";
                  *$v = \$progress;
              }
          } else {
              die "Unknown import argument: $_";
          }
      }
  }
  
  # store Progress::Any objects for each task
  our %indicators;  # key = task name
  
  # store output objects
  our %outputs;     # key = task name, value = [$outputobj, ...]
  
  # store settings/data for each object
  our %output_data; # key = "$output_object", value = {key=>val, ...}
  
  # internal attributes:
  # - _elapsed (float*) = accumulated elapsed time so far
  # - _start_time (float) = when is the last time the indicator state is changed
  #     from 'stopped' to 'started'. when indicator is changed from 'started' to
  #     'stopped', this will be set to undef.
  # - _remaining = used to store user's estimation of remaining time. will be
  #     unset after each update().
  
  # return 1 if created, 0 if already created/initialized
  sub _init_indicator {
      my ($class, $task) = @_;
  
      #say "D: _init_indicator($task)";
  
      # prevent double initialization
      return $indicators{$task} if $indicators{$task};
  
      my $progress = bless({
          task        => $task,
          title       => $task,
          target      => 0,
          pos         => 0,
          state       => 'stopped',
  
          _remaining          => undef,
          _set_remaining_time => undef,
          _elapsed            => 0,
          _start_time         => 0,
      }, $class);
      $indicators{$task} = $progress;
  
      # if we create an indicator named a.b.c, we must also create a.b, a, and ''.
      if ($task =~ s/\.?\w+\z//) {
          $class->_init_indicator($task);
      }
  
      $progress;
  }
  
  sub get_indicator {
      my ($class, %args) = @_;
  
      my %oargs = %args;
  
      my $task   = delete($args{task});
      if (!defined($task)) {
          my @caller = caller(0);
          #say "D:caller=".join(",",map{$_//""} @caller);
          $task = $caller[0] eq '(eval)' ? 'main' : $caller[0];
          $task =~ s/::/./g;
          $task =~ s/[^.\w]+/_/g;
      }
      die "Invalid task syntax '$task', please only use dotted words"
          unless $task =~ /\A(?:\w+(\.\w+)*)?\z/;
  
      my %uargs;
  
      my $p = $class->_init_indicator($task);
      for my $an (qw/title target pos remaining state/) {
          if (exists $args{$an}) {
              $uargs{$an} = delete($args{$an});
          }
      }
      die "Unknown argument(s) to get_indicator(): ".join(", ", keys(%args))
          if keys(%args);
      $p->_update(%uargs) if keys %uargs;
  
      $p;
  }
  
  my %attrs = (
      title     => {is => 'rw'},
      target    => {is => 'rw'},
      pos       => {is => 'rw'},
      state     => {is => 'rw'},
  );
  
  # create attribute methods
  for my $an (keys %attrs) {
      next if $attrs{$an}{manual};
      my $code;
      if ($attrs{$an}{is} eq 'rw') {
          $code = sub {
              my $self = shift;
              if (@_) {
                  $self->_update($an => shift);
              }
              $self->{$an};
          };
      } else {
          $code = sub {
              my $self = shift;
              die "Can't set value, $an is an ro attribute" if @_;
              $self->{$an};
          };
      }
      no strict 'refs';
      *{$an} = $code;
  }
  
  sub elapsed {
      my $self = shift;
  
      if ($self->{state} eq 'started') {
          return $self->{_elapsed} + (time()-$self->{_start_time});
      } else {
          return $self->{_elapsed};
      }
  }
  
  sub total_pos {
      my $self = shift;
  
      my $t = $self->{task};
  
      my $res = $self->{pos};
      for (keys %indicators) {
          if ($t eq '') {
              next if $_ eq '';
          } else {
              next unless index($_, "$t.") == 0;
          }
          $res += $indicators{$_}{pos};
      }
      $res;
  }
  
  sub total_target {
      my $self = shift;
  
      my $t = $self->{task};
  
      my $res = $self->{target};
      return undef unless defined($res);
  
      for (keys %indicators) {
          if ($t eq '') {
              next if $_ eq '';
          } else {
              next unless index($_, "$t.") == 0;
          }
          return undef unless defined $indicators{$_}{target};
          $res += $indicators{$_}{target};
      }
      $res;
  }
  
  sub percent_complete {
      my $self = shift;
  
      my $total_pos    = $self->total_pos;
      my $total_target = $self->total_target;
  
      return undef unless defined($total_target);
      if ($total_target == 0) {
          if ($self->{state} eq 'finished') {
              return 100;
          } else {
              return 0;
          }
      } else {
          return $total_pos / $total_target * 100;
      }
  }
  
  sub remaining {
      my $self = shift;
  
      if (defined $self->{_remaining}) {
          if ($self->{state} eq 'started') {
              my $r = $self->{_remaining}-(time()-$self->{_set_remaining_time});
              return $r > 0 ? $r : 0;
          } else {
              return $self->{_remaining};
          }
      } else {
          if (defined $self->{target}) {
              if ($self->{pos} == 0) {
                  return 0;
              } else {
                  return ($self->{target} - $self->{pos})/$self->{pos} *
                      $self->elapsed;
              }
          } else {
              return undef;
          }
      }
  }
  
  sub total_remaining {
      my $self = shift;
  
      my $t = $self->{task};
  
      my $res = $self->remaining;
      return undef unless defined $res;
  
      for (keys %indicators) {
          if ($t eq '') {
              next if $_ eq '';
          } else {
              next unless index($_, "$t.") == 0;
          }
          my $res2 = $indicators{$_}->remaining;
          return undef unless defined $res2;
          $res += $res2;
      }
      $res;
  }
  
  # the routine to use to update rw attributes, does validation and checks to make
  # sure things are consistent.
  sub _update {
      my ($self, %args) = @_;
  
      # no need to check for unknown arg in %args, it's an internal method anyway
  
      my $now = time();
  
      my $task = $self->{task};
      #use Data::Dump; print "D: _update($task) "; dd \%args;
  
    SET_TITLE:
      {
          last unless exists $args{title};
          my $val = $args{title};
          die "Invalid value for title, must be defined"
              unless defined($val);
          $self->{title} = $val;
      }
  
    SET_TARGET:
      {
          last unless exists $args{target};
          my $val = $args{target};
          die "Invalid value for target, must be a positive number or undef"
              unless !defined($val) || $val >= 0;
          # ensure that pos does not exceed target
          if (defined($val) && $self->{pos} > $val) {
              $self->{pos} = $val;
          }
          $self->{target} = $val;
          undef $self->{_remaining};
      }
  
    SET_POS:
      {
          last unless exists $args{pos};
          my $val = $args{pos};
          die "Invalid value for pos, must be a positive number"
              unless defined($val) && $val >= 0;
          # ensure that pos does not exceed target
          if (defined($self->{target}) && $val > $self->{target}) {
              $val = $self->{target};
          }
          $self->{pos} = $val;
          undef $self->{_remaining};
      }
  
    SET_REMAINING:
      {
          last unless exists $args{remaining};
          my $val = $args{remaining};
          die "Invalid value for remaining, must be a positive number"
              unless defined($val) && $val >= 0;
          $self->{_remaining} = $val;
          $self->{_set_remaining_time} = $now;
      }
  
    SET_STATE:
      {
          last unless exists $args{state};
          my $old = $self->{state};
          my $val = $args{state} // 'started';
          die "Invalid value for state, must be stopped/started/finished"
              unless $val =~ /\A(?:stopped|started|finished)\z/;
          last if $old eq $val;
          if ($val eq 'started') {
              $self->{_start_time} = $now;
  
              # automatically start parents
              my @parents;
              {
                  my $t = $task;
                  while (1) {
                      last unless $t =~ s/\.\w+\z//;
                      push @parents, $t;
                  }
                  push @parents, '';
              }
              for my $t (@parents) {
                  my $p = $indicators{$t};
                  if ($p->{state} ne 'started') {
                      $p->{state}       = 'started';
                      $p->{_start_time} = $now;
                  }
              }
          } else {
              $self->{_elapsed} += $now - $self->{_start_time};
              if ($val eq 'finished') {
                  die "BUG: Can't finish task '$task', pos is still < target"
                      if defined($self->{target}) &&
                          $self->{pos} < $self->{target};
                  $self->{_remaining} = 0;
                  $self->{_set_remaining_time} = $now;
              }
          }
          $self->{state} = $val;
      }
  
    DONE:
      #use Data::Dump; print "after update: "; dd $self;
      return;
  }
  
  sub _should_update_output {
      my ($self, $output, $now) = @_;
  
      my $key = "$output";
      $output_data{$key} //= {};
      my $odata = $output_data{$key};
      if (!defined($odata->{mtime})) {
          # output has never been updated, update
          return 1;
      } elsif ($self->{state} eq 'finished') {
          # finishing, update the output to show finished state
          return 1;
      } elsif ($odata->{force_update}) {
          # force update
          delete $odata->{force_update};
          return 1;
      # } elsif ($args->{prio} eq 'low') {
          # perhaps provide something like this? a low-priority or minor update so
          # we don't have to update the outputs?
      } else {
          # normal update, update if not too frequent
          if (!defined($odata->{freq})) {
              # negative number means seconds, positive means pos delta. only
              # update if that number of seconds, or that difference in pos has
              # been passed.
              $odata->{freq} = -0.5;
          }
          if ($odata->{freq} < 0) {
              return 1 if $now >= $odata->{mtime} - $odata->{freq};
          } else {
              return 1 if abs($self->{pos} - $odata->{pos}) >= $odata->{freq};
          }
          return 0;
      }
  }
  
  sub update {
      my ($self, %args) = @_;
  
      my $pos   = delete($args{pos}) // $self->{pos} + 1;
      my $state = delete($args{state}) // 'started';
      $self->_update(pos => $pos, state => $state);
  
      my $message  = delete($args{message});
      my $level    = delete($args{level});
      die "Unknown argument(s) to update(): ".join(", ", keys(%args))
          if keys(%args);
  
      my $now = time();
  
      # find output(s) and call it
      {
          my $task = $self->{task};
          while (1) {
              if ($outputs{$task}) {
                  for my $output (@{ $outputs{$task} }) {
                      next unless $self->_should_update_output($output, $now);
                      if (ref($message) eq 'CODE') {
                          $message = $message->();
                      }
                      $output->update(
                          indicator => $indicators{$task},
                          message   => $message,
                          level     => $level,
                          time      => $now,
                      );
                      my $key = "$output";
                      $output_data{$key}{mtime} = $now;
                      $output_data{$key}{pos}   = $pos;
                  }
              }
              last unless $task =~ s/\.?\w+\z//;
          }
      }
  }
  
  sub start {
      my $self = shift;
      $self->_update(state => 'started');
  }
  
  sub stop {
      my $self = shift;
      $self->_update(state => 'stopped');
  }
  
  sub finish {
      my ($self, %args) = @_;
      $self->update(pos=>$self->{target}, state=>'finished', %args);
  }
  
  # - currently used letters: emnPpRrTt%
  # - currently used by Output::TermProgressBarColor: bB
  # - letters that can be used later: s (state)
  sub fill_template {
      my ($self, $template, %args) = @_;
  
      # TODO: some caching so "%e%e" produces two identical numbers
  
      state $re = qr{( # all=1
                         %
                         ( #width=2
                             -?\d+ )?
                         ( #dot=3
                             \.?)
                         ( #prec=4
                             \d+)?
                         ( #conv=5
                             [emnPpRrTt%])
                     )}x;
  
      state $sub = sub {
          my %args = @_;
  
          my ($all, $width, $dot, $prec, $conv) = ($1, $2, $3, $4, $5);
  
          my $p = $args{indicator};
  
          my ($fmt, $sconv, $data);
          if ($conv eq 'n') {
              $data = $p->{task};
          } elsif ($conv eq 't') {
              $data = $p->{title};
          } elsif ($conv eq '%') {
              $data = '%';
          } elsif ($conv eq 'm') {
              $data = $args{message} // '';
          } elsif ($conv eq 'p') {
              my $val = $p->percent_complete;
              $width //= 3;
              if (defined $val) {
                  $data = $val;
                  $prec //= 0;
                  $sconv = "f";
              } else {
                  $data = '?';
              }
          } elsif ($conv eq 'P') {
              $data = $p->total_pos;
              $prec //= 0;
              $sconv = "f";
          } elsif ($conv eq 'T') {
              my $val = $p->total_target;
              if (defined $val) {
                  $data = $val;
                  $prec //= 0;
                  $sconv = "f";
              } else {
                  $data = '?';
              }
          } elsif ($conv eq 'e') {
              my $val = $p->elapsed;
              $val = 1 if $val < 1; # TMP, prevent duration() return "just now"
              $data = Time::Duration::concise(Time::Duration::duration($val));
              $width //= -8;
          } elsif ($conv eq 'r') {
              my $val = $p->total_remaining;
              if (defined $val) {
                  $val = 1 if $val < 1; # TMP, prevent duration() return "just now
                  $data = Time::Duration::concise(Time::Duration::duration($val));
              } else {
                  $data = '?';
              }
              $width //= -8;
          } elsif ($conv eq 'R') {
              my $val = $p->total_remaining;
              if (defined $val) {
                  $val = 1 if $val < 1; # TMP, prevent duration() return "just now
                  $data = Time::Duration::concise(Time::Duration::duration($val)).
                      " left"; # XXX i18n
              } else {
                  $val = $p->elapsed;
                  $val = 1 if $val < 1; # TMP, prevent duration() return "just now
                  $data = Time::Duration::concise(Time::Duration::duration($val)).
                      " elapsed"; # XXX i18n
              }
              $width //= -(8 + 1 + 7);
          } else {
              # return as-is
              $fmt = '%s';
              $data = $all;
          }
  
          # sprintf format
          $sconv //= 's';
          $dot = "." if $sconv eq 'f';
          $fmt //= join("", grep {defined} ("%", $width, $dot, $prec, $sconv));
  
          #say "D:fmt=$fmt";
          sprintf $fmt, $data;
  
      };
      $template =~ s{$re}{$sub->(%args, indicator=>$self)}egox;
  
      $template;
  }
  
  1;
  # ABSTRACT: Record progress to any output
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Progress::Any - Record progress to any output
  
  =head1 VERSION
  
  This document describes version 0.20 of Progress::Any (from Perl distribution Progress-Any), released on 2015-01-27.
  
  =head1 SYNOPSIS
  
  =head2 First example, simple usage in a script
  
   use Progress::Any '$progress';
   use Progress::Any::Output 'TermProgressBarColor';
  
   $progress->target(10);
   for (1..10) {
       $progress->update(message => "Doing item $_");
       sleep 1;
   }
  
  Sample output:
  
   % ./script.pl
    60% [Doing item 6====           ]3s left
  
  =head2 Second example, usage in module as well as script
  
  In your module:
  
   package MyApp;
   use Progress::Any;
  
   sub download {
       my @urls = @_;
       return unless @urls;
       my $progress = Progress::Any->get_indicator(
           task => "download", pos=>0, target=>~~@urls);
       for my $url (@urls) {
           # download the $url ...
           $progress->update(message => "Downloaded $url");
       }
       $progress->finish;
   }
  
  In your application:
  
   use MyApp;
   use Progress::Any::Output;
   Progress::Any::Output->set('TermProgressBarColor');
  
   MyApp::download("url1", "url2", "url3", "url4", "url5");
  
  sample output, in succession:
  
   % ./script.pl
    20% [====== Downloaded url1           ]0m00s Left
    40% [=======Downloaded url2           ]0m01s Left
    60% [=======Downloaded url3           ]0m01s Left
    80% [=======Downloaded url4==         ]0m00s Left
  
  (At 100%, the output automatically cleans up the progress bar).
  
  =head3 Another example, demonstrating multiple indicators and the LogAny output:
  
   use Progress::Any;
   use Progress::Any::Output;
   use Log::Any::App;
  
   Progress::Any::Output->set('LogAny', template => '[%-8t] [%P/%2T] %m');
   my $pdl = Progress::Any->get_indicator(task => 'download');
   my $pcp = Progress::Any->get_indicator(task => 'copy');
  
   $pdl->pos(10);
   $pdl->target(10);
   $pdl->update(message => "downloading A");
   $pcp->update(message => "copying A");
   $pdl->update(message => "downloading B");
   $pcp->update(message => "copying B");
  
  will show something like:
  
   [download] [1/10] downloading A
   [copy    ] [1/ ?] copying A
   [download] [2/10] downloading B
   [copy    ] [2/ ?] copying B
  
  =head2 Example of using with Perinci::CmdLine
  
  If you use L<Perinci::CmdLine>, you can mark your function as expecting a
  Progress::Any object and it will be supplied to you in a special argument
  C<-progress>:
  
   use File::chdir;
   use Perinci::CmdLine;
   $SPEC{check_dir} = {
       v => 1.1,
       args => {
           dir => {summary=>"Path to check", schema=>"str*", req=>1, pos=>0},
       },
       features => {progress=>1},
   };
   sub check_dir {
       my %args = @_;
       my $progress = $args{-progress};
       my $dir = $args{dir};
       (-d $dir) or return [412, "No such dir: $dir"];
       local $CWD = $dir;
       opendir my($dh), $dir;
       my @ent = readdir($dh);
       $progress->pos(0);
       $progress->target(~~@ent);
       for (@ent) {
           # do the check ...
           $progress->update(message => $_);
           sleep 1;
       }
       $progress->finish;
       [200];
   }
   Perinci::CmdLine->new(url => '/main/check_dir')->run;
  
  =head1 DESCRIPTION
  
  C<Progress::Any> is an interface for applications that want to display progress
  to users. It decouples progress updating and output, rather similar to how
  L<Log::Any> decouples log producers and consumers (output). The API is also
  rather similar to Log::Any, except I<Adapter> is called I<Output> and
  I<category> is called I<task>.
  
  Progress::Any records position/target and calculates elapsed time, estimated
  remaining time, and percentage of completion. One or more output modules
  (Progress::Any::Output::*) display this information.
  
  In your modules, you typically only need to use Progress::Any, get one or more
  indicators, set target and update it during work. In your application, you use
  Progress::Any::Output and set/add one or more outputs to display the progress.
  By setting output only in the application and not in modules, you separate the
  formatting/display concern from the logic.
  
  Screenshots:
  
  =head1 STATUS
  
  API might still change, will be stabilized in 1.0.
  
  =begin HTML
  
  <p><img src="http://blogs.perl.org/users/perlancar/progany-tpc-sample.jpg" /><br />Using TermProgressBarColor output
  
  <p><img src="http://blogs.perl.org/users/perlancar/progany-dn-sample.jpg" /><br />Using DesktopNotify output
  
  =end HTML
  
  The list of features:
  
  =over 4
  
  =item * multiple progress indicators
  
  You can use different indicator for each task/subtask.
  
  =item * customizable output
  
  Output is handled by one of C<Progress::Any::Output::*> modules. Currently
  available outputs: C<Null> (no output), C<TermMessage> (display as simple
  message on terminal), C<TermProgressBarColor> (display as color progress bar on
  terminal), C<LogAny> (log using L<Log::Any>), C<Callback> (call a subroutine).
  Other possible output ideas: IM/Twitter/SMS, GUI, web/AJAX, remote/RPC (over
  L<Riap> for example, so that L<Perinci::CmdLine>-based command-line clients can
  display progress update from remote functions).
  
  =item * multiple outputs
  
  One or more outputs can be used to display one or more indicators.
  
  =item * hierarchical progress
  
  A task can be divided into subtasks. If a subtask is updated, its parent task
  (and its parent, and so on) are also updated proportionally.
  
  =item * message
  
  Aside from setting a number/percentage, allow including a message when updating
  indicator.
  
  =item * undefined target
  
  Target can be undefined, so a bar output might not show any bar (or show them,
  but without percentage indicator), but can still show messages.
  
  =item * retargetting
  
  Target can be changed in the middle of things.
  
  =back
  
  =head1 EXPORTS
  
  =head2 $progress => OBJ
  
  The root indicator. Equivalent to:
  
   Progress::Any->get_indicator(task => '')
  
  =head1 ATTRIBUTES
  
  Below are the attributes of an indicator/task:
  
  =head2 task => STR* (default: from caller's package, or C<main>)
  
  Task name. If not specified will be set to caller's package (C<::> will be
  replaced with C<.>), e.g. if you are calling this method from
  C<Foo::Bar::baz()>, then task will be set to C<Foo.Bar>. If caller is code
  inside eval, C<main> will be used instead.
  
  =head2 title => STR* (default: task name)
  
  Specify task title. Task title is a longer description for a task and can
  contain spaces and other characters. It is displayed in some outputs, as well as
  using C<%t> in C<fill_template()>. For example, for a task called C<copy>, its
  title might be C<Copying files to remote server>.
  
  =head2 target => POSNUM (default: 0)
  
  The total number of items to finish. Can be set to undef to mean that we don't
  know (yet) how many items there are to finish (in which case, we cannot estimate
  percent of completion and remaining time).
  
  =head2 pos => POSNUM* (default: 0)
  
  The number of items that are already done. It cannot be larger than C<target>,
  if C<target> is defined. If C<target> is set to a value smaller than C<pos> or
  C<pos> is set to a value larger than C<target>, C<pos> will be changed to be
  C<target>.
  
  =head2 state => STR (default: C<stopped>)
  
  State of task/indicator. Either: C<stopped>, C<started>, or C<finished>.
  Initially it will be set to C<stopped>, which means elapsed time won't be
  running and will stay at 0. C<update()> will set the state to C<started> to get
  elapsed time to run. At the end of task, you can call C<finish()> (or
  alternatively set C<state> to C<finished>) to stop the elapsed time again.
  
  The difference between C<stopped> and C<finished> is: when C<target> and C<pos>
  are both at 0, percent completed is assumed to be 0% when state is C<stopped>,
  but 100% when state is C<finished>.
  
  =head1 METHODS
  
  =head2 Progress::Any->get_indicator(%args) => OBJ
  
  Get a progress indicator for a certain task. C<%args> contain attribute values,
  at least C<task> must be specified.
  
  Note that this module maintains a list of indicator singleton objects for each
  task (in C<%indicators> package variable), so subsequent C<get_indicator()> for
  the same task will return the same object.
  
  =head2 $progress->update(%args)
  
  Update indicator. Will also, usually, update associated output(s) if necessary.
  
  Arguments:
  
  =over 4
  
  =item * pos => NUM
  
  Set the new position. If unspecified, defaults to current position + 1. If pos
  is larger than target, outputs will generally still show 100%. Note that
  fractions are allowed.
  
  =item * message => str|code
  
  Set a message to be displayed when updating indicator.
  
  Aside from a string, you can also pass a coderef here. It can be used to delay
  costly calculation. The message will only be calculated when actually sent to
  output.
  
  =item * level => NUM
  
  EXPERIMENTAL, NOT YET IMPLEMENTED BY MOST OUTPUTS. Setting the importance level
  of this update. Default is C<normal> (or C<low> for fractional update), but can
  be set to C<high> or C<low>. Output can choose to ignore updates lower than a
  certain level.
  
  =item * state => STR
  
  Can be set to C<finished> to finish a task.
  
  =back
  
  =head2 $progress->finish(%args)
  
  Equivalent to:
  
   $progress->update(
       ( pos => $progress->target ) x !!defined($progress->target),
       state => 'finished',
       %args,
   );
  
  =head2 $progress->start()
  
  Set state to C<started>.
  
  =head2 $progress->stop()
  
  Set state to C<stopped>.
  
  =head2 $progress->elapsed() => FLOAT
  
  Get elapsed time. Just like a stop-watch, when state is C<started> elapsed time
  will run and when state is C<stopped>, it will freeze.
  
  =head2 $progress->remaining() => undef|FLOAT
  
  Give estimated remaining time until task is finished, which will depend on how
  fast the C<update()> is called, i.e. how fast C<pos> is approaching C<target>.
  Will be undef if C<target> is undef.
  
  =head2 $progress->total_remaining() => undef|FLOAT
  
  Give estimated remaining time added by all its subtasks' remaining. Return undef
  if any one of those time is undef.
  
  =head2 $progress->total_pos() => FLOAT
  
  Total of indicator's pos and all of its subtasks'.
  
  =head2 $progress->total_target() => undef|FLOAT
  
  Total of indicator's target and all of its subtasks'. Return undef if any one of
  those is undef.
  
  =head2 $progress->percent_complete() => undef|FLOAT
  
  Give percentage of completion, calculated using C<< total_pos / total_target *
  100 >>. Undef if total_target is undef.
  
  =head2 $progress->fill_template($template)
  
  Fill template with values, like in C<sprintf()>. Usually used by output modules.
  Available templates:
  
  =over
  
  =item * C<%(width)n>
  
  Task name (the value of the C<task> attribute). C<width> is optional, an
  integer, like in C<sprintf()>, can be negative to mean left-justify instead of
  right.
  
  =item * C<%(width)t>
  
  Task title (the value of the C<title> attribute).
  
  =item * C<%(width)e>
  
  Elapsed time (the result from the C<elapsed()> method). Currently using
  L<Time::Duration> concise format, e.g. 10s, 1m40s, 16m40s, 1d4h, and so on.
  Format might be configurable and localizable in the future. Default width is -8.
  Examples:
  
   2m30s
   10s
  
  =item * C<%(width)r>
  
  Estimated remaining time (the result of the C<total_remaining()> method).
  Currently using L<Time::Duration> concise format, e.g. 10s, 1m40s, 16m40s, 1d4h,
  and so on. Will show C<?> if unknown. Format might be configurable and
  localizable in the future. Default width is -8. Examples:
  
   1m40s
   5s
  
  =item * C<%(width)R>
  
  Estimated remaining time I<or> elapsed time, if estimated remaining time is not
  calculatable (e.g. when target is undefined). Format might be configurable and
  localizable in the future. Default width is -(8+1+7). Examples:
  
   30s left
   1m40s elapsed
  
  =item * C<%(width).(prec)p>
  
  Percentage of completion (the result of the C<percent_complete()> method).
  C<width> and C<precision> are optional, like C<%f> in Perl's C<sprintf()>,
  default is C<%3.0p>. If percentage is unknown (due to target being undef), will
  show C<?>.
  
  =item * C<%(width)P>
  
  Current position (the result of the C<total_pos()> method).
  
  =item * C<%(width)T>
  
  Target (the result of the C<total_target()> method). If undefined, will show
  C<?>.
  
  =item * C<%m>
  
  Message (the C<update()> parameter). If message is unspecified, will show empty
  string.
  
  =item * C<%%>
  
  A literal C<%> sign.
  
  =back
  
  =head1 FAQ
  
  =head1 SEE ALSO
  
  Other progress modules on CPAN: L<Term::ProgressBar>,
  L<Term::ProgressBar::Simple>, L<Time::Progress>, among others.
  
  Output modules: C<Progress::Any::Output::*>
  
  See examples on how Progress::Any is used by other modules: L<Perinci::CmdLine>
  (supplying progress object to functions), L<Git::Bunch> (using progress object).
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Progress-Any>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Progress-Any>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Progress-Any>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PROGRESS_ANY

$fatpacked{"Progress/Any/Output.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PROGRESS_ANY_OUTPUT';
  package Progress::Any::Output;
  
  our $DATE = '2015-01-27'; # DATE
  our $VERSION = '0.20'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Progress::Any;
  
  sub import {
      my $self = shift;
      __PACKAGE__->set(@_) if @_;
  }
  
  sub _set_or_add {
      my $class = shift;
      my $which = shift;
  
      my $opts;
      if (@_ && ref($_[0]) eq 'HASH') {
          $opts = shift;
      } else {
          $opts = {};
      }
  
      my $output = shift or die "Please specify output name";
      $output =~ /\A(?:\w+(::\w+)*)?\z/ or die "Invalid output syntax '$output'";
  
      my $task = $opts->{task} // "";
  
      my $outputo;
      unless (ref $outputo) {
          my $outputpm = $output; $outputpm =~ s!::!/!g; $outputpm .= ".pm";
          require "Progress/Any/Output/$outputpm";
          no strict 'refs';
          $outputo = "Progress::Any::Output::$output"->new(@_);
      }
  
      if ($which eq 'set') {
          $Progress::Any::outputs{$task} = [$outputo];
      } else {
          $Progress::Any::outputs{$task} //= [];
          push @{ $Progress::Any::outputs{$task} }, $outputo;
      }
  
      $outputo;
  }
  
  sub set {
      my $class = shift;
      $class->_set_or_add('set', @_);
  }
  
  sub add {
      my $class = shift;
      $class->_set_or_add('add', @_);
  }
  
  1;
  # ABSTRACT: Assign output to progress indicators
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Progress::Any::Output - Assign output to progress indicators
  
  =head1 VERSION
  
  This document describes version 0.20 of Progress::Any::Output (from Perl distribution Progress-Any), released on 2015-01-27.
  
  =head1 SYNOPSIS
  
  In your application:
  
   use Progress::Any::Output;
   Progress::Any::Output->set('TermProgressBarColor');
  
  or:
  
   use Progress::Any::Output 'TermProgressBarColor';
  
  To give parameters to output:
  
   use Progress::Any::Output;
   Progress::Any::Output->set('TermProgressBarColor', width=>50, ...);
  
  or:
  
   use Progress::Any::Output 'TermProgressBarColor', width=>50, ...;
  
  To assign output to a certain (sub)task:
  
   use Progress::Any::Output;
   Progress::Any::Output->set({task=>'main.download'}, 'TermMessage');
  
  To add additional output, use C<add()> instead of C<set()>.
  
  =head1 DESCRIPTION
  
  See L<Progress::Any> for overview.
  
  =head1 METHODS
  
  =head2 Progress::Any::Output->set([ \%opts ], $output[, @args]) => obj
  
  Set (or replace) output. Will load and instantiate
  C<Progress::Any::Output::$output>. To only set output for a certain (sub)task,
  set C<%opts> to C<< { task => $task } >>. C<@args> will be passed to output
  module's constructor.
  
  Return the instantiated object.
  
  If C<$output> is an object (a reference, really), it will be used as-is.
  
  =head2 Progress::Any::Output->add([ \%opts ], $output[, @args])
  
  Like set(), but will add output instead of replace existing one(s).
  
  =head1 SEE ALSO
  
  L<Progress::Any>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Progress-Any>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Progress-Any>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Progress-Any>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PROGRESS_ANY_OUTPUT

$fatpacked{"Progress/Any/Output/Null.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PROGRESS_ANY_OUTPUT_NULL';
  package Progress::Any::Output::Null;
  
  use 5.010;
  use strict;
  use warnings;
  
  our $VERSION = '0.20'; # VERSION
  
  sub new {
      my ($class, %args) = @_;
      bless \%args, $class;
  }
  
  sub update {
      1;
  }
  
  1;
  # ABSTRACT: Null output
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Progress::Any::Output::Null - Null output
  
  =head1 VERSION
  
  This document describes version 0.20 of Progress::Any::Output::Null (from Perl distribution Progress-Any), released on 2015-01-27.
  
  =for Pod::Coverage ^(new|update)$
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Progress-Any>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Progress-Any>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Progress-Any>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PROGRESS_ANY_OUTPUT_NULL

$fatpacked{"Progress/Any/Output/TermProgressBarColor.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PROGRESS_ANY_OUTPUT_TERMPROGRESSBARCOLOR';
  package Progress::Any::Output::TermProgressBarColor;
  
  our $DATE = '2015-01-28'; # DATE
  our $VERSION = '0.18'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Color::ANSI::Util qw(ansifg ansibg);
  use Text::ANSI::Util qw(ta_mbtrunc ta_mbswidth ta_length);
  require Win32::Console::ANSI if $^O =~ /Win/;
  
  $|++;
  
  # patch handle
  my ($ph1, $ph2);
  
  sub _patch {
      my $out = shift;
  
      return if $ph1;
      require Monkey::Patch::Action;
      $ph1 = Monkey::Patch::Action::patch_package(
          'Log::Any::Adapter::ScreenColoredLevel', 'hook_before_log', 'replace',
          sub {
              $out->cleanup;
              $Progress::Any::output_data{"$out"}{force_update} = 1;
          }
      ) if defined &{"Log::Any::Adapter::ScreenColoredLevel::hook_before_log"};
      $ph2 = Monkey::Patch::Action::patch_package(
          'Log::Any::Adapter::ScreenColoredLevel', 'hook_after_log', 'replace',
          sub {
              my ($self, $msg) = @_;
              print { $self->{_fh} } "\n" unless $msg =~ /\R\z/;
              $out->keep_delay_showing if $out->{show_delay};
          }
      ) if defined &{"Log::Any::Adapter::ScreenColoredLevel::hook_after_log"};
  }
  
  sub _unpatch {
      undef $ph1;
      undef $ph2;
  }
  
  sub new {
      my ($class, %args0) = @_;
  
      my %args;
  
      $args{width} = delete($args0{width});
      if (!defined($args{width})) {
          my ($cols, $rows);
          if ($ENV{COLUMNS}) {
              $cols = $ENV{COLUMNS};
          } elsif (eval { require Term::Size; 1 }) {
              ($cols, $rows) = Term::Size::chars();
          } else {
              $cols = 80;
          }
          # on windows if we print at rightmost column, cursor will move to the
          # next line, so we try to avoid that
          $args{width} = $^O =~ /Win/ ? $cols-1 : $cols;
      }
  
      $args{fh} = delete($args0{fh});
      $args{fh} //= \*STDOUT;
  
      $args{show_delay} = delete($args0{show_delay});
  
      keys(%args0) and die "Unknown output parameter(s): ".
          join(", ", keys(%args0));
  
      $args{_last_hide_time} = time();
  
      my $self = bless \%args, $class;
      $self->_patch;
      $self;
  }
  
  sub update {
      my ($self, %args) = @_;
  
      my $now = time();
  
      # if there is show_delay, don't display until we've surpassed it
      if (defined $self->{show_delay}) {
          return if $now - $self->{show_delay} < $self->{_last_hide_time};
      }
  
      # "erase" previous display
      my $ll = $self->{_lastlen};
      if (defined $self->{_lastlen}) {
          print { $self->{fh} } "\b" x $self->{_lastlen};
          undef $self->{_lastlen};
      }
  
      my $p = $args{indicator};
      my $tottgt = $p->total_target;
      my $totpos = $p->total_pos;
      my $is_complete = $p->{state} eq 'finished' ||
          defined($tottgt) && $tottgt > 0 && $totpos == $tottgt;
      if ($is_complete) {
          if ($ll) {
              my $fh = $self->{fh};
              print $fh " " x $ll, "\b" x $ll;
              $self->{_last_hide_time} = $now;
          }
          return;
      }
  
      # XXX follow 'template'
      my $bar;
      my $bar_pct = $p->fill_template("%p%% ", %args);
  
      my $bar_eta = $p->fill_template("%R", %args);
  
      my $bar_bar = "";
      my $bwidth = $self->{width} - length($bar_pct) - length($bar_eta) - 2;
      if ($bwidth > 0) {
          if ($tottgt) {
              my $bfilled = int($totpos / $tottgt * $bwidth);
              $bfilled = $bwidth if $bfilled > $bwidth;
              $bar_bar = ("=" x $bfilled) . (" " x ($bwidth-$bfilled));
  
              my $message = $args{message};
          } else {
              # display 15% width of bar just moving right
              my $bfilled = int(0.15 * $bwidth);
              $bfilled = 1 if $bfilled < 1;
              $self->{_x}++;
              if ($self->{_x} > $bwidth-$bfilled) {
                  $self->{_x} = 0;
              }
              $bar_bar = (" " x $self->{_x}) . ("=" x $bfilled) .
                  (" " x ($bwidth-$self->{_x}-$bfilled));
          }
  
          my $msg = $args{message};
          if (defined $msg) {
              if ($msg =~ m!</elspan!) {
                  require String::Elide::Parts;
                  $msg = String::Elide::Parts::elide($msg, $bwidth);
              }
              $msg = ta_mbtrunc($msg, $bwidth);
              my $mwidth = ta_mbswidth($msg);
              $bar_bar = ansifg("808080") . $msg . ansifg("ff8000") .
                  substr($bar_bar, $mwidth);
          }
  
          $bar_bar = ansifg("ff8000") . $bar_bar;
      }
  
      $bar = join(
          "",
          ansifg("ffff00"), $bar_pct,
          "[$bar_bar]",
          ansifg("ffff00"), $bar_eta,
          "\e[0m",
      );
      print { $self->{fh} } $bar;
  
      $self->{_lastlen} = ta_length($bar);
  }
  
  sub cleanup {
      my ($self) = @_;
  
      # sometimes (e.g. when a subtask's target is undefined) we don't get
      # state=finished at the end. but we need to cleanup anyway at the end of
      # app, so this method is provided and will be called by e.g.
      # Perinci::CmdLine
  
      my $ll = $self->{_lastlen};
      return unless $ll;
      print { $self->{fh} } "\b" x $ll, " " x $ll, "\b" x $ll;
  }
  
  sub keep_delay_showing {
      my $self = shift;
  
      $self->{_last_hide_time} = time();
  }
  
  sub DESTROY {
      my $self = shift;
      $self->_unpatch;
  }
  
  1;
  # ABSTRACT: Output progress to terminal as color bar
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Progress::Any::Output::TermProgressBarColor - Output progress to terminal as color bar
  
  =head1 VERSION
  
  This document describes version 0.18 of Progress::Any::Output::TermProgressBarColor (from Perl distribution Progress-Any-Output-TermProgressBarColor), released on 2015-01-28.
  
  =head1 SYNOPSIS
  
   use Progress::Any::Output;
  
   # use default options
   Progress::Any::Output->set('TermProgressBarColor');
  
   # set options
   Progress::Any::Output->set('TermProgressBarColor',
                              width=>50, fh=>\*STDERR, show_delay=>5);
  
  =head1 DESCRIPTION
  
  B<THIS IS AN EARLY RELEASE, SOME THINGS ARE NOT YET IMPLEMENTED E.G. TEMPLATE,
  STYLES, COLOR THEMES>.
  
  Sample screenshots:
  
  =for Pod::Coverage ^(update|cleanup)$
  
  =for HTML <img src="http://blogs.perl.org/users/perlancar/progany-tpc-sample.jpg" />
  
  This output displays progress indicators as colored progress bar on terminal. It
  produces output similar to that produced by L<Term::ProgressBar>, except that it
  uses the L<Progress::Any> framework and has additional features:
  
  =over
  
  =item * colors and color themes
  
  =item * template and styles
  
  =item * wide character support
  
  =item * displaying message text in addition to bar/percentage number
  
  =back
  
  XXX option to cleanup when complete or not (like in Term::ProgressBar) and
  should default to 1.
  
  =head1 METHODS
  
  =head2 new(%args) => OBJ
  
  Instantiate. Usually called through C<<
  Progress::Any::Output->set("TermProgressBarColor", %args) >>.
  
  Known arguments:
  
  =over
  
  =item * width => INT
  
  Width of progress bar. The default is to detect terminal width and use the whole
  width.
  
  =item * color_theme => STR
  
  Not yet implemented.
  
  Choose color theme. To see what color themes are available, use
  C<list_color_themes()>.
  
  =item * style => STR
  
  Not yet implemented.
  
  Choose style. To see what styles are available, use C<list_styles()>. Styles
  determine the characters used for drawing the bar, alignment, etc.
  
  =item * template => STR (default: '%p [%B]%e')
  
  Not yet implemented.
  
  See B<fill_template> in Progress::Any's documentation. Aside from template
  strings supported by Progress::Any, this output recognizes these additional
  strings: C<%b> to display the progress bar (using the rest of the available
  width), C<%B> to display the progress bar as well as the message inside it.
  
  =item * fh => handle (default: \*STDOUT)
  
  Instead of the default STDOUT, you can direct the output to another filehandle.
  
  =item * show_delay => int
  
  If set, will delay showing the progress bar until the specified number of
  seconds. This can be used to create, e.g. a CLI application that is relatively
  not chatty but will display progress after several seconds of seeming inactivity
  to indicate users that the process is still going on.
  
  =back
  
  =head2 keep_delay_showing()
  
  Can be called to reset the timer that counts down to show progress bar when
  C<show_delay> is defined. For example, if C<show_delay> is 5 seconds and two
  seconds have passed, it should've been 3 seconds before progress bar is shown in
  the next C<update()>. However, if you call this method, it will be 5 seconds
  again before showing.
  
  =head1 ENVIRONMENT
  
  =head2 COLOR => BOOL
  
  Can be used to force or disable color.
  
  =head2 COLOR_DEPTH => INT
  
  Can be used to override color depth detection. See L<Color::ANSI::Util>.
  
  =head2 COLUMNS => INT
  
  Can be used to override terminal width detection.
  
  =head1 SEE ALSO
  
  L<Progress::Any>
  
  L<Term::ProgressBar>
  
  Ruby library: ruby-progressbar, L<https://github.com/jfelchner/ruby-progressbar>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Progress-Any-Output-TermProgressBarColor>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Progress-Any-Output-TermProgressBarColor>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Progress-Any-Output-TermProgressBarColor>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
PROGRESS_ANY_OUTPUT_TERMPROGRESSBARCOLOR

$fatpacked{"Regexp/Stringify.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_STRINGIFY';
  package Regexp::Stringify;
  
  our $DATE = '2015-01-08'; # DATE
  our $VERSION = '0.03'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use re qw(regexp_pattern);
  use Version::Util qw(version_ge);
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(stringify_regexp);
  
  our %SPEC;
  
  $SPEC{stringify_regexp} = {
      v => 1.1,
      summary => 'Stringify a Regexp object',
      description => <<'_',
  
  This routine is an alternative to Perl's default stringification of Regexp
  object (i.e.:`"$re"`) and has some features/options, e.g.: producing regexp
  string that is compatible with certain perl versions.
  
  If given a string (or other non-Regexp object), will return it as-is.
  
  _
      args => {
          regexp => {
              schema => 're*',
              req => 1,
              pos => 0,
          },
          plver => {
              summary => 'Target perl version',
              schema => 'str*',
              description => <<'_',
  
  Try to produce a regexp object compatible with a certain perl version (should at
  least be >= 5.10).
  
  For example, in perl 5.14 regex stringification changes, e.g. `qr/hlagh/i` would
  previously be stringified as `(?i-xsm:hlagh)`, but now it's stringified as
  `(?^i:hlagh)`. If you set `plver` to 5.10 or 5.12, then this routine will
  still produce the former. It will also ignore regexp modifiers that are
  introduced in newer perls.
  
  Note that not all regexp objects will be translated to older perls, e.g. if it
  contains constructs not known to older perls.
  
  _
          },
          with_qr => {
              schema  => 'bool',
              description => <<'_',
  
  If you set this to 1, then `qr/a/i` will be stringified as `'qr/a/i'` instead as
  `'(^i:a)'`. The resulting string can then be eval-ed to recreate the Regexp
  object.
  
  _
          },
      },
      result_naked => 1,
      result => {
          schema => 'str*',
      },
  };
  sub stringify_regexp {
      my %args = @_;
  
      my $re = $args{regexp};
      return $re unless ref($re) eq 'Regexp';
      my $plver = $args{plver} // $^V;
  
      my ($pat, $mod) = regexp_pattern($re);
  
      my $ge_5140 = version_ge($plver, 5.014);
      unless ($ge_5140) {
          $mod =~ s/[adlu]//g;
      }
  
      if ($args{with_qr}) {
          return "qr($pat)$mod";
      } else {
          if ($ge_5140) {
              return "(^$mod:$pat)";
          } else {
              return "(?:(?$mod-)$pat)";
          }
      }
  }
  
  1;
  # ABSTRACT: Stringify a Regexp object
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Regexp::Stringify - Stringify a Regexp object
  
  =head1 VERSION
  
  This document describes version 0.03 of Regexp::Stringify (from Perl distribution Regexp-Stringify), released on 2015-01-08.
  
  =head1 SYNOPSIS
  
  Assuming this runs on Perl 5.14 or newer.
  
   use Regexp::Stringify qw(stringify_regexp);
   $str = stringify_regexp(regexp=>qr/a/i);                       # '(^i:a)'
   $str = stringify_regexp(regexp=>qr/a/i, with_qr=>1);           # 'qr(a)i'
   $str = stringify_regexp(regexp=>qr/a/i, plver=>5.010);         # '(?:(?i-)a)'
   $str = stringify_regexp(regexp=>qr/a/ui, plver=>5.010);        # '(?:(?i-)a)'
  
  =head1 FUNCTIONS
  
  
  =head2 stringify_regexp(%args) -> str
  
  {en_US Stringify a Regexp object}.
  
  {en_US 
  This routine is an alternative to Perl's default stringification of Regexp
  object (i.e.:C<"$re">) and has some features/options, e.g.: producing regexp
  string that is compatible with certain perl versions.
  
  If given a string (or other non-Regexp object), will return it as-is.
  }
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<plver> => I<str>
  
  {en_US Target perl version}.
  
  {en_US 
  Try to produce a regexp object compatible with a certain perl version (should at
  least be >= 5.10).
  
  For example, in perl 5.14 regex stringification changes, e.g. C<qr/hlagh/i> would
  previously be stringified as C<(?i-xsm:hlagh)>, but now it's stringified as
  C<(?^i:hlagh)>. If you set C<plver> to 5.10 or 5.12, then this routine will
  still produce the former. It will also ignore regexp modifiers that are
  introduced in newer perls.
  
  Note that not all regexp objects will be translated to older perls, e.g. if it
  contains constructs not known to older perls.
  }
  
  =item * B<regexp>* => I<re>
  
  =item * B<with_qr> => I<bool>
  
  {en_US 
  If you set this to 1, then C<qr/a/i> will be stringified as C<'qr/a/i'> instead as
  C<'(^i:a)'>. The resulting string can then be eval-ed to recreate the Regexp
  object.
  }
  
  =back
  
  Return value:  (str)
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Regexp-Stringify>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Regexp-Stringify>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Regexp-Stringify>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
REGEXP_STRINGIFY

$fatpacked{"Regexp/Wildcards.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_WILDCARDS';
  package Regexp::Wildcards;
  
  use strict;
  use warnings;
  
  use Carp           qw<croak>;
  use Scalar::Util   qw<blessed>;
  use Text::Balanced qw<extract_bracketed>;
  
  =head1 NAME
  
  Regexp::Wildcards - Converts wildcard expressions to Perl regular expressions.
  
  =head1 VERSION
  
  Version 1.05
  
  =cut
  
  use vars qw<$VERSION>;
  BEGIN {
   $VERSION = '1.05';
  }
  
  =head1 SYNOPSIS
  
      use Regexp::Wildcards;
  
      my $rw = Regexp::Wildcards->new(type => 'unix');
  
      my $re;
      $re = $rw->convert('a{b?,c}*');          # Do it Unix shell style.
      $re = $rw->convert('a?,b*',   'win32');  # Do it Windows shell style.
      $re = $rw->convert('*{x,y}?', 'jokers'); # Process the jokers and
                                               # escape the rest.
      $re = $rw->convert('%a_c%',   'sql');    # Turn SQL wildcards into
                                               # regexps.
  
      $rw = Regexp::Wildcards->new(
       do      => [ qw<jokers brackets> ], # Do jokers and brackets.
       capture => [ qw<any greedy> ],      # Capture *'s greedily.
      );
  
      $rw->do(add => 'groups');            # Don't escape groups.
      $rw->capture(rem => [ qw<greedy> ]); # Actually we want non-greedy
                                           # matches.
      $re = $rw->convert('*a{,(b)?}?c*');  # '(.*?)a(?:|(b).).c(.*?)'
      $rw->capture();                      # No more captures.
  
  =head1 DESCRIPTION
  
  In many situations, users may want to specify patterns to match but don't need the full power of regexps.
  Wildcards make one of those sets of simplified rules.
  This module converts wildcard expressions to Perl regular expressions, so that you can use them for matching.
  
  It handles the C<*> and C<?> jokers, as well as Unix bracketed alternatives C<{,}>, but also C<%> and C<_> SQL wildcards.
  If required, it can also keep original C<(...)> groups or C<^> and C<$> anchors.
  Backspace (C<\>) is used as an escape character.
  
  Typesets that mimic the behaviour of Windows and Unix shells are also provided.
  
  =head1 METHODS
  
  =cut
  
  sub _check_self {
   croak 'First argument isn\'t a valid ' . __PACKAGE__ . ' object'
    unless blessed $_[0] and $_[0]->isa(__PACKAGE__);
  }
  
  my %types = (
   jokers   => [ qw<jokers> ],
   sql      => [ qw<sql> ],
   commas   => [ qw<commas> ],
   brackets => [ qw<brackets> ],
   unix     => [ qw<jokers brackets> ],
   win32    => [ qw<jokers commas> ],
  );
  $types{$_} = $types{win32} for qw<dos os2 MSWin32 cygwin>;
  $types{$_} = $types{unix}  for qw<linux
                                    darwin machten next
                                    aix irix hpux dgux dynixptx
                                    bsdos freebsd openbsd
                                    svr4 solaris sunos dec_osf
                                    sco_sv unicos unicosmk>;
  
  my %escapes = (
   jokers   => '?*',
   sql      => '_%',
   commas   => ',',
   brackets => '{},',
   groups   => '()',
   anchors  => '^$',
  );
  
  my %captures = (
   single   => sub { $_[1] ? '(.)' : '.' },
   any      => sub { $_[1] ? ($_[0]->{greedy} ? '(.*)'
                                              : '(.*?)')
                           : '.*' },
   brackets => sub { $_[1] ? '(' : '(?:'; },
   greedy   => undef,
  );
  
  sub _validate {
   my $self  = shift;
   _check_self $self;
   my $valid = shift;
   my $old   = shift;
   $old = { } unless defined $old;
  
   my %opts;
   if (@_ <= 1) {
    $opts{set} = defined $_[0] ? $_[0] : { };
   } elsif (@_ % 2) {
    croak 'Arguments must be passed as an unique scalar or as key => value pairs';
   } else {
    %opts = @_;
   }
  
   my %checked;
   for (qw<set add rem>) {
    my $opt = $opts{$_};
    next unless defined $opt;
  
    my $cb = {
     ''      => sub { +{ ($_[0] => 1) x (exists $valid->{$_[0]}) } },
     'ARRAY' => sub { +{ map { ($_ => 1) x (exists $valid->{$_}) } @{$_[0]} } },
     'HASH'  => sub { +{ map { ($_ => $_[0]->{$_}) x (exists $valid->{$_}) }
                          keys %{$_[0]} } }
    }->{ ref $opt };
    croak 'Wrong option set' unless $cb;
    $checked{$_} = $cb->($opt);
   }
  
   my $config = (exists $checked{set}) ? $checked{set} : $old;
   $config->{$_} = $checked{add}->{$_} for grep $checked{add}->{$_},
                                            keys %{$checked{add} || {}};
   delete $config->{$_}                for grep $checked{rem}->{$_},
                                            keys %{$checked{rem} || {}};
  
   $config;
  }
  
  sub _do {
   my $self = shift;
  
   my $config;
   $config->{do}      = $self->_validate(\%escapes, $self->{do}, @_);
   $config->{escape}  = '';
   $config->{escape} .= $escapes{$_} for keys %{$config->{do}};
   $config->{escape}  = quotemeta $config->{escape};
  
   $config;
  }
  
  sub do {
   my $self = shift;
   _check_self $self;
  
   my $config  = $self->_do(@_);
   $self->{$_} = $config->{$_} for keys %$config;
  
   $self;
  }
  
  sub _capture {
   my $self = shift;
  
   my $config;
   $config->{capture} = $self->_validate(\%captures, $self->{capture}, @_);
   $config->{greedy}  = delete $config->{capture}->{greedy};
   for (keys %captures) {
    $config->{'c_' . $_} = $captures{$_}->($config, $config->{capture}->{$_})
                                                 if $captures{$_}; # Skip 'greedy'
   }
  
   $config;
  }
  
  sub capture {
   my $self = shift;
   _check_self $self;
  
   my $config  = $self->_capture(@_);
   $self->{$_} = $config->{$_} for keys %$config;
  
   $self;
  }
  
  sub _type {
   my ($self, $type) = @_;
   $type = 'unix'     unless defined $type;
   croak 'Wrong type' unless exists $types{$type};
  
   my $config      = $self->_do($types{$type});
   $config->{type} = $type;
  
   $config;
  }
  
  sub type {
   my $self = shift;
   _check_self $self;
  
   my $config  = $self->_type(@_);
   $self->{$_} = $config->{$_} for keys %$config;
  
   $self;
  }
  
  sub new {
   my $class = shift;
   $class    = blessed($class) || $class || __PACKAGE__;
  
   croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
   my %args = @_;
  
   my $self = bless { }, $class;
  
   if (defined $args{do}) {
    $self->do($args{do});
   } else {
    $self->type($args{type});
   }
  
   $self->capture($args{capture});
  }
  
  =head2 C<new>
  
      my $rw = Regexp::Wildcards->new(do => $what, capture => $capture);
      my $rw = Regexp::Wildcards->new(type => $type, capture => $capture);
  
  Constructs a new L<Regexp::Wildcard> object.
  
  C<do> lists all features that should be enabled when converting wildcards to regexps.
  Refer to L</do> for details on what can be passed in C<$what>.
  
  The C<type> specifies a predefined set of C<do> features to use.
  See L</type> for details on which types are valid.
  The C<do> option overrides C<type>.
  
  C<capture> lists which atoms should be capturing.
  Refer to L</capture> for more details.
  
  =head2 C<do>
  
      $rw->do($what);
      $rw->do(set => $c1);
      $rw->do(add => $c2);
      $rw->do(rem => $c3);
  
  Specifies the list of metacharacters to convert or to prevent for escaping.
  They fit into six classes :
  
  =over 4
  
  =item *
  
  C<'jokers'>
  
  Converts C<?> to C<.> and C<*> to C<.*>.
  
      'a**\\*b??\\?c' ==> 'a.*\\*b..\\?c'
  
  =item *
  
  C<'sql'>
  
  Converts C<_> to C<.> and C<%> to C<.*>.
  
      'a%%\\%b__\\_c' ==> 'a.*\\%b..\\_c'
  
  =item *
  
  C<'commas'>
  
  Converts all C<,> to C<|> and puts the complete resulting regular expression inside C<(?: ... )>.
  
      'a,b{c,d},e' ==> '(?:a|b\\{c|d\\}|e)'
  
  =item *
  
  C<'brackets'>
  
  Converts all matching C<{ ... ,  ... }> brackets to C<(?: ... | ... )> alternations.
  If some brackets are unbalanced, it tries to substitute as many of them as possible, and then escape the remaining unmatched C<{> and C<}>.
  Commas outside of any bracket-delimited block are also escaped.
  
      'a,b{c,d},e'    ==> 'a\\,b(?:c|d)\\,e'
      '{a\\{b,c}d,e}' ==> '(?:a\\{b|c)d\\,e\\}'
      '{a{b,c\\}d,e}' ==> '\\{a\\{b\\,c\\}d\\,e\\}'
  
  =item *
  
  C<'groups'>
  
  Keeps the parenthesis C<( ... )> of the original string without escaping them.
  Currently, no check is done to ensure that the parenthesis are matching.
  
      'a(b(c))d\\(\\)' ==> (no change)
  
  =item *
  
  C<'anchors'>
  
  Prevents the I<beginning-of-line> C<^> and I<end-of-line> C<$> anchors to be escaped.
  Since C<[...]> character class are currently escaped, a C<^> will always be interpreted as I<beginning-of-line>.
  
      'a^b$c' ==> (no change)
  
  =back
  
  Each C<$c> can be any of :
  
  =over 4
  
  =item *
  
  A hash reference, with wanted metacharacter group names (described above) as keys and booleans as values ;
  
  =item *
  
  An array reference containing the list of wanted metacharacter classes ;
  
  =item *
  
  A plain scalar, when only one group is required.
  
  =back
  
  When C<set> is present, the classes given as its value replace the current object options.
  Then the C<add> classes are added, and the C<rem> classes removed.
  
  Passing a sole scalar C<$what> is equivalent as passing C<< set => $what >>.
  No argument means C<< set => [ ] >>.
  
      $rw->do(set => 'jokers');           # Only translate jokers.
      $rw->do('jokers');                  # Same.
      $rw->do(add => [ qw<sql commas> ]); # Translate also SQL and commas.
      $rw->do(rem => 'jokers');           # Specifying both 'sql' and
                                          # 'jokers' is useless.
      $rw->do();                          # Translate nothing.
  
  The C<do> method returns the L<Regexp::Wildcards> object.
  
  =head2 C<type>
  
      $rw->type($type);
  
  Notifies to convert the metacharacters that corresponds to the predefined type C<$type>.
  C<$type> can be any of :
  
  =over 4
  
  =item *
  
  C<'jokers'>, C<'sql'>, C<'commas'>, C<'brackets'>
  
  Singleton types that enable the corresponding C<do> classes.
  
  =item *
  
  C<'unix'>
  
  Covers typical Unix shell globbing features (effectively C<'jokers'> and C<'brackets'>).
  
  =item *
  
  C<$^O> values for common Unix systems
  
  Wrap to C<'unix'> (see L<perlport> for the list).
  
  =item *
  
  C<undef>
  
  Defaults to C<'unix'>.
  
  =item *
  
  C<'win32'>
  
  Covers typical Windows shell globbing features (effectively C<'jokers'> and C<'commas'>).
  
  =item *
  
  C<'dos'>, C<'os2'>, C<'MSWin32'>, C<'cygwin'>
  
  Wrap to C<'win32'>.
  
  =back
  
  In particular, you can usually pass C<$^O> as the C<$type> and get the corresponding shell behaviour.
  
      $rw->type('win32'); # Set type to win32.
      $rw->type($^O);     # Set type to unix on Unices and win32 on Windows
      $rw->type();        # Set type to unix.
  
  The C<type> method returns the L<Regexp::Wildcards> object.
  
  =head2 C<capture>
  
      $rw->capture($captures);
      $rw->capture(set => $c1);
      $rw->capture(add => $c2);
      $rw->capture(rem => $c3);
  
  Specifies the list of atoms to capture.
  This method works like L</do>, except that the classes are different :
  
  =over 4
  
  =item *
  
  C<'single'>
  
  Captures all unescaped I<"exactly one"> metacharacters, i.e. C<?> for wildcards or C<_> for SQL.
  
      'a???b\\??' ==> 'a(.)(.)(.)b\\?(.)'
      'a___b\\__' ==> 'a(.)(.)(.)b\\_(.)'
  
  =item *
  
  C<'any'>
  
  Captures all unescaped I<"any"> metacharacters, i.e. C<*> for wildcards or C<%> for SQL.
  
      'a***b\\**' ==> 'a(.*)b\\*(.*)'
      'a%%%b\\%%' ==> 'a(.*)b\\%(.*)'
  
  =item *
  
  C<'greedy'>
  
  When used in conjunction with C<'any'>, it makes the C<'any'> captures greedy (by default they are not).
  
      'a***b\\**' ==> 'a(.*?)b\\*(.*?)'
      'a%%%b\\%%' ==> 'a(.*?)b\\%(.*?)'
  
  =item *
  
  C<'brackets'>
  
  Capture matching C<{ ... , ... }> alternations.
  
      'a{b\\},\\{c}' ==> 'a(b\\}|\\{c)'
  
  =back
  
      $rw->capture(set => 'single');           # Only capture "exactly one"
                                               # metacharacters.
      $rw->capture('single');                  # Same.
      $rw->capture(add => [ qw<any greedy> ]); # Also greedily capture
                                               # "any" metacharacters.
      $rw->capture(rem => 'greedy');           # No more greed please.
      $rw->capture();                          # Capture nothing.
  
  The C<capture> method returns the L<Regexp::Wildcards> object.
  
  =head2 C<convert>
  
      my $rx = $rw->convert($wc);
      my $rx = $rw->convert($wc, $type);
  
  Converts the wildcard expression C<$wc> into a regular expression according to the options stored into the L<Regexp::Wildcards> object, or to C<$type> if it's supplied.
  It successively escapes all unprotected regexp special characters that doesn't hold any meaning for wildcards, then replace C<'jokers'>, C<'sql'> and C<'commas'> or C<'brackets'> (depending on the L</do> or L</type> options), all of this by applying the C<'capture'> rules specified in the constructor or by L</capture>.
  
  =cut
  
  sub convert {
   my ($self, $wc, $type) = @_;
   _check_self $self;
  
   my $config = (defined $type) ? $self->_type($type) : $self;
   return unless defined $wc;
  
   my $e = $config->{escape};
   # Escape :
   # - an even number of \ that doesn't protect a regexp/wildcard metachar
   # - an odd number of \ that doesn't protect a wildcard metachar
   $wc =~ s/
    (?<!\\)(
     (?:\\\\)*
     (?:
       [^\w\s\\$e]
      |
       \\
       (?: [^\W$e] | \s | $ )
     )
    )
   /\\$1/gx;
  
   my $do = $config->{do};
   $wc = $self->_jokers($wc) if $do->{jokers};
   $wc = $self->_sql($wc)    if $do->{sql};
   if ($do->{brackets}) {
    $wc = $self->_bracketed($wc);
   } elsif ($do->{commas} and $wc =~ /(?<!\\)(?:\\\\)*,/) {
    $wc = $self->{'c_brackets'} . $self->_commas($wc) . ')';
   }
  
   $wc
  }
  
  =head1 EXPORT
  
  An object module shouldn't export any function, and so does this one.
  
  =head1 DEPENDENCIES
  
  L<Carp> (core module since perl 5), L<Scalar::Util>, L<Text::Balanced> (since 5.7.3).
  
  =head1 CAVEATS
  
  This module does not implement the strange behaviours of Windows shell that result from the special handling of the three last characters (for the file extension).
  For example, Windows XP shell matches C<*a> like C<.*a>, C<*a?> like C<.*a.?>, C<*a??> like C<.*a.{0,2}> and so on.
  
  =head1 SEE ALSO
  
  L<Text::Glob>.
  
  =head1 AUTHOR
  
  Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
  
  You can contact me by mail or on C<irc.perl.org> (vincent).
  
  =head1 BUGS
  
  Please report any bugs or feature requests to C<bug-regexp-wildcards at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Regexp-Wildcards>.
  I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
  
  =head1 SUPPORT
  
  You can find documentation for this module with the perldoc command.
  
      perldoc Regexp::Wildcards
  
  Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Regexp-Wildcards>.
  
  =head1 COPYRIGHT & LICENSE
  
  Copyright 2007,2008,2009,2013 Vincent Pit, all rights reserved.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  =cut
  
  sub _extract ($) { extract_bracketed $_[0], '{',  qr/.*?(?<!\\)(?:\\\\)*(?={)/ }
  
  sub _jokers {
   my $self = shift;
   local $_ = $_[0];
  
   # substitute ? preceded by an even number of \
   my $s = $self->{c_single};
   s/(?<!\\)((?:\\\\)*)\?/$1$s/g;
   # substitute * preceded by an even number of \
   $s = $self->{c_any};
   s/(?<!\\)((?:\\\\)*)\*+/$1$s/g;
  
   $_
  }
  
  sub _sql {
   my $self = shift;
   local $_ = $_[0];
  
   # substitute _ preceded by an even number of \
   my $s = $self->{c_single};
   s/(?<!\\)((?:\\\\)*)_/$1$s/g;
   # substitute % preceded by an even number of \
   $s = $self->{c_any};
   s/(?<!\\)((?:\\\\)*)%+/$1$s/g;
  
   $_
  }
  
  sub _commas {
   local $_ = $_[1];
  
   # substitute , preceded by an even number of \
   s/(?<!\\)((?:\\\\)*),/$1|/g;
  
   $_
  }
  
  sub _brackets {
   my ($self, $rest) = @_;
  
   substr $rest, 0, 1, '';
   chop $rest;
  
   my ($re, $bracket, $prefix) = ('');
   while (do { ($bracket, $rest, $prefix) = _extract $rest; $bracket }) {
    $re .= $self->_commas($prefix) . $self->_brackets($bracket);
   }
   $re .= $self->_commas($rest);
  
   $self->{c_brackets} . $re . ')';
  }
  
  sub _bracketed {
   my ($self, $rest) = @_;
  
   my ($re, $bracket, $prefix) = ('');
   while (do { ($bracket, $rest, $prefix) = _extract $rest; $bracket }) {
    $re .= $prefix . $self->_brackets($bracket);
   }
   $re .= $rest;
  
   $re =~ s/(?<!\\)((?:\\\\)*[\{\},])/\\$1/g;
  
   $re;
  }
  
  1; # End of Regexp::Wildcards
REGEXP_WILDCARDS

$fatpacked{"Riap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'RIAP';
  package Riap;
  
  our $DATE = '2015-03-05'; # DATE
  our $VERSION = '1.2.3'; # VERSION
  
  1;
  # ABSTRACT: Rinci access protocol
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Riap - Rinci access protocol
  
  =head1 VERSION
  
  This document describes version 1.2.3 of Riap (from Perl distribution Riap), released on 2015-03-05.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Riap>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Riap>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Riap>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
RIAP

$fatpacked{"Rinci.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'RINCI';
  package Rinci;
  
  our $VERSION = '1.1.75'; # VERSION
  
  1;
  # ABSTRACT: Language-neutral metadata for your code
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Rinci - Language-neutral metadata for your code
  
  =head1 VERSION
  
  This document describes version 1.1.75 of Rinci (from Perl distribution Rinci), released on 2015-03-28.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Rinci>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Rinci>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Rinci>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
RINCI

$fatpacked{"Role/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ROLE_TINY';
  package Role::Tiny;
  
  sub _getglob { \*{$_[0]} }
  sub _getstash { \%{"$_[0]::"} }
  
  use strict;
  use warnings;
  
  our $VERSION = '2.000000';
  $VERSION = eval $VERSION;
  
  our %INFO;
  our %APPLIED_TO;
  our %COMPOSED;
  our %COMPOSITE_INFO;
  our @ON_ROLE_CREATE;
  
  # Module state workaround totally stolen from Zefram's Module::Runtime.
  
  BEGIN {
    *_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0};
    *_MRO_MODULE = "$]" < 5.010 ? sub(){"MRO/Compat.pm"} : sub(){"mro.pm"};
  }
  
  sub Role::Tiny::__GUARD__::DESTROY {
    delete $INC{$_[0]->[0]} if @{$_[0]};
  }
  
  sub _load_module {
    (my $proto = $_[0]) =~ s/::/\//g;
    $proto .= '.pm';
    return 1 if $INC{$proto};
    # can't just ->can('can') because a sub-package Foo::Bar::Baz
    # creates a 'Baz::' key in Foo::Bar's symbol table
    return 1 if grep !/::$/, keys %{_getstash($_[0])||{}};
    my $guard = _WORK_AROUND_BROKEN_MODULE_STATE
      && bless([ $proto ], 'Role::Tiny::__GUARD__');
    require $proto;
    pop @$guard if _WORK_AROUND_BROKEN_MODULE_STATE;
    return 1;
  }
  
  sub import {
    my $target = caller;
    my $me = shift;
    strict->import;
    warnings->import;
    return if $me->is_role($target); # already exported into this package
    $INFO{$target}{is_role} = 1;
    # get symbol table reference
    my $stash = _getstash($target);
    # install before/after/around subs
    foreach my $type (qw(before after around)) {
      *{_getglob "${target}::${type}"} = sub {
        require Class::Method::Modifiers;
        push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
        return;
      };
    }
    *{_getglob "${target}::requires"} = sub {
      push @{$INFO{$target}{requires}||=[]}, @_;
      return;
    };
    *{_getglob "${target}::with"} = sub {
      $me->apply_roles_to_package($target, @_);
      return;
    };
    # grab all *non-constant* (stash slot is not a scalarref) subs present
    # in the symbol table and store their refaddrs (no need to forcibly
    # inflate constant subs into real subs) with a map to the coderefs in
    # case of copying or re-use
    my @not_methods = (map { *$_{CODE}||() } grep !ref($_), values %$stash);
    @{$INFO{$target}{not_methods}={}}{@not_methods} = @not_methods;
    # a role does itself
    $APPLIED_TO{$target} = { $target => undef };
    $_->($target) for @ON_ROLE_CREATE;
  }
  
  sub role_application_steps {
    qw(_install_methods _check_requires _install_modifiers _copy_applied_list);
  }
  
  sub apply_single_role_to_package {
    my ($me, $to, $role) = @_;
  
    _load_module($role);
  
    die "This is apply_role_to_package" if ref($to);
    die "${role} is not a Role::Tiny" unless $me->is_role($role);
  
    foreach my $step ($me->role_application_steps) {
      $me->$step($to, $role);
    }
  }
  
  sub _copy_applied_list {
    my ($me, $to, $role) = @_;
    # copy our role list into the target's
    @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
  }
  
  sub apply_roles_to_object {
    my ($me, $object, @roles) = @_;
    die "No roles supplied!" unless @roles;
    my $class = ref($object);
    # on perl < 5.8.9, magic isn't copied to all ref copies. bless the parameter
    # directly, so at least the variable passed to us will get any magic applied
    bless($_[1], $me->create_class_with_roles($class, @roles));
  }
  
  my $role_suffix = 'A000';
  sub _composite_name {
    my ($me, $superclass, @roles) = @_;
  
    my $new_name = join(
      '__WITH__', $superclass, my $compose_name = join '__AND__', @roles
    );
  
    if (length($new_name) > 252) {
      $new_name = $COMPOSED{abbrev}{$new_name}
        ||= substr($new_name, 0, 250 - length $role_suffix).'__'.$role_suffix++;
    }
    return wantarray ? ($new_name, $compose_name) : $new_name;
  }
  
  sub create_class_with_roles {
    my ($me, $superclass, @roles) = @_;
  
    die "No roles supplied!" unless @roles;
  
    _load_module($superclass);
    {
      my %seen;
      $seen{$_}++ for @roles;
      if (my @dupes = grep $seen{$_} > 1, @roles) {
        die "Duplicated roles: ".join(', ', @dupes);
      }
    }
  
    my ($new_name, $compose_name) = $me->_composite_name($superclass, @roles);
  
    return $new_name if $COMPOSED{class}{$new_name};
  
    foreach my $role (@roles) {
      _load_module($role);
      die "${role} is not a Role::Tiny" unless $me->is_role($role);
    }
  
    require(_MRO_MODULE);
  
    my $composite_info = $me->_composite_info_for(@roles);
    my %conflicts = %{$composite_info->{conflicts}};
    if (keys %conflicts) {
      my $fail =
        join "\n",
          map {
            "Method name conflict for '$_' between roles "
            ."'".join(' and ', sort values %{$conflicts{$_}})."'"
            .", cannot apply these simultaneously to an object."
          } keys %conflicts;
      die $fail;
    }
  
    my @composable = map $me->_composable_package_for($_), reverse @roles;
  
    # some methods may not exist in the role, but get generated by
    # _composable_package_for (Moose accessors via Moo).  filter out anything
    # provided by the composable packages, excluding the subs we generated to
    # make modifiers work.
    my @requires = grep {
      my $method = $_;
      !grep $_->can($method) && !$COMPOSED{role}{$_}{modifiers_only}{$method},
        @composable
    } @{$composite_info->{requires}};
  
    $me->_check_requires(
      $superclass, $compose_name, \@requires
    );
  
    *{_getglob("${new_name}::ISA")} = [ @composable, $superclass ];
  
    @{$APPLIED_TO{$new_name}||={}}{
      map keys %{$APPLIED_TO{$_}}, @roles
    } = ();
  
    $COMPOSED{class}{$new_name} = 1;
    return $new_name;
  }
  
  # preserved for compat, and apply_roles_to_package calls it to allow an
  # updated Role::Tiny to use a non-updated Moo::Role
  
  sub apply_role_to_package { shift->apply_single_role_to_package(@_) }
  
  sub apply_roles_to_package {
    my ($me, $to, @roles) = @_;
  
    return $me->apply_role_to_package($to, $roles[0]) if @roles == 1;
  
    my %conflicts = %{$me->_composite_info_for(@roles)->{conflicts}};
    my @have = grep $to->can($_), keys %conflicts;
    delete @conflicts{@have};
  
    if (keys %conflicts) {
      my $fail =
        join "\n",
          map {
            "Due to a method name conflict between roles "
            ."'".join(' and ', sort values %{$conflicts{$_}})."'"
            .", the method '$_' must be implemented by '${to}'"
          } keys %conflicts;
      die $fail;
    }
  
    # conflicting methods are supposed to be treated as required by the
    # composed role. we don't have an actual composed role, but because
    # we know the target class already provides them, we can instead
    # pretend that the roles don't do for the duration of application.
    my @role_methods = map $me->_concrete_methods_of($_), @roles;
    # separate loops, since local ..., delete ... for ...; creates a scope
    local @{$_}{@have} for @role_methods;
    delete @{$_}{@have} for @role_methods;
  
    # the if guard here is essential since otherwise we accidentally create
    # a $INFO for something that isn't a Role::Tiny (or Moo::Role) because
    # autovivification hates us and wants us to die()
    if ($INFO{$to}) {
      delete $INFO{$to}{methods}; # reset since we're about to add methods
    }
  
    # backcompat: allow subclasses to use apply_single_role_to_package
    # to apply changes.  set a local var so ours does nothing.
    our %BACKCOMPAT_HACK;
    if($me ne __PACKAGE__
        and exists $BACKCOMPAT_HACK{$me} ? $BACKCOMPAT_HACK{$me} :
        $BACKCOMPAT_HACK{$me} =
          $me->can('role_application_steps')
            == \&role_application_steps
          && $me->can('apply_single_role_to_package')
            != \&apply_single_role_to_package
    ) {
      foreach my $role (@roles) {
        $me->apply_single_role_to_package($to, $role);
      }
    }
    else {
      foreach my $step ($me->role_application_steps) {
        foreach my $role (@roles) {
          $me->$step($to, $role);
        }
      }
    }
    $APPLIED_TO{$to}{join('|',@roles)} = 1;
  }
  
  sub _composite_info_for {
    my ($me, @roles) = @_;
    $COMPOSITE_INFO{join('|', sort @roles)} ||= do {
      foreach my $role (@roles) {
        _load_module($role);
      }
      my %methods;
      foreach my $role (@roles) {
        my $this_methods = $me->_concrete_methods_of($role);
        $methods{$_}{$this_methods->{$_}} = $role for keys %$this_methods;
      }
      my %requires;
      @requires{map @{$INFO{$_}{requires}||[]}, @roles} = ();
      delete $requires{$_} for keys %methods;
      delete $methods{$_} for grep keys(%{$methods{$_}}) == 1, keys %methods;
      +{ conflicts => \%methods, requires => [keys %requires] }
    };
  }
  
  sub _composable_package_for {
    my ($me, $role) = @_;
    my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role;
    return $composed_name if $COMPOSED{role}{$composed_name};
    $me->_install_methods($composed_name, $role);
    my $base_name = $composed_name.'::_BASE';
    # force stash to exist so ->can doesn't complain
    _getstash($base_name);
    # Not using _getglob, since setting @ISA via the typeglob breaks
    # inheritance on 5.10.0 if the stash has previously been accessed an
    # then a method called on the class (in that order!), which
    # ->_install_methods (with the help of ->_install_does) ends up doing.
    { no strict 'refs'; @{"${composed_name}::ISA"} = ( $base_name ); }
    my $modifiers = $INFO{$role}{modifiers}||[];
    my @mod_base;
    my @modifiers = grep !$composed_name->can($_),
      do { my %h; @h{map @{$_}[1..$#$_-1], @$modifiers} = (); keys %h };
    foreach my $modified (@modifiers) {
      push @mod_base, "sub ${modified} { shift->next::method(\@_) }";
    }
    my $e;
    {
      local $@;
      eval(my $code = join "\n", "package ${base_name};", @mod_base);
      $e = "Evaling failed: $@\nTrying to eval:\n${code}" if $@;
    }
    die $e if $e;
    $me->_install_modifiers($composed_name, $role);
    $COMPOSED{role}{$composed_name} = {
      modifiers_only => { map { $_ => 1 } @modifiers },
    };
    return $composed_name;
  }
  
  sub _check_requires {
    my ($me, $to, $name, $requires) = @_;
    return unless my @requires = @{$requires||$INFO{$name}{requires}||[]};
    if (my @requires_fail = grep !$to->can($_), @requires) {
      # role -> role, add to requires, role -> class, error out
      if (my $to_info = $INFO{$to}) {
        push @{$to_info->{requires}||=[]}, @requires_fail;
      } else {
        die "Can't apply ${name} to ${to} - missing ".join(', ', @requires_fail);
      }
    }
  }
  
  sub _concrete_methods_of {
    my ($me, $role) = @_;
    my $info = $INFO{$role};
    # grab role symbol table
    my $stash = _getstash($role);
    # reverse so our keys become the values (captured coderefs) in case
    # they got copied or re-used since
    my $not_methods = { reverse %{$info->{not_methods}||{}} };
    $info->{methods} ||= +{
      # grab all code entries that aren't in the not_methods list
      map {
        my $code = *{$stash->{$_}}{CODE};
        ( ! $code or exists $not_methods->{$code} ) ? () : ($_ => $code)
      } grep !ref($stash->{$_}), keys %$stash
    };
  }
  
  sub methods_provided_by {
    my ($me, $role) = @_;
    die "${role} is not a Role::Tiny" unless $me->is_role($role);
    (keys %{$me->_concrete_methods_of($role)}, @{$INFO{$role}->{requires}||[]});
  }
  
  sub _install_methods {
    my ($me, $to, $role) = @_;
  
    my $info = $INFO{$role};
  
    my $methods = $me->_concrete_methods_of($role);
  
    # grab target symbol table
    my $stash = _getstash($to);
  
    # determine already extant methods of target
    my %has_methods;
    @has_methods{grep
      +(ref($stash->{$_}) || *{$stash->{$_}}{CODE}),
      keys %$stash
    } = ();
  
    foreach my $i (grep !exists $has_methods{$_}, keys %$methods) {
      no warnings 'once';
      my $glob = _getglob "${to}::${i}";
      *$glob = $methods->{$i};
  
      # overloads using method names have the method stored in the scalar slot
      # and &overload::nil in the code slot.
      next
        unless $i =~ /^\(/
          && ((defined &overload::nil && $methods->{$i} == \&overload::nil)
              || (defined &overload::_nil && $methods->{$i} == \&overload::_nil));
  
      my $overload = ${ *{_getglob "${role}::${i}"}{SCALAR} };
      next
        unless defined $overload;
  
      *$glob = \$overload;
    }
  
    $me->_install_does($to);
  }
  
  sub _install_modifiers {
    my ($me, $to, $name) = @_;
    return unless my $modifiers = $INFO{$name}{modifiers};
    if (my $info = $INFO{$to}) {
      push @{$info->{modifiers}}, @{$modifiers||[]};
    } else {
      foreach my $modifier (@{$modifiers||[]}) {
        $me->_install_single_modifier($to, @$modifier);
      }
    }
  }
  
  my $vcheck_error;
  
  sub _install_single_modifier {
    my ($me, @args) = @_;
    defined($vcheck_error) or $vcheck_error = do {
      local $@;
      eval { Class::Method::Modifiers->VERSION(1.05); 1 }
        ? 0
        : $@
    };
    $vcheck_error and die $vcheck_error;
    Class::Method::Modifiers::install_modifier(@args);
  }
  
  my $FALLBACK = sub { 0 };
  sub _install_does {
    my ($me, $to) = @_;
  
    # only add does() method to classes
    return if $me->is_role($to);
  
    my $does = $me->can('does_role');
    # add does() only if they don't have one
    *{_getglob "${to}::does"} = $does unless $to->can('does');
  
    return
      if $to->can('DOES') and $to->can('DOES') != (UNIVERSAL->can('DOES') || 0);
  
    my $existing = $to->can('DOES') || $to->can('isa') || $FALLBACK;
    my $new_sub = sub {
      my ($proto, $role) = @_;
      $proto->$does($role) or $proto->$existing($role);
    };
    no warnings 'redefine';
    return *{_getglob "${to}::DOES"} = $new_sub;
  }
  
  sub does_role {
    my ($proto, $role) = @_;
    require(_MRO_MODULE);
    foreach my $class (@{mro::get_linear_isa(ref($proto)||$proto)}) {
      return 1 if exists $APPLIED_TO{$class}{$role};
    }
    return 0;
  }
  
  sub is_role {
    my ($me, $role) = @_;
    return !!($INFO{$role} && $INFO{$role}{is_role});
  }
  
  1;
  __END__
  
  =encoding utf-8
  
  =head1 NAME
  
  Role::Tiny - Roles. Like a nouvelle cuisine portion size slice of Moose.
  
  =head1 SYNOPSIS
  
   package Some::Role;
  
   use Role::Tiny;
  
   sub foo { ... }
  
   sub bar { ... }
  
   around baz => sub { ... }
  
   1;
  
  else where
  
   package Some::Class;
  
   use Role::Tiny::With;
  
   # bar gets imported, but not foo
   with 'Some::Role';
  
   sub foo { ... }
  
   # baz is wrapped in the around modifier by Class::Method::Modifiers
   sub baz { ... }
  
   1;
  
  If you wanted attributes as well, look at L<Moo::Role>.
  
  =head1 DESCRIPTION
  
  C<Role::Tiny> is a minimalist role composition tool.
  
  =head1 ROLE COMPOSITION
  
  Role composition can be thought of as much more clever and meaningful multiple
  inheritance.  The basics of this implementation of roles is:
  
  =over 2
  
  =item *
  
  If a method is already defined on a class, that method will not be composed in
  from the role.
  
  =item *
  
  If a method that the role L</requires> to be implemented is not implemented,
  role application will fail loudly.
  
  =back
  
  Unlike L<Class::C3>, where the B<last> class inherited from "wins," role
  composition is the other way around, where the class wins. If multiple roles
  are applied in a single call (single with statement), then if any of their
  provided methods clash, an exception is raised unless the class provides
  a method since this conflict indicates a potential problem.
  
  =head1 IMPORTED SUBROUTINES
  
  =head2 requires
  
   requires qw(foo bar);
  
  Declares a list of methods that must be defined to compose role.
  
  =head2 with
  
   with 'Some::Role1';
  
   with 'Some::Role1', 'Some::Role2';
  
  Composes another role into the current role (or class via L<Role::Tiny::With>).
  
  If you have conflicts and want to resolve them in favour of Some::Role1 you
  can instead write:
  
   with 'Some::Role1';
   with 'Some::Role2';
  
  If you have conflicts and want to resolve different conflicts in favour of
  different roles, please refactor your codebase.
  
  =head2 before
  
   before foo => sub { ... };
  
  See L<< Class::Method::Modifiers/before method(s) => sub { ... } >> for full
  documentation.
  
  Note that since you are not required to use method modifiers,
  L<Class::Method::Modifiers> is lazily loaded and we do not declare it as
  a dependency. If your L<Role::Tiny> role uses modifiers you must depend on
  both L<Class::Method::Modifiers> and L<Role::Tiny>.
  
  =head2 around
  
   around foo => sub { ... };
  
  See L<< Class::Method::Modifiers/around method(s) => sub { ... } >> for full
  documentation.
  
  Note that since you are not required to use method modifiers,
  L<Class::Method::Modifiers> is lazily loaded and we do not declare it as
  a dependency. If your L<Role::Tiny> role uses modifiers you must depend on
  both L<Class::Method::Modifiers> and L<Role::Tiny>.
  
  =head2 after
  
   after foo => sub { ... };
  
  See L<< Class::Method::Modifiers/after method(s) => sub { ... } >> for full
  documentation.
  
  Note that since you are not required to use method modifiers,
  L<Class::Method::Modifiers> is lazily loaded and we do not declare it as
  a dependency. If your L<Role::Tiny> role uses modifiers you must depend on
  both L<Class::Method::Modifiers> and L<Role::Tiny>.
  
  =head2 Strict and Warnings
  
  In addition to importing subroutines, using C<Role::Tiny> applies L<strict> and
  L<warnings> to the caller.
  
  =head1 SUBROUTINES
  
  =head2 does_role
  
   if (Role::Tiny::does_role($foo, 'Some::Role')) {
     ...
   }
  
  Returns true if class has been composed with role.
  
  This subroutine is also installed as ->does on any class a Role::Tiny is
  composed into unless that class already has an ->does method, so
  
    if ($foo->does('Some::Role')) {
      ...
    }
  
  will work for classes but to test a role, one must use ::does_role directly.
  
  Additionally, Role::Tiny will override the standard Perl C<DOES> method
  for your class. However, if C<any> class in your class' inheritance
  hierarchy provides C<DOES>, then Role::Tiny will not override it.
  
  =head1 METHODS
  
  =head2 apply_roles_to_package
  
   Role::Tiny->apply_roles_to_package(
     'Some::Package', 'Some::Role', 'Some::Other::Role'
   );
  
  Composes role with package.  See also L<Role::Tiny::With>.
  
  =head2 apply_roles_to_object
  
   Role::Tiny->apply_roles_to_object($foo, qw(Some::Role1 Some::Role2));
  
  Composes roles in order into object directly.  Object is reblessed into the
  resulting class.
  
  =head2 create_class_with_roles
  
   Role::Tiny->create_class_with_roles('Some::Base', qw(Some::Role1 Some::Role2));
  
  Creates a new class based on base, with the roles composed into it in order.
  New class is returned.
  
  =head2 is_role
  
   Role::Tiny->is_role('Some::Role1')
  
  Returns true if the given package is a role.
  
  =head1 CAVEATS
  
  =over 4
  
  =item * On perl 5.8.8 and earlier, applying a role to an object won't apply any
  overloads from the role to all copies of the object.
  
  =back
  
  =head1 SEE ALSO
  
  L<Role::Tiny> is the attribute-less subset of L<Moo::Role>; L<Moo::Role> is
  a meta-protocol-less subset of the king of role systems, L<Moose::Role>.
  
  Ovid's L<Role::Basic> provides roles with a similar scope, but without method
  modifiers, and having some extra usage restrictions.
  
  =head1 AUTHOR
  
  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
  
  =head1 CONTRIBUTORS
  
  dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
  
  frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com>
  
  hobbs - Andrew Rodland (cpan:ARODLAND) <arodland@cpan.org>
  
  jnap - John Napiorkowski (cpan:JJNAPIORK) <jjn1056@yahoo.com>
  
  ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
  
  chip - Chip Salzenberg (cpan:CHIPS) <chip@pobox.com>
  
  ajgb - Alex J. G. BurzyÅski (cpan:AJGB) <ajgb@cpan.org>
  
  doy - Jesse Luehrs (cpan:DOY) <doy at tozt dot net>
  
  perigrin - Chris Prather (cpan:PERIGRIN) <chris@prather.org>
  
  Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
  
  ilmari - Dagfinn Ilmari MannsÃ¥ker (cpan:ILMARI) <ilmari@ilmari.org>
  
  tobyink - Toby Inkster (cpan:TOBYINK) <tobyink@cpan.org>
  
  haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2010-2012 the Role::Tiny 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
ROLE_TINY

$fatpacked{"Role/Tiny/With.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ROLE_TINY_WITH';
  package Role::Tiny::With;
  
  use strict;
  use warnings;
  
  our $VERSION = '2.000000';
  $VERSION = eval $VERSION;
  
  use Role::Tiny ();
  
  use Exporter 'import';
  our @EXPORT = qw( with );
  
  sub with {
      my $target = caller;
      Role::Tiny->apply_roles_to_package($target, @_)
  }
  
  1;
  
  =head1 NAME
  
  Role::Tiny::With - Neat interface for consumers of Role::Tiny roles
  
  =head1 SYNOPSIS
  
   package Some::Class;
  
   use Role::Tiny::With;
  
   with 'Some::Role';
  
   # The role is now mixed in
  
  =head1 DESCRIPTION
  
  C<Role::Tiny> is a minimalist role composition tool.  C<Role::Tiny::With>
  provides a C<with> function to compose such roles.
  
  =head1 AUTHORS
  
  See L<Role::Tiny> for authors.
  
  =head1 COPYRIGHT AND LICENSE
  
  See L<Role::Tiny> for the copyright and license.
  
  =cut
  
  
ROLE_TINY_WITH

$fatpacked{"Sah/Schema/DefHash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SAH_SCHEMA_DEFHASH';
  package Sah::Schema::DefHash;
  
  use 5.010001;
  use strict;
  use warnings;
  
  our $VERSION = '1.0.9'; # VERSION
  our $DATE = '2015-04-02'; # DATE
  
  our %SCHEMAS;
  
  $SCHEMAS{defhash} = [hash => {
      # tmp
      _prop => {
          v => {},
          defhash_v => {},
          name => {},
          caption => {},
          summary => {},
          description => {},
          tags => {},
          default_lang => {},
          x => {},
      },
  
      keys => {
  
          v         => ['float*', default=>1],
  
          defhash_v => ['int*', default=>1],
  
          name      => [
              'str*',
              'clset&' => [
                  {
                      match             => qr/\A\w+\z/,
                      'match.err_level' => 'warn',
                      'match.err_msg'   => 'should be a word',
                  },
                  {
                      max_len             => 32,
                      'max_len.err_level' => 'warn',
                      'max_len.err_msg'   => 'should be short',
                  },
              ],
          ],
  
          caption   => [
              'str*',
          ],
  
          summary   => [
              'str',
              'clset&' => [
                  {
                      max_len             => 72,
                      'max_len.err_level' => 'warn',
                      'max_len.err_msg'   => 'should be short',
                  },
                  {
                      'match'           => qr/\n/,
                      'match.op'        => 'not',
                      'match.err_level' => 'warn',
                      'match.err_msg'   => 'should only be a single-line text',
                  },
              ],
          ],
  
          description => [
              'str',
          ],
  
          tags => [
              'array',
              of => [
                  'any*',
                  of => [
                      'str*',
                      'hash*', # XXX defhash, but this is circular
                  ],
              ],
          ],
  
          default_lang => [
              'str*', # XXX check format, e.g. 'en' or 'en_US'
          ],
  
          x => [
              'any',
          ],
      },
      'keys.restrict' => 0,
      'allowed_keys_re' => qr/\A\w+(\.\w+)*\z/,
  }];
  
  $SCHEMAS{defhash_v1} = [defhash => {
      keys => {
          defhash_v => ['int*', is=>1],
      },
  }];
  
  # XXX check known attributes (.alt, etc)
  # XXX check alt.XXX format (e.g. must be alt\.(lang\.\w+|env_lang\.\w+)
  # XXX *.alt.*.X should also be of the same type (e.g. description.alt.lang.foo
  
  1;
  # ABSTRACT: Sah schemas to validate DefHash
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Sah::Schema::DefHash - Sah schemas to validate DefHash
  
  =head1 VERSION
  
  This document describes version 1.0.9 of Sah::Schema::DefHash (from Perl distribution DefHash), released on 2015-04-02.
  
  =head1 SYNOPSIS
  
   # schemas are put in the %SCHEMAS package variable
  
  =head1 DESCRIPTION
  
  This module contains L<Sah> schemas to validate L<DefHash>.
  
  =head1 SCHEMAS
  
  =over
  
  =item * defhash
  
  =item * defhash_v1
  
  =back
  
  =head1 SEE ALSO
  
  L<Sah>, L<Data::Sah>
  
  L<DefHash>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/DefHash>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-DefHash>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=DefHash>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
SAH_SCHEMA_DEFHASH

$fatpacked{"Sah/Schema/Rinci.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SAH_SCHEMA_RINCI';
  package Sah::Schema::Rinci;
  
  our $DATE = '2015-03-28'; # DATE
  our $VERSION = '1.1.75'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  our %SCHEMAS;
  
  my %dh_props = (
      v => {},
      defhash_v => {},
      name => {},
      caption => {},
      summary => {},
      description => {},
      tags => {},
      default_lang => {},
      x => {},
  );
  
  $SCHEMAS{rinci} = [hash => {
      # tmp
      _ver => 1.1, # this has the effect of version checking
      _prop => {
          %dh_props,
  
          entity_v => {},
          entity_date => {},
          links => {
              _elem_prop => {
                  %dh_props,
  
                  url => {},
              },
          },
      },
  }];
  
  $SCHEMAS{rinci_function} = [hash => {
      # tmp
      _ver => 1.1,
      _prop => {
          %dh_props,
  
          # from common rinci metadata
          entity_v => {},
          entity_date => {},
          links => {},
  
          is_func => {},
          is_meth => {},
          is_class_meth => {},
          args => {
              _value_prop => {
                  %dh_props,
  
                  # common rinci metadata
                  links => {},
  
                  schema => {},
                  filters => {},
                  default => {},
                  req => {},
                  pos => {},
                  greedy => {},
                  partial => {},
                  stream => {},
                  is_password => {},
                  cmdline_aliases => {
                      _value_prop => {
                          summary => {},
                          description => {},
                          schema => {},
                          code => {},
                          is_flag => {},
                      },
                  },
                  cmdline_on_getopt => {},
                  cmdline_prompt => {},
                  completion => {},
                  element_completion => {},
                  cmdline_src => {},
                  meta => 'fix',
                  element_meta => 'fix',
                  deps => {
                      _keys => {
                          arg => {},
                          all => {},
                          any => {},
                          none => {},
                      },
                  },
              },
          },
          args_as => {},
          args_groups => {
              _elem_prop => {
                  %dh_props,
                  args => {},
                  rel => {},
              },
          },
          result => {
              _prop => {
                  %dh_props,
  
                  schema => {},
                  statuses => {
                      _value_prop => {
                          # from defhash
                          summary => {},
                          description => {},
                          schema => {},
                      },
                  },
                  partial => {},
                  stream => {},
              },
          },
          result_naked => {},
          examples => {
              _elem_prop => {
                  %dh_props,
  
                  args => {},
                  argv => {},
                  src => {},
                  src_plang => {},
                  status => {},
                  result => {},
                  test => {},
              },
          },
          features => {
              _keys => {
                  reverse => {},
                  tx => {},
                  dry_run => {},
                  pure => {},
                  immutable => {},
                  idempotent => {},
                  check_arg => {},
              },
          },
          deps => {
              _keys => {
                  all => {},
                  any => {},
                  none => {},
                  env => {},
                  prog => {},
                  pkg => {},
                  func => {},
                  code => {},
                  tmp_dir => {},
                  trash_dir => {},
              },
          },
      },
  }];
  $SCHEMAS{rinci_function}[1]{_prop}{args}{_value_prop}{meta} =
      $SCHEMAS{rinci_function}[1];
  $SCHEMAS{rinci_function}[1]{_prop}{args}{_value_prop}{element_meta} =
      $SCHEMAS{rinci_function}[1];
  
  # rinci_package
  # rinci_variable
  
  $SCHEMAS{rinci_resmeta} = [hash => {
      # tmp
      _ver => 1.1,
      _prop => {
          %dh_props,
  
          perm_err => {},
          func => {}, # XXX func.*
          cmdline => {}, # XXX cmdline.*
          logs => {},
          prev => {},
          results => {},
          part_start => {},
          part_len => {},
          len => {},
          stream => {},
      },
  }];
  
  # list of known special arguments: -dry_run, -action, -tx_action,
  # -res_part_start, -res_part_len, -arg_part_start, -arg_part_len
  
  1;
  # ABSTRACT: Sah schemas for Rinci metadata
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Sah::Schema::Rinci - Sah schemas for Rinci metadata
  
  =head1 VERSION
  
  This document describes version 1.1.75 of Sah::Schema::Rinci (from Perl distribution Rinci), released on 2015-03-28.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Rinci>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Rinci>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Rinci>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
SAH_SCHEMA_RINCI

$fatpacked{"Scalar/Util/Numeric/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SCALAR_UTIL_NUMERIC_PP';
  package Scalar::Util::Numeric::PP;
  
  our $DATE = '2015-04-12'; # DATE
  our $VERSION = '0.02'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(
                         isint
                         isnum
                         isnan
                         isinf
                         isneg
                         isfloat
                 );
  
  sub isint {
      local $_ = shift;
      return 0 unless defined;
      return 1 if /\A[+-]?(?:0|[1-9][0-9]*)\z/;
      0;
  }
  
  sub isnan($) {
      local $_ = shift;
      return 0 unless defined;
      return 1 if /\A\s*[+-]?nan\s*\z/i;
      0;
  }
  
  sub isinf($) {
      local $_ = shift;
      return 0 unless defined;
      return 1 if /\A\s*[+-]?inf(?:inity)?\s*\z/i;
      0;
  }
  
  sub isneg($) {
      local $_ = shift;
      return 0 unless defined;
      return 1 if /\A\s*-/;
      0;
  }
  
  sub isnum($) {
      local $_ = shift;
      return 0 unless defined;
      return 1 if isint($_);
      return 1 if isfloat($_);
      0;
  }
  
  sub isfloat($) {
      local $_ = shift;
      return 0 unless defined;
      return 1 if /\A[+-]?(?:0|[1-9][0-9]*)(\.[0-9]+)?([eE][+-]?[0-9]+)?\z/
          && $1 || $2;
      return 1 if isnan($_) || isinf($_);
      0;
  }
  
  1;
  # ABSTRACT: Pure-perl drop-in replacement/approximation of Scalar::Util::Numeric
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Scalar::Util::Numeric::PP - Pure-perl drop-in replacement/approximation of Scalar::Util::Numeric
  
  =head1 VERSION
  
  This document describes version 0.02 of Scalar::Util::Numeric::PP (from Perl distribution Scalar-Util-Numeric-PP), released on 2015-04-12.
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  This module is written mainly for the convenience of L<Data::Sah>, as a drop-in
  pure-perl replacement for the XS module L<Scalar::Util::Numeric>, in the case
  when Data::Sah needs to generate code that uses PP modules instead of XS ones.
  
  Not all functions from Scalar::Util::Numeric have been provided.
  
  =head1 FUNCTIONS
  
  =head2 isint
  
  =head2 isfloat
  
  =head2 isnum
  
  =head2 isneg
  
  =head2 isinf
  
  =head2 isnan
  
  =head1 SEE ALSO
  
  L<Data::Sah>
  
  L<Scalar::Util::Numeric>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Scalar-Util-Numeric-PP>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Scalar-Util-Numeric-PP>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Scalar-Util-Numeric-PP>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
SCALAR_UTIL_NUMERIC_PP

$fatpacked{"String/Elide/Parts.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_ELIDE_PARTS';
  package String::Elide::Parts;
  
  our $DATE = '2015-01-23'; # DATE
  our $VERSION = '0.01'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(elide);
  
  sub _elide_part {
      my ($str, $len, $marker, $truncate) = @_;
  
      my $len_marker = length($marker);
      if ($len <= $len_marker) {
          return substr($marker, 0, $len);
      }
  
      if ($truncate eq 'left') {
          return $marker . substr($str, length($str) - $len+$len_marker);
      } elsif ($truncate eq 'middle') {
          my $left  = substr($str, 0,
                             ($len-$len_marker)/2);
          my $right = substr($str,
                             length($str) - ($len-$len_marker-length($left)));
          return $left . $marker . $right;
      } elsif ($truncate eq 'ends') {
          if ($len <= 2*$len_marker) {
              return substr($marker . $marker, 0, $len);
          }
          return $marker . substr($str, (length($str)-$len)/2 + $len_marker,
                                  $len-2*$len_marker) . $marker;
      } else { # right
          return substr($str, 0, $len-$len_marker) . $marker;
      }
  }
  
  sub elide {
      my ($str, $len, $opts) = @_;
  
      $opts //= {};
      my $truncate  = $opts->{truncate} // 'right';
      my $marker = $opts->{marker} // '..';
  
      # split into parts by priority
      my @parts;
      my @parts_attrs;
      my $parts_len = 0;
      while ($str =~ m#<elspan([^>]*)>(.*?)</elspan>|(.*?)(?=<elspan)|(.*)#g) {
          if (defined $1) {
              next unless length $2;
              push @parts, $2;
              push @parts_attrs, $1;
          } elsif (defined $3) {
              next unless length $3;
              push @parts, $3;
              push @parts_attrs, undef;
          } elsif (defined $4) {
              next unless length $4;
              push @parts, $4;
              push @parts_attrs, undef;
          }
      }
      return "" unless @parts && $len > 0;
      for my $i (0..@parts-1) {
          $parts_len += length($parts[$i]);
          if (defined $parts_attrs[$i]) {
              my $attrs = {};
              $attrs->{truncate} = $1 // $2
                  if $parts_attrs[$i] =~ /\btruncate=(?:"([^"]*)"|(\S+))/;
              $attrs->{prio} = $1 // $2
                  if $parts_attrs[$i] =~ /\bprio(?:rity)?=(?:"([^"]*)"|(\S+))/;
              $parts_attrs[$i] = $attrs;
          } else {
              $parts_attrs[$i] = {prio=>1};
          }
      }
  
      #use DD; dd \@parts; dd \@parts_attrs;
  
      # used to flip and flop between eliding left and right end, used when
      # truncate is 'ends'
      my $flip = 0;
  
      # elide and truncate part by part until str is short enough
    PART:
      while (1) {
          if ($parts_len <= $len) {
              return join("", @parts);
          }
  
          # collect part indexes that have the largest priority
          my @indexes;
          my $highest_prio;
          for (@parts_attrs) {
              $highest_prio = $_->{prio} if !defined($highest_prio) ||
                  $highest_prio < $_->{prio};
          }
          for my $i (0..@parts_attrs-1) {
              push @indexes, $i if $parts_attrs[$i]{prio} == $highest_prio;
          }
  
          # pick which part (index) to elide
          my $index;
          if ($truncate eq 'left') {
              $index = $indexes[0];
          } elsif ($truncate eq 'middle') {
              $index = $indexes[@indexes/2];
          } elsif ($truncate eq 'ends') {
              $index = $flip++ % 2 ? $indexes[0] : $indexes[-1];
          } else { # right
              $index = $indexes[-1];
          }
  
          my $part_len = length($parts[$index]);
          if ($parts_len - $part_len >= $len) {
              # we need to fully eliminate this part then search for another part
              #say "D:eliminating part (prio=$highest_prio): <$parts[$index]>";
              $parts_len -= $part_len;
              splice @parts, $index, 1;
              splice @parts_attrs, $index, 1;
              next PART;
          }
  
          # we just need to elide this part and return the result
          #say "D:eliding part (prio=$highest_prio): <$parts[$index]>";
          $parts[$index] = _elide_part(
              $parts[$index],
              $part_len - ($parts_len-$len),
              $marker,
              $parts_attrs[$index]{truncate} // $truncate,
          );
          return join("", @parts);
  
      } # while 1
  }
  
  1;
  # ABSTRACT: Elide a string with multiple parts of different priorities
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  String::Elide::Parts - Elide a string with multiple parts of different priorities
  
  =head1 VERSION
  
  This document describes version 0.01 of String::Elide::Parts (from Perl distribution String-Elide-Parts), released on 2015-01-23.
  
  =head1 SYNOPSIS
  
   use String::Elide qw(elide);
  
   # single string with no parts
  
   my $text = "this is your brain";
   elide($text, 16);                       # -> "this is your ..."
   elide($text, 16, {truncate=>"left"});   # -> "...is your brain"
   elide($text, 16, {truncate=>"middle"}); # -> "this is... brain"
   elide($text, 16, {truncate=>"ends"});   # -> "... is your b..."
  
   elide($text, 16, {marker=>"--"});       # -> "this is your b--"
   elide($text, 16, {marker=>"--"});       # -> "this is your b--"
  
   # multipart strings: we want to elide URL first, then the Downloading text,
   # then the speed
  
   $text = "<elspan prio=2>Downloading</elspan> <elspan prio=3 truncate=middle>http://www.example.com/somefile</elspan> 320.0k/5.5M";
   elide($text, 56); # -> "Downloading http://www.example.com/somefile 320.0k/5.5M"
   elide($text, 55); # -> "Downloading http://www.example.com/somefile 320.0k/5.5M"
   elide($text, 50); # -> "Downloading http://www.e..com/somefile 320.0k/5.5M"
   elide($text, 45); # -> "Downloading http://ww..m/somefile 320.0k/5.5M"
   elide($text, 40); # -> "Downloading http://..omefile 320.0k/5.5M"
   elide($text, 35); # -> "Downloading http..efile 320.0k/5.5M"
   elide($text, 30); # -> "Downloading ht..le 320.0k/5.5M"
   elide($text, 25); # -> "Downloading . 320.0k/5.5M"
   elide($text, 24); # -> "Downloading  320.0k/5.5M"
   elide($text, 23); # -> "Download..  320.0k/5.5M"
   elide($text, 20); # -> "Downl..  320.0k/5.5M"
   elide($text, 15); # -> "..  320.0k/5.5M"
   elide($text, 13); # -> "  320.0k/5.5M"
   elide($text, 12); # -> "  320.0k/5.."
  
  =head1 DESCRIPTION
  
  String::Elide is similar to other string eliding modules, with one main
  difference: it accepts string marked with parts of different priorities. The
  goal is to retain more important information as much as possible when length is
  reduced.
  
  =head1 FUNCTIONS
  
  =head2 elide($str, $len[, \%opts]) => str
  
  Elide a string if length exceeds C<$len>.
  
  String can be marked with C<< <elspan prio=N truncate=T>...</elspan> >> so there
  can be multiple parts with different priorities and truncate direction. The
  default priority is 1. You can mark less important strings with higher priority
  to let it be elided first.
  
  Known options:
  
  =over
  
  =item * marker => str (default: '..')
  
  =item * truncate => 'left'|'middle'|'middle'|'ends' (default: 'right')
  
  =back
  
  =head1 SEE ALSO
  
  =head2 Similar elide modules
  
  L<Text::Elide> is simple, does not have many options, and elides at word
  boundaries.
  
  L<String::Truncate> has similar interface like String::Elide and has some
  options.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/String-Elide-Parts>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-String-Elide-Parts>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=String-Elide-Parts>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
STRING_ELIDE_PARTS

$fatpacked{"String/Indent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_INDENT';
  package String::Indent;
  
  our $DATE = '2015-03-06'; # DATE
  our $VERSION = '0.03'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         indent
                 );
  
  sub indent {
      my ($indent, $str, $opts) = @_;
      $opts //= {};
  
      my $ibl = $opts->{indent_blank_lines} // 1;
      my $fli = $opts->{first_line_indent} // $indent;
      my $sli = $opts->{subsequent_lines_indent} // $indent;
      #say "D:ibl=<$ibl>, fli=<$fli>, sli=<$sli>";
  
      my $i = 0;
      $str =~ s/^([^\r\n]?)/$i++; !$ibl && !$1 ? "$1" : $i==1 ? "$fli$1" : "$sli$1"/egm;
      $str;
  }
  
  1;
  # ABSTRACT: String indenting routines
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  String::Indent - String indenting routines
  
  =head1 VERSION
  
  This document describes version 0.03 of String::Indent (from Perl distribution String-Indent), released on 2015-03-06.
  
  =head1 FUNCTIONS
  
  =head2 indent($indent, $str, \%opts) => STR
  
  Indent every line in $str with $indent. Example:
  
   indent('  ', "one\ntwo\nthree") # "  one\n  two\n  three"
  
  %opts is optional. Known options:
  
  =over 4
  
  =item * indent_blank_lines => bool (default: 1)
  
  If set to false, does not indent blank lines (i.e., lines containing only zero
  or more whitespaces).
  
  =item * first_line_indent => str
  
  If set, then the first line will be set to this instead of the normal indent.
  
  =item * subsequent_lines_indent => str
  
  If set, then all lines but the first line will be set to this instead of the
  normal indent.
  
  =back
  
  =head1 SEE ALSO
  
  L<Indent::String>, L<String::Nudge>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/String-Indent>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-String-Indent>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=String-Indent>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
STRING_INDENT

$fatpacked{"String/LineNumber.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_LINENUMBER';
  package String::LineNumber;
  
  our $DATE = '2014-12-10'; # DATE
  our $VERSION = '0.01'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         linenum
                 );
  
  sub linenum {
      my ($str, $opts) = @_;
      $opts //= {};
      $opts->{width}      //= 4;
      $opts->{zeropad}    //= 0;
      $opts->{skip_empty} //= 1;
  
      my $i = 0;
      $str =~ s/^(([\t ]*\S)?.*)/
          sprintf(join("",
                       "%",
                       ($opts->{zeropad} && !($opts->{skip_empty}
                                                  && !defined($2)) ? "0" : ""),
                       $opts->{width}, "s",
                       "|%s"),
                  ++$i && $opts->{skip_empty} && !defined($2) ? "" : $i,
                  $1)/meg;
  
      $str;
  }
  
  1;
  # ABSTRACT: Give line number to each line of string
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  String::LineNumber - Give line number to each line of string
  
  =head1 VERSION
  
  This document describes version 0.01 of String::LineNumber (from Perl distribution String-LineNumber), released on 2014-12-10.
  
  =head1 FUNCTIONS
  
  =head2 linenum($str, \%opts) => STR
  
  Add line numbers. For example:
  
       1|line1
       2|line2
        |
       4|line4
  
  Known options:
  
  =over 4
  
  =item * width => INT (default: 4)
  
  =item * zeropad => BOOL (default: 0)
  
  If turned on, will output something like:
  
    0001|line1
    0002|line2
        |
    0004|line4
  
  =item * skip_empty => BOOL (default: 1)
  
  If set to false, keep printing line number even if line is empty:
  
       1|line1
       2|line2
       3|
       4|line4
  
  =back
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/String-LineNumber>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-String-LineNumber>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=String-LineNumber>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
STRING_LINENUMBER

$fatpacked{"String/PerlQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_PERLQUOTE';
  package String::PerlQuote;
  
  our $DATE = '2014-12-10'; # DATE
  our $VERSION = '0.01'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         single_quote
                         double_quote
                 );
  
  # BEGIN COPY PASTE FROM Data::Dump
  my %esc = (
      "\a" => "\\a",
      "\b" => "\\b",
      "\t" => "\\t",
      "\n" => "\\n",
      "\f" => "\\f",
      "\r" => "\\r",
      "\e" => "\\e",
  );
  
  # put a string value in double quotes
  sub double_quote {
    local($_) = $_[0];
    # If there are many '"' we might want to use qq() instead
    s/([\\\"\@\$])/\\$1/g;
    return qq("$_") unless /[^\040-\176]/;  # fast exit
  
    s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
  
    # no need for 3 digits in escape for these
    s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
  
    s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
    s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
  
    return qq("$_");
  }
  # END COPY PASTE FROM Data::Dump
  
  sub single_quote {
    local($_) = $_[0];
    s/([\\'])/\\$1/g;
    return qq('$_');
  }
  1;
  # ABSTRACT: Quote a string like Perl does
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  String::PerlQuote - Quote a string like Perl does
  
  =head1 VERSION
  
  This document describes version 0.01 of String::PerlQuote (from Perl distribution String-PerlQuote), released on 2014-12-10.
  
  =head1 FUNCTIONS
  
  =head2 double_quote($str) => STR
  
  Quote or encode C<$str> to the Perl double quote (C<">) literal representation
  of the string. Example:
  
   say double_quote("a");        # => "a"     (with the quotes)
   say double_quote("a\n");      # => "a\n"
   say double_quote('"');        # => "\""
   say double_quote('$foo');     # => "\$foo"
  
  This code is taken from C<quote()> in L<Data::Dump>. Maybe I didn't look more
  closely, but I couldn't a module that provides a function to do something like
  this. L<String::Escape>, for example, provides C<qqbackslash> but it does not
  escape C<$>.
  
  =head2 single_quote($str) => STR
  
  Like C<double_quote> but will produce a Perl single quote literal representation
  instead of the double quote ones. In single quotes, only literal backslash C<\>
  and single quote character C<'> are escaped, the rest are displayed as-is, so
  the result might span multiple lines or contain other non-printable characters.
  
   say single_quote("Mom's");    # => 'Mom\'s' (with the quotes)
   say single_quote("a\\");      # => 'a\\"
   say single_quote('"');        # => '"'
   say single_quote("\$foo");    # => '$foo'
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/String-PerlQuote>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-String-PerlQuote>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=String-PerlQuote>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
STRING_PERLQUOTE

$fatpacked{"String/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_SHELLQUOTE';
  # $Id: ShellQuote.pm,v 1.11 2010-06-11 20:08:57 roderick Exp $
  #
  # Copyright (c) 1997 Roderick Schertler.  All rights reserved.  This
  # program is free software; you can redistribute it and/or modify it
  # under the same terms as Perl itself.
  
  =head1 NAME
  
  String::ShellQuote - quote strings for passing through the shell
  
  =head1 SYNOPSIS
  
      $string = shell_quote @list;
      $string = shell_quote_best_effort @list;
      $string = shell_comment_quote $string;
  
  =head1 DESCRIPTION
  
  This module contains some functions which are useful for quoting strings
  which are going to pass through the shell or a shell-like object.
  
  =over
  
  =cut
  
  package String::ShellQuote;
  
  use strict;
  use vars qw($VERSION @ISA @EXPORT);
  
  require Exporter;
  
  $VERSION	= '1.04';
  @ISA		= qw(Exporter);
  @EXPORT		= qw(shell_quote shell_quote_best_effort shell_comment_quote);
  
  sub croak {
      require Carp;
      goto &Carp::croak;
  }
  
  sub _shell_quote_backend {
      my @in = @_;
      my @err = ();
  
      if (0) {
  	require RS::Handy;
  	print RS::Handy::data_dump(\@in);
      }
  
      return \@err, '' unless @in;
  
      my $ret = '';
      my $saw_non_equal = 0;
      foreach (@in) {
  	if (!defined $_ or $_ eq '') {
  	    $_ = "''";
  	    next;
  	}
  
  	if (s/\x00//g) {
  	    push @err, "No way to quote string containing null (\\000) bytes";
  	}
  
      	my $escape = 0;
  
  	# = needs quoting when it's the first element (or part of a
  	# series of such elements), as in command position it's a
  	# program-local environment setting
  
  	if (/=/) {
  	    if (!$saw_non_equal) {
  	    	$escape = 1;
  	    }
  	}
  	else {
  	    $saw_non_equal = 1;
  	}
  
  	if (m|[^\w!%+,\-./:=@^]|) {
  	    $escape = 1;
  	}
  
  	if ($escape
  		|| (!$saw_non_equal && /=/)) {
  
  	    # ' -> '\''
      	    s/'/'\\''/g;
  
  	    # make multiple ' in a row look simpler
  	    # '\'''\'''\'' -> '"'''"'
      	    s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;
  
  	    $_ = "'$_'";
  	    s/^''//;
  	    s/''$//;
  	}
      }
      continue {
  	$ret .= "$_ ";
      }
  
      chop $ret;
      return \@err, $ret;
  }
  
  =item B<shell_quote> [I<string>]...
  
  B<shell_quote> quotes strings so they can be passed through the shell.
  Each I<string> is quoted so that the shell will pass it along as a
  single argument and without further interpretation.  If no I<string>s
  are given an empty string is returned.
  
  If any I<string> can't be safely quoted B<shell_quote> will B<croak>.
  
  =cut
  
  sub shell_quote {
      my ($rerr, $s) = _shell_quote_backend @_;
  
      if (@$rerr) {
      	my %seen;
      	@$rerr = grep { !$seen{$_}++ } @$rerr;
  	my $s = join '', map { "shell_quote(): $_\n" } @$rerr;
  	chomp $s;
  	croak $s;
      }
      return $s;
  }
  
  =item B<shell_quote_best_effort> [I<string>]...
  
  This is like B<shell_quote>, excpet if the string can't be safely quoted
  it does the best it can and returns the result, instead of dying.
  
  =cut
  
  sub shell_quote_best_effort {
      my ($rerr, $s) = _shell_quote_backend @_;
  
      return $s;
  }
  
  =item B<shell_comment_quote> [I<string>]
  
  B<shell_comment_quote> quotes the I<string> so that it can safely be
  included in a shell-style comment (the current algorithm is that a sharp
  character is placed after any newlines in the string).
  
  This routine might be changed to accept multiple I<string> arguments
  in the future.  I haven't done this yet because I'm not sure if the
  I<string>s should be joined with blanks ($") or nothing ($,).  Cast
  your vote today!  Be sure to justify your answer.
  
  =cut
  
  sub shell_comment_quote {
      return '' unless @_;
      unless (@_ == 1) {
  	croak "Too many arguments to shell_comment_quote "
  	    	    . "(got " . @_ . " expected 1)";
      }
      local $_ = shift;
      s/\n/\n#/g;
      return $_;
  }
  
  1;
  
  __END__
  
  =back
  
  =head1 EXAMPLES
  
      $cmd = 'fuser 2>/dev/null ' . shell_quote @files;
      @pids = split ' ', `$cmd`;
  
      print CFG "# Configured by: ",
  		shell_comment_quote($ENV{LOGNAME}), "\n";
  
  =head1 BUGS
  
  Only Bourne shell quoting is supported.  I'd like to add other shells
  (particularly cmd.exe), but I'm not familiar with them.  It would be a
  big help if somebody supplied the details.
  
  =head1 AUTHOR
  
  Roderick Schertler <F<roderick@argon.org>>
  
  =head1 SEE ALSO
  
  perl(1).
  
  =cut
STRING_SHELLQUOTE

$fatpacked{"String/Trim/More.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_TRIM_MORE';
  package String::Trim::More;
  
  our $DATE = '2014-12-10'; # DATE
  our $VERSION = '0.02'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         ltrim
                         rtrim
                         trim
                         ltrim_lines
                         rtrim_lines
                         trim_lines
                         trim_blank_lines
  
                         ellipsis
                 );
  
  sub ltrim {
      my $str = shift;
      $str =~ s/\A\s+//s;
      $str;
  }
  
  sub rtrim {
      my $str = shift;
      $str =~ s/\s+\z//s;
      $str;
  }
  
  sub trim {
      my $str = shift;
      $str =~ s/\A\s+//s;
      $str =~ s/\s+\z//s;
      $str;
  }
  
  sub ltrim_lines {
      my $str = shift;
      $str =~ s/^[ \t]+//mg; # XXX other unicode non-newline spaces
      $str;
  }
  
  sub rtrim_lines {
      my $str = shift;
      $str =~ s/[ \t]+$//mg;
      $str;
  }
  
  sub trim_lines {
      my $str = shift;
      $str =~ s/^[ \t]+//mg;
      $str =~ s/[ \t]+$//mg;
      $str;
  }
  
  sub trim_blank_lines {
      local $_ = shift;
      return $_ unless defined;
      s/\A(?:\n\s*)+//;
      s/(?:\n\s*){2,}\z/\n/;
      $_;
  }
  
  sub ellipsis {
      my ($str, $maxlen, $ellipsis) = @_;
      $maxlen   //= 80;
      $ellipsis //= "...";
  
      if (length($str) <= $maxlen) {
          return $str;
      } else {
          return substr($str, 0, $maxlen-length($ellipsis)) . $ellipsis;
      }
  }
  
  1;
  # ABSTRACT: Various string trimming utilities
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  String::Trim::More - Various string trimming utilities
  
  =head1 VERSION
  
  This document describes version 0.02 of String::Trim::More (from Perl distribution String-Trim-More), released on 2014-12-10.
  
  =head1 DESCRIPTION
  
  This is an alternative to L<String::Trim> (and similar modules, see L</"SEE
  ALSO">). Instead of a single C<trim> function, this module provides several from
  which you can choose on, depending on your needs.
  
  =head1 FUNCTIONS
  
  =head2 ltrim($str) => STR
  
  Trim whitespaces (including newlines) at the beginning of string. Equivalent to:
  
   $str =~ s/\A\s+//s;
  
  =head2 ltrim_lines($str) => STR
  
  Trim whitespaces (not including newlines) at the beginning of each line of
  string. Equivalent to:
  
   $str =~ s/^\s+//mg;
  
  =head2 rtrim($str) => STR
  
  Trim whitespaces (including newlines) at the end of string. Equivalent to:
  
   $str =~ s/[ \t]+\z//s;
  
  =head2 rtrim_lines($str) => STR
  
  Trim whitespaces (not including newlines) at the end of each line of
  string. Equivalent to:
  
   $str =~ s/[ \t]+$//mg;
  
  =head2 trim($str) => STR
  
  ltrim + rtrim.
  
  =head2 trim_lines($str) => STR
  
  ltrim_lines + rtrim_lines.
  
  =head2 trim_blank_lines($str) => STR
  
  Trim blank lines at the beginning and the end. Won't trim blank lines in the
  middle. Blank lines include lines with only whitespaces in them.
  
  =head2 ellipsis($str[, $maxlen, $ellipsis]) => STR
  
  Return $str unmodified if $str's length is less than $maxlen (default 80).
  Otherwise cut $str to ($maxlen - length($ellipsis)) and append $ellipsis
  (default '...') at the end.
  
  =head1 SEE ALSO
  
  L<String::Trim>, L<Text::Trim>, L<String::Strip>, L<String::Util>.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/String-Trim-More>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-String-Trim-More>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=String-Trim-More>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by perlancar@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
STRING_TRIM_MORE

$fatpacked{"String/Wildcard/Bash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_WILDCARD_BASH';
  package String::Wildcard::Bash;
  
  use 5.010001;
  use strict;
  use warnings;
  
  our $VERSION = '0.02'; # VERSION
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         contains_wildcard
                 );
  
  # note: order is important here, brace encloses the other
  my $re1 =
      qr(
            # non-escaped brace expression, with at least one comma
            (?P<brace>
                (?<!\\)(?:\\\\)*\{
                (?:           \\\\ | \\\{ | \\\} | [^\\\{\}] )*
                (?:, (?:  \\\\ | \\\{ | \\\} | [^\\\{\}] )* )+
                (?<!\\)(?:\\\\)*\}
            )
        |
            # non-escaped brace expression, to catch * or ? or [...] inside so
            # they don't go to below pattern, because bash doesn't consider them
            # wildcards, e.g. '/{et?,us*}' expands to '/etc /usr', but '/{et?}'
            # doesn't expand at all to /etc.
            (?P<braceno>
                (?<!\\)(?:\\\\)*\{
                (?:           \\\\ | \\\{ | \\\} | [^\\\{\}] )*
                (?<!\\)(?:\\\\)*\}
            )
        |
            (?P<class>
                # non-empty, non-escaped character class
                (?<!\\)(?:\\\\)*\[
                (?:  \\\\ | \\\[ | \\\] | [^\\\[\]] )+
                (?<!\\)(?:\\\\)*\]
            )
        |
            (?P<joker>
                # non-escaped * and ?
                (?<!\\)(?:\\\\)*[*?]
            )
        )ox;
  
  sub contains_wildcard {
      my $str = shift;
  
      while ($str =~ /$re1/go) {
          my %m = %+;
          return 1 if $m{brace} || $m{class} || $m{joker};
      }
      0;
  }
  
  1;
  # ABSTRACT: Bash wildcard string routines
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  String::Wildcard::Bash - Bash wildcard string routines
  
  =head1 VERSION
  
  This document describes version 0.02 of String::Wildcard::Bash (from Perl distribution String-Wildcard-Bash), released on 2015-01-03.
  
  =head1 SYNOPSIS
  
      use String::Wildcard::Bash qw(contains_wildcard);
  
      say 1 if contains_wildcard(""));      # -> 0
      say 1 if contains_wildcard("ab*"));   # -> 1
      say 1 if contains_wildcard("ab\\*")); # -> 0
  
  =head1 DESCRIPTION
  
  =for Pod::Coverage ^(qqquote)$
  
  =head1 FUNCTIONS
  
  =head2 contains_wildcard($str) => bool
  
  Return true if C<$str> contains wildcard pattern. Wildcard patterns include C<*>
  (meaning zero or more characters), C<?> (exactly one character), C<[...]>
  (character class), C<{...,}> (brace expansion). Can handle escaped/backslash
  (e.g. C<foo\*> does not contain wildcard, it's C<foo> followed by a literal
  asterisk C<*>).
  
  Aside from wildcard, bash does other types of expansions/substitutions too, but
  these are not considered wildcard. These include tilde expansion (e.g. C<~>
  becomes C</home/alice>), parameter and variable expansion (e.g. C<$0> and
  C<$HOME>), arithmetic expression (e.g. C<$[1+2]>), history (C<!>), and so on.
  
  Although this module has 'Bash' in its name, this set of wildcards should be
  applicable to other Unix shells. Haven't checked completely though.
  
  =head1 SEE ALSO
  
  L<Regexp::Wildcards> to convert a string with wildcard pattern to equivalent
  regexp pattern. Can handle Unix wildcards as well as SQL and DOS/Win32. As of
  this writing (v1.05), it does not handle character class (C<[...]>) and
  interprets brace expansion differently than bash.
  
  Other C<String::Wildcard::*> modules.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/String-Wildcard-Bash>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-String-Wildcard-Bash>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=String-Wildcard-Bash>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
STRING_WILDCARD_BASH

$fatpacked{"Sub/Delete.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SUB_DELETE';
  use 5.008003;
  
  package Sub::Delete;
  
  $VERSION = '1.00002';
  @EXPORT = delete_sub;
  
use Exporter 5.57 'import';
  use constant point0 => 0+$] eq 5.01;
  
  # This sub must come before any lexical vars.
  sub strict_eval($) {
   local %^H if point0;
   local *@;
   use#
    strict 'vars';
   local $SIG{__WARN__} = sub {};
   eval shift
  }
  
  my %sigils = qw( SCALAR $  ARRAY @  HASH % );
  
  sub delete_sub {
  	my $sub = shift;
  	my($stashname, $key) = $sub =~ /(.*::)((?:(?!::).)*)\z/s
  		? ($1,$2) : (caller()."::", $sub);
  	exists +(my $stash = \%$stashname)->{$key} or return;
  	ref $stash->{$key} eq 'SCALAR' and  # perl5.10 constant
  		delete $stash->{$key}, return;
  	my $globname = "$stashname$key"; 
  	my $glob = *$globname; # autovivify the glob in case future perl
  	defined *$glob{CODE} or return;  # versions add new funny stuff
  	my $check_importedness
  	 = $stashname =~ /^(?:(?!\d)\w*(?:::\w*)*)\z/
  	   && $key    =~ /^(?!\d)\w+\z/;
  	my %imported_slots;
  	my $package;
  	if($check_importedness) {
  		$package = substr $stashname, 0, -2;
  		for (qw "SCALAR ARRAY HASH") {
  			defined *$glob{$_} or next;
  			$imported_slots{$_} = strict_eval
  			  "package $package; 0 && $sigils{$_}$key; 1"
  		}
  	}
          delete $stash->{$key};
  	keys %imported_slots == 1 and exists $imported_slots{SCALAR}
  	 and !$imported_slots{SCALAR} and Internals'SvREFCNT $$glob =>== 1
  	 and !defined *$glob{IO} and !defined *$glob{FORMAT}
  	 and return; # empty glob
  	my $newglob = \*$globname;
  	local *alias = *$newglob;
  	defined *$glob{$_} and (
  	 !$check_importedness || $imported_slots{$_}
  	  ? *$newglob
  	  : *alias
  	) = *$glob{$_}
  		for qw "SCALAR ARRAY HASH";
  	defined *$glob{$_} and *$newglob = *$glob{$_}
  		for qw "IO FORMAT";
  	return # nothing;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Sub::Delete - Perl module enabling one to delete subroutines
  
  =head1 VERSION
  
  1.00002
  
  =head1 SYNOPSIS
  
      use Sub::Delete;
      sub foo {}
      delete_sub 'foo';
      eval 'foo();1' or die; # dies
  
  =head1 DESCRIPTION
  
  This module provides one function, C<delete_sub>, that deletes the
  subroutine whose name is passed to it. (To load the module without
  importing the function, write S<C<use Sub::Delete();>>.)
  
  This does more than simply undefine
  the subroutine in the manner of C<undef &foo>, which leaves a stub that
  can trigger AUTOLOAD (and, consequently, won't work for deleting methods).
  The subroutine is completely obliterated from the
  symbol table (though there may be
  references to it elsewhere, including in compiled code).
  
  =head1 PREREQUISITES
  
  This module requires L<perl> 5.8.3 or higher.
  
  =head1 LIMITATIONS
  
  If you take a reference to a glob containing a subroutine, and then delete
  the subroutine with C<delete_sub>, you will find that the glob you 
  referenced still has a subroutine in it. This is because C<delete_sub>
  removes a glob, replaces it with another, and then copies the contents of
  the old glob into the new one, except for the C<CODE> slot. (This is nearly
  impossible to fix without breaking constant::lexical.)
  
  =head1 BUGS
  
  If you find any bugs, please report them to the author via e-mail.
  
  =head1 AUTHOR & COPYRIGHT
  
  Copyright (C) 2008-10 Father Chrysostomos (sprout at, um, cpan dot org)
  
  This program is free software; you may redistribute or modify it (or both)
  under the same terms as perl.
  
  =head1 SEE ALSO
  
  L<perltodo>, which has C<delete &sub> listed as a possible future feature
  
  L<Symbol::Glob> and L<Symbol::Util>, both of which predate this module (but
  I only discovered them recently), and which allow one to delete any
  arbitrary slot from a glob. Neither of them takes perl 5.10 constants
  into account, however. They also both differ from this module, in that a
  subroutine referenced in compiled code can no longer be called if deleted
  from its glob. The entire glob must be replaced (which this module does).
  
  =cut
SUB_DELETE

$fatpacked{"Sub/Install.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SUB_INSTALL';
  use strict;
  use warnings;
  package Sub::Install;
  # ABSTRACT: install subroutines into packages easily
  $Sub::Install::VERSION = '0.928';
  use Carp;
  use Scalar::Util ();
  
  #pod =head1 SYNOPSIS
  #pod
  #pod   use Sub::Install;
  #pod
  #pod   Sub::Install::install_sub({
  #pod     code => sub { ... },
  #pod     into => $package,
  #pod     as   => $subname
  #pod   });
  #pod
  #pod =head1 DESCRIPTION
  #pod
  #pod This module makes it easy to install subroutines into packages without the
  #pod unsightly mess of C<no strict> or typeglobs lying about where just anyone can
  #pod see them.
  #pod
  #pod =func install_sub
  #pod
  #pod   Sub::Install::install_sub({
  #pod    code => \&subroutine,
  #pod    into => "Finance::Shady",
  #pod    as   => 'launder',
  #pod   });
  #pod
  #pod This routine installs a given code reference into a package as a normal
  #pod subroutine.  The above is equivalent to:
  #pod
  #pod   no strict 'refs';
  #pod   *{"Finance::Shady" . '::' . "launder"} = \&subroutine;
  #pod
  #pod If C<into> is not given, the sub is installed into the calling package.
  #pod
  #pod If C<code> is not a code reference, it is looked for as an existing sub in the
  #pod package named in the C<from> parameter.  If C<from> is not given, it will look
  #pod in the calling package.
  #pod
  #pod If C<as> is not given, and if C<code> is a name, C<as> will default to C<code>.
  #pod If C<as> is not given, but if C<code> is a code ref, Sub::Install will try to
  #pod find the name of the given code ref and use that as C<as>.
  #pod
  #pod That means that this code:
  #pod
  #pod   Sub::Install::install_sub({
  #pod     code => 'twitch',
  #pod     from => 'Person::InPain',
  #pod     into => 'Person::Teenager',
  #pod     as   => 'dance',
  #pod   });
  #pod
  #pod is the same as:
  #pod
  #pod   package Person::Teenager;
  #pod
  #pod   Sub::Install::install_sub({
  #pod     code => Person::InPain->can('twitch'),
  #pod     as   => 'dance',
  #pod   });
  #pod
  #pod =func reinstall_sub
  #pod
  #pod This routine behaves exactly like C<L</install_sub>>, but does not emit a
  #pod warning if warnings are on and the destination is already defined.
  #pod
  #pod =cut
  
  sub _name_of_code {
    my ($code) = @_;
    require B;
    my $name = B::svref_2object($code)->GV->NAME;
    return $name unless $name =~ /\A__ANON__/;
    return;
  }
  
  # See also Params::Util, to which this code was donated.
  sub _CODELIKE {
    (Scalar::Util::reftype($_[0])||'') eq 'CODE'
    || Scalar::Util::blessed($_[0])
    && (overload::Method($_[0],'&{}') ? $_[0] : undef);
  }
  
  # do the heavy lifting
  sub _build_public_installer {
    my ($installer) = @_;
  
    sub {
      my ($arg) = @_;
      my ($calling_pkg) = caller(0);
  
      # I'd rather use ||= but I'm whoring for Devel::Cover.
      for (qw(into from)) { $arg->{$_} = $calling_pkg unless $arg->{$_} }
  
      # This is the only absolutely required argument, in many cases.
      Carp::croak "named argument 'code' is not optional" unless $arg->{code};
  
      if (_CODELIKE($arg->{code})) {
        $arg->{as} ||= _name_of_code($arg->{code});
      } else {
        Carp::croak
          "couldn't find subroutine named $arg->{code} in package $arg->{from}"
          unless my $code = $arg->{from}->can($arg->{code});
  
        $arg->{as}   = $arg->{code} unless $arg->{as};
        $arg->{code} = $code;
      }
  
      Carp::croak "couldn't determine name under which to install subroutine"
        unless $arg->{as};
  
      $installer->(@$arg{qw(into as code) });
    }
  }
  
  # do the ugly work
  
  my $_misc_warn_re;
  my $_redef_warn_re;
  BEGIN {
    $_misc_warn_re = qr/
      Prototype\ mismatch:\ sub\ .+?  |
      Constant subroutine .+? redefined
    /x;
    $_redef_warn_re = qr/Subroutine\ .+?\ redefined/x;
  }
  
  my $eow_re;
  BEGIN { $eow_re = qr/ at .+? line \d+\.\Z/ };
  
  sub _do_with_warn {
    my ($arg) = @_;
    my $code = delete $arg->{code};
    my $wants_code = sub {
      my $code = shift;
      sub {
        my $warn = $SIG{__WARN__} ? $SIG{__WARN__} : sub { warn @_ }; ## no critic
        local $SIG{__WARN__} = sub {
          my ($error) = @_;
          for (@{ $arg->{suppress} }) {
              return if $error =~ $_;
          }
          for (@{ $arg->{croak} }) {
            if (my ($base_error) = $error =~ /\A($_) $eow_re/x) {
              Carp::croak $base_error;
            }
          }
          for (@{ $arg->{carp} }) {
            if (my ($base_error) = $error =~ /\A($_) $eow_re/x) {
              return $warn->(Carp::shortmess $base_error);
            }
          }
          ($arg->{default} || $warn)->($error);
        };
        $code->(@_);
      };
    };
    return $wants_code->($code) if $code;
    return $wants_code;
  }
  
  sub _installer {
    sub {
      my ($pkg, $name, $code) = @_;
      no strict 'refs'; ## no critic ProhibitNoStrict
      *{"$pkg\::$name"} = $code;
      return $code;
    }
  }
  
  BEGIN {
    *_ignore_warnings = _do_with_warn({
      carp => [ $_misc_warn_re, $_redef_warn_re ]
    });
  
    *install_sub = _build_public_installer(_ignore_warnings(_installer));
  
    *_carp_warnings =  _do_with_warn({
      carp     => [ $_misc_warn_re ],
      suppress => [ $_redef_warn_re ],
    });
  
    *reinstall_sub = _build_public_installer(_carp_warnings(_installer));
  
    *_install_fatal = _do_with_warn({
      code     => _installer,
      croak    => [ $_redef_warn_re ],
    });
  }
  
  #pod =func install_installers
  #pod
  #pod This routine is provided to allow Sub::Install compatibility with
  #pod Sub::Installer.  It installs C<install_sub> and C<reinstall_sub> methods into
  #pod the package named by its argument.
  #pod
  #pod  Sub::Install::install_installers('Code::Builder'); # just for us, please
  #pod  Code::Builder->install_sub({ name => $code_ref });
  #pod
  #pod  Sub::Install::install_installers('UNIVERSAL'); # feeling lucky, punk?
  #pod  Anything::At::All->install_sub({ name => $code_ref });
  #pod
  #pod The installed installers are similar, but not identical, to those provided by
  #pod Sub::Installer.  They accept a single hash as an argument.  The key/value pairs
  #pod are used as the C<as> and C<code> parameters to the C<install_sub> routine
  #pod detailed above.  The package name on which the method is called is used as the
  #pod C<into> parameter.
  #pod
  #pod Unlike Sub::Installer's C<install_sub> will not eval strings into code, but
  #pod will look for named code in the calling package.
  #pod
  #pod =cut
  
  sub install_installers {
    my ($into) = @_;
  
    for my $method (qw(install_sub reinstall_sub)) {
      my $code = sub {
        my ($package, $subs) = @_;
        my ($caller) = caller(0);
        my $return;
        for (my ($name, $sub) = %$subs) {
          $return = Sub::Install->can($method)->({
            code => $sub,
            from => $caller,
            into => $package,
            as   => $name
          });
        }
        return $return;
      };
      install_sub({ code => $code, into => $into, as => $method });
    }
  }
  
  #pod =head1 EXPORTS
  #pod
  #pod Sub::Install exports C<install_sub> and C<reinstall_sub> only if they are
  #pod requested.
  #pod
  #pod =head2 exporter
  #pod
  #pod Sub::Install has a never-exported subroutine called C<exporter>, which is used
  #pod to implement its C<import> routine.  It takes a hashref of named arguments,
  #pod only one of which is currently recognize: C<exports>.  This must be an arrayref
  #pod of subroutines to offer for export.
  #pod
  #pod This routine is mainly for Sub::Install's own consumption.  Instead, consider
  #pod L<Sub::Exporter>.
  #pod
  #pod =cut
  
  sub exporter {
    my ($arg) = @_;
  
    my %is_exported = map { $_ => undef } @{ $arg->{exports} };
  
    sub {
      my $class = shift;
      my $target = caller;
      for (@_) {
        Carp::croak "'$_' is not exported by $class" if !exists $is_exported{$_};
        install_sub({ code => $_, from => $class, into => $target });
      }
    }
  }
  
  BEGIN { *import = exporter({ exports => [ qw(install_sub reinstall_sub) ] }); }
  
  #pod =head1 SEE ALSO
  #pod
  #pod =over
  #pod
  #pod =item L<Sub::Installer>
  #pod
  #pod This module is (obviously) a reaction to Damian Conway's Sub::Installer, which
  #pod does the same thing, but does it by getting its greasy fingers all over
  #pod UNIVERSAL.  I was really happy about the idea of making the installation of
  #pod coderefs less ugly, but I couldn't bring myself to replace the ugliness of
  #pod typeglobs and loosened strictures with the ugliness of UNIVERSAL methods.
  #pod
  #pod =item L<Sub::Exporter>
  #pod
  #pod This is a complete Exporter.pm replacement, built atop Sub::Install.
  #pod
  #pod =back
  #pod
  #pod =head1 EXTRA CREDITS
  #pod
  #pod Several of the tests are adapted from tests that shipped with Damian Conway's
  #pod Sub-Installer distribution.
  #pod
  #pod =cut
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Sub::Install - install subroutines into packages easily
  
  =head1 VERSION
  
  version 0.928
  
  =head1 SYNOPSIS
  
    use Sub::Install;
  
    Sub::Install::install_sub({
      code => sub { ... },
      into => $package,
      as   => $subname
    });
  
  =head1 DESCRIPTION
  
  This module makes it easy to install subroutines into packages without the
  unsightly mess of C<no strict> or typeglobs lying about where just anyone can
  see them.
  
  =head1 FUNCTIONS
  
  =head2 install_sub
  
    Sub::Install::install_sub({
     code => \&subroutine,
     into => "Finance::Shady",
     as   => 'launder',
    });
  
  This routine installs a given code reference into a package as a normal
  subroutine.  The above is equivalent to:
  
    no strict 'refs';
    *{"Finance::Shady" . '::' . "launder"} = \&subroutine;
  
  If C<into> is not given, the sub is installed into the calling package.
  
  If C<code> is not a code reference, it is looked for as an existing sub in the
  package named in the C<from> parameter.  If C<from> is not given, it will look
  in the calling package.
  
  If C<as> is not given, and if C<code> is a name, C<as> will default to C<code>.
  If C<as> is not given, but if C<code> is a code ref, Sub::Install will try to
  find the name of the given code ref and use that as C<as>.
  
  That means that this code:
  
    Sub::Install::install_sub({
      code => 'twitch',
      from => 'Person::InPain',
      into => 'Person::Teenager',
      as   => 'dance',
    });
  
  is the same as:
  
    package Person::Teenager;
  
    Sub::Install::install_sub({
      code => Person::InPain->can('twitch'),
      as   => 'dance',
    });
  
  =head2 reinstall_sub
  
  This routine behaves exactly like C<L</install_sub>>, but does not emit a
  warning if warnings are on and the destination is already defined.
  
  =head2 install_installers
  
  This routine is provided to allow Sub::Install compatibility with
  Sub::Installer.  It installs C<install_sub> and C<reinstall_sub> methods into
  the package named by its argument.
  
   Sub::Install::install_installers('Code::Builder'); # just for us, please
   Code::Builder->install_sub({ name => $code_ref });
  
   Sub::Install::install_installers('UNIVERSAL'); # feeling lucky, punk?
   Anything::At::All->install_sub({ name => $code_ref });
  
  The installed installers are similar, but not identical, to those provided by
  Sub::Installer.  They accept a single hash as an argument.  The key/value pairs
  are used as the C<as> and C<code> parameters to the C<install_sub> routine
  detailed above.  The package name on which the method is called is used as the
  C<into> parameter.
  
  Unlike Sub::Installer's C<install_sub> will not eval strings into code, but
  will look for named code in the calling package.
  
  =head1 EXPORTS
  
  Sub::Install exports C<install_sub> and C<reinstall_sub> only if they are
  requested.
  
  =head2 exporter
  
  Sub::Install has a never-exported subroutine called C<exporter>, which is used
  to implement its C<import> routine.  It takes a hashref of named arguments,
  only one of which is currently recognize: C<exports>.  This must be an arrayref
  of subroutines to offer for export.
  
  This routine is mainly for Sub::Install's own consumption.  Instead, consider
  L<Sub::Exporter>.
  
  =head1 SEE ALSO
  
  =over
  
  =item L<Sub::Installer>
  
  This module is (obviously) a reaction to Damian Conway's Sub::Installer, which
  does the same thing, but does it by getting its greasy fingers all over
  UNIVERSAL.  I was really happy about the idea of making the installation of
  coderefs less ugly, but I couldn't bring myself to replace the ugliness of
  typeglobs and loosened strictures with the ugliness of UNIVERSAL methods.
  
  =item L<Sub::Exporter>
  
  This is a complete Exporter.pm replacement, built atop Sub::Install.
  
  =back
  
  =head1 EXTRA CREDITS
  
  Several of the tests are adapted from tests that shipped with Damian Conway's
  Sub-Installer distribution.
  
  =head1 AUTHOR
  
  Ricardo SIGNES <rjbs@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2005 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
SUB_INSTALL

$fatpacked{"Term/ReadKey.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TERM_READKEY';
  package Term::ReadKey;
  
  =head1 NAME
  
  Term::ReadKey - A perl module for simple terminal control
  
  =head1 SYNOPSIS
  
      use Term::ReadKey;
      ReadMode 4; # Turn off controls keys
      while (not defined ($key = ReadKey(-1))) {
          # No key yet
      }
      print "Get key $key\n";
      ReadMode 0; # Reset tty mode before exiting
  
  =head1 DESCRIPTION
  
  Term::ReadKey is a compiled perl module dedicated to providing simple
  control over terminal driver modes (cbreak, raw, cooked, etc.,) support for
  non-blocking reads, if the architecture allows, and some generalized handy
  functions for working with terminals. One of the main goals is to have the
  functions as portable as possible, so you can just plug in "use
  Term::ReadKey" on any architecture and have a good likelihood of it working.
  
  Version 2.30.01:
  Added handling of arrows, page up/down, home/end, insert/delete keys 
  under Win32. These keys emit xterm-compatible sequences.
  Works with Term::ReadLine::Perl.
  
  =over 4
  
  =item ReadMode MODE [, Filehandle]
  
  Takes an integer argument or a string synonym (case insensitive), which
  can currently be one of the following values:
  
      INT   SYNONYM    DESCRIPTION
  
      0    'restore'   Restore original settings.
  
      1    'normal'    Change to what is commonly the default mode,
                       echo on, buffered, signals enabled, Xon/Xoff
                       possibly enabled, and 8-bit mode possibly disabled.
  
      2    'noecho'    Same as 1, just with echo off. Nice for
                       reading passwords.
  
      3    'cbreak'    Echo off, unbuffered, signals enabled, Xon/Xoff
                       possibly enabled, and 8-bit mode possibly enabled.
  
      4    'raw'       Echo off, unbuffered, signals disabled, Xon/Xoff
                       disabled, and 8-bit mode possibly disabled.
  
      5    'ultra-raw' Echo off, unbuffered, signals disabled, Xon/Xoff 
                       disabled, 8-bit mode enabled if parity permits,
                       and CR to CR/LF translation turned off. 
  
  
  These functions are automatically applied to the STDIN handle if no
  other handle is supplied. Modes 0 and 5 have some special properties
  worth mentioning: not only will mode 0 restore original settings, but it
  cause the next ReadMode call to save a new set of default settings. Mode
  5 is similar to mode 4, except no CR/LF translation is performed, and if
  possible, parity will be disabled (only if not being used by the terminal,
  however. It is no different from mode 4 under Windows.)
  
  If you just need to read a key at a time, then modes 3 or 4 are probably
  sufficient. Mode 4 is a tad more flexible, but needs a bit more work to
  control. If you use ReadMode 3, then you should install a SIGINT or END
  handler to reset the terminal (via ReadMode 0) if the user aborts the
  program via C<^C>. (For any mode, an END handler consisting of "ReadMode 0"
  is actually a good idea.)
  
  If you are executing another program that may be changing the terminal mode,
  you will either want to say
  
      ReadMode 1;             # same as ReadMode 'normal'
      system('someprogram');
      ReadMode 1;
  
  which resets the settings after the program has run, or:
  
      $somemode=1;
      ReadMode 0;             # same as ReadMode 'restore'
      system('someprogram');
      ReadMode 1;
  
  which records any changes the program may have made, before resetting the
  mode.
  
  =item ReadKey MODE [, Filehandle]
  
  Takes an integer argument, which can currently be one of the following 
  values:
  
      0    Perform a normal read using getc
      -1   Perform a non-blocked read
      >0	 Perform a timed read
  
  If the filehandle is not supplied, it will default to STDIN. If there is
  nothing waiting in the buffer during a non-blocked read, then undef will be
  returned.  In most situations, you will probably want to use C<ReadKey -1>.
  
  I<NOTE> that if the OS does not provide any known mechanism for non-blocking
  reads, then a C<ReadKey -1> can die with a fatal error. This will hopefully
  not be common.
  
  If MODE is greater then zero, then ReadKey will use it as a timeout value in
  seconds (fractional seconds are allowed), and won't return C<undef> until
  that time expires.
  
  I<NOTE>, again, that some OS's may not support this timeout behaviour.
  
  If MODE is less then zero, then this is treated as a timeout
  of zero, and thus will return immediately if no character is waiting. A MODE
  of zero, however, will act like a normal getc.
  
  I<NOTE>, there are currently some limitations with this call under Windows.
  It may be possible that non-blocking reads will fail when reading repeating
  keys from more then one console.
  
  
  =item ReadLine MODE [, Filehandle]
  
  Takes an integer argument, which can currently be one of the following 
  values:
  
      0    Perform a normal read using scalar(<FileHandle>)
      -1   Perform a non-blocked read
      >0	 Perform a timed read
  
  If there is nothing waiting in the buffer during a non-blocked read, then
  undef will be returned.
  
  I<NOTE>, that if the OS does not provide any known mechanism for
  non-blocking reads, then a C<ReadLine 1> can die with a fatal
  error. This will hopefully not be common.
  
  I<NOTE> that a non-blocking test is only performed for the first character
  in the line, not the entire line.  This call will probably B<not> do what
  you assume, especially with C<ReadMode> MODE values higher then 1. For
  example, pressing Space and then Backspace would appear to leave you
  where you started, but any timeouts would now be suspended.
  
  B<This call is currently not available under Windows>.
  
  =item GetTerminalSize [Filehandle]
  
  Returns either an empty array if this operation is unsupported, or a four
  element array containing: the width of the terminal in characters, the
  height of the terminal in character, the width in pixels, and the height in
  pixels. (The pixel size will only be valid in some environments.)
  
  I<NOTE>, under Windows, this function must be called with an B<output>
  filehandle, such as C<STDOUT>, or a handle opened to C<CONOUT$>.
  
  =item SetTerminalSize WIDTH,HEIGHT,XPIX,YPIX [, Filehandle]
  
  Return -1 on failure, 0 otherwise.
  
  I<NOTE> that this terminal size is only for B<informative> value, and
  changing the size via this mechanism will B<not> change the size of
  the screen. For example, XTerm uses a call like this when
  it resizes the screen. If any of the new measurements vary from the old, the
  OS will probably send a SIGWINCH signal to anything reading that tty or pty.
  
  B<This call does not work under Windows>.
  
  =item GetSpeeds [, Filehandle]
  
  Returns either an empty array if the operation is unsupported, or a two
  value array containing the terminal in and out speeds, in B<decimal>. E.g,
  an in speed of 9600 baud and an out speed of 4800 baud would be returned as
  (9600,4800). Note that currently the in and out speeds will always be
  identical in some OS's.
  
  B<No speeds are reported under Windows>.
  
  =item GetControlChars [, Filehandle]
  
  Returns an array containing key/value pairs suitable for a hash. The pairs
  consist of a key, the name of the control character/signal, and the value
  of that character, as a single character.
  
  B<This call does nothing under Windows>.
  
  Each key will be an entry from the following list:
  
  	DISCARD
  	DSUSPEND
  	EOF
  	EOL
  	EOL2
  	ERASE
  	ERASEWORD
  	INTERRUPT
  	KILL
  	MIN
  	QUIT
  	QUOTENEXT
  	REPRINT
  	START
  	STATUS
  	STOP
  	SUSPEND
  	SWITCH
  	TIME
  
  Thus, the following will always return the current interrupt character,
  regardless of platform.
  
  	%keys = GetControlChars;
  	$int = $keys{INTERRUPT};
  
  =item SetControlChars [, Filehandle]
  
  Takes an array containing key/value pairs, as a hash will produce. The pairs
  should consist of a key that is the name of a legal control
  character/signal, and the value should be either a single character, or a
  number in the range 0-255. SetControlChars will die with a runtime error if
  an invalid character name is passed or there is an error changing the
  settings. The list of valid names is easily available via
  
  	%cchars = GetControlChars();
  	@cnames = keys %cchars;
  
  B<This call does nothing under Windows>.
  
  =back
  
  =head1 AUTHOR
  
  Kenneth Albanowski <kjahds@kjahds.com>
  
  Currently maintained by Jonathan Stowe <jns@gellyfish.co.uk>
  
  =head1 SUPPORT
  
  The code is maintained at 
  
       https://github.com/jonathanstowe/TermReadKey
  
  Please feel free to fork and suggest patches.
  
  
  =head1 LICENSE
  
  Prior to the 2.31 release the license statement was:
  
   Copyright (C) 1994-1999 Kenneth Albanowski.
                  2001-2005 Jonathan Stowe and others
  
                   Unlimited distribution and/or modification is allowed as long as this
                    copyright notice remains intact.
  
  And was only stated in the README file.
  
  Because I believe the original author's intent was to be more open than the
  other commonly used licenses I would like to leave that in place. However if
  you or your lawyers require something with some more words you can optionally
  choose to license this under the standard Perl license:
  
        This module is free software; you can redistribute it and/or modify it
        under the terms of the Artistic License. For details, see the full
        text of the license in the file "Artistic" that should have been provided
        with the version of perl you are using.
  
        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.
  
  
  =cut
  
  use vars qw($VERSION);
  
  $VERSION = '2.32';
  
  require Exporter;
  require AutoLoader;
  require DynaLoader;
  use Carp;
  
  @ISA = qw(Exporter AutoLoader DynaLoader);
  
  # Items to export into callers namespace by default
  # (move infrequently used names to @EXPORT_OK below)
  
  @EXPORT = qw(
    ReadKey
    ReadMode
    ReadLine
    GetTerminalSize
    SetTerminalSize
    GetSpeed
    GetControlChars
    SetControlChars
  );
  
  @EXPORT_OK = qw();
  
  bootstrap Term::ReadKey;
  
  # Preloaded methods go here.  Autoload methods go after __END__, and are
  # processed by the autosplit program.
  
  # Should we use LINES and COLUMNS to try and get the terminal size?
  # Change this to zero if you have systems where these are commonly
  # set to erroneous values. (But if either are near zero, they won't be
  # used anyhow.)
  
  $UseEnv = 1;
  
  $CurrentMode = 0;
  
  %modes = (                            # lowercase is canonical
      original    => 0,
      restore     => 0,
      normal      => 1,
      noecho      => 2,
      cbreak      => 3,
      raw         => 4,
      'ultra-raw' => 5
  );
  
  sub ReadMode
  {
      my ($mode) = $modes{ lc $_[0] };  # lowercase is canonical
      my ($fh) = normalizehandle( ( @_ > 1 ? $_[1] : \*STDIN ) );
      if ( defined($mode) ) { $CurrentMode = $mode }
      elsif ( $_[0] =~ /^\d/ ) { $CurrentMode = $_[0] }
      else { croak("Unknown terminal mode `$_[0]'"); }
      SetReadMode($CurrentMode, $fh);
  }
  
  sub normalizehandle
  {
      my ($file) = @_;
  
      #	print "Handle = $file\n";
      if ( ref($file) ) { return $file; }    # Reference is fine
  
      #	if($file =~ /^\*/) { return $file; } # Type glob is good
      if ( ref( \$file ) eq 'GLOB' ) { return $file; }    # Glob is good
  
      #	print "Caller = ",(caller(1))[0],"\n";
      return \*{ ( ( caller(1) )[0] ) . "::$file" };
  }
  
  sub GetTerminalSize
  {
      my ($file) = normalizehandle( ( @_ > 1 ? $_[1] : \*STDOUT ) );
      my (@results) = ();
      my (@fail);
  
      if ( &termsizeoptions() & 1 )                       # VIO
      {
          @results = GetTermSizeVIO($file);
          push( @fail, "VIOGetMode call" );
      }
      elsif ( &termsizeoptions() & 2 )                    # GWINSZ
      {
          @results = GetTermSizeGWINSZ($file);
          push( @fail, "TIOCGWINSZ ioctl" );
      }
      elsif ( &termsizeoptions() & 4 )                    # GSIZE
      {
          @results = GetTermSizeGSIZE($file);
          push( @fail, "TIOCGSIZE ioctl" );
      }
      elsif ( &termsizeoptions() & 8 )                    # WIN32
      {
          @results = GetTermSizeWin32($file);
          push( @fail, "Win32 GetConsoleScreenBufferInfo call" );
      }
      else
      {
          @results = ();
      }
  
      if ( @results < 4 and $UseEnv )
      {
          my ($C) = defined( $ENV{COLUMNS} ) ? $ENV{COLUMNS} : 0;
          my ($L) = defined( $ENV{LINES} )   ? $ENV{LINES}   : 0;
          if ( ( $C >= 2 ) and ( $L >= 2 ) )
          {
              @results = ( $C + 0, $L + 0, 0, 0 );
          }
          push( @fail, "COLUMNS and LINES environment variables" );
      }
  
      if ( @results < 4 )
      {
          my ($prog) = "resize";
  
          # Workaround for Solaris path silliness
          if ( -f "/usr/openwin/bin/resize" ) {
              $prog = "/usr/openwin/bin/resize";
          }
  
          my ($resize) = scalar(`$prog 2>/dev/null`);
          if (
              defined $resize
              and (  $resize =~ /COLUMNS\s*=\s*(\d+)/
                  or $resize =~ /setenv\s+COLUMNS\s+'?(\d+)/ )
            )
          {
              $results[0] = $1;
              if (   $resize =~ /LINES\s*=\s*(\d+)/
                  or $resize =~ /setenv\s+LINES\s+'?(\d+)/ )
              {
                  $results[1] = $1;
                  @results[ 2, 3 ] = ( 0, 0 );
              }
              else
              {
                  @results = ();
              }
          }
          else
          {
              @results = ();
          }
          push( @fail, "resize program" );
      }
  
      if ( @results < 4 )
      {
          my ($prog) = "stty size";
  
          my ($stty) = scalar(`$prog 2>/dev/null`);
          if (
              defined $stty
              and (  $stty =~ /(\d+) (\d+)/ )
            )
          {
              $results[0] = $2;
  			$results[1] = $1;
  			@results[ 2, 3 ] = ( 0, 0 );
          }
          else
          {
              @results = ();
          }
          push( @fail, "stty program" );
      }
  
      if ( @results != 4 )
      {
          warn "Unable to get Terminal Size."
            . join( "", map( " The $_ didn't work.", @fail ) );
  	return undef;
      }
  
      @results;
  }
  
  if ( &blockoptions() & 1 )    # Use nodelay
  {
      if ( &blockoptions() & 2 )    #poll
      {
          eval <<'DONE';
  		sub ReadKey {
  		  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
                    if (defined $_[0] && $_[0] > 0) {
                      if ($_[0]) {
                        return undef if &pollfile($File,$_[0]) == 0;
                      }
  		  }
                    if (defined $_[0] && $_[0] < 0) {
                       &setnodelay($File,1);
                    }
                    my ($value) = getc $File;
                    if (defined $_[0] && $_[0] < 0) {
                       &setnodelay($File,0);
                    }
                    $value;
  		}
  		sub ReadLine {
  		  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  
                    if (defined $_[0] && $_[0] > 0) {
                       if ($_[0]) {
                         return undef if &pollfile($File,$_[0]) == 0;
                       }
  		  }
                    if (defined $_[0] && $_[0] < 0) {
                       &setnodelay($File,1)
                    };
                    my ($value) = scalar(<$File>);
                    if ( defined $_[0] && $_[0]<0 ) {
                      &setnodelay($File,0)
                    };
                    $value;
  		}
  DONE
      }
      elsif ( &blockoptions() & 4 )    #select
      {
          eval <<'DONE';
  		sub ReadKey {
  		  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
                    if(defined $_[0] && $_[0]>0) {
  				if($_[0]) {return undef if &selectfile($File,$_[0])==0}
  		    }
  			if(defined $_[0] && $_[0]<0) {&setnodelay($File,1);}
  			my($value) = getc $File;
  			if(defined $_[0] && $_[0]<0) {&setnodelay($File,0);}
  			$value;
  		}
  		sub ReadLine {
  		  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  		    if(defined $_[0] && $_[0]>0) {
  				if($_[0]) {return undef if &selectfile($File,$_[0])==0}
  		    }
  			if(defined $_[0] && $_[0]<0) {&setnodelay($File,1)};
  			my($value)=scalar(<$File>);
  			if(defined $_[0] && $_[0]<0) {&setnodelay($File,0)};
  			$value;
  		}
  DONE
      }
      else
      {    #nothing
          eval <<'DONE';
  		sub ReadKey {
  		  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  		    if(defined $_[0] && $_[0]>0) {
  		    	# Nothing better seems to exist, so I just use time-of-day
  		    	# to timeout the read. This isn't very exact, though.
  		    	$starttime=time;
  		    	$endtime=$starttime+$_[0];
  				&setnodelay($File,1);
  				my($value)=undef;
  		    	while(time<$endtime) { # This won't catch wraparound!
  		    		$value = getc $File;
  		    		last if defined($value);
  		    	}
  				&setnodelay($File,0);
  				return $value;
  		    }
  			if(defined $_[0] && $_[0]<0) {&setnodelay($File,1);}
  			my($value) = getc $File;
  			if(defined $_[0] && $_[0]<0) {&setnodelay($File,0);}
  			$value;
  		}
  		sub ReadLine {
  		  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  		    if(defined $_[0] && $_[0]>0) {
  		    	# Nothing better seems to exist, so I just use time-of-day
  		    	# to timeout the read. This isn't very exact, though.
  		    	$starttime=time;
  		    	$endtime=$starttime+$_[0];
  				&setnodelay($File,1);
  				my($value)=undef;
  		    	while(time<$endtime) { # This won't catch wraparound!
  		    		$value = scalar(<$File>);
  		    		last if defined($value);
  		    	}
  				&setnodelay($File,0);
  				return $value;
  		    }
  			if(defined $_[0] && $_[0]<0) {&setnodelay($File,1)};
  			my($value)=scalar(<$File>);
  			if(defined $_[0] && $_[0]<0) {&setnodelay($File,0)};
  			$value;
  		}
  DONE
      }
  }
  elsif ( &blockoptions() & 2 )    # Use poll
  {
      eval <<'DONE';
  	sub ReadKey {
  	  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  		if(defined $_[0] && $_[0] != 0) {
                       return undef if &pollfile($File,$_[0]) == 0
                  }
  		getc $File;
  	}
  	sub ReadLine {
  	  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  		if(defined $_[0] && $_[0]!=0) {
                       return undef if &pollfile($File,$_[0]) == 0;
                  }
  		scalar(<$File>);
  	}
  DONE
  }
  elsif ( &blockoptions() & 4 )    # Use select
  {
      eval <<'DONE';
  	sub ReadKey {
  	  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  		if(defined $_[0] && $_[0] !=0 ) {
                       return undef if &selectfile($File,$_[0])==0
                  }
  		getc $File;
  	}
  	sub ReadLine {
  	  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  		if(defined $_[0] && $_[0] != 0) {
                       return undef if &selectfile($File,$_[0]) == 0;
                  }
  		scalar(<$File>);
  	}
  DONE
  }
  elsif ( &blockoptions() & 8 )    # Use Win32
  {
      eval <<'DONE';
  	sub ReadKey {
  	  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
          if ($_[0] || $CurrentMode >= 3) {
  			Win32PeekChar($File, $_[0]);
          } else {
          	getc $File;
          }
  		#if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])};
  		#getc $File;
  	}
  	sub ReadLine {
  	  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  		#if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])};
  		#scalar(<$File>);
  		if($_[0]) 
  			{croak("Non-blocking ReadLine is not supported on this architecture")}
  		scalar(<$File>);
  	}
  DONE
  }
  else
  {
      eval <<'DONE';
  	sub ReadKey {
  	  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  		if($_[0]) 
  			{croak("Non-blocking ReadKey is not supported on this architecture")}
  		getc $File;
  	}
  	sub ReadLine {
  	  my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
  		if($_[0]) 
  			{croak("Non-blocking ReadLine is not supported on this architecture")}
  		scalar(<$File>);
  	}
  DONE
  }
  
  package Term::ReadKey;    # return to package ReadKey so AutoSplit is happy
  1;
  
  __END__;
TERM_READKEY

$fatpacked{"Test/Config/IOD/Common.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEST_CONFIG_IOD_COMMON';
  package Test::Config::IOD::Common;
  
  our $DATE = '2015-03-27'; # DATE
  our $VERSION = '0.15'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use Module::Load;
  use Test::More 0.98;
  
  our $CLASS = "Config::IOD::Reader";
  
  sub test_common_iod {
  
      load $CLASS;
  
      subtest "opt: default_section" => sub {
          test_read_iod(
              args  => {default_section=>'bawaan'},
              input => <<'_',
  a=1
  _
              result => {bawaan=>{a=>1}},
          );
      };
  
      subtest "opt: allow_directives" => sub {
          test_read_iod(
              args  => {allow_directives=>['merge']},
              input => <<'_',
  ;!noop
  _
              dies  => 1,
          );
          test_read_iod(
              args  => {allow_directives=>['noop']},
              input => <<'_',
  ;!noop
  _
              result => {},
          );
      };
  
      subtest "opt: disallow_directives" => sub {
          test_read_iod(
              args  => {disallow_directives=>['noop']},
              input => <<'_',
  ;!noop
  _
              dies  => 1,
          );
          test_read_iod(
              args  => {disallow_directives=>['merge']},
              input => <<'_',
  ;!noop
  _
              result => {},
          );
      };
  
      subtest "opt: allow_directives + disallow_directives" => sub {
          test_read_iod(
              args  => {
                  allow_directives    => ['noop'],
                  disallow_directives => ['noop'],
              },
              input => <<'_',
  ;!noop
  _
              dies  => 1,
          );
      };
  
      subtest "opt: enable_quoting=0" => sub {
          test_read_iod(
              args  => {enable_quoting=>0},
              input => <<'_',
  name="1\n2"
  _
              result => {GLOBAL=>{name=>'"1\\n2"'}},
          );
      };
  
      subtest "opt: enable_bracket=0" => sub {
          test_read_iod(
              args  => {enable_bracket=>0},
              input => <<'_',
  name=[1,2,3]
  _
              result => {GLOBAL=>{name=>'[1,2,3]'}},
          );
      };
  
      subtest "opt: enable_brace=0" => sub {
          test_read_iod(
              args  => {enable_brace=>0},
              input => <<'_',
  name={"a":1}
  _
              result => {GLOBAL=>{name=>'{"a":1}'}},
          );
      };
  
      subtest "opt: enable_encoding=0" => sub {
          test_read_iod(
              args  => {enable_encoding=>0},
              input => <<'_',
  name=!hex 5e5e
  _
              result => {GLOBAL=>{name=>'!hex 5e5e'}},
          );
      };
  
      subtest "opt: allow_encodings" => sub {
          test_read_iod(
              args  => {allow_encodings=>['hex']},
              input => <<'_',
  name=!json "1\n2"
  _
              dies => 1,
          );
          test_read_iod(
              args  => {allow_encodings=>['json']},
              input => <<'_',
  name=!json "1\n2"
  name2=!j "3\n4"
  _
              result => {GLOBAL=>{name=>"1\n2", name2=>"3\n4"}},
          );
      };
  
      subtest "opt: disallow_encodings" => sub {
          test_read_iod(
              args  => {disallow_encodings=>['json']},
              input => <<'_',
  name=!json "1\n2"
  _
              dies => 1,
          );
          test_read_iod(
              args  => {disallow_encodings=>['json']},
              input => <<'_',
  name=!j "1\n2"
  _
              dies => 1,
          );
          test_read_iod(
              args  => {disallow_encodings=>['hex']},
              input => <<'_',
  name=!json "1\n2"
  _
              result => {GLOBAL=>{name=>"1\n2"}},
          );
      };
  
      subtest "opt: allow_encodings + disallow_encodings" => sub {
          test_read_iod(
              args  => {
                  allow_encodings   =>['json'],
                  disallow_encodings=>['json'],
              },
              input => <<'_',
  name=!json "1\n2"
  _
              dies => 1,
          );
      };
  
      subtest "opt: allow_bang_only=0" => sub {
          test_read_iod(
              args  => {allow_bang_only=>0},
              input => <<'_',
  a=1
  !noop
  _
              dies => 1,
          );
      };
  
      subtest "opt: allow_duplicate_key=0" => sub {
          test_read_iod(
              args  => {allow_duplicate_key=>0},
              input => <<'_',
  a=1
  a=2
  _
              dies => 1,
          );
      };
  
      subtest "opt: ignore_unknown_directive=1" => sub {
          test_read_iod(
              args  => {ignore_unknown_directive=>1},
              input => <<'_',
  ;!foo bar
  _
              result => {},
          );
      };
  
      # temporarily placed here
      subtest "expr" => sub {
          test_read_iod(
              name  => "must be enabled first",
              args  => {},
              input => <<'_',
  a=!e 1+1
  _
              dies => 1,
          );
          test_read_iod(
              name  => "must be valid",
              args  => {enable_expr=>1},
              input => <<'_',
  a=!e 1+
  _
              dies => 1,
          );
          test_read_iod(
              args  => {enable_expr=>1},
              input => <<'_',
  a=!e 1+1
  [sect]
  b=!e val("GLOBAL.a")*3
  c=!e val("b") x 3
  _
              result => {GLOBAL=>{a=>2}, sect=>{b=>6, c=>666}},
          );
      };
  }
  
  sub test_read_iod {
      my %args = @_;
  
      my $parser_args = $args{args};
      my $test_name = $args{name} //
          "{". join(", ",
                    (map {"$_=$parser_args->{$_}"}
                         sort keys %$parser_args),
                ) . "}";
      subtest $test_name => sub {
  
          my $parser = $CLASS->new(%$parser_args);
  
          my $res;
          eval {
              if ($CLASS eq 'Config::IOD') {
                  $res = $parser->read_string($args{input})->dump;
              } else {
                  $res = $parser->read_string($args{input});
              }
          };
          my $err = $@;
          if ($args{dies}) {
              ok($err, "dies") or diag explain $res;
              return;
          } else {
              ok(!$err, "doesn't die")
                  or do { diag explain "err=$err"; return };
              is_deeply($res, $args{result}, 'result')
                  or diag explain $res;
          }
      };
  }
  
  1;
  # ABSTRACT: Common tests for Config::IOD and Config::IOD::Reader
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Test::Config::IOD::Common - Common tests for Config::IOD and Config::IOD::Reader
  
  =head1 VERSION
  
  This document describes version 0.15 of Test::Config::IOD::Common (from Perl distribution Config-IOD-Reader), released on 2015-03-27.
  
  =for Pod::Coverage .+
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Config-IOD-Reader>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Config-IOD-Reader>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Config-IOD-Reader>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
TEST_CONFIG_IOD_COMMON

$fatpacked{"Test/Data/Sah.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEST_DATA_SAH';
  package Test::Data::Sah;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.52'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use Data::Dump qw(dump);
  use Data::Sah qw(gen_validator);
  use Test::More 0.98;
  
  use Exporter qw(import);
  our @EXPORT_OK = qw(test_sah_cases);
  
  # XXX support js & human testing too
  sub test_sah_cases {
      my $tests = shift;
      my $opts  = shift // {};
  
      my $sah = Data::Sah->new;
      my $plc = $sah->get_compiler('perl');
  
      my $gvopts = $opts->{gen_validator_opts} // {};
      my $rt = $gvopts->{return_type} // 'bool';
  
      for my $test (@$tests) {
          my $v = gen_validator($test->{schema}, $gvopts);
          my $res = $v->($test->{input});
          my $name = $test->{name} //
              "data " . dump($test->{input}) . " should".
                  ($test->{valid} ? " pass" : " not pass"). " schema " .
                      dump($test->{schema});
          my $testres;
          if ($test->{valid}) {
              if ($rt eq 'bool') {
                  $testres = ok($res, $name);
              } elsif ($rt eq 'str') {
                  $testres = is($res, "", $name) or diag explain $res;
              } elsif ($rt eq 'full') {
                  $testres = is(~~keys(%{$res->{errors}}), 0, $name) or diag explain $res;
              }
          } else {
              if ($rt eq 'bool') {
                  $testres = ok(!$res, $name);
              } elsif ($rt eq 'str') {
                  $testres = isnt($res, "", $name) or diag explain $res;
              } elsif ($rt eq 'full') {
                  $testres = isnt(~~keys(%{$res->{errors}}), 0, $name) or diag explain $res;
              }
          }
          next if $testres;
  
          # when test fails, show the validator generated code to help debugging
          my $cd = $plc->compile(schema => $test->{schema});
          diag "schema compilation result:\n----begin generated code----\n",
              explain($cd->{result}), "\n----end generated code----\n",
                  "that code should return ", ($test->{valid} ? "true":"false"),
                      " when fed \$data=", dump($test->{input}),
                          " but instead returns ", dump($res);
  
          # also show the result for return_type=full
          my $vfull = gen_validator($test->{schema}, {return_type=>"full"});
          diag "\nvalidator result (full):\n----begin result----\n",
              explain($vfull->($test->{input})), "----end result----";
      }
  }
  
  1;
  # ABSTRACT: Test routines for Data::Sah
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Test::Data::Sah - Test routines for Data::Sah
  
  =head1 VERSION
  
  This document describes version 0.52 of Test::Data::Sah (from Perl distribution Data-Sah), released on 2015-04-15.
  
  =head1 FUNCTIONS
  
  =head2 test_sah_cases(\@tests)
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
TEST_DATA_SAH

$fatpacked{"Test/Perinci/CmdLine.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEST_PERINCI_CMDLINE';
  package Test::Perinci::CmdLine;
  
  our $DATE = '2015-04-12'; # DATE
  our $VERSION = '1.10'; # VERSION
  
  use 5.010;
  use strict;
  use warnings;
  
  use Capture::Tiny qw(capture);
  use Test::More 0.98;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(test_run test_complete);
  
  our $CLASS = "Perinci::CmdLine::Lite";
  
  sub test_run {
      my %args = @_;
  
      my $name = "test_run: " . ($args{name} // join(" ", @{$args{argv} // []}));
  
      subtest $name => sub {
          no strict 'refs';
          no warnings 'redefine';
  
          local *{"$CLASS\::hook_after_get_meta"}          = $args{hook_after_get_meta}          if $args{hook_after_get_meta};
          local *{"$CLASS\::hook_before_run"}              = $args{hook_before_run}              if $args{hook_before_run};
          local *{"$CLASS\::hook_before_read_config_file"} = $args{hook_before_read_config_file} if $args{hook_before_read_config_file};
          local *{"$CLASS\::hook_after_parse_argv"}        = $args{hook_after_parse_argv}        if $args{hook_after_parse_argv};
          local *{"$CLASS\::hook_format_result"}           = $args{hook_format_result}           if $args{hook_format_result};
          local *{"$CLASS\::hook_format_row"}              = $args{hook_format_row}              if $args{hook_format_row};
          local *{"$CLASS\::hook_display_result"}          = $args{hook_display_result}          if $args{hook_display_result};
          local *{"$CLASS\::hook_after_run"}               = $args{hook_after_run}               if $args{hook_after_run};
  
          my %cmdargs = %{$args{args}};
          $cmdargs{exit} = 0;
          $cmdargs{read_config} //= 0;
          my $cmd = $CLASS->new(%cmdargs);
  
          local @ARGV = @{$args{argv} // []};
          my ($stdout, $stderr);
          my $res;
          eval {
              ($stdout, $stderr) = capture {
                  $res = $cmd->run;
              };
          };
          my $eval_err = $@;
          my $exit_code = $res->[3]{'x.perinci.cmdline.base.exit_code'};
  
          if ($args{dies}) {
              ok($eval_err || ref($eval_err), "dies");
              return;
          } else {
              ok(!$eval_err, "doesn't die") or diag("dies: $eval_err");
          }
  
          if (defined $args{exit_code}) {
              is($exit_code, $args{exit_code}, "exit code");
          }
  
          if ($args{status}) {
              is($res->[0], $args{status}, "status")
                  or diag explain $res;
          }
  
          if ($args{output_re}) {
              like($stdout // "", $args{output_re}, "output_re")
                  or diag("output is <" . ($stdout // "") . ">");
          }
  
          if ($args{posttest}) {
              $args{posttest}->(\@ARGV, $stdout, $stderr, $res);
          }
      };
  }
  
  sub test_complete {
      my (%args) = @_;
  
      my $cmd = $CLASS->new(%{$args{args}}, exit=>0);
  
      local @ARGV = @{$args{argv} // []};
  
      # $args{comp_line0} contains comp_line with '^' indicating where comp_point
      # should be, the caret will be stripped. this is more convenient than
      # counting comp_point manually.
      my $comp_line  = $args{comp_line0};
      defined ($comp_line) or die "BUG: comp_line0 not defined";
      my $comp_point = index($comp_line, '^');
      $comp_point >= 0 or
          die "BUG: comp_line0 should contain ^ to indicate where comp_point is";
      $comp_line =~ s/\^//;
  
      local $ENV{COMP_LINE}  = $comp_line;
      local $ENV{COMP_POINT} = $comp_point;
  
      my ($stdout, $stderr);
      my $res;
      ($stdout, $stderr) = capture {
          $res = $cmd->run;
      };
      my $exit_code = $res->[3]{'x.perinci.cmdline.base.exit_code'};
  
      my $name = "test_complete: " . ($args{name} // $args{comp_line0});
      subtest $name => sub {
          is($exit_code, 0, "exit code = 0");
          is($stdout // "", join("", map {"$_\n"} @{$args{result}}), "result");
      };
  }
  
  1;
  # ABSTRACT: Test library for Perinci::CmdLine{::Classic,::Lite}
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Test::Perinci::CmdLine - Test library for Perinci::CmdLine{::Classic,::Lite}
  
  =head1 VERSION
  
  This document describes version 1.10 of Test::Perinci::CmdLine (from Perl distribution Perinci-CmdLine-Lite), released on 2015-04-12.
  
  =head1 FUNCTIONS
  
  =head2 test_run(%args)
  
  =head2 test_complete(%args)
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Perinci-CmdLine-Lite>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-Perinci-CmdLine-Lite>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-CmdLine-Lite>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
TEST_PERINCI_CMDLINE

$fatpacked{"Text/ANSI/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_ANSI_UTIL';
  package Text::ANSI::Util;
  
  use 5.010001;
  use locale;
  use strict;
  use utf8;
  use warnings;
  
  use List::Util qw(min max);
  use Text::WideChar::Util 0.10 qw(mbswidth mbtrunc);
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(
                         ta_add_color_resets
                         ta_detect
                         ta_extract_codes
                         ta_highlight
                         ta_highlight_all
                         ta_length
                         ta_length_height
                         ta_mbpad
                         ta_mbswidth
                         ta_mbswidth_height
                         ta_mbtrunc
                         ta_mbwrap
                         ta_pad
                         ta_split_codes
                         ta_split_codes_single
                         ta_strip
                         ta_trunc
                         ta_wrap
                 );
  
  our $VERSION = '0.16'; # VERSION
  
  # used to find/strip escape codes from string
  our $re       = qr/
                        #\e\[ (?: (\d+) ((?:;[^;]+?)*) )? ([\x40-\x7e])
                        # without captures
                        \e\[ (?: \d+ (?:;[^;]+?)* )? [\x40-\x7e]
                    /osx;
  
  sub ta_detect {
      my $text = shift;
      $text =~ $re ? 1:0;
  }
  
  sub ta_length {
      my $text = shift;
      length(ta_strip($text));
  }
  
  sub _ta_length_height {
      my ($is_mb, $text) = @_;
      my $num_lines = 0;
      my @lens;
      for my $e (split /(\r?\n)/, ta_strip($text)) {
          if ($e =~ /\n/) {
              $num_lines++;
              next;
          }
          $num_lines = 1 if $num_lines == 0;
          push @lens, $is_mb ? mbswidth($e) : length($e);
      }
      [max(@lens) // 0, $num_lines];
  }
  
  sub ta_length_height {
      _ta_length_height(0, @_);
  }
  
  sub ta_mbswidth_height {
      _ta_length_height(1, @_);
  }
  
  sub ta_strip {
      my $text = shift;
      $text =~ s/$re//go;
      $text;
  }
  
  sub ta_extract_codes {
      my $text = shift;
      my $res = "";
      $res .= $1 while $text =~ /((?:$re)+)/go;
      $res;
  }
  
  sub ta_split_codes {
      my $text = shift;
      return split(/((?:$re)+)/o, $text);
  }
  
  sub ta_split_codes_single {
      my $text = shift;
      return split(/($re)/o, $text);
  }
  
  # same like _ta_mbswidth, but without handling multiline text
  sub _ta_mbswidth0 {
      my $text = shift;
      mbswidth(ta_strip($text));
  }
  
  sub ta_mbswidth {
      my $text = shift;
      ta_mbswidth_height($text)->[0];
  }
  
  sub _ta_wrap {
      my ($is_mb, $text, $width, $opts) = @_;
      $width //= 80;
      $opts  //= {};
  
      # basically similar to Text::WideChar::Util's algorithm. we adjust for
      # dealing with ANSI codes by splitting codes first (to easily do color
      # resets/replays), then grouping into words and paras, then doing wrapping.
  
      my @termst; # store term type, 's' (spaces), 'w' (word), 'c' (cjk word) or
                  # 'p' (parabreak)
      my @terms;  # store the text (w/ codes); for ws, only store the codes
      my @pterms; # store the plaintext ver, but only for ws to check parabreak
      my @termsw; # store width of each term, only for non-ws
      my @termsc; # store color replay code
      {
          my @ch = ta_split_codes_single($text);
          my $crcode = ""; # code for color replay to be put at the start of line
          my $term      = '';
          my $pterm     = '';
          my $prev_type = '';
          while (my ($pt, $c) = splice(@ch, 0, 2)) {
              #use Data::Dump; print "D:chunk: "; dd [$pt, $c];
  
              # split into (CJK and non-CJK) words and spaces.
  
              my @s; # (WORD1, TYPE, ...) where type is 's' for space, 'c' for
                     # CJK word, or 'w' for non-CJK word
              while ($pt =~ /($Text::WideChar::Util::re_cjk+)|(\S+)|(\s+)/gox) {
                  if ($1) {
                      push @s, $1, 'c';
                  } elsif ($3) {
                      push @s, $3, 's';
                  } else {
                      my $pt2 = $2;
                      while ($pt2 =~ /($Text::WideChar::Util::re_cjk_class+)|
                                      ($Text::WideChar::Util::re_cjk_negclass+)/gox) {
                          if ($1) {
                              push @s, $1, 'c';
                          } else {
                              push @s, $2, 'w';
                          }
                      }
                  }
              }
  
              #use Data::Dump; say "D:s=",Data::Dump::dump(\@s);
  
              my $only_code = 1 if !@s;
              while (1) {
                  my ($s, $s_type) = splice @s, 0, 2;
                  $s_type //= '';
                  last unless $only_code || defined($s);
                  # empty text, only code
                  if ($only_code) {
                      $s = "";
                      $term .= $c if defined $c;
                  }
                  #say "D:s=[$s]  prev_type=$prev_type \@ch=",~~@ch,"  \@s=",~~@s;
  
                  if ($s_type && $s_type ne 's') {
                      if ($prev_type eq 's') {
                          #say "D:found word, completed previous ws [$term]";
                          push @termst, 's';
                          push @terms , $term;
                          push @pterms, $pterm;
                          push @termsw, undef;
                          push @termsc, $crcode;
                          # start new word
                          $pterm = ''; $term = '';
                      } elsif ($prev_type && $prev_type ne $s_type) {
                          #say "D:found a ".($s_type eq 'c' ? 'CJK':'non-CJK')." word, completed previous ".($prev_type eq 'c' ? 'CJK':'non-CJK')." word [$term]";
                          push @termst, $prev_type;
                          push @terms , $term;
                          push @pterms, $pterm;
                          push @termsw, $is_mb ? mbswidth($pterm):length($pterm);
                          push @termsc, $crcode;
                          # start new word
                          $pterm = ''; $term = '';
                      }
                      $pterm .= $s;
                      $term  .= $s; $term .= $c if defined($c) && !@s;
                      if (!@s && !@ch) {
                          #say "D:complete word because this is the last token";
                          push @termst, $s_type;
                          push @terms , $term;
                          push @pterms, "";
                          push @termsw, $is_mb ? mbswidth($pterm):length($pterm);
                          push @termsc, $crcode;
                      }
                  } elsif (length($s)) {
                      if ($prev_type ne 's') {
                          #say "D:found ws, completed previous word [$term]";
                          push @termst, $prev_type;
                          push @terms , $term;
                          push @pterms, "";
                          push @termsw, $is_mb ? mbswidth($pterm):length($pterm);
                          push @termsc, $crcode;
                          # start new ws
                          $pterm = ''; $term = '';
                      }
                      $pterm .= $s;
                      $term  .= $c if defined($c) && !@s;
                      if (!@s && !@ch) {
                          #say "D:complete ws because this is the last token";
                          push @termst, 's';
                          push @terms , $term;
                          push @pterms, $pterm;
                          push @termsw, undef;
                          push @termsc, $crcode;
                      }
                  }
                  $prev_type = $s_type;
  
                  if (!@s) {
                      if (defined($c) && $c =~ /m\z/) {
                          if ($c eq "\e[0m") {
                              #say "D:found color reset, emptying crcode";
                              $crcode = "";
                          } elsif ($c =~ /m\z/) {
                              #say "D:adding to crcode";
                              $crcode .= $c;
                          }
                      }
                      last if $only_code;
                  }
  
              } # splice @s
          } # splice @ch
      }
  
      # mark parabreaks
      {
          my $i = 0;
          while ($i < @pterms) {
              if ($termst[$i] eq 's') {
                  if ($pterms[$i] =~ /[ \t]*(\n(?:[ \t]*\n)+)([ \t]*)/) {
                      #say "D:found parabreak";
                      $pterms[$i] = $1;
                      $termst[$i] = 'p';
                      if ($i < @pterms-1) {
                          # stick color code to the beginning of next para
                          $terms [$i+1] = $terms[$i] . $terms [$i+1];
                          $terms [$i] = "";
                      }
                      if (length $2) {
                          #say "D:found space after parabreak, splitting";
                          splice @termst, $i+1, 0, "s";
                          splice @terms , $i+1, 0, "";
                          splice @pterms, $i+1, 0, $2;
                          splice @termsw, $i+1, 0, undef;
                          splice @termsc, $i+1, 0, $termsc[$i];
                          $i += 2;
                          next;
                      }
                  }
              }
              $i++;
          }
      }
  
      #use Data::Dump::Color; my @d; for (0..$#terms) { push @d, {type=>$termst[$_], term=>$terms[$_], pterm=>$pterms[$_], termc=>$termsc[$_], termw=>$termsw[$_], } } dd \@d;
      #return;
  
      #use Data::Dump; say "D:termst=".Data::Dump::dump(\@termst);
      #use Data::Dump; say "D:terms =".Data::Dump::dump(\@terms);
      #use Data::Dump; say "D:pterms=".Data::Dump::dump(\@pterms);
      #use Data::Dump; say "D:termsw=".Data::Dump::dump(\@termsw);
      #use Data::Dump; say "D:termsc=".Data::Dump::dump(\@termsc);
  
      my ($maxww, $minww);
  
      # now we perform wrapping
  
      my @res;
      {
          my $tw = $opts->{tab_width} // 8;
          die "Please specify a positive tab width" unless $tw > 0;
          my $optfli  = $opts->{flindent};
          my $optfliw = Text::WideChar::Util::_get_indent_width($is_mb, $optfli, $tw) if defined $optfli;
          my $optsli  = $opts->{slindent};
          my $optsliw = Text::WideChar::Util::_get_indent_width($is_mb, $optsli, $tw) if defined $optsli;
          my $pad = $opts->{pad};
          my $x = 0;
          my $y = 0;
          my ($fli, $sli, $fliw, $sliw);
          my $is_parastart = 1;
          my $line_has_word = 0;
          my ($termt, $prev_t);
        TERM:
          for my $i (0..$#terms) {
              $prev_t = $termt if $i;
              $termt = $termst[$i];
              my $term  = $terms[$i];
              my $pterm = $pterms[$i];
              my $termw = $termsw[$i];
              my $crcode = $i > 0 ? $termsc[$i-1] : "";
              #say "D:term=[", ($termt eq 'w' ? $term : $pterm), "] ($termt)";
  
              # end of paragraph
              if ($termt eq 'p') {
                  my $numnl = 0;
                  $numnl++ while $pterm =~ /\n/g;
                  for (1..$numnl) {
                      push @res, "\e[0m" if $crcode && $_ == 1;
                      push @res, " " x ($width-$x) if $pad;
                      push @res, "\n";
                      $x = 0;
                      $y++;
                  }
                  $line_has_word = 0;
                  $x = 0;
                  $is_parastart = 1;
                  next TERM;
              }
  
              if ($is_parastart) {
                  # this is the start of paragraph, determine indents
                  if (defined $optfli) {
                      $fli  = $optfli;
                      $fliw = $optfliw;
                  } else {
                      if ($termt eq 's') {
                          $fli  = $pterm;
                          $fliw = Text::WideChar::Util::_get_indent_width($is_mb, $fli, $tw);
                      } else {
                          $fli  = "";
                          $fliw = 0;
                      }
                      #say "D:deduced fli from text [$fli] ($fliw)";
                      my $j = $i;
                      $sli = undef;
                      while ($j < @terms && $termst[$j] ne 'p') {
                          if ($termst[$j] eq 's') {
                              if ($pterms[$j] =~ /\n([ \t]+)/) {
                                  $sli  = $1;
                                  $sliw = Text::WideChar::Util::_get_indent_width($is_mb, $sli, $tw);
                                  last;
                              }
                          }
                          $j++;
                      }
                      if (!defined($sli)) {
                          $sli  = "";
                          $sliw = 0;
                      }
                      #say "D:deduced sli from text [$sli] ($sliw)";
                      die "Subsequent indent must be less than width" if $sliw >= $width;
                  }
  
                  #say "D:inserting the fli [$fli] ($fliw)";
                  push @res, $fli;
                  $x += $fliw;
              } # parastart
  
              $is_parastart = 0;
  
              if ($termt eq 's') {
                  # just print the codes
                  push @res, $term;
  
                  # maintain terminating newline
                  if ($pterm =~ /\n/ && $i == $#terms) {
                      push @res, "\e[0m" if $crcode;
                      push @res, " " x ($width-$x) if $pad;
                      push @res, "\n";
                      $line_has_word = 0;
                  }
              }
  
              if ($termt ne 's') {
                  # we need to chop long words
                  my @words;
                  my @wordsw;
                  my @wordst; # c if cjk, w if not
                  my @wordswsb; # whether there are ws before the word
                  my $j = 0;
                  my $c = ""; # see below for explanation
                  while (1) {
                      $j++;
                      # most words shouldn't be that long. and we don't need to
                      # truncate long CJK word first here because it will get
                      # truncated later.
                      if ($termw <= $width-$sliw || $termt eq 'c') {
                          push @words   , $c . $term;
                          push @wordsw  , $termw;
                          push @wordst  , $termt;
                          push @wordswsb, ($prev_t && $prev_t eq 's')?1:0;
                          last;
                      }
                      #use Data::Dump; print "D:truncating long word "; dd $term;
                      my $res = $is_mb ? ta_mbtrunc($term, $width-$sliw, 1) :
                          ta_trunc($term, $width-$sliw, 1);
  
                      my ($tword, $twordw);
                      if ($j == 1) {
                          $tword  = $res->[0];
                          $twordw = $res->[1];
                      } else {
                          # since ta_{,mb}trunc() adds the codes until the end of
                          # the word, to avoid messing colors, for the second word
                          # and so on we need to replay colors by prefixing with:
                          # \e[0m (reset) + $crcode + (all the codes from the
                          # start of the long word up until the truncated
                          # position, stored in $c).
                          #
                          # there might be faster way, but it is expected that
                          # long words are not that common.
                          $tword  = ($crcode ? "\e[0m" . $crcode : "") .
                              $c . $res->[0];
                          $twordw = $res->[1];
                      }
                      $c .= ta_extract_codes(substr($term, 0, $res->[2]));
                      #use Data::Dump; print "D:truncated word is "; dd $tword;
  
                      push @words   , $tword;
                      push @wordsw  , $twordw;
                      push @wordst  , $termt;
                      push @wordswsb, $j == 1 ? (($prev_t && $prev_t eq 's')?1:0) : 0;
                      $term  = substr($term, $res->[2]);
                      $termw = $is_mb ? _ta_mbswidth0($term) : ta_length($term);
                  }
  
                  #use Data::Dump; print "D:words="; dd \@words; print "D:wordsw="; dd \@wordsw; print "D:wordswsb="; dd \@wordswsb;
  
                  # the core of the wrapping algo
                  for my $word (@words) {
                      my $wordw = shift @wordsw;
                      my $wordt = shift @wordst;
                      my $ws_before = shift @wordswsb;
                      #say "D:x=$x word=$word wordw=$wordw wordt=$wordt ws_before=$ws_before line_has_word=$line_has_word width=$width";
  
                      $maxww = $wordw if !defined($maxww) || $maxww < $wordw;
                      $minww = $wordw if !defined($minww) || $minww > $wordw;
  
                      if ($x + ($line_has_word ? 1:0) + $wordw <= $width) {
                          if ($line_has_word && $ws_before) {
                              push @res, " ";
                              $x++;
                          }
                          push @res, $word;
                          $x += $wordw;
                      } else {
                          # line break
                          while (1) {
                              if ($wordt eq 'c') {
                                  # a CJK word can be line-broken
                                  my $res;
                                  if ($ws_before) {
                                      $res = ta_mbtrunc($word, $width-$x-1, 1);
                                      push @res, " ", $res->[0];
                                  } else {
                                      $res = ta_mbtrunc($word, $width-$x, 1);
                                      push @res, $res->[0];
                                  }
                                  #say "D:truncated CJK word: $word (".length($word)."), ".($width-$x)." -> $res->[0] (".length($res->[0]).") & $res->[1], remaining=$res->[3] (".length($res->[3]).")";
                                  $word = $res->[3];
                                  $wordw = _ta_mbswidth0($res->[3]);
                              } else {
                                  push @res, "\e[0m" if $crcode;
                              }
                              push @res, " " x ($width-$x) if $pad;
                              push @res, "\n";
                              $y++;
                              push @res, $crcode;
                              push @res, $sli;
  
                              if ($sliw + $wordw <= $width) {
                                  push @res, $word;
                                  $x = $sliw + $wordw;
                                  last;
                              } else {
                                  # word still too long, break again
                                  $x = $sliw;
                              }
                          }
                      }
                      $line_has_word++;
                  }
  
              }
          } # for term
          push @res, " " x ($width-$x) if $line_has_word && $pad;
      }
  
      if ($opts->{return_stats}) {
          return [join("", @res), {
              max_word_width => $maxww,
              min_word_width => $minww,
          }];
      } else {
          return join("", @res);
      }
  }
  
  sub ta_wrap {
      _ta_wrap(0, @_);
  }
  
  sub ta_mbwrap {
      _ta_wrap(1, @_);
  }
  
  sub _ta_pad {
      my ($is_mb, $text, $width, $which, $padchar, $is_trunc) = @_;
      if ($which) {
          $which = substr($which, 0, 1);
      } else {
          $which = "r";
      }
      $padchar //= " ";
  
      my $w = $is_mb ? _ta_mbswidth0($text) : ta_length($text);
      if ($is_trunc && $w > $width) {
          my $res = $is_mb ?
              ta_mbtrunc($text, $width, 1) : ta_trunc($text, $width, 1);
          $text = $res->[0] . ($padchar x ($width-$res->[1]));
      } else {
          if ($which eq 'l') {
              $text = ($padchar x ($width-$w)) . $text;
          } elsif ($which eq 'c') {
              my $n = int(($width-$w)/2);
              $text = ($padchar x $n) . $text . ($padchar x ($width-$w-$n));
          } else {
              $text .= ($padchar x ($width-$w));
          }
      }
      $text;
  }
  
  sub ta_pad {
      _ta_pad(0, @_);
  }
  
  sub ta_mbpad {
      _ta_pad(1, @_);
  }
  
  sub _ta_trunc {
      my ($is_mb, $text, $width, $return_extra) = @_;
  
      # return_extra (undocumented): if set to 1, will return [truncated_text,
      # visual width, length(chars) up to truncation point, rest of the text not
      # included]
  
      my $w = $is_mb ? _ta_mbswidth0($text) : ta_length($text);
      if ($w <= $width) {
          return $return_extra ? [$text, $w, length($text), ''] : $text;
      }
      my @p = ta_split_codes($text);
      my @res;
      my $append = 1; # whether we should add more text
      my $code4rest = '';
      my $rest = '';
      $w = 0;
      my $c = 0;
      #use Data::Dump; dd \@p;
      while (my ($t, $ansi) = splice @p, 0, 2) {
          #say "D: t=<$t>, \@p=", ~~@p, ", code4rest=<$code4rest>, rest=<$rest>";
          if ($append) {
              my $tw = $is_mb ? mbswidth($t) : length($t);
              #say "D: tw=$tw";
              if ($w+$tw <= $width) {
                  push @res, $t;
                  $w += $tw;
                  $c += length($t);
                  $append = 0 if $w == $width;
                  #say "D:end1" unless $append;
              } else {
                  my $tres = $is_mb ?
                      mbtrunc($t, $width-$w, 1) :
                          [substr($t, 0, $width-$w), $width-$w, $width-$w];
                  #use Data::Dump; dd $tres;
                  push @res, $tres->[0];
                  $w += $tres->[1];
                  $c += $tres->[2];
                  $rest = substr($t, $tres->[2]);
                  $append = 0;
                  #say "D:end2";
              }
          } else {
              $rest .= $t;
          }
          if (defined $ansi) {
              push @res, $ansi;
              $c += length($ansi) if $append;
              $code4rest .= $ansi if $append;
              $rest .= $ansi unless $append;
          }
      }
  
      if ($return_extra) {
          return [join("", @res), $w, $c, $code4rest . $rest];
      } else {
          return join("", @res);
      }
  }
  
  sub ta_trunc {
      _ta_trunc(0, @_);
  }
  
  sub ta_mbtrunc {
      _ta_trunc(1, @_);
  }
  
  sub _ta_highlight {
      my ($is_all, $text, $needle, $color) = @_;
  
      # break into chunks
      my (@chptext, @chcode, @chsavedc); # chunk plain texts, codes, saved codes
      my $sc = "";
      my $plaintext = "";
      my @ch = ta_split_codes_single($text);
      while (my ($pt, $c) = splice(@ch, 0, 2)) {
          push @chptext , $pt;
          push @chcode  , $c;
          push @chsavedc, $sc;
          $plaintext .= $pt;
          if (defined($c) && $c =~ /m\z/) {
              if ($c eq "\e[0m") {
                  $sc = "";
              } elsif ($c =~ /m\z/) {
                  $sc .= $c;
              }
          }
      }
      #use Data::Dump; print "\@chptext: "; dd \@chptext; print "\@chcode: "; dd \@chcode; print "\@chsavedc: "; dd \@chsavedc;
  
      # gather a list of needles to highlight, with their positions
      my (@needle, @npos);
      if (ref($needle) eq 'Regexp') {
          my @m = $plaintext =~ /$needle/g;
          return $text unless @m;
          my $pos = 0;
          while ($pos < length($plaintext)) {
              my @pt;
              for (@m) {
                  my $p = index($plaintext, $_, $pos);
                  push @pt, [$p, $_] if $p >= 0;
              }
              last unless @pt;
              my $pmin = $pt[0][0];
              my $t = $pt[0][1];
              for (@pt) {
                  if ($pmin > $_->[0] ||
                          $pmin==$_->[0] && length($t) < length($_->[1])) {
                      $pmin = $_->[0];
                      $t = $_->[1];
                  }
              }
              push @needle, $t;
              push @npos  , $pmin;
              last unless $is_all;
              $pos = $pmin + length($t);
          }
      } else {
          my $pos = 0;
          while (1) {
              #say "D:finding '$needle' in '$plaintext' from pos '$pos'";
              my $p = index($plaintext, $needle, $pos);
              last if $p < 0;
              push @needle, $needle;
              push @npos  , $p;
              last unless $is_all;
              $pos = $p + length($needle);
              last if $pos >= length($plaintext);
          }
          return $text unless @needle;
      }
      #use Data::Dump; print "\@needle: "; dd \@needle; print "\@npos: "; dd \@npos;
  
      my @res;
      my $found = 1;
      my $pos = 0;
      my $i = 0;
      my $curneed = shift @needle;
      my $npos    = shift @npos;
    CHUNK:
      while (1) {
          last if $i >= @chptext;
          my $pos2  = $pos+length($chptext[$i])-1;
          my $npos2 = $npos+length($curneed)-1;
          #say "D: chunk=[$chptext[$i]], npos=$npos, npos2=$npos2, pos=$pos, pos2=$pos2";
          if ($pos > $npos2 || $pos2 < $npos || !$found) {
              #say "D:inserting chunk: [$chptext[$i]]";
              # no need to highlight
              push @res, $chptext[$i];
              push @res, $chcode[$i] if defined $chcode[$i];
              goto L1;
          }
  
          # there is chunk text at the left of needle?
          if ($pos < $npos) {
              my $pre = substr($chptext[$i], 0, $npos-$pos);
              #say "D:inserting pre=[$pre]";
              push @res, $pre;
          }
  
          my $npart = substr($curneed,
                             max(0, $pos-$npos),
                             min($pos2, $npos2)-max($pos, $npos)+1);
          if (length($npart)) {
              #say "D:inserting npart=[$npart]";
              push @res, $color, $npart;
              push @res, "\e[0m";
              #use Data::Dump; dd [$chsaved[$i], $chcode[$i]];
              push @res, $chsavedc[$i];
          }
  
          # is there chunk text at the right of needle?
          if ($npos2 <= $pos2) {
              #say "D:We have run past current needle [$curneed]";
              my $post = substr($chptext[$i], $npos2-$pos+1);
  
              if (@needle) {
                  $curneed = shift @needle;
                  $npos    = shift @npos;
                  #say "D:Finding the next needle ($curneed) at pos $npos";
                  $pos     = $npos2+1;
                  $chptext[$i] = $post;
                  $found = 1;
                  redo CHUNK;
              } else {
                  # we're done finding needle
                  $found = 0;
              }
  
              if (!$found) {
                  #say "D:inserting post=[$post]";
                  push @res, $post;
                  push @res, $chcode[$i] if defined $chcode[$i];
              }
          }
  
        L1:
          $pos = $pos2+1;
          $i++;
      }
  
      join "", @res;
  }
  
  sub ta_highlight {
      _ta_highlight(0, @_);
  }
  
  sub ta_highlight_all {
      _ta_highlight(1, @_);
  }
  
  sub ta_add_color_resets {
      my (@text) = @_;
  
      my @res;
      my $i = 0;
      my $savedc = "";
      for my $text (@text) {
          $i++;
          my $newt = $i > 1 && !$savedc ? "\e[0m" : $savedc;
  
          # break into chunks
          my @ch = ta_split_codes_single($text);
          while (my ($t, $c) = splice(@ch, 0, 2)) {
              $newt .= $t;
              if (defined($c) && $c =~ /m\z/) {
                  $newt .= $c;
                  if ($c eq "\e[0m") {
                      $savedc = "";
                  } elsif ($c =~ /m\z/) {
                      $savedc .= $c;
                  }
              }
          }
  
          $newt .= "\e[0m" if $savedc && $i < @text;
          push @res, $newt;
      }
  
      @res;
  }
  
  1;
  # ABSTRACT: Routines for text containing ANSI escape codes
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Text::ANSI::Util - Routines for text containing ANSI escape codes
  
  =head1 VERSION
  
  This document describes version 0.16 of Text::ANSI::Util (from Perl distribution Text-ANSI-Util), released on 2015-01-03.
  
  =head1 SYNOPSIS
  
   use Text::ANSI::Util qw(
       ta_add_color_resets
       ta_detect ta_highlight ta_highlight_all ta_length ta_mbpad ta_mbswidth
       ta_mbswidth_height ta_mbwrap ta_pad ta_split_codes ta_split_codes_single
       ta_strip ta_wrap);
  
   # detect whether text has ANSI escape codes?
   say ta_detect("red");       # => false
   say ta_detect("\e[31mred"); # => true
  
   # calculate length of text (excluding the ANSI escape codes)
   say ta_length("red");       # => 3
   say ta_length("\e[31mred"); # => 3
  
   # calculate visual width of text if printed on terminal (can handle Unicode
   # wide characters and exclude the ANSI escape codes)
   say ta_mbswidth("\e[31mred");  # => 3
   say ta_mbswidth("\e[31mçº¢è²"); # => 4
  
   # ditto, but also return the number of lines
   say ta_mbswidth_height("\e[31mred\nçº¢è²"); # => [4, 2]
  
   # strip ANSI escape codes
   say ta_strip("\e[31mred"); # => "red"
  
   # split codes (ANSI codes are always on the even positions)
   my @parts = ta_split_codes("\e[31mred"); # => ("", "\e[31m", "red")
  
   # wrap text to a certain column width, handle ANSI escape codes
   say ta_wrap("....", 40);
  
   # ditto, but handle wide characters
   say ta_mbwrap(...);
  
   # pad (left, right, center) text to a certain width
   say ta_pad("foo", 10);                          # => "foo       "
   say ta_pad("foo", 10, "left");                  # => "       foo"
   say ta_pad("foo\nbarbaz\n", 10, "center", "."); # => "...foo....\n..barbaz..\n"
  
   # ditto, but handle wide characters
   say ta_mbpad(...);
  
   # truncate text to a certain width while still passing ANSI escape codes
   use Term::ANSIColor;
   my $text = color("red")."red text".color("reset"); # => "\e[31mred text\e[0m"
   say ta_trunc($text, 5);                            # => "\e[31mred t\e[0m"
  
   # ditto, but handle wide characters
   say ta_mbtrunc(...);
  
   # highlight the first occurence of some string within text
   say ta_highlight("some text", "ome", "\e[7m\e[31m");
  
   # ditto, but highlight all occurrences
   say ta_highlight_all(...);
  
  =head1 DESCRIPTION
  
  This module provides routines for dealing with text containing ANSI escape codes
  (mainly ANSI color codes).
  
  Current caveats:
  
  =over
  
  =item * All codes are assumed to have zero width
  
  This is true for color codes and some other codes, but there are also codes to
  alter cursor positions which means they can have negative or undefined width.
  
  =item * Single-character CSI (control sequence introducer) currently ignored
  
  Only C<ESC+[> (two-character CSI) is currently parsed.
  
  BTW, in ASCII terminals, single-character CSI is C<0x9b>. In UTF-8 terminals, it
  is C<0xc2, 0x9b> (2 bytes).
  
  =item * Private-mode- and trailing-intermediate character currently not parsed
  
  =item * Only color reset code \e[0m is recognized
  
  For simplicity, currently multiple SGR (select graphic rendition) parameters
  inside a single ANSI escape code is not parsed. This means that color reset code
  like C<\e[1;0m> or C<\e[31;47;0m> is not recognized, only C<\e[0m> is. I believe
  this should not be a problem with most real-world text out there.
  
  =back
  
  =head1 FUNCTIONS
  
  =head2 ta_detect($text) => BOOL
  
  Return true if C<$text> contains ANSI escape codes, false otherwise.
  
  =head2 ta_length($text) => INT
  
  Count the number of characters in $text, while ignoring ANSI escape codes.
  Equivalent to C<< length(ta_strip($text)) >>. See also: ta_mbswidth().
  
  =head2 ta_length_height($text) => [INT, INT]
  
  Like ta_length(), but also gives height (number of lines). For example, C<<
  ta_length_height("foobar\nb\n") >> gives [6, 3].
  
  =head2 ta_mbswidth($text) => INT
  
  Return visual width of C<$text> (in number of columns) if printed on terminal.
  Equivalent to C<< Text::WideChar::Util::mbswidth(ta_strip($text)) >>. This
  function can be used e.g. in making sure that your text aligns vertically when
  output to the terminal in tabular/table format.
  
  Note that C<ta_mbswidth()> handles multiline text correctly, e.g.: C<<
  ta_mbswidth("foo\nbarbaz") >> gives 6 instead of 3-1+8 = 8. It splits the input
  text first against C<< /\r?\n/ >>.
  
  =head2 ta_mbswidth_height($text) => [INT, INT]
  
  Like C<ta_mbswidth()>, but also gives height (number of lines). For example, C<<
  ta_mbswidth_height("è¥¿çªå\nb\n") >> gives [6, 3].
  
  =head2 ta_strip($text) => STR
  
  Strip ANSI escape codes from C<$text>, returning the stripped text.
  
  =head2 ta_extract_codes($text) => STR
  
  This is the opposite of C<ta_strip()>, return only the ANSI codes in C<$text>.
  
  =head2 ta_split_codes($text) => LIST
  
  Split C<$text> to a list containing alternating ANSI escape codes and text. ANSI
  escape codes are always on the second element, fourth, and so on. Example:
  
   ta_split_codes("");              # => ()
   ta_split_codes("a");             # => ("a")
   ta_split_codes("a\e[31m");       # => ("a", "\e[31m")
   ta_split_codes("\e[31ma");       # => ("", "\e[31m", "a")
   ta_split_codes("\e[31ma\e[0m");  # => ("", "\e[31m", "a", "\e[0m")
   ta_split_codes("\e[31ma\e[0mb"); # => ("", "\e[31m", "a", "\e[0m", "b")
   ta_split_codes("\e[31m\e[0mb");  # => ("", "\e[31m\e[0m", "b")
  
  so you can do something like:
  
   my @parts = ta_split_codes($text);
   while (my ($text, $ansicode) = splice(@parts, 0, 2)) {
       ...
   }
  
  =head2 ta_split_codes_single($text) => LIST
  
  Like C<ta_split_codes()> but each ANSI escape code is split separately, instead
  of grouped together. This routine is currently used internally e.g. for
  C<ta_mbwrap()> and C<ta_highlight()> to trace color reset/replay codes.
  
  =head2 ta_wrap($text, $width, \%opts) => STR
  
  Like L<Text::WideChar::Util>'s wrap() except handles ANSI escape codes. Perform
  color reset at the end of each line and a color replay at the start of
  subsequent line so the text is safe for combining in a multicolumn/tabular
  layout.
  
  Options:
  
  =over
  
  =item * flindent => STR
  
  First line indent. See Text::WideChar::Util for more details.
  
  =item * slindent => STR
  
  First line indent. See Text::WideChar::Util for more details.
  
  =item * tab_width => INT (default: 8)
  
  First line indent. See Text::WideChar::Util for more details.
  
  =item * pad => BOOL (default: 0)
  
  If set to true, will pad each line to C<$width>. This is convenient if you need
  the lines padded, saves calls to ta_pad().
  
  =item * return_stats => BOOL (default: 0)
  
  If set to true, then instead of returning the wrapped string, function will
  return C<< [$wrapped, $stats] >> where C<$stats> is a hash containing some
  information like C<max_word_width>, C<min_word_width>.
  
  =back
  
  Performance: ~500/s on my Core i5 1.7GHz laptop for a ~1KB of text (with zero to
  moderate amount of color codes). As a comparison, Text::WideChar::Util's wrap()
  can do about 2000/s.
  
  =head2 ta_mbwrap($text, $width, \%opts) => STR
  
  Like ta_wrap(), but it uses ta_mbswidth() instead of ta_length(), so it can
  handle wide characters.
  
  Performance: ~300/s on my Core i5 1.7GHz laptop for a ~1KB of text (with zero to
  moderate amount of color codes). As a comparison, Text::WideChar::Util's
  mbwrap() can do about 650/s.
  
  =head2 ta_add_color_resets(@text) => LIST
  
  Make sure that a color reset command (add C<\e[0m>) to the end of each element
  and a replay of all the color codes from the previous element, from the last
  color reset) to the start of the next element, and so on. Return the new list.
  
  This makes each element safe to be combined with other array of text into a
  single line, e.g. in a multicolumn/tabular layout. An example:
  
  Without color resets:
  
   my @col1 = split /\n/, "\e[31mred\nmerah\e[0m";
   my @col2 = split /\n/, "\e[32mgreen\e[1m\nhijau tebal\e[0m";
  
   printf "%s | %s\n", $col1[0], $col2[0];
   printf "%s | %s\n", $col1[1], $col2[1];
  
  the printed output:
  
   \e[31mred | \e[32mgreen
   merah\e[0m | \e[1mhijau tebal\e[0m
  
  The C<merah> text on the second line will become green because of the effect of
  the last color command printed (C<\e[32m>). However, with ta_add_color_resets():
  
   my @col1 = ta_add_color_resets(split /\n/, "\e[31mred\nmerah\e[0m");
   my @col2 = ta_add_color_resets(split /\n/, "\e[32mgreen\e[1m\nhijau tebal\e[0m");
  
   printf "%s | %s\n", $col1[0], $col2[0];
   printf "%s | %s\n", $col1[1], $col2[1];
  
  the printed output (C<< <...> >>) marks the code added by ta_add_color_resets():
  
   \e[31mred<\e[0m> | \e[32mgreen\e[1m<\e[0m>
   <\e[31m>merah\e[0m | <\e[32m\e[1m>hijau tebal\e[0m
  
  All the cells are printed with the intended colors.
  
  =head2 ta_pad($text, $width[, $which[, $padchar[, $truncate]]]) => STR
  
  Return C<$text> padded with C<$padchar> to C<$width> columns. C<$which> is
  either "r" or "right" for padding on the right (the default if not specified),
  "l" or "left" for padding on the right, or "c" or "center" or "centre" for
  left+right padding to center the text.
  
  C<$padchar> is whitespace if not specified. It should be string having the width
  of 1 column.
  
  Does *not* handle multiline text; you can split text by C</\r?\n/> yourself.
  
  =head2 ta_mbpad($text, $width[, $which[, $padchar[, $truncate]]]) => STR
  
  Like ta_pad() but it uses ta_mbswidth() instead of ta_length(), so it can handle
  wide characters.
  
  =head2 ta_trunc($text, $width) => STR
  
  Truncate C<$text> to C<$width> columns while still including all the ANSI escape
  codes. This ensures that truncated text still reset colors, etc.
  
  Does *not* handle multiline text; you can split text by C</\r?\n/> yourself.
  
  =head2 ta_mbtrunc($text, $width) => STR
  
  Like ta_trunc() but it uses ta_mbswidth() instead of ta_length(), so it can
  handle wide characters.
  
  =head2 ta_highlight($text, $needle, $color) => STR
  
  Highlight the first occurence of C<$needle> in C<$text> with <$color>, taking
  care not to mess up existing colors.
  
  C<$needle> can be a string or a Regexp object.
  
  Implementation note: to not mess up colors, we save up all color codes from the
  last reset (C<\e[0m>) before inserting the highlight color + highlight text.
  Then we issue C<\e[0m> and the saved up color code to return back to the color
  state before the highlight is inserted. This is the same technique as described
  in ta_add_color_resets().
  
  =head2 ta_highlight_all($text, $needle, $color) => STR
  
  Like ta_highlight(), but highlight all occurences instead of only the first.
  
  =head1 FAQ
  
  =head2 How do I truncate string based on number of characters?
  
  You can simply use ta_trunc() even on text containing wide characters.
  ta_trunc() uses Perl's length() which works on a per-character basis.
  
  =head2 How do I highlight a string case-insensitively?
  
  You can currently use a regex for the C<$needle> and use the C<i> modifier.
  Example:
  
   use Term::ANSIColor;
   ta_highlight($text, qr/\b(foo)\b/i, color("bold red"));
  
  =head1 SEE ALSO
  
  L<Term::ANSIColor>
  
  L<Text::ANSITable> uses this module. In fact, this module was first created
  specifically for Text::ANSITable.
  
  http://en.wikipedia.org/wiki/ANSI_escape_code
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Text-ANSI-Util>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Text-ANSI-Util>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Text-ANSI-Util>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
TEXT_ANSI_UTIL

$fatpacked{"Text/LineFold.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_LINEFOLD';
  #-*- perl -*-
  
  package Text::LineFold;
  require 5.008;
  
  =encoding utf-8
  
  =head1 NAME
  
  Text::LineFold - Line Folding for Plain Text
  
  =head1 SYNOPSIS
  
      use Text::LineFold;
      $lf = Text::LineFold->new();
      
      # Fold lines
      $folded = $lf->fold($string, 'PLAIN');
      $indented = $lf->fold(' ' x 8, ' ' x 4, $string);
  
      # Unfold lines
      $unfolded = $lf->unfold($string, 'FIXED');
  
  =head1 DESCRIPTION
  
  Text::LineFold folds or unfolds lines of plain text.
  As it mainly focuses on plain text e-mail messages,
  RFC 3676 flowed format is also supported.
  
  =cut
  
  ### Pragmas:
  use strict;
  use vars qw($VERSION @EXPORT_OK @ISA $Config);
  
  ### Exporting:
  use Exporter;
  
  ### Inheritance:
  our @ISA = qw(Exporter Unicode::LineBreak);
  
  ### Other modules:
  use Carp qw(croak carp);
  use Encode qw(is_utf8);
  use MIME::Charset;
  use Unicode::LineBreak qw(:all);
  
  ### Globals
  
  ### The package Version
  our $VERSION = '2012.04';
  
  ### Public Configuration Attributes
  our $Config = {
      ### %{$Unicode::LineBreak::Config},
      Charset => 'UTF-8',
      Language => 'XX',
      OutputCharset => undef,
      TabSize => 8,
  };
  
  ### Privates
  
  my %FORMAT_FUNCS = (
      'FIXED' => sub {
  	my $self = shift;
  	my $action = shift;
  	my $str = shift;
  	if ($action =~ /^so[tp]/) {
  	    $self->{_} = {};
  	    $self->{_}->{'ColMax'} = $self->config('ColMax');
  	    $self->config('ColMax' => 0) if $str =~ /^>/;
  	} elsif ($action eq "") {
  	    $self->{_}->{line} = $str;
  	} elsif ($action eq "eol") {
  	    return $self->config('Newline');
  	} elsif ($action =~ /^eo/) {
  	    if (length $self->{_}->{line} and $self->config('ColMax')) {
  		$str = $self->config('Newline').$self->config('Newline');
  	    } else {
  		$str = $self->config('Newline');
  	    }
  	    $self->config('ColMax' => $self->{_}->{'ColMax'});
  	    delete $self->{_};
  	    return $str;
  	}
  	undef;
      },
      'FLOWED' => sub { # RFC 3676
  	my $self = shift;
  	my $action = shift;
  	my $str = shift;
  	if ($action eq 'sol') {
  	    if ($self->{_}->{prefix}) {
  		return $self->{_}->{prefix}.' '.$str;
  	    } elsif ($str =~ /^(?: |From |>)/) {
  		return ' '.$str;
  	    }
  	} elsif ($action =~ /^so/) {
  	    $self->{_} = {};
  	    if ($str =~ /^(>+)/) {
  		$self->{_}->{prefix} = $1;
  	    } else {
  		$self->{_}->{prefix} = '';
  		if ($str =~ /^(?: |From )/) {
  		    return ' '.$str;
  		}
  	    }
  	} elsif ($action eq "") {
  	    $self->{_}->{line} = $str;
  	} elsif ($action eq 'eol') {
  	    $str = ' ' if length $str;
  	    return $str.' '.$self->config('Newline');
  	} elsif ($action =~ /^eo/) {
  	    if (length $self->{_}->{line} and !length $self->{_}->{prefix}) {
  		$str = ' '.$self->config('Newline').$self->config('Newline');
  	    } else {
  		$str = $self->config('Newline');
  	    }
  	    delete $self->{_};
  	    return $str;
  	}
  	undef;
      },
      'PLAIN' => sub {
  	return $_[0]->config('Newline') if $_[1] =~ /^eo/;
  	undef;
      },
  );
  
  =head2 Public Interface
  
  =over 4
  
  =item new ([KEY => VALUE, ...])
  
  I<Constructor>.
  About KEY => VALUE pairs see config method.
  
  =back
  
  =cut
  
  sub new {
      my $class = shift;
      my $self = bless __PACKAGE__->SUPER::new(), $class;
      $self->config(@_);
      $self;
  }
  
  =over 4
  
  =item $self->config (KEY)
  
  =item $self->config ([KEY => VAL, ...])
  
  I<Instance method>.
  Get or update configuration.  Following KEY => VALUE pairs may be specified.
  
  =over 4
  
  =item Charset => CHARSET
  
  Character set that is used to encode string.
  It may be string or L<MIME::Charset> object.
  Default is C<"UTF-8">.
  
  =item Language => LANGUAGE
  
  Along with Charset option, this may be used to define language/region
  context.
  Default is C<"XX">.
  See also L<Unicode::LineBreak/Context> option.
  
  =item Newline => STRING
  
  String to be used for newline sequence.
  Default is C<"\n">.
  
  =item OutputCharset => CHARSET
  
  Character set that is used to encode result of fold()/unfold().
  It may be string or L<MIME::Charset> object.
  If a special value C<"_UNICODE_"> is specified, result will be Unicode string.
  Default is the value of Charset option.
  
  =item TabSize => NUMBER
  
  Column width of tab stops.
  When 0 is specified, tab stops are ignored.
  Default is 8.
  
  =item BreakIndent
  
  =item CharMax
  
  =item ColMax
  
  =item ColMin
  
  =item ComplexBreaking
  
  =item EAWidth
  
  =item HangulAsAL
  
  =item LBClass
  
  =item LegacyCM
  
  =item Prep
  
  =item Urgent
  
  See L<Unicode::LineBreak/Options>.
  
  =back
  
  =back
  
  =cut
  
  sub config {
      my $self = shift;
      my @opts = qw{Charset Language OutputCharset TabSize};
      my %opts = map { (uc $_ => $_) } @opts;
      my $newline = undef;
  
      # Get config.
      if (scalar @_ == 1) {
  	if ($opts{uc $_[0]}) {
  	    return $self->{$opts{uc $_[0]}};
  	}
  	return $self->SUPER::config($_[0]);
      }
  
      # Set config.
      my @o = ();
      my %params = @_;
      foreach my $k (keys %params) {
          my $v = $params{$k};
  	if ($opts{uc $k}) {
  	    $self->{$opts{uc $k}} = $v;
  	} elsif (uc $k eq uc 'Newline') {
  	    $newline = $v;
  	} else {
  	    push @o, $k => $v;
  	}
      }
      $self->SUPER::config(@o) if scalar @o;
  
      # Character set and language assumed.
      if (ref $self->{Charset} eq 'MIME::Charset') {
          $self->{_charset} = $self->{Charset};
      } else {
          $self->{Charset} ||= $Config->{Charset};
          $self->{_charset} = MIME::Charset->new($self->{Charset});
      }
      $self->{Charset} = $self->{_charset}->as_string;
      my $ocharset = uc($self->{OutputCharset} || $self->{Charset});
      $ocharset = MIME::Charset->new($ocharset)
  	unless ref $ocharset eq 'MIME::Charset' or $ocharset eq '_UNICODE_';
      unless ($ocharset eq '_UNICODE_') {
  	$self->{_charset}->encoder($ocharset);
  	$self->{OutputCharset} = $ocharset->as_string;
      }
      $self->{Language} = uc($self->{Language} || $Config->{Language});
  
      ## Context
      $self->SUPER::config(Context =>
  			 context(Charset => $self->{Charset},
  				 Language => $self->{Language}));
  
      ## Set sizing method.
      $self->SUPER::config(Sizing => sub {
  	my ($self, $cols, $pre, $spc, $str) = @_;
  
  	my $tabsize = $self->{TabSize};
  	my $spcstr = $spc.$str;
  	$spcstr->pos(0);
  	while (!$spcstr->eos and $spcstr->item->lbc == LB_SP) {
  	    my $c = $spcstr->next;
  	    if ($c eq "\t") {
  		$cols += $tabsize - $cols % $tabsize if $tabsize;
  	    } else {
  		$cols += $c->columns;
  	    }
  	}
  	return $cols + $spcstr->substr($spcstr->pos)->columns;
      });
  
      ## Classify horizontal tab as line breaking class SP.
      $self->SUPER::config(LBClass => [ord("\t") => LB_SP]);
      ## Tab size
      if (defined $self->{TabSize}) {
  	croak "Invalid TabSize option" unless $self->{TabSize} =~ /^\d+$/;
  	$self->{TabSize} += 0;
      } else {
  	$self->{TabSize} = $Config->{TabSize};
      }
  
      ## Newline
      if (defined $newline) {
  	$newline = $self->{_charset}->decode($newline)
  	    unless is_utf8($newline);
  	$self->SUPER::config(Newline => $newline);
      }
  }
  
  =over 4
  
  =item $self->fold (STRING, [METHOD])
  
  =item $self->fold (INITIAL_TAB, SUBSEQUENT_TAB, STRING, ...)
  
  I<Instance method>.
  fold() folds lines of string STRING and returns it.
  Surplus SPACEs and horizontal tabs at end of line are removed,
  newline sequences are replaced by that specified by Newline option
  and newline is appended at end of text if it does not exist.
  Horizontal tabs are treated as tab stops according to TabSize option.
  
  By the first style, following options may be specified for METHOD argument.
  
  =over 4
  
  =item C<"FIXED">
  
  Lines preceded by C<"E<gt>"> won't be folded.
  Paragraphs are separated by empty line.
  
  =item C<"FLOWED">
  
  C<"Format=Flowed; DelSp=Yes"> formatting defined by RFC 3676.
  
  =item C<"PLAIN">
  
  Default method.  All lines are folded.
  
  =back
  
  Second style is similar to L<Text::Wrap/wrap()>.
  All lines are folded.
  INITIAL_TAB is inserted at beginning of paragraphs and SUBSEQUENT_TAB
  at beginning of other broken lines.
  
  =back
  
  =cut
  
  # Special breaking characters: VT, FF, NEL, LS, PS
  my $special_break = qr/([\x{000B}\x{000C}\x{0085}\x{2028}\x{2029}])/os;
  
  sub fold {
      my $self = shift;
      my $str;
  
      if (2 < scalar @_) {
  	my $initial_tab = shift || '';
  	$initial_tab = $self->{_charset}->decode($initial_tab)
  	    unless is_utf8($initial_tab);
  	my $subsequent_tab = shift || '';
  	$subsequent_tab = $self->{_charset}->decode($subsequent_tab)
  	    unless is_utf8($subsequent_tab);
  	my @str = @_;
  
  	## Decode and concat strings.
  	$str = shift @str;
  	$str = $self->{_charset}->decode($str) unless is_utf8($str);
  	foreach my $s (@str) {
  	    next unless defined $s and length $s;
  
  	    $s = $self->{_charset}->decode($s) unless is_utf8($s);
  	    unless (length $str) {
  		$str = $s;
  	    } elsif ($str =~ /(\s|$special_break)$/ or
  		     $s =~ /^(\s|$special_break)/) {
  		$str .= $s;
  	    } else {
  		$str .= ' ' if $self->breakingRule($str, $s) == INDIRECT;
  		$str .= $s;
  	    }
  	}
  
  	## Set format method.
  	$self->SUPER::config(Format => sub {
  	    my $self = shift;
  	    my $event = shift;
  	    my $str = shift;
  	    if ($event =~ /^eo/) { return $self->config('Newline'); }
  	    if ($event =~ /^so[tp]/) { return $initial_tab.$str; }
  	    if ($event eq 'sol') { return $subsequent_tab.$str; }
  	    undef;
  	});
      } else {
  	$str = shift;
  	my $method = uc(shift || '');
  	return '' unless defined $str and length $str;
  
  	## Decode string.
  	$str = $self->{_charset}->decode($str) unless is_utf8($str);
  
  	## Set format method.
  	$self->SUPER::config(Format => $FORMAT_FUNCS{$method} ||
  			     $FORMAT_FUNCS{'PLAIN'});
      }
  
      ## Do folding.
      my $result = '';
      foreach my $s (split $special_break, $str) {
  	if ($s =~ $special_break) {
  	    $result .= $s;
  	} else {
  	    $result .= $self->break($str);
  	}
      }
  
      ## Encode result.
      if ($self->{OutputCharset} eq '_UNICODE_') {
          return $result;
      } else {
          return $self->{_charset}->encode($result);
      }
  }
  
  =over 4
  
  =item $self->unfold (STRING, METHOD)
  
  Conjunct folded paragraphs of string STRING and returns it.
  
  Following options may be specified for METHOD argument.
  
  =over 4
  
  =item C<"FIXED">
  
  Default method.
  Lines preceded by C<"E<gt>"> won't be conjuncted.
  Treat empty line as paragraph separator.
  
  =item C<"FLOWED">
  
  Unfold C<"Format=Flowed; DelSp=Yes"> formatting defined by RFC 3676.
  
  =item C<"FLOWEDSP">
  
  Unfold C<"Format=Flowed; DelSp=No"> formatting defined by RFC 3676.
  
  =begin comment
  
  =item C<"OBSFLOWED">
  
  Unfold C<"Format=Flowed> formatting defined by (obsoleted) RFC 2646
  as well as possible.
  
  =end comment
  
  =back
  
  =back
  
  =cut
  
  sub unfold {
      my $self = shift;
      my $str = shift;
      return '' unless defined $str and length $str;
  
      ## Get format method.
      my $method = uc(shift || 'FIXED');
      $method = 'FIXED' unless $method =~ /^(?:FIXED|FLOWED|FLOWEDSP|OBSFLOWED)$/;
      my $delsp = $method eq 'FLOWED';
  
      ## Decode string and canonizalize newline.
      $str = $self->{_charset}->decode($str) unless is_utf8($str);
      $str =~ s/\r\n|\r/\n/g;
  
      ## Do unfolding.
      my $result = '';
      foreach my $s (split $special_break, $str) {
  	if ($s eq '') {
  	    next;
  	} elsif ($s =~ $special_break) {
  	    $result .= $s;
  	    next;
  	} elsif ($method eq 'FIXED') {
  	    pos($s) = 0;
  	    while ($s !~ /\G\z/cg) {
  		if ($s =~ /\G\n/cg) {
  		    $result .= $self->config('Newline');
  		} elsif ($s =~ /\G(.+)\n\n/cg) {
  		    $result .= $1.$self->config('Newline');
  		} elsif ($s =~ /\G(>.*)\n/cg) {
  		    $result .= $1.$self->config('Newline');
  		} elsif ($s =~ /\G(.+)\n(?=>)/cg) {
  		    $result .= $1.$self->config('Newline');
  		} elsif ($s =~ /\G(.+?)( *)\n(?=(.+))/cg) {
  		    my ($l, $s, $n) = ($1, $2, $3);
  		    $result .= $l;
  		    if ($n =~ /^ /) {
  			$result .= $self->config('Newline');
  		    } elsif (length $s) {
  			$result .= $s;
  		    } elsif (length $l) {
  			$result .= ' '
  			    if $self->breakingRule($l, $n) == INDIRECT;
  		    }
  		} elsif ($s =~ /\G(.+)\n/cg) {
  		    $result .= $1.$self->config('Newline');
  		} elsif ($s =~ /\G(.+)/cg) {
  		    $result .= $1.$self->config('Newline');
  		    last;
  		}
  	    }
  	} elsif ($method eq 'FLOWED' or $method eq 'FLOWEDSP' or
  		 $method eq 'OBSFLOWED') {
  	    my $prefix = undef;
  	    pos($s) = 0;
  	    while ($s !~ /\G\z/cg) {
  		if ($s =~ /\G(>+) ?(.*?)( ?)\n/cg) {
  		    my ($p, $l, $s) = ($1, $2, $3);
  		    unless (defined $prefix) {
  			$result .= $p.' '.$l;
  		    } elsif ($p ne $prefix) {
  			$result .= $self->config('Newline');
  			$result .= $p.' '.$l;
  		    } else {
  			$result .= $l;
  		    }
  		    unless (length $s) {
  			$result .= $self->config('Newline');
  			$prefix = undef;
  		    } else {
  			$prefix = $p;
  			$result .= $s unless $delsp;
  		    }
  		} elsif ($s =~ /\G ?(.*?)( ?)\n/cg) {
  		    my ($l, $s) = ($1, $2);
  		    unless (defined $prefix) {
  			$result .= $l;
  		    } elsif ('' ne $prefix) {
  			$result .= $self->config('Newline');
  			$result .= $l;
  		    } else {
  			$result .= $l;
  		    }
  		    unless (length $s) {
  			$result .= $self->config('Newline');
  			$prefix = undef;
  		    } else {
  			$result .= $s unless $delsp;
  			$prefix = '';
  		    }
  		} elsif ($s =~ /\G ?(.*)/cg) {
  		    $result .= $1.$self->config('Newline');
  		    last;
  		}
  	    }
  	}
      }
      ## Encode result.
      if ($self->{OutputCharset} eq '_UNICODE_') {
          return $result;
      } else {
          return $self->{_charset}->encode($result);
      }
  }
  
  =head1 BUGS
  
  Please report bugs or buggy behaviors to developer.
  
  CPAN Request Tracker:
  L<http://rt.cpan.org/Public/Dist/Display.html?Name=Unicode-LineBreak>.
  
  =head1 VERSION
  
  Consult $VERSION variable.
  
  =head1 SEE ALSO
  
  L<Unicode::LineBreak>, L<Text::Wrap>.
  
  =head1 AUTHOR
  
  Copyright (C) 2009-2012 Hatuka*nezumi - IKEDA Soji <hatuka(at)nezumi.nu>.
  
  This program is free software; you can redistribute it and/or modify it 
  under the same terms as Perl itself.
  
  =cut
  
  1;
TEXT_LINEFOLD

$fatpacked{"Text/Table/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_TABLE_TINY';
  use strict;
  use warnings;
  package Text::Table::Tiny;
  use List::Util qw();
  
  # ABSTRACT: makes simple tables from two-dimensional arrays, with limited templating options
  
  
  our $COLUMN_SEPARATOR = '|';
  our $ROW_SEPARATOR = '-';
  our $CORNER_MARKER = '+';
  our $HEADER_ROW_SEPARATOR = '=';
  our $HEADER_CORNER_MARKER = 'O';
  
  sub table {
  
      my %params = @_;
      my $rows = $params{rows} or die "Must provide rows!";
  
      # foreach col, get the biggest width
      my $widths = _maxwidths($rows);
      my $max_index = _max_array_index($rows);
  
      # use that to get the field format and separators
      my $format = _get_format($widths);
      my $row_sep = _get_row_separator($widths);
      my $head_row_sep = _get_header_row_separator($widths);
  
      # here we go...
      my @table;
      push @table, $row_sep;
  
      # if the first row's a header:
      my $data_begins = 0;
      if ( $params{header_row} ) {
          my $header_row = $rows->[0];
  	$data_begins++;
          push @table, sprintf(
  	    $format, 
  	    map { defined($header_row->[$_]) ? $header_row->[$_] : '' } (0..$max_index)
  	);
          push @table, $params{separate_rows} ? $head_row_sep : $row_sep;
      }
  
      # then the data
      foreach my $row ( @{ $rows }[$data_begins..$#$rows] ) {
          push @table, sprintf(
  	    $format, 
  	    map { defined($row->[$_]) ? $row->[$_] : '' } (0..$max_index)
  	);
          push @table, $row_sep if $params{separate_rows};
      }
  
      # this will have already done the bottom if called explicitly
      push @table, $row_sep unless $params{separate_rows};
      return join("\n",grep {$_} @table);
  }
  
  sub _get_cols_and_rows ($) {
      my $rows = shift;
      return ( List::Util::max( map { scalar @$_ } @$rows), scalar @$rows);
  }
  
  sub _maxwidths {
      my $rows = shift;
      # what's the longest array in this list of arrays?
      my $max_index = _max_array_index($rows);
      my $widths = [];
      for my $i (0..$max_index) {
          # go through the $i-th element of each array, find the longest
          my $max = List::Util::max(map {defined $$_[$i] ? length($$_[$i]) : 0} @$rows);
          push @$widths, $max;
      }
      return $widths;
  }
  
  # return highest top-index from all rows in case they're different lengths
  sub _max_array_index {
      my $rows = shift;
      return List::Util::max( map { $#$_ } @$rows );
  }
  
  sub _get_format {
      my $widths = shift;
      return "$COLUMN_SEPARATOR ".join(" $COLUMN_SEPARATOR ",map { "%-${_}s" } @$widths)." $COLUMN_SEPARATOR";
  }
  
  sub _get_row_separator {
      my $widths = shift;
      return "$CORNER_MARKER$ROW_SEPARATOR".join("$ROW_SEPARATOR$CORNER_MARKER$ROW_SEPARATOR",map { $ROW_SEPARATOR x $_ } @$widths)."$ROW_SEPARATOR$CORNER_MARKER";
  }
  
  sub _get_header_row_separator {
      my $widths = shift;
      return "$HEADER_CORNER_MARKER$HEADER_ROW_SEPARATOR".join("$HEADER_ROW_SEPARATOR$HEADER_CORNER_MARKER$HEADER_ROW_SEPARATOR",map { $HEADER_ROW_SEPARATOR x $_ } @$widths)."$HEADER_ROW_SEPARATOR$HEADER_CORNER_MARKER";
  }
  
  1;
  
  __END__
  =pod
  
  =head1 NAME
  
  Text::Table::Tiny - makes simple tables from two-dimensional arrays, with limited templating options
  
  =head1 VERSION
  
  version 0.03
  
  =head1 OPTIONS
  
  =over 4
  
  =item *
  
  header_row
  
  true/false, designate first row in $rows as a header row and separate with a line
  
  =item *
  
  separate_rows
  
  true/false put a separator line between rows and use a thicker line for header separator
  
  =back
  
  =head1 SYNOPSIS
  
      use Text::Table::Tiny;
      my $rows = [
          # header row
          ['Name', 'Rank', 'Serial'],
          # rows
          ['alice', 'pvt', '123456'],
          ['bob',   'cpl', '98765321'],
          ['carol', 'brig gen', '8745'],
      ];
      # separate rows puts lines between rows, header_row says that the first row is headers
      print Text::Table::Tiny::table(rows => $rows, separate_rows => 1, header_row => 1);
  
    Example in the synopsis: Text::Table::Tiny::table(rows => $rows);
  
      +-------+----------+----------+
      | Name  | Rank     | Serial   |
      | alice | pvt      | 123456   |
      | bob   | cpl      | 98765321 |
      | carol | brig gen | 8745     |
      +-------+----------+----------+
  
    with header_row: Text::Table::Tiny::table(rows => $rows, header_row => 1);
  
      +-------+----------+----------+
      | Name  | Rank     | Serial   |
      +-------+----------+----------+
      | alice | pvt      | 123456   |
      | bob   | cpl      | 98765321 |
      | carol | brig gen | 8745     |
      +-------+----------+----------+
  
    with header_row and separate_rows: Text::Table::Tiny::table(rows => $rows, header_row => 1, separate_rows => 1);
  
      +-------+----------+----------+
      | Name  | Rank     | Serial   |
      O=======O==========O==========O
      | alice | pvt      | 123456   |
      +-------+----------+----------+
      | bob   | cpl      | 98765321 |
      +-------+----------+----------+
      | carol | brig gen | 8745     |
      +-------+----------+----------+
  
  =head1 FORMAT VARIABLES
  
  =over 4
  
  =item *
  
  $Text::Table::Tiny::COLUMN_SEPARATOR = '|';
  
  =item *
  
  $Text::Table::Tiny::ROW_SEPARATOR = '-';
  
  =item *
  
  $Text::Table::Tiny::CORNER_MARKER = '+';
  
  =item *
  
  $Text::Table::Tiny::HEADER_ROW_SEPARATOR = '=';
  
  =item *
  
  $Text::Table::Tiny::HEADER_CORNER_MARKER = 'O';
  
  =back
  
  =head1 AUTHOR
  
  Creighton Higgins <chiggins@chiggins.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2012 by Creighton Higgins.
  
  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
  
TEXT_TABLE_TINY

$fatpacked{"Text/WideChar/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_WIDECHAR_UTIL';
  package Text::WideChar::Util;
  
  our $DATE = '2015-01-03'; # DATE
  our $VERSION = '0.14'; # VERSION
  
  use 5.010001;
  use locale;
  use strict;
  use utf8;
  use warnings;
  
  use Unicode::GCString;
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT_OK = qw(
                         mbpad
                         pad
                         mbswidth
                         mbswidth_height
                         length_height
                         mbtrunc
                         trunc
                         mbwrap
                         wrap
                 );
  
  sub mbswidth {
      Unicode::GCString->new($_[0])->columns;
  }
  
  sub mbswidth_height {
      my $text = shift;
      my $num_lines = 0;
      my $len = 0;
      for my $e (split /(\r?\n)/, $text) {
          if ($e =~ /\n/) {
              $num_lines++;
              next;
          }
          $num_lines = 1 if $num_lines == 0;
          my $l = mbswidth($e);
          $len = $l if $len < $l;
      }
      [$len, $num_lines];
  }
  
  sub length_height {
      my $text = shift;
      my $num_lines = 0;
      my $len = 0;
      for my $e (split /(\r?\n)/, $text) {
          if ($e =~ /\n/) {
              $num_lines++;
              next;
          }
          $num_lines = 1 if $num_lines == 0;
          my $l = length($e);
          $len = $l if $len < $l;
      }
      [$len, $num_lines];
  }
  
  sub _get_indent_width {
      my ($is_mb, $indent, $tab_width) = @_;
      my $w = 0;
      for (split //, $indent) {
          if ($_ eq "\t") {
              # go to the next tab
              $w = $tab_width * (int($w/$tab_width) + 1);
          } else {
              $w += $is_mb ? mbswidth($_) : 1;
          }
      }
      $w;
  }
  
  our $re_cjk = qr/(?:
                       \p{Block=CJK_Compatibility}
                   |   \p{Block=CJK_Compatibility_Forms}
                   |   \p{Block=CJK_Compatibility_Ideographs}
                   |   \p{Block=CJK_Compatibility_Ideographs_Supplement}
                   |   \p{Block=CJK_Radicals_Supplement}
                   |   \p{Block=CJK_Strokes}
                   |   \p{Block=CJK_Symbols_And_Punctuation}
                   |   \p{Block=CJK_Unified_Ideographs}
                   |   \p{Block=CJK_Unified_Ideographs_Extension_A}
                   |   \p{Block=CJK_Unified_Ideographs_Extension_B}
                       #|   \p{Block=CJK_Unified_Ideographs_Extension_C}
                       [ï¼ã]
                   )/x;
  our $re_cjk_class = qr/[
                             \p{Block=CJK_Compatibility}
                             \p{Block=CJK_Compatibility_Forms}
                             \p{Block=CJK_Compatibility_Ideographs}
                             \p{Block=CJK_Compatibility_Ideographs_Supplement}
                             \p{Block=CJK_Radicals_Supplement}
                             \p{Block=CJK_Strokes}
                             \p{Block=CJK_Symbols_And_Punctuation}
                             \p{Block=CJK_Unified_Ideographs}
                             \p{Block=CJK_Unified_Ideographs_Extension_A}
                             \p{Block=CJK_Unified_Ideographs_Extension_B}
                             ï¼ã
                        ]/x;
  our $re_cjk_negclass = qr/[^
                                \p{Block=CJK_Compatibility}
                                \p{Block=CJK_Compatibility_Forms}
                                \p{Block=CJK_Compatibility_Ideographs}
                                \p{Block=CJK_Compatibility_Ideographs_Supplement}
                                \p{Block=CJK_Radicals_Supplement}
                                \p{Block=CJK_Strokes}
                                \p{Block=CJK_Symbols_And_Punctuation}
                                \p{Block=CJK_Unified_Ideographs}
                                \p{Block=CJK_Unified_Ideographs_Extension_A}
                                \p{Block=CJK_Unified_Ideographs_Extension_B}
                                ï¼ã
                        ]/x;
  
  sub _wrap {
      my ($is_mb, $text, $width, $opts) = @_;
      $width //= 80;
      $opts  //= {};
  
      # our algorithm: split into paragraphs, then process each paragraph. at the
      # start of paragraph, determine indents (either from %opts, or deduced from
      # text, like in Emacs) then push first-line indent. proceed to push words,
      # while adding subsequent-line indent at the start of each line.
  
      my $tw = $opts->{tab_width} // 8;
      die "Please specify a positive tab width" unless $tw > 0;
      my $optfli  = $opts->{flindent};
      my $optfliw = _get_indent_width($is_mb, $optfli, $tw) if defined $optfli;
      my $optsli  = $opts->{slindent};
      my $optsliw = _get_indent_width($is_mb, $optsli, $tw) if defined $optsli;
      my @res;
  
      my @para = split /(\n(?:[ \t]*\n)+)/, $text;
      #say "D:para=[",join(", ", @para),"]";
  
      my ($maxww, $minww);
  
    PARA:
      while (my ($ptext, $pbreak) = splice @para, 0, 2) {
          my $x = 0;
          my $y = 0;
          my $line_has_word = 0;
  
          # determine indents
          my ($fli, $sli, $fliw, $sliw);
          if (defined $optfli) {
              $fli  = $optfli;
              $fliw = $optfliw;
          } else {
              # XXX emacs can also treat ' #' as indent, e.g. when wrapping
              # multi-line perl comment.
              ($fli) = $ptext =~ /\A([ \t]*)\S/;
              if (defined $fli) {
                  $fliw = _get_indent_width($is_mb, $fli, $tw);
              } else {
                  $fli  = "";
                  $fliw = 0;
              }
          }
          if (defined $optsli) {
              $sli  = $optsli;
              $sliw = $optsliw;
          } else {
              ($sli) = $ptext =~ /\A[^\n]*\S[\n]([ \t+]*)\S/;
              if (defined $sli) {
                  $sliw = _get_indent_width($is_mb, $sli, $tw);
              } else {
                  $sli  = "";
                  $sliw = 0;
              }
          }
          die "Subsequent indent must be less than width" if $sliw >= $width;
  
          push @res, $fli;
          $x += $fliw;
  
          my @words0; # (WORD1, WORD1_IS_CJK?, WS_AFTER?, WORD2, WORD2_IS_CJK?, WS_AFTER?, ...)
          # we differentiate/split between CJK "word" (cluster of CJK letters,
          # really) and non-CJK word, e.g. "æå¾ç±ä½ myå¯ç±çand beautiful,
          # beautiful wife" is split to ["æå¾ç±ä½ ", "my", "å¯ç±ç", "and",
          # "beautiful,", "beautiful", "wife"]. we do this because CJK word can be
          # line-broken on a per-letter basis, as they don't separate words with
          # whitespaces.
          while ($ptext =~ /(?: ($re_cjk+)|(\S+) ) (\s*)/gox) {
              my $ws_after = $3 ? 1:0;
              if ($1) {
                  push @words0, $1, 1, $ws_after;
              } else {
                  my $ptext2 = $2;
                  while ($ptext2 =~ /($re_cjk_class+)|
                                     ($re_cjk_negclass+)/gox) {
                      if ($1) {
                          push @words0, $1, 1, 0;
                      } else {
                          push @words0, $2, 0, 0;
                      }
                  }
                  $words0[-1] = $ws_after;
              }
          }
  
          # process each word
          my $prev_ws_after;
          while (@words0) {
              my ($word0, $is_cjk, $ws_after) = splice @words0, 0, 3;
              my @words;
              my @wordsw;
              while (1) {
                  my $wordw = $is_mb ? mbswidth($word0) : length($word0);
  
                  # long cjk word is not truncated here because it will be
                  # line-broken later when wrapping.
                  if ($wordw <= $width-$sliw || $is_cjk) {
                      push @words , $word0;
                      push @wordsw, $wordw;
                      last;
                  }
                  # truncate long word
                  if ($is_mb) {
                      my $res = mbtrunc($word0, $width-$sliw, 1);
                      push @words , $res->[0];
                      push @wordsw, $res->[1];
                      $word0 = substr($word0, length($res->[0]));
                      #say "D:truncated long word (mb): $text -> $res->[0] & $res->[1], word0=$word0";
                  } else {
                      my $w2 = substr($word0, 0, $width-$sliw);
                      push @words , $w2;
                      push @wordsw, $width-$sliw;
                      $word0 = substr($word0, $width-$sliw);
                      #say "D:truncated long word: $w2, ".($width-$sliw).", word0=$word0";
                  }
              }
  
              for my $word (@words) {
                  my $wordw = shift @wordsw;
                  #say "D:x=$x word=$word is_cjk=$is_cjk ws_after=$ws_after wordw=$wordw line_has_word=$line_has_word width=$width";
  
                  $maxww = $wordw if !defined($maxww) || $maxww < $wordw;
                  $minww = $wordw if !defined($minww) || $minww > $wordw;
  
                  my $x_after_word = $x + ($line_has_word ? 1:0) + $wordw;
                  if ($x_after_word <= $width) {
                      # the addition of word hasn't exceeded column width
                      if ($line_has_word) {
                          if ($prev_ws_after) {
                              push @res, " ";
                              $x++;
                          }
                      }
                      push @res, $word;
                      $x += $wordw;
                  } else {
                      while (1) {
                          if ($is_cjk) {
                              # CJK word can be broken
                              my $res;
                              if ($prev_ws_after) {
                                  $res = mbtrunc($word, $width - $x - 1, 1);
                                  push @res, " ", $res->[0];
                              } else {
                                  $res = mbtrunc($word, $width - $x, 1);
                                  push @res, $res->[0];
                              }
                              my $word2 = substr($word, length($res->[0]));
                              #say "D:truncated CJK word: $word -> $res->[0] & $res->[1], remaining=$word2";
                              $word = $word2;
                              $wordw = mbswidth($word);
                          }
  
                          # move the word to the next line
                          push @res, "\n", $sli;
                          $y++;
  
                          if ($sliw + $wordw <= $width) {
                              push @res, $word;
                              $x = $sliw + $wordw;
                              last;
                          } else {
                              # still too long, truncate again
                              $x = $sliw;
                          }
                      }
                  }
                  $line_has_word++;
              }
              $prev_ws_after = $ws_after;
          }
  
          if (defined $pbreak) {
              push @res, $pbreak;
          } else {
              push @res, "\n" if $ptext =~ /\n[ \t]*\z/;
          }
      }
  
      if ($opts->{return_stats}) {
          return [join("", @res), {
              max_word_width => $maxww,
              min_word_width => $minww,
          }];
      } else {
          return join("", @res);
      }
  }
  
  sub mbwrap {
      _wrap(1, @_);
  }
  
  sub wrap {
      _wrap(0, @_);
  }
  
  sub _pad {
      my ($is_mb, $text, $width, $which, $padchar, $is_trunc) = @_;
      if ($which) {
          $which = substr($which, 0, 1);
      } else {
          $which = "r";
      }
      $padchar //= " ";
  
      my $w = $is_mb ? mbswidth($text) : length($text);
      if ($is_trunc && $w > $width) {
          my $res = mbtrunc($text, $width, 1);
          $text = $res->[0] . ($padchar x ($width-$res->[1]));
      } else {
          if ($which eq 'l') {
              $text = ($padchar x ($width-$w)) . $text;
          } elsif ($which eq 'c') {
              my $n = int(($width-$w)/2);
              $text = ($padchar x $n) . $text . ($padchar x ($width-$w-$n));
          } else {
              $text .= ($padchar x ($width-$w));
          }
      }
      $text;
  }
  
  sub mbpad {
      _pad(1, @_);
  }
  
  sub pad {
      _pad(0, @_);
  }
  
  sub _trunc {
      my ($is_mb, $text, $width, $return_width) = @_;
  
      # return_width (undocumented): if set to 1, will return [truncated_text,
      # visual width, length(chars) up to truncation point]
  
      my $w = $is_mb ? mbswidth($text) : length($text);
      die "Invalid argument, width must not be negative" unless $width >= 0;
      if ($w <= $width) {
          return $return_width ? [$text, $w, length($text)] : $text;
      }
  
      my $c = 0;
  
      # perform binary cutting
      my @res;
      my $wres = 0; # total width of text in @res
      my $l = int($w/2); $l = 1 if $l == 0;
      my $end = 0;
      while (1) {
          my $left  = substr($text, 0, $l);
          my $right = $l > length($text) ? "" : substr($text, $l);
          my $wl = $is_mb ? mbswidth($left) : length($left);
          #say "D:left=$left, right=$right, wl=$wl";
          if ($wres + $wl > $width) {
              $text = $left;
          } else {
              push @res, $left;
              $wres += $wl;
              $c += length($left);
              $text = $right;
          }
          $l = int(($l+1)/2);
          #say "D:l=$l";
          last if $l==1 && $end>1;
          $end++ if $l==1;
      }
      if ($return_width) {
          return [join("", @res), $wres, $c];
      } else {
          return join("", @res);
      }
  }
  
  sub mbtrunc {
      _trunc(1, @_);
  }
  
  sub trunc {
      _trunc(0, @_);
  }
  
  1;
  # ABSTRACT: Routines for text containing wide characters
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Text::WideChar::Util - Routines for text containing wide characters
  
  =head1 VERSION
  
  This document describes version 0.14 of Text::WideChar::Util (from Perl distribution Text-WideChar-Util), released on 2015-01-03.
  
  =head1 SYNOPSIS
  
   use Text::WideChar::Util qw(
       mbpad pad mbswidth mbswidth_height mbtrunc trunc mbwrap wrap);
  
   # get width as well as number of lines
   say mbswidth_height("red\nçº¢è²"); # => [4, 2]
  
   # wrap text to a certain column width
   say mbwrap("....", 40);
  
   # pad (left, right, center) text to specified column width, handle multilines
   say mbpad("foo", 10);                          # => "foo       "
   say mbpad("çº¢è²", 10, "left");                 # => "      çº¢è²"
   say mbpad("foo\nbarbaz\n", 10, "center", "."); # => "...foo....\n..barbaz..\n"
  
   # truncate text to a certain column width
   say mbtrunc("çº¢è²",  2); # => "çº¢"
   say mbtrunc("çº¢è²",  3); # => "çº¢"
   say mbtrunc("çº¢red", 3); # => "çº¢r"
  
  =head1 DESCRIPTION
  
  This module provides routines for dealing with text containing wide characters
  (wide meaning occupying more than 1 column width in terminal).
  
  =head1 FUNCTIONS
  
  =head2 mbswidth($text) => INT
  
  Like L<Text::CharWidth>'s mbswidth(), except implemented using L<<
  Unicode::GCString->new($text)->columns >>.
  
  =head2 mbswidth_height($text) => [INT, INT]
  
  Like mbswidth(), but also gives height (number of lines). For example, C<<
  mbswidth_height("foobar\nb\n") >> gives [6, 3].
  
  =head2 length_height($text) => [INT, INT]
  
  This is the non-wide version of mbswidth_height() and can be used if your text
  only contains printable ASCII characters and newlines.
  
  =head2 mbwrap($text, $width, \%opts) => STR
  
  Wrap C<$text> to C<$width> columns. It uses mbswidth() instead of Perl's
  length() which works on a per-character basis. Has some support for wrapping
  Kanji/CJK (Chinese/Japanese/Korean) text which do not have whitespace between
  words.
  
  Options:
  
  =over
  
  =item * tab_width => INT (default: 8)
  
  Set tab width.
  
  Note that tab will only have effect on the indent. Tab between text will be
  replaced with a single space.
  
  =item * flindent => STR
  
  First line indent. If unspecified, will be deduced from the first line of text.
  
  =item * slindent => STD
  
  Subsequent line indent. If unspecified, will be deduced from the second line of
  text, or if unavailable, will default to empty string (C<"">).
  
  =item * return_stats => BOOL (default: 0)
  
  If set to true, then instead of returning the wrapped string, function will
  return C<< [$wrapped, $stats] >> where C<$stats> is a hash containing some
  information like C<max_word_width>, C<min_word_width>.
  
  =back
  
  Performance: ~450/s on my Core i5 1.7GHz laptop for a 1KB of text.
  
  =head2 wrap($text, $width, \%opts) => STR
  
  Like mbwrap(), but uses character-based length() instead of column width-wise
  mbswidth(). Provided as an alternative to the venerable L<Text::Wrap>'s wrap()
  but with a different behaviour. This module's wrap() can reflow newline and its
  behavior is more akin to Emacs (try reflowing a paragraph in Emacs using
  C<M-q>).
  
  Performance: ~2000/s on my Core i5 1.7GHz laptop for a ~1KB of text.
  Text::Wrap::wrap() on the other hand is ~2500/s.
  
  =head2 mbpad($text, $width[, $which[, $padchar[, $truncate]]]) => STR
  
  Return C<$text> padded with C<$padchar> to C<$width> columns. C<$which> is
  either "r" or "right" for padding on the right (the default if not specified),
  "l" or "left" for padding on the right, or "c" or "center" or "centre" for
  left+right padding to center the text.
  
  C<$padchar> is whitespace if not specified. It should be string having the width
  of 1 column.
  
  =head2 pad($text, $width[, $which[, $padchar[, $truncate]]]) => STR
  
  The non-wide version of mbpad(), just like in mbwrap() vs wrap().
  
  =head2 mbtrunc($text, $width) => STR
  
  Truncate C<$text> to C<$width> columns. It uses mbswidth() instead of Perl's
  length(), so it can handle wide characters.
  
  Does *not* handle multiple lines.
  
  =head2 trunc($text, $width) => STR
  
  The non-wide version of mbtrunc(), just like in mbwrap() vs wrap(). This is
  actually not much more than Perl's C<< substr($text, 0, $width) >>.
  
  =head1 INTERNAL NOTES
  
  Should we wrap at hyphens? Probably not. Both Emacs as well as Text::Wrap do
  not.
  
  =head1 SEE ALSO
  
  L<Unicode::GCString> which is consulted for visual width of characters.
  L<Text::CharWidth> is about 2.5x faster but it gives weird results (-1 for
  characters like "\n" and "\t") and my Strawberry Perl installation fails to
  build it.
  
  L<Text::ANSI::Util> which can also handle text containing wide characters as
  well ANSI escape codes.
  
  L<Text::WrapI18N> which provides an alternative to wrap()/mbwrap() with
  comparable speed, though wrapping result might differ slightly. And the module
  currently uses Text::CharWidth.
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Text-WideChar-Util>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Text-WideChar-Util>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Text-WideChar-Util>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
TEXT_WIDECHAR_UTIL

$fatpacked{"Text/sprintfn.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_SPRINTFN';
  package Text::sprintfn;
  
  use 5.010001;
  use strict;
  use warnings;
  
  require Exporter;
  our @ISA       = qw(Exporter);
  our @EXPORT    = qw(sprintfn printfn);
  
  our $VERSION = '0.07'; # VERSION
  
  our $distance  = 10;
  
  my  $re1   = qr/[^)]+/s;
  my  $re2   = qr{(?<fmt>
                      %
                         (?<pi> \d+\$ | \((?<npi>$re1)\)\$?)?
                         (?<flags> [ +0#-]+)?
                         (?<vflag> \*?[v])?
                         (?<width> -?\d+ |
                             \*\d+\$? |
                             \((?<nwidth>$re1)\))?
                         (?<dot>\.?)
                         (?<prec>
                             (?: \d+ | \* |
                             \((?<nprec>$re1)\) ) ) ?
                         (?<conv> [%csduoxefgXEGbBpniDUOF])
                     )}x;
  our $regex = qr{($re2|%|[^%]+)}s;
  
  # faster version, without using named capture
  if (1) {
      $regex = qr{( #all=1
                      ( #fmt=2
                          %
                          (#pi=3
                              \d+\$ | \(
                              (#npi=4
                                  [^)]+)\)\$?)?
                          (#flags=5
                              [ +0#-]+)?
                          (#vflag=6
                              \*?[v])?
                          (#width=7
                              -?\d+ |
                              \*\d+\$? |
                              \((#nwidth=8
                                  [^)]+)\))?
                          (#dot=9
                              \.?)
                          (#prec=10
                              (?: \d+ | \* |
                                  \((#nprec=11
                                      [^)]+)\) ) ) ?
                          (#conv=12
                              [%csduoxefgXEGbBpniDUOF])
                      ) | % | [^%]+
                  )}xs;
  }
  
  sub sprintfn {
      my ($format, @args) = @_;
  
      my $hash;
      if (ref($args[0]) eq 'HASH') {
          $hash = shift(@args);
      }
      return sprintf($format, @args) if !$hash;
  
      my %indexes; # key = $hash key, value = index for @args
      push @args, (undef) x $distance;
  
      $format =~ s{$regex}{
          my ($all, $fmt, $pi, $npi, $flags,
              $vflag, $width, $nwidth, $dot, $prec,
              $nprec, $conv) =
              ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12);
  
          my $res;
          if ($fmt) {
  
              if (defined $npi) {
                  my $i = $indexes{$npi};
                  if (!$i) {
                      $i = @args + 1;
                      push @args, $hash->{$npi};
                      $indexes{$npi} = $i;
                  }
                  $pi = "${i}\$";
              }
  
              if (defined $nwidth) {
                  $width = $hash->{$nwidth};
              }
  
              if (defined $nprec) {
                  $prec = $hash->{$nprec};
              }
  
              $res = join("",
                  grep {defined} (
                      "%",
                      $pi, $flags, $vflag,
                      $width, $dot, $prec, $conv)
                  );
          } else {
              my $i = @args + 1;
              push @args, $all;
              $res = "\%${i}\$s";
          }
          $res;
      }xego;
  
      # DEBUG
      #use Data::Dump; dd [$format, @args];
  
      sprintf $format, @args;
  }
  
  sub printfn {
      print sprintfn @_;
  }
  
  1;
  # ABSTRACT: Drop-in replacement for sprintf(), with named parameter support
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Text::sprintfn - Drop-in replacement for sprintf(), with named parameter support
  
  =head1 VERSION
  
  This document describes version 0.07 of Text::sprintfn (from Perl distribution Text-sprintfn), released on 2015-01-03.
  
  =head1 SYNOPSIS
  
   use Text::sprintfn; # by default exports sprintfn() and printfn()
  
   # with no hash, behaves just like printf
   printfn '<%04d>', 1, 2; # <0001>
  
   # named parameter
   printfn '<%(v1)-4d>', {v1=>-2}; # <-2  >
  
   # mixed named and positional
   printfn '<%d> <%(v1)d> <%d>', {v1=>1}, 2, 3; # <2> <1> <3>
  
   # named width
   printfn "<%(v1)(v2).1f>", {v1=>3, v2=>4}; # <   3>
  
   # named precision
   printfn "<%(v1)(v2).(v2)f>", {v1=>3, v2=>4}; # <3.0000>
  
  =head1 DESCRIPTION
  
  This module provides sprintfn() and printfn(), which are like sprintf() and
  printf(), with the exception that they support named parameters from a hash.
  
  =head1 FUNCTIONS
  
  =head2 sprintfn $fmt, \%hash, ...
  
  If first argument after format is not a hash, sprintfn() will behave exactly
  like sprintf().
  
  If hash is given, sprintfn() will look for named parameters in argument and
  supply the values from the hash. Named parameters are surrounded with
  parentheses, i.e. "(NAME)". They can occur in format parameter index:
  
   %2$d        # sprintf version, take argument at index 2
   %(two)d     # $ is optional
   %(two)$d    # same
  
  or in width:
  
   %-10d       # sprintf version, use (minimum) width of 10
   %-(width)d  # like sprintf, but use width from hash key 'width'
   %(var)-(width)d  # format hash key 'var' with width from hash key 'width'
  
  or in precision:
  
   %6.2f       # sprintf version, use precision of 2 decimals
   %6.(prec)f  # like sprintf, but use precision from hash key 'prec'
   %(width).(prec)f
   %(var)(width).(prec)f
  
  The existence of formats using hash keys will not affect indexes of the rest of
  the argument, example:
  
   sprintfn "<%(v1)s> <%2$d> <%d>", {v1=>10}, 0, 1, 2; # "<10> <2> <0>"
  
  Like sprintf(), if format is unknown/erroneous, it will be printed as-is.
  
  There is currently no way to escape ")" in named parameter, e.g.:
  
   %(var containing ))s
  
  =head2 printfn $fmt, ...
  
  Equivalent to: print sprintfn($fmt, ...).
  
  =head1 RATIONALE
  
  There exist other CPAN modules for string formatting with named parameter
  support. Two of such modules are L<String::Formatter> and
  L<Text::Sprintf::Named>. This module is far simpler to use and retains all of
  the features of Perl's sprintf() (which we like, or perhaps hate, but
  nevertheless are familiar with).
  
  String::Formatter requires you to create a new formatter function first.
  Text::Sprintf::Named also accordingly requires you to instantiate an object
  first. There is currently no way to mix named and positional parameters. And you
  don't get the full features of sprintf().
  
  =head1 HOW IT WORKS
  
  Text::sprintfn works by converting the format string into sprintf format, i.e.
  replacing the named parameters like C<%(foo)s> to something like C<%11$s>.
  
  =head1 DOWNSIDES
  
  Currently the main downside is speed. On my computer, sprintfn() is about two
  orders of magnitude slower than plain sprintf(). A simple benchmark on my PC
  (Core i5-2400 @ 3.1GHz):
  
   $ bench -MText::sprintfn -n -2 'sprintf("%s %d %d", "one", 2, 3)' 'sprintfn("%(str)s %d %d", {str=>"one"}, 2, 3)'
   Benchmarking a => sub { sprintf("%s %d %d", "one", 2, 3) }, b => sub { sprintfn("%(str)s %d %d", {str=>"one"}, 2, 3) } ...
   a: 13666654 calls (6831551/s), 2.001s (0.0001ms/call)
   b: 72461 calls (35045/s), 2.068s (0.0285ms/call)
   Fastest is a (194.9x b)
  
  =head1 TIPS AND TRICKS
  
  =head2 Common mistake 1
  
  Writing
  
   %(var)
  
  instead of
  
   %(var)s
  
  =head2 Common mistake 2 (a bit more newbish)
  
  Writing
  
   sprintfn $format, %hash, ...;
  
  instead of
  
   sprintfn $format, \%hash, ...;
  
  =head2 Alternative hashes
  
  You have several hashes (%h1, %h2, %h3) which should be consulted for values.
  You can either merge the hash first:
  
   %h = (%h1, %h2, %h3); # or use some hash merging module
   printfn $format, \%h, ...;
  
  or create a tied hash which can consult hashes for you:
  
   tie %h, 'Your::Module', \%h1, \%h2, \%h3;
   printfn $format, \%h, ...;
  
  =head1 SEE ALSO
  
  sprintf() section on L<perlfunc>
  
  L<String::Formatter>
  
  L<Text::Sprintf::Named>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Text-sprintfn>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Text-sprintfn>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Text-sprintfn>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
TEXT_SPRINTFN

$fatpacked{"Tie/IxHash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIE_IXHASH';
  #
  # Tie/IxHash.pm
  #
  # Indexed hash implementation for Perl
  #
  # See below for documentation.
  #
  
  require 5.005;
  
  package Tie::IxHash;
  use strict;
  use integer;
  require Tie::Hash;
  use vars qw/@ISA $VERSION/;
  @ISA = qw(Tie::Hash);
  
  $VERSION = $VERSION = '1.23';
  
  #
  # standard tie functions
  #
  
  sub TIEHASH {
    my($c) = shift;
    my($s) = [];
    $s->[0] = {};   # hashkey index
    $s->[1] = [];   # array of keys
    $s->[2] = [];   # array of data
    $s->[3] = 0;    # iter count
  
    bless $s, $c;
  
    $s->Push(@_) if @_;
  
    return $s;
  }
  
  #sub DESTROY {}           # costly if there's nothing to do
  
  sub FETCH {
    my($s, $k) = (shift, shift);
    return exists( $s->[0]{$k} ) ? $s->[2][ $s->[0]{$k} ] : undef;
  }
  
  sub STORE {
    my($s, $k, $v) = (shift, shift, shift);
    
    if (exists $s->[0]{$k}) {
      my($i) = $s->[0]{$k};
      $s->[1][$i] = $k;
      $s->[2][$i] = $v;
      $s->[0]{$k} = $i;
    }
    else {
      push(@{$s->[1]}, $k);
      push(@{$s->[2]}, $v);
      $s->[0]{$k} = $#{$s->[1]};
    }
  }
  
  sub DELETE {
    my($s, $k) = (shift, shift);
  
    if (exists $s->[0]{$k}) {
      my($i) = $s->[0]{$k};
      for ($i+1..$#{$s->[1]}) {    # reset higher elt indexes
        $s->[0]{ $s->[1][$_] }--;    # timeconsuming, is there is better way?
      }
      if ( $i == $s->[3]-1 ) {
        $s->[3]--;
      }
      delete $s->[0]{$k};
      splice @{$s->[1]}, $i, 1;
      return (splice(@{$s->[2]}, $i, 1))[0];
    }
    return undef;
  }
  
  sub EXISTS {
    exists $_[0]->[0]{ $_[1] };
  }
  
  sub FIRSTKEY {
    $_[0][3] = 0;
    &NEXTKEY;
  }
  
  sub NEXTKEY {
    return $_[0][1][ $_[0][3]++ ] if ($_[0][3] <= $#{ $_[0][1] } );
    return undef;
  }
  
  
  
  #
  #
  # class functions that provide additional capabilities
  #
  #
  
  sub new { TIEHASH(@_) }
  
  sub Clear {
    my $s = shift;
    $s->[0] = {};   # hashkey index
    $s->[1] = [];   # array of keys
    $s->[2] = [];   # array of data
    $s->[3] = 0;    # iter count
    return;
  }
  
  #
  # add pairs to end of indexed hash
  # note that if a supplied key exists, it will not be reordered
  #
  sub Push {
    my($s) = shift;
    while (@_) {
      $s->STORE(shift, shift);
    }
    return scalar(@{$s->[1]});
  }
  
  sub Push2 {
    my($s) = shift;
    $s->Splice($#{$s->[1]}+1, 0, @_);
    return scalar(@{$s->[1]});
  }
  
  #
  # pop last k-v pair
  #
  sub Pop {
    my($s) = shift;
    my($k, $v, $i);
    $k = pop(@{$s->[1]});
    $v = pop(@{$s->[2]});
    if (defined $k) {
      delete $s->[0]{$k};
      return ($k, $v);
    }
    return undef;
  }
  
  sub Pop2 {
    return $_[0]->Splice(-1);
  }
  
  #
  # shift
  #
  sub Shift {
    my($s) = shift;
    my($k, $v, $i);
    $k = shift(@{$s->[1]});
    $v = shift(@{$s->[2]});
    if (defined $k) {
      delete $s->[0]{$k};
      for (keys %{$s->[0]}) {
        $s->[0]{$_}--;
      }
      return ($k, $v);
    }
    return undef;
  }
  
  sub Shift2 {
    return $_[0]->Splice(0, 1);
  }
  
  #
  # unshift
  # if a supplied key exists, it will not be reordered
  #
  sub Unshift {
    my($s) = shift;
    my($k, $v, @k, @v, $len, $i);
  
    while (@_) {
      ($k, $v) = (shift, shift);
      if (exists $s->[0]{$k}) {
        $i = $s->[0]{$k};
        $s->[1][$i] = $k;
        $s->[2][$i] = $v;
        $s->[0]{$k} = $i;
      }
      else {
        push(@k, $k);
        push(@v, $v);
        $len++;
      }
    }
    if (defined $len) {
      for (keys %{$s->[0]}) {
        $s->[0]{$_} += $len;
      }
      $i = 0;
      for (@k) {
        $s->[0]{$_} = $i++;
      }
      unshift(@{$s->[1]}, @k);
      return unshift(@{$s->[2]}, @v);
    }
    return scalar(@{$s->[1]});
  }
  
  sub Unshift2 {
    my($s) = shift;
    $s->Splice(0,0,@_);
    return scalar(@{$s->[1]});
  }
  
  #
  # splice 
  #
  # any existing hash key order is preserved. the value is replaced for
  # such keys, and the new keys are spliced in the regular fashion.
  #
  # supports -ve offsets but only +ve lengths
  #
  # always assumes a 0 start offset
  #
  sub Splice {
    my($s, $start, $len) = (shift, shift, shift);
    my($k, $v, @k, @v, @r, $i, $siz);
    my($end);                   # inclusive
  
    # XXX  inline this 
    ($start, $end, $len) = $s->_lrange($start, $len);
  
    if (defined $start) {
      if ($len > 0) {
        my(@k) = splice(@{$s->[1]}, $start, $len);
        my(@v) = splice(@{$s->[2]}, $start, $len);
        while (@k) {
          $k = shift(@k);
          delete $s->[0]{$k};
          push(@r, $k, shift(@v));
        }
        for ($start..$#{$s->[1]}) {
          $s->[0]{$s->[1][$_]} -= $len;
        }
      }
      while (@_) {
        ($k, $v) = (shift, shift);
        if (exists $s->[0]{$k}) {
          #      $s->STORE($k, $v);
          $i = $s->[0]{$k};
          $s->[1][$i] = $k;
          $s->[2][$i] = $v;
          $s->[0]{$k} = $i;
        }
        else {
          push(@k, $k);
          push(@v, $v);
          $siz++;
        }
      }
      if (defined $siz) {
        for ($start..$#{$s->[1]}) {
          $s->[0]{$s->[1][$_]} += $siz;
        }
        $i = $start;
        for (@k) {
          $s->[0]{$_} = $i++;
        }
        splice(@{$s->[1]}, $start, 0, @k);
        splice(@{$s->[2]}, $start, 0, @v);
      }
    }
    return @r;
  }
  
  #
  # delete elements specified by key
  # other elements higher than the one deleted "slide" down 
  #
  sub Delete {
    my($s) = shift;
  
    for (@_) {
      #
      # XXX potential optimization: could do $s->DELETE only if $#_ < 4.
      #     otherwise, should reset all the hash indices in one loop
      #
      $s->DELETE($_);
    }
  }
  
  #
  # replace hash element at specified index
  #
  # if the optional key is not supplied the value at index will simply be 
  # replaced without affecting the order.
  #
  # if an element with the supplied key already exists, it will be deleted first.
  #
  # returns the key of replaced value if it succeeds.
  #
  sub Replace {
    my($s) = shift;
    my($i, $v, $k) = (shift, shift, shift);
    if (defined $i and $i <= $#{$s->[1]} and $i >= 0) {
      if (defined $k) {
        delete $s->[0]{ $s->[1][$i] };
        $s->DELETE($k) ; #if exists $s->[0]{$k};
        $s->[1][$i] = $k;
        $s->[2][$i] = $v;
        $s->[0]{$k} = $i;
        return $k;
      }
      else {
        $s->[2][$i] = $v;
        return $s->[1][$i];
      }
    }
    return undef;
  }
  
  #
  # Given an $start and $len, returns a legal start and end (where start <= end)
  # for the current hash. 
  # Legal range is defined as 0 to $#s+1
  # $len defaults to number of elts upto end of list
  #
  #          0   1   2   ...
  #          | X | X | X ... X | X | X |
  #                           -2  -1       (no -0 alas)
  # X's above are the elements 
  #
  sub _lrange {
    my($s) = shift;
    my($offset, $len) = @_;
    my($start, $end);         # both inclusive
    my($size) = $#{$s->[1]}+1;
  
    return undef unless defined $offset;
    if($offset < 0) {
      $start = $offset + $size;
      $start = 0 if $start < 0;
    }
    else {
      ($offset > $size) ? ($start = $size) : ($start = $offset);
    }
  
    if (defined $len) {
      $len = -$len if $len < 0;
      $len = $size - $start if $len > $size - $start;
    }
    else {
      $len = $size - $start;
    }
    $end = $start + $len - 1;
  
    return ($start, $end, $len);
  }
  
  #
  # Return keys at supplied indices
  # Returns all keys if no args.
  #
  sub Keys   { 
    my($s) = shift;
    return ( @_ == 1
  	 ? $s->[1][$_[0]]
  	 : ( @_
  	   ? @{$s->[1]}[@_]
  	   : @{$s->[1]} ) );
  }
  
  #
  # Returns values at supplied indices
  # Returns all values if no args.
  #
  sub Values {
    my($s) = shift;
    return ( @_ == 1
  	 ? $s->[2][$_[0]]
  	 : ( @_
  	   ? @{$s->[2]}[@_]
  	   : @{$s->[2]} ) );
  }
  
  #
  # get indices of specified hash keys
  #
  sub Indices { 
    my($s) = shift;
    return ( @_ == 1 ? $s->[0]{$_[0]} : @{$s->[0]}{@_} );
  }
  
  #
  # number of k-v pairs in the ixhash
  # note that this does not equal the highest index
  # owing to preextended arrays
  #
  sub Length {
   return scalar @{$_[0]->[1]};
  }
  
  #
  # Reorder the hash in the supplied key order
  #
  # warning: any unsupplied keys will be lost from the hash
  # any supplied keys that dont exist in the hash will be ignored
  #
  sub Reorder {
    my($s) = shift;
    my(@k, @v, %x, $i);
    return unless @_;
  
    $i = 0;
    for (@_) {
      if (exists $s->[0]{$_}) {
        push(@k, $_);
        push(@v, $s->[2][ $s->[0]{$_} ] );
        $x{$_} = $i++;
      }
    }
    $s->[1] = \@k;
    $s->[2] = \@v;
    $s->[0] = \%x;
    return $s;
  }
  
  sub SortByKey {
    my($s) = shift;
    $s->Reorder(sort $s->Keys);
  }
  
  sub SortByValue {
    my($s) = shift;
    $s->Reorder(sort { $s->FETCH($a) cmp $s->FETCH($b) } $s->Keys)
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Tie::IxHash - ordered associative arrays for Perl
  
  
  =head1 SYNOPSIS
  
      # simple usage
      use Tie::IxHash;
      tie HASHVARIABLE, 'Tie::IxHash' [, LIST];
  
      # OO interface with more powerful features
      use Tie::IxHash;
      TIEOBJECT = Tie::IxHash->new( [LIST] );
      TIEOBJECT->Splice( OFFSET [, LENGTH [, LIST]] );
      TIEOBJECT->Push( LIST );
      TIEOBJECT->Pop;
      TIEOBJECT->Shift;
      TIEOBJECT->Unshift( LIST );
      TIEOBJECT->Keys( [LIST] );
      TIEOBJECT->Values( [LIST] );
      TIEOBJECT->Indices( LIST );
      TIEOBJECT->Delete( [LIST] );
      TIEOBJECT->Replace( OFFSET, VALUE, [KEY] );
      TIEOBJECT->Reorder( LIST );
      TIEOBJECT->SortByKey;
      TIEOBJECT->SortByValue;
      TIEOBJECT->Length;
  
  
  =head1 DESCRIPTION
  
  This Perl module implements Perl hashes that preserve the order in which the
  hash elements were added.  The order is not affected when values
  corresponding to existing keys in the IxHash are changed.  The elements can
  also be set to any arbitrary supplied order.  The familiar perl array
  operations can also be performed on the IxHash.
  
  
  =head2 Standard C<TIEHASH> Interface
  
  The standard C<TIEHASH> mechanism is available. This interface is 
  recommended for simple uses, since the usage is exactly the same as
  regular Perl hashes after the C<tie> is declared.
  
  
  =head2 Object Interface
  
  This module also provides an extended object-oriented interface that can be
  used for more powerful operations with the IxHash.  The following methods
  are available:
  
  =over 8
  
  =item FETCH, STORE, DELETE, EXISTS
  
  These standard C<TIEHASH> methods mandated by Perl can be used directly.
  See the C<tie> entry in perlfunc(1) for details.
  
  =item Push, Pop, Shift, Unshift, Splice
  
  These additional methods resembling Perl functions are available for
  operating on key-value pairs in the IxHash. The behavior is the same as the
  corresponding perl functions, except when a supplied hash key already exists
  in the hash. In that case, the existing value is updated but its order is
  not affected.  To unconditionally alter the order of a supplied key-value
  pair, first C<DELETE> the IxHash element.
  
  =item Keys
  
  Returns an array of IxHash element keys corresponding to the list of supplied
  indices.  Returns an array of all the keys if called without arguments.
  Note the return value is mostly only useful when used in a list context
  (since perl will convert it to the number of elements in the array when
  used in a scalar context, and that may not be very useful).
  
  If a single argument is given, returns the single key corresponding to
  the index.  This is usable in either scalar or list context.
  
  =item Values
  
  Returns an array of IxHash element values corresponding to the list of supplied
  indices.  Returns an array of all the values if called without arguments.
  Note the return value is mostly only useful when used in a list context
  (since perl will convert it to the number of elements in the array when
  used in a scalar context, and that may not be very useful).
  
  If a single argument is given, returns the single value corresponding to
  the index.  This is usable in either scalar or list context.
  
  =item Indices
  
  Returns an array of indices corresponding to the supplied list of keys.
  Note the return value is mostly only useful when used in a list context
  (since perl will convert it to the number of elements in the array when
  used in a scalar context, and that may not be very useful).
  
  If a single argument is given, returns the single index corresponding to
  the key.  This is usable in either scalar or list context.
  
  =item Delete
  
  Removes elements with the supplied keys from the IxHash.
  
  =item Replace
  
  Substitutes the IxHash element at the specified index with the supplied
  value-key pair.  If a key is not supplied, simply substitutes the value at
  index with the supplied value. If an element with the supplied key already
  exists, it will be removed from the IxHash first.
  
  =item Reorder
  
  This method can be used to manipulate the internal order of the IxHash
  elements by supplying a list of keys in the desired order.  Note however,
  that any IxHash elements whose keys are not in the list will be removed from
  the IxHash.
  
  =item Length
  
  Returns the number of IxHash elements.
  
  =item SortByKey
  
  Reorders the IxHash elements by textual comparison of the keys.
  
  =item SortByValue
  
  Reorders the IxHash elements by textual comparison of the values.
  
  =item Clear
  
  Resets the IxHash to its pristine state: with no elements at all.
  
  =back
  
  
  =head1 EXAMPLE
  
      use Tie::IxHash;
  
      # simple interface
      $t = tie(%myhash, 'Tie::IxHash', 'a' => 1, 'b' => 2);
      %myhash = (first => 1, second => 2, third => 3);
      $myhash{fourth} = 4;
      @keys = keys %myhash;
      @values = values %myhash;
      print("y") if exists $myhash{third};
  
      # OO interface
      $t = Tie::IxHash->new(first => 1, second => 2, third => 3);
      $t->Push(fourth => 4); # same as $myhash{'fourth'} = 4;
      ($k, $v) = $t->Pop;    # $k is 'fourth', $v is 4
      $t->Unshift(neg => -1, zeroth => 0); 
      ($k, $v) = $t->Shift;  # $k is 'neg', $v is -1
      @oneandtwo = $t->Splice(1, 2, foo => 100, bar => 101);
  
      @keys = $t->Keys;
      @values = $t->Values;
      @indices = $t->Indices('foo', 'zeroth');
      @itemkeys = $t->Keys(@indices);
      @itemvals = $t->Values(@indices);
      $t->Replace(2, 0.3, 'other');
      $t->Delete('second', 'zeroth');
      $len = $t->Length;     # number of key-value pairs
  
      $t->Reorder(reverse @keys);
      $t->SortByKey;
      $t->SortByValue;
  
  
  =head1 BUGS
  
  You cannot specify a negative length to C<Splice>. Negative indexes are OK,
  though.
  
  
  =head1 NOTE
  
  Indexing always begins at 0 (despite the current C<$[> setting) for 
  all the functions.
  
  
  =head1 TODO
  
  Addition of elements with keys that already exist to the end of the IxHash
  must be controlled by a switch.
  
  Provide C<TIEARRAY> interface when it stabilizes in Perl.
  
  Rewrite using XSUBs for efficiency.
  
  
  =head1 AUTHOR
  
  Gurusamy Sarathy        gsar@umich.edu
  
  Copyright (c) 1995 Gurusamy Sarathy. All rights reserved.
  This program is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  
  =head1 VERSION
  
  Version 1.23
  
  
  =head1 SEE ALSO
  
  perl(1)
  
  =cut
TIE_IXHASH

$fatpacked{"Time/Duration.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIME_DURATION';
  
  package Time::Duration;
  # POD is at the end.
  $VERSION = '1.1';
  require Exporter;
  @ISA = ('Exporter');
  @EXPORT = qw( later later_exact earlier earlier_exact
                ago ago_exact from_now from_now_exact
                duration duration_exact
                concise
              );
  @EXPORT_OK = ('interval', @EXPORT);
  
  use strict;
  use constant DEBUG => 0;
  
  our $MILLISECOND = 0;
  
  # ALL SUBS ARE PURE FUNCTIONS
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  sub concise ($) {
    my $string = $_[0];
    DEBUG and print "in : $string\n";
    $string =~ tr/,//d;
    $string =~ s/\band\b//;
    $string =~ s/\b(year|day|hour|minute|second)s?\b/substr($1,0,1)/eg;
    $string =~ s/\b(millisecond)s?\b/ms/g;
    $string =~ s/\s*(\d+)\s*/$1/g;
    return $string;
  }
  
  sub later {
    interval(      $_[0], $_[1], ' earlier', ' later', 'right then'); }
  sub later_exact {
    interval_exact($_[0], $_[1], ' earlier', ' later', 'right then'); }
  sub earlier {
    interval(      $_[0], $_[1], ' later', ' earlier', 'right then'); }
  sub earlier_exact {
    interval_exact($_[0], $_[1], ' later', ' earlier', 'right then'); }
  sub ago {
    interval(      $_[0], $_[1], ' from now', ' ago', 'right now'); }
  sub ago_exact {
    interval_exact($_[0], $_[1], ' from now', ' ago', 'right now'); }
  sub from_now {
    interval(      $_[0], $_[1], ' ago', ' from now', 'right now'); }
  sub from_now_exact {
    interval_exact($_[0], $_[1], ' ago', ' from now', 'right now'); }
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  sub duration_exact {
    my $span = $_[0];   # interval in seconds
    my $precision = int($_[1] || 0) || 2;  # precision (default: 2)
    return '0 seconds' unless $span;
    _render('',
            _separate(abs $span));
  }
  
  sub duration {
    my $span = $_[0];   # interval in seconds
    my $precision = int($_[1] || 0) || 2;  # precision (default: 2)
    return '0 seconds' unless $span;
    _render('',
            _approximate($precision,
                         _separate(abs $span)));
  }
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  sub interval_exact {
    my $span = $_[0];                    # interval, in seconds
                                         # precision is ignored
    my $direction = ($span < 0) ? $_[2]  # what a neg number gets
                  : ($span > 0) ? $_[3]  # what a pos number gets
                  : return        $_[4]; # what zero gets
    _render($direction,
            _separate($span));
  }
  
  sub interval {
    my $span = $_[0];                     # interval, in seconds
    my $precision = int($_[1] || 0) || 2; # precision (default: 2)
    my $direction = ($span < 0) ? $_[2]   # what a neg number gets
                  : ($span > 0) ? $_[3]   # what a pos number gets
                  : return        $_[4];  # what zero gets
    _render($direction,
            _approximate($precision,
                         _separate($span)));
  }
  
  #~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#
  #
  # The actual figuring is below here
  
  use constant MINUTE => 60;
  use constant HOUR => 3600;
  use constant DAY  => 24 * HOUR;
  use constant YEAR => 365 * DAY;
  
  sub _separate {
    # Breakdown of seconds into units, starting with the most significant
    
    my $remainder = abs $_[0]; # remainder
    my $this; # scratch
    my @wheel; # retval
    
    # Years:
    $this = int($remainder / (365 * 24 * 60 * 60));
    push @wheel, ['year', $this, 1_000_000_000];
    $remainder -= $this * (365 * 24 * 60 * 60);
      
    # Days:
    $this = int($remainder / (24 * 60 * 60));
    push @wheel, ['day', $this, 365];
    $remainder -= $this * (24 * 60 * 60);
      
    # Hours:
    $this = int($remainder / (60 * 60));
    push @wheel, ['hour', $this, 24];
    $remainder -= $this * (60 * 60);
    
    # Minutes:
    $this = int($remainder / 60);
    push @wheel, ['minute', $this, 60];
    $remainder -= $this * 60;
    
    push @wheel, ['second', int($remainder), 60];
  
  	# Thanks to Steven Haryanto (http://search.cpan.org/~sharyanto/) for the basis of this change.
  	if ($MILLISECOND) {
  		$remainder -= int($remainder);
  		push @wheel, ['millisecond', sprintf("%0.f", $remainder * 1000), 1000];
  	}
  
    return @wheel;
  }
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  sub _approximate {
    # Now nudge the wheels into an acceptably (im)precise configuration
    my($precision, @wheel) = @_;
  
   Fix:
    {
      # Constraints for leaving this block:
      #  1) number of nonzero wheels must be <= $precision
      #  2) no wheels can be improperly expressed (like having "60" for mins)
    
      my $nonzero_count = 0;
      my $improperly_expressed;
  
      DEBUG and print join ' ', '#', (map "${$_}[1] ${$_}[0]",  @wheel), "\n";
      for(my $i = 0; $i < @wheel; $i++) {
        my $this = $wheel[$i];
        next if $this->[1] == 0; # Zeros require no attention.
        ++$nonzero_count;
        next if $i == 0; # the years wheel is never improper or over any limit; skip
        
        if($nonzero_count > $precision) {
          # This is one nonzero wheel too many!
          DEBUG and print '', $this->[0], " is one nonzero too many!\n";
  
          # Incr previous wheel if we're big enough:
          if($this->[1] >= ($this->[-1] / 2)) {
            DEBUG and printf "incrementing %s from %s to %s\n",
             $wheel[$i-1][0], $wheel[$i-1][1], 1 + $wheel[$i-1][1], ;
            ++$wheel[$i-1][1];
          }
  
          # Reset this and subsequent wheels to 0:
          for(my $j = $i; $j < @wheel; $j++) { $wheel[$j][1] = 0 }
          redo Fix; # Start over.
        } elsif($this->[1] >= $this->[-1]) {
          # It's an improperly expressed wheel.  (Like "60" on the mins wheel)
          $improperly_expressed = $i;
          DEBUG and print '', $this->[0], ' (', $this->[1], 
             ") is improper!\n";
        }
      }
      
      if(defined $improperly_expressed) {
        # Only fix the least-significant improperly expressed wheel (at a time).
        DEBUG and printf "incrementing %s from %s to %s\n",
         $wheel[$improperly_expressed-1][0], $wheel[$improperly_expressed-1][1], 
          1 + $wheel[$improperly_expressed-1][1], ;
        ++$wheel[ $improperly_expressed - 1][1];
        $wheel[ $improperly_expressed][1] = 0;
        # We never have a "150" in the minutes slot -- if it's improper,
        #  it's only by having been rounded up to the limit.
        redo Fix; # Start over.
      }
      
      # Otherwise there's not too many nonzero wheels, and there's no
      #  improperly expressed wheels, so fall thru...
    }
  
    return @wheel;
  }
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  sub _render {
    # Make it into English
  
    my $direction = shift @_;
    my @wheel = map
          {;
              (  $_->[1] == 0) ? ()  # zero wheels
              : ($_->[1] == 1) ? "${$_}[1] ${$_}[0]"  # singular
              :                  "${$_}[1] ${$_}[0]s" # plural
          }
          @_
    ;
    return "just now" unless @wheel; # sanity
    $wheel[-1] .= $direction;
    return $wheel[0] if @wheel == 1;
    return "$wheel[0] and $wheel[1]" if @wheel == 2;
    $wheel[-1] = "and $wheel[-1]";
    return join q{, }, @wheel;
  }
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1;
  
  __END__
  
  so "1y 0d 1h 50m 50s", N=3, so you round at minutes to "1y 0d 1h 51m 0s",
  #That's okay, so fall thru.
  
  so "1y 1d 0h 59m 50s", N=3, so you round at minutes to "1y 1d 0h 60m 0s",
  but that's not improperly expressed, so you loop around and get
  "1y 1d 1h 0m 0s", which is short enough, and is properly expressed.
  
  =head1 NAME
  
  Time::Duration - rounded or exact English expression of durations
  
  =head1 SYNOPSIS
  
  Example use in a program that ends by noting its runtime:
  
    my $start_time = time();
    use Time::Duration;
    
    # then things that take all that time, and then ends:
    print "Runtime ", duration(time() - $start_time), ".\n";
  
  Example use in a program that reports age of a file:
  
    use Time::Duration;
    my $file = 'that_file';
    my $age = $^T - (stat($file))[9];  # 9 = modtime
    print "$file was modified ", ago($age);
  
  =head1 DESCRIPTION
  
  This module provides functions for expressing durations in rounded or exact
  terms.
  
  
  In the first example in the Synopsis, using duration($interval_seconds):
  
  If the C<time() - $start_time> is 3 seconds, this prints
  "Runtime: B<3 seconds>.".  If it's 0 seconds, it's "Runtime: B<0 seconds>.".
  If it's 1 second, it's "Runtime: B<1 second>.".  If it's 125 seconds, you
  get "Runtime: B<2 minutes and 5 seconds>.".  If it's 3820 seconds (which
  is exactly 1h, 3m, 40s), you get it rounded to fit within two expressed
  units: "Runtime: B<1 hour and 4 minutes>.".  Using duration_exact instead
  would return "Runtime: B<1 hour, 3 minutes, and 40 seconds>".
  
  In the second example in the Synopsis, using ago($interval_seconds):
  
  If the $age is 3 seconds, this prints
  "I<file> was modified B<3 seconds ago>".  If it's 0 seconds, it's
  "I<file> was modified B<just now>", as a special case.  If it's 1 second,
  it's "from B<1 second ago>".  If it's 125 seconds, you get "I<file> was
  modified B<2 minutes and 5 seconds ago>".  If it's 3820 seconds (which
  is exactly 1h, 3m, 40s), you get it rounded to fit within two expressed
  units: "I<file> was modified B<1 hour and 4 minutes ago>".  
  Using ago_exact instead
  would return "I<file> was modified B<1 hour, 3 minutes, and 40 seconds
  ago>".  And if the file's
  modtime is, surprisingly, three seconds into the future, $age is -3,
  and you'll get the equally and appropriately surprising
  "I<file> was modified B<3 seconds from now>."
  
  =head1 MILLISECOND MODE
  
  By default, this module assumes input is an integer representing number
  of seconds and only emits results based on the integer part of any
  floating-point values passed to it.  However, if you set the variable
  C<$Time::Duration::MILLISECOND> to any true value, then the methods will
  interpret inputs as floating-point numbers and will emit results containing
  information about the number of milliseconds in the value.
  
  For example, C<duration(1.021)> will return B<1 second and 21 milliseconds>
  in this mode.
  
  Millisecond mode is not enabled by default because this module sees heavy use
  and existing users of it may be relying on its implicit truncation of non-integer
  arguments.
  
  
  =head1 FUNCTIONS
  
  This module provides all the following functions, which are all exported
  by default when you call C<use Time::Duration;>.
  
  
  =over
  
  =item duration($seconds)
  
  =item duration($seconds, $precision)
  
  Returns English text expressing the approximate time duration 
  of abs($seconds), with at most S<C<$precision || 2>> expressed units.
  (That is, duration($seconds) is the same as duration($seconds,2).)
  
  For example, duration(120) or duration(-120) is "2 minutes".  And
  duration(0) is "0 seconds".
  
  The precision figure means that no more than that many units will
  be used in expressing the time duration.  For example,
  31,629,659 seconds is a duration of I<exactly>
  1 year, 1 day, 2 hours, and 59 seconds (assuming 1 year = exactly
  365 days, as we do assume in this module).  However, if you wanted
  an approximation of this to at most two expressed (i.e., nonzero) units, it
  would round it and truncate it to "1 year and 1 day".  Max of 3 expressed
  units would get you "1 year, 1 day, and 2 hours".  Max of 4 expressed
  units would get you "1 year, 1 day, 2 hours, and 59 seconds",
  which happens to be exactly true.  Max of 5 (or more) expressed units
  would get you the same, since there are only four nonzero units possible
  in for that duration.
  
  =item duration_exact($seconds)
  
  Same as duration($seconds), except that the returned value is an exact
  (unrounded) expression of $seconds.  For example, duration_exact(31629659)
  returns "1 year, 1 day, 2 hours, and 59 seconds later",
  which is I<exactly> true.
  
  
  =item ago($seconds)
  
  =item ago($seconds, $precision)
  
  For a positive value of seconds, this prints the same as
  C<duration($seconds, [$precision]) . S<' ago'>>.  For example,
  ago(120) is "2 minutes ago".  For a negative value of seconds,
  this prints the same as
  C<duration($seconds, [$precision]) . S<' from now'>>.  For example,
  ago(-120) is "2 minutes from now".  As a special case, ago(0)
  returns "right now".
  
  =item ago_exact($seconds)
  
  Same as ago($seconds), except that the returned value is an exact
  (unrounded) expression of $seconds.
  
  
  =item from_now($seconds)
  
  =item from_now($seconds, $precision)
  
  =item from_now_exact($seconds)
  
  The same as ago(-$seconds), ago(-$seconds, $precision), 
  ago_exact(-$seconds).  For example, from_now(120) is "2 minutes from now".
  
  
  =item later($seconds)
  
  =item later($seconds, $precision)
  
  For a positive value of seconds, this prints the same as
  C<duration($seconds, [$precision]) . S<' later'>>.  For example,
  ago(120) is "2 minutes later".  For a negative value of seconds,
  this prints the same as
  C<duration($seconds, [$precision]) . S<' earlier'>>.  For example,
  later(-120) is "2 minutes earlier".  As a special case, later(0)
  returns "right then".
  
  =item later_exact($seconds)
  
  Same as later($seconds), except that the returned value is an exact
  (unrounded) expression of $seconds.
  
  =item earlier($seconds)
  
  =item earlier($seconds, $precision)
  
  =item earlier_exact($seconds)
  
  The same as later(-$seconds), later(-$seconds, $precision), 
  later_exact(-$seconds).  For example, earlier(120) is "2 minutes earlier".
  
  
  =item concise( I<function(> ... ) )
  
  Concise takes the string output of one of the above functions and makes
  it more concise.  For example, 
  C<< ago(4567) >> returns "1 hour and 16 minutes ago", but
  C<< concise(ago(4567)) >> returns "1h16m ago".
  
  =back
  
  
  
  =head1 I18N/L10N NOTES
  
  Little of the internals of this module are English-specific.  See source
  and/or contact me if you're interested in making a localized version
  for some other language than English.
  
  
  
  =head1 BACKSTORY
  
  I wrote the basic C<ago()> function for use in Infobot
  (C<http://www.infobot.org>), because I was tired of this sort of
  response from the Purl Infobot:
  
    me> Purl, seen Woozle?
    <Purl> Woozle was last seen on #perl 20 days, 7 hours, 32 minutes
    and 40 seconds ago, saying: Wuzzle!
  
  I figured if it was 20 days ago, I don't care about the seconds.  So
  once I had written C<ago()>, I abstracted the code a bit and got
  all the other functions.
  
  
  =head1 CAVEAT
  
  This module calls a durational "year" an interval of exactly 365
  days of exactly 24 hours each, with no provision for leap years or
  monkey business with 23/25 hour days (much less leap seconds!).  But
  since the main work of this module is approximation, that shouldn't
  be a great problem for most purposes.
  
  
  =head1 SEE ALSO
  
  L<Date::Interval|Date::Interval>, which is similarly named, but does
  something rather different.
  
  I<Star Trek: The Next Generation> (1987-1994), where the character
  Data would express time durations like
  "1 year, 20 days, 22 hours, 59 minutes, and 35 seconds"
  instead of rounding to "1 year and 21 days".  This is because no-one
  ever told him to use Time::Duration.
  
  
  
  =head1 COPYRIGHT AND DISCLAIMER
  
  Copyright 2013, Sean M. Burke C<sburke@cpan.org>; Avi Finkel,
  C<avi@finkel.org>, all rights reserved.  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.
  
  =head1 AUTHOR
  
  Current maintainer Avi Finkel, C<avi@finkel.org>; Original author
  Sean M. Burke, C<sburke@cpan.org>
  
  =cut
  
  
TIME_DURATION

$fatpacked{"Time/Zone.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIME_ZONE';
  
  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;
TIME_ZONE

$fatpacked{"Unicode/GCString.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'UNICODE_GCSTRING';
  #-*-perl-*-
  
  package Unicode::GCString;
  require 5.008;
  
  =encoding utf-8
  
  =cut
  
  ### Pragmas:
  use strict;
  use warnings;
  use vars qw($VERSION @EXPORT_OK @ISA);
  
  ### Exporting:
  use Exporter;
  our @EXPORT_OK = qw();
  our %EXPORT_TAGS = ('all' => [@EXPORT_OK]);
  
  ### Inheritance:
  our @ISA = qw(Exporter);
  
  ### Other modules:
  use Unicode::LineBreak;
  
  ### Globals
  
  # The package version
  our $VERSION = '2013.10';
  
  use overload 
      '@{}' => \&as_arrayref,
      '${}' => \&as_scalarref,
      '""' => \&as_string,
      '.' => \&concat,
      #XXX'.=' => \&concat, #FIXME:segfault
      'cmp' => \&cmp,
      '<>' => \&next,
      ;
  
  sub new {
      my $class = shift;
  
      my $self;
      if (scalar @_ <= 2) {
  	$self = __PACKAGE__->_new(@_);
      } else {
  	my $str = shift;
  	my $lb = Unicode::LineBreak->new(@_);
  	$self = __PACKAGE__->_new($str, $lb);
      }
      bless $self, $class;
  }
  
  sub as_arrayref {
      my @a = shift->as_array;
      return \@a;
  }
  
  1;
UNICODE_GCSTRING

$fatpacked{"Unicode/LineBreak.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'UNICODE_LINEBREAK';
  #-*- perl -*-
  
  package Unicode::LineBreak;
  require 5.008;
  
  ### Pragmas:
  use strict;
  use warnings;
  use vars qw($VERSION @EXPORT_OK @ISA $Config @Config);
  
  ### Exporting:
  use Exporter;
  our @EXPORT_OK = qw(UNICODE_VERSION SOMBOK_VERSION context);
  our %EXPORT_TAGS = ('all' => [@EXPORT_OK]);
  
  ### Inheritance:
  our @ISA = qw(Exporter);
  
  ### Other modules:
  use Carp qw(croak carp);
  use Encode qw(is_utf8);
  use MIME::Charset;
  use Unicode::GCString;
  
  ### Globals
  
  ### The package version
  our $VERSION = '2014.06';
  
  ### Public Configuration Attributes
  our @Config = (
      BreakIndent => 'YES',
      CharMax => 998,
      ColMax => 76,
      ColMin => 0,
      ComplexBreaking => 'YES',
      Context => 'NONEASTASIAN',
      EAWidth => undef,
      Format => 'SIMPLE',
      HangulAsAL => 'NO',
      LBClass => undef,
      LegacyCM => 'YES',
      Newline => "\n",
      Prep => undef,
      Sizing => 'UAX11',
      Urgent => undef,
      ViramaAsJoiner => 'YES',
  );
  our $Config = {};
  eval { require Unicode::LineBreak::Defaults; };
  push @Config, (%$Config);
  
  ### Exportable constants
  use Unicode::LineBreak::Constants;
  use constant 1.01;
  my $package = __PACKAGE__;
  my @consts = grep { s/^${package}::(\w\w+)$/$1/ } keys %constant::declared;
  push @EXPORT_OK, @consts;
  push @{$EXPORT_TAGS{'all'}}, @consts;
  
  ### Load XS module
  require XSLoader;
  XSLoader::load('Unicode::LineBreak', $VERSION);
  
  ### Load dynamic constants
  foreach my $p ((['EA', EAWidths()], ['LB', LBClasses()])) {
      my $prop = shift @{$p};
      my $idx = 0;
      foreach my $val (@{$p}) {
  	no strict;
  	my $const = "${prop}_${val}";
  	*{$const} = eval "sub { $idx }";
  	push @EXPORT_OK, $const;
  	push @{$EXPORT_TAGS{'all'}}, $const;
  	$idx++;
      }
  }
  
  ### Privates
  my $EASTASIAN_CHARSETS = qr{
      ^BIG5 |
      ^CP9\d\d |
      ^EUC- |
      ^GB18030 | ^GB2312 | ^GBK |
      ^HZ |
      ^ISO-2022- |
      ^KS_C_5601 |
      ^SHIFT_JIS
  }ix;
  
  my $EASTASIAN_LANGUAGES = qr{
      ^AIN |
      ^JA\b | ^JPN |
      ^KO\b | ^KOR |
      ^ZH\b | ^CHI
  }ix;
  
  use overload
      '%{}' => \&as_hashref,
      '${}' => \&as_scalarref,
      '""' => \&as_string,
      ;
  
  sub new {
      my $class = shift;
  
      my $self = __PACKAGE__->_new();
      $self->config(@Config);
      $self->config(@_);
      bless $self, $class;
  }
  
  sub config ($@) {
      my $self = shift;
  
      # Get config.
      if (scalar @_ == 1) {
  	my $k = shift;
  	my $ret;
  
  	if (uc $k eq uc 'CharactersMax') {
  	    return $self->_config('CharMax');
  	} elsif (uc $k eq uc 'ColumnsMax') {
  	    return $self->_config('ColMax');
  	} elsif (uc $k eq uc 'ColumnsMin') {
  	    return $self->_config('ColMin');
  	} elsif (uc $k eq uc 'SizingMethod') {
  	    return $self->_config('Sizing');
  	} elsif (uc $k eq uc 'TailorEA') {
  	    carp "$k is obsoleted.  Use EAWidth";
  	    $ret = $self->_config('EAWidth');
  	    if (! defined $ret) {
  		return [];
  	    } else {
  		return [map { ($_->[0] => $_->[1]) } @{$ret}];
  	    }
  	} elsif (uc $k eq uc 'TailorLB') {
  	    carp "$k is obsoleted.  Use LBClass";
  	    $ret = $self->_config('LBClass');
  	    if (! defined $ret) {
  		return [];
  	    } else {
  		return [map { ($_->[0] => $_->[1]) } @{$ret}];
  	    }
  	} elsif (uc $k eq uc 'UrgentBreaking') {
  	    return $self->_config('Urgent');
  	} elsif (uc $k eq uc 'UserBreaking') {
  	    carp "$k is obsoleted.  Use Prep";
  	    $ret = $self->_config('Prep');
  	    if (! defined $ret) {
  		return [];
  	    } else {
  		return $ret;
  	    }
  	} else {
  	    return $self->_config($k);
  	}
      }
  
      # Set config.
      my @config = ();
      while (0 < scalar @_) {
  	my $k = shift;
  	my $v = shift;
  
          if (uc $k eq uc 'CharactersMax') {
  	    push @config, 'CharMax' => $v;
  	} elsif (uc $k eq uc 'ColumnsMax') {
  	    push @config, 'ColMax' => $v;
  	} elsif (uc $k eq uc 'ColumnsMin') {
  	    push @config, 'ColMin' => $v;
  	} elsif (uc $k eq uc 'SizingMethod') {
  	    push @config, 'Sizing' => $v;
  	} elsif (uc $k eq uc 'TailorLB') {
  	    carp "$k is obsoleted.  Use LBClass";
  	    push @config, 'LBClass' => undef;
  	    if (! defined $v) {
  		;
  	    } else {
  		my @v = @{$v};
  		while (scalar(@v)) {
  		    my $k = shift @v;
  		    my $v = shift @v;
  		    push @config, 'LBClass' => [ $k => $v ];
  		}
  	    }
  	} elsif (uc $k eq uc 'TailorEA') {
  	    carp "$k is obsoleted.  Use EAWidth";
  	    push @config, 'EAWidth' => undef;
  	    if (! defined $v) {
  		;
  	    } else {
  		my @v = @{$v};
  		while (scalar(@v)) {
  		    my $k = shift @v;
  		    my $v = shift @v;
  		    push @config, 'EAWidth' => [ $k => $v ];
  		}
  	    }
  	} elsif (uc $k eq uc 'UserBreaking') {
  	    carp "$k is obsoleted.  Use Prep";
  	    push @config, 'Prep' => undef;
  	    if (! defined $v) {
  		;
  	    } elsif (ref $v eq 'ARRAY') {
  		push @config, map { ('Prep' => $_) } @{$v};
  	    } else {
  		push @config, 'Prep' => $v;
  	    }
  	} elsif (uc $k eq uc 'UrgentBreaking') {
  	    push @config, 'Urgent' => $v;
  	} else {
  	    push @config, $k => $v;
  	}
      }
  
      $self->_config(@config) if scalar @config;
  }
  
  sub context (@) {
      my %opts = @_;
  
      my $charset;
      my $language;
      my $context;
      foreach my $k (keys %opts) {
  	if (uc $k eq 'CHARSET') {
  	    if (ref $opts{$k}) {
  		$charset = $opts{$k}->as_string;
  	    } else {
  		$charset = MIME::Charset->new($opts{$k})->as_string;
  	    }
  	} elsif (uc $k eq 'LANGUAGE') {
  	    $language = uc $opts{$k};
  	    $language =~ s/_/-/;
  	}
      }
      if ($charset and $charset =~ /$EASTASIAN_CHARSETS/) {
          $context = 'EASTASIAN';
      } elsif ($language and $language =~ /$EASTASIAN_LANGUAGES/) {
  	$context = 'EASTASIAN';
      } else {
  	$context = 'NONEASTASIAN';
      }
      $context;
  }
  
  1;
UNICODE_LINEBREAK

$fatpacked{"Version/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_UTIL';
  package Version::Util;
  
  use 5.010001;
  use strict;
  use version 0.77;
  use warnings;
  
  require Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(
                         cmp_version
                         version_eq version_ne
                         version_lt version_le version_gt version_ge
                         version_between version_in
                 );
  
  our $VERSION = '0.71'; # VERSION
  
  sub cmp_version {
      version->parse($_[0]) <=> version->parse($_[1]);
  }
  
  sub version_eq {
      version->parse($_[0]) == version->parse($_[1]);
  }
  
  sub version_ne {
      version->parse($_[0]) != version->parse($_[1]);
  }
  
  sub version_lt {
      version->parse($_[0]) <  version->parse($_[1]);
  }
  
  sub version_le {
      version->parse($_[0]) <= version->parse($_[1]);
  }
  
  sub version_gt {
      version->parse($_[0]) >  version->parse($_[1]);
  }
  
  sub version_ge {
      version->parse($_[0]) >= version->parse($_[1]);
  }
  
  sub version_between {
      my $v = version->parse(shift);
      while (@_) {
          my $v1 = shift;
          my $v2 = shift;
          return 1 if $v >= version->parse($v1) && $v <= version->parse($v2);
      }
      0;
  }
  
  sub version_in {
      my $v = version->parse(shift);
      for (@_) {
          return 1 if $v == version->parse($_);
      }
      0;
  }
  
  1;
  # ABSTRACT: Version-number utilities
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Version::Util - Version-number utilities
  
  =head1 VERSION
  
  version 0.71
  
  =head1 DESCRIPTION
  
  This module provides several convenient functions related to version numbers,
  e.g. for comparing them.
  
  =head1 FUNCTIONS
  
  =head2 cmp_version($v1, $v2) => -1|0|1
  
  Equivalent to:
  
   version->parse($v1) <=> version->parse($v2)
  
  =head2 version_eq($v1, $v2) => BOOL
  
  =head2 version_ne($v1, $v2) => BOOL
  
  =head2 version_lt($v1, $v2) => BOOL
  
  =head2 version_le($v1, $v2) => BOOL
  
  =head2 version_gt($v1, $v2) => BOOL
  
  =head2 version_ge($v1, $v2) => BOOL
  
  =head2 version_between($v, $v1, $v2[, $v1b, $v2b, ...]) => BOOL
  
  =head2 version_in($v, $v1[, $v2, ...]) => BOOL
  
  =head1 SEE ALSO
  
  L<version>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/Version-Util>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/sharyanto/perl-Version-Util>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Version-Util>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  Steven Haryanto <stevenharyanto@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Steven Haryanto.
  
  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
VERSION_UTIL

$fatpacked{"WWW/PAUSE/Simple.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'WWW_PAUSE_SIMPLE';
  package WWW::PAUSE::Simple;
  
  our $DATE = '2015-04-15'; # DATE
  our $VERSION = '0.21'; # VERSION
  
  use 5.010001;
  use strict;
  use warnings;
  use Log::Any::IfLOG '$log';
  use Exporter qw(import);
  our @EXPORT_OK = qw(
                         upload_file
                         list_files
                         delete_files
                         undelete_files
                         reindex_files
                         list_dists
                         delete_old_releases
                         set_password
                         set_account_info
                 );
  
  use Perinci::Object;
  
  our %SPEC;
  
  our $re_archive_ext = qr/(?:tar|tar\.(?:Z|gz|bz2|xz)|zip|rar)/;
  
  our %common_args = (
      username => {
          summary => 'PAUSE ID',
          schema  => ['str*', match=>'\A\w{2,9}\z', max_len=>9],
          req     => 1,
          tags    => ['common'],
      },
      password => {
          summary => 'PAUSE password',
          schema  => 'str*',
          is_password => 1,
          req     => 1,
          tags    => ['common'],
      },
  );
  
  our %detail_arg = (
      detail => {
          summary => 'Whether to return detailed records',
          schema  => 'bool',
      },
  );
  
  our %detail_l_arg = (
      detail => {
          summary => 'Whether to return detailed records',
          schema  => 'bool',
          cmdline_aliases => {l=>{}},
      },
  );
  
  our %files_arg = (
      files => {
          summary => 'File names/wildcard patterns',
          'summary.alt.plurality.singular' => 'File name/wildcard pattern',
          schema  => ['array*', of=>'str*', min_len=>1],
          'x.name.is_plural' => 1,
          req => 1,
          pos => 0,
          greedy => 1,
      },
  );
  
  our %file_opt_arg = (
      files => {
          summary => 'File names/wildcard patterns',
          'summary.alt.plurality.singular' => 'File name/wildcard pattern',
          schema  => ['array*', of=>'str*'],
          'x.name.is_plural' => 1,
          pos => 0,
          greedy => 1,
      },
  );
  
  $SPEC{':package'} = {
      v => 1.1,
      summary => 'An API for PAUSE',
  };
  
  sub _common_args {
      my $args = shift;
      (username=>$args->{username}, password=>$args->{password});
  }
  
  sub _request {
      require HTTP::Request::Common;
  
      my %args = @_;
  
      state $ua = do {
          require LWP::UserAgent;
          LWP::UserAgent->new;
      };
      my $req = HTTP::Request::Common::POST(
          "https://pause.perl.org/pause/authenquery",
          @{ $args{post_data} });
      $req->authorization_basic($args{username}, $args{password});
  
      $ua->request($req);
  }
  
  sub _htres2envres {
      my $res = shift;
      [$res->code, $res->message, $res->content];
  }
  
  $SPEC{upload_file} = {
      v => 1.1,
      summary => 'Upload file(s) to your PAUSE account',
      args => {
          %common_args,
          %files_arg,
          subdir => {
              summary => 'Subdirectory to put the file(s) into',
              schema  => 'str*',
              default => '',
          },
      },
  };
  sub upload_file {
      require File::Basename;
  
      my %args = @_;
      my $files  = $args{files}
          or return [400, "Please specify at least one file"];
      my $subdir = $args{subdir} // '';
  
      my $envres = envresmulti();
  
      for my $file (@$files) {
          my $res;
          {
              unless (-f $file) {
                  $res = [404, "No such file"];
                  last;
              }
  
              $log->tracef("Uploading %s ...", $file);
              my $httpres = _request(
                  %args,
                  post_data => [
                      Content_Type => 'form-data',
                      Content => {
                          HIDDENNAME                        => $args{username},
                          CAN_MULTIPART                     => 0,
                          pause99_add_uri_upload            => File::Basename::basename($file),
                          SUBMIT_pause99_add_uri_httpupload => " Upload this file from my disk ",
                          pause99_add_uri_uri               => "",
                          pause99_add_uri_httpupload        => [$file],
                          (length($subdir) ? (pause99_add_uri_subdirtext => $subdir) : ()),
                      },
                  ]
              );
              if (!$httpres->is_success) {
                  $res = _htres2envres($httpres);
                  last;
              }
              if ($httpres->content !~ m!<h3>Submitting query</h3>\s*<p>(.+?)</p>!s) {
                  $res = [543, "Can't scrape upload status from response", $httpres->content];
                  last;
              }
              my $str = $1;
              if ($str =~ /Query succeeded/) {
                  $res = [200, "OK", undef, {"func.raw_status" => $str}];
              } else {
                  $res = [500, "Failed: $str"];
              }
          }
          $res->[3] //= {};
          $res->[3]{item_id} = $file;
          $log->tracef("Result of upload: %s", $res);
          $envres->add_result($res->[0], $res->[1], $res->[3]);
      }
      $envres->as_struct;
  }
  
  $SPEC{list_files} = {
      v => 1.1,
      summary => 'List files on your PAUSE account',
      args => {
          %common_args,
          %detail_l_arg,
          %file_opt_arg,
          del => {
              summary => 'Only list files which are scheduled for deletion',
              'summary.alt.bool.not' => 'Only list files which are not scheduled for deletion',
              schema => 'bool',
              tags => ['category:filtering'],
          },
      },
  };
  sub list_files {
      require Date::Parse;
      require Regexp::Wildcards;
      require String::Wildcard::Bash;
  
      my %args  = @_;
      my $q   = $args{files} // [];
      my $del = $args{del};
  
      my $httpres = _request(
          %args,
          post_data => [{ACTION=>'show_files'}],
      );
  
      # convert wildcard patterns in arguments to regexp
      $q = [@$q];
      for (@$q) {
          next unless String::Wildcard::Bash::contains_wildcard($_);
          my $re = Regexp::Wildcards->new(type=>'unix')->convert($_);
          $re = qr/\A($re)\z/;
          $_ = $re;
      }
  
      return _htres2envres($httpres) unless $httpres->is_success;
      return [543, "Can't scrape list of files from response",
              $httpres->content]
          unless $httpres->content =~ m!<h3>Files in directory.+</h3><pre>(.+)</pre>!s;
      my $str = $1;
      my @files;
    REC:
      while ($str =~ m!(?:\A |<br/> )(.+?)\s+(\d+)\s+(Scheduled for deletion \(due at )?(\w+, \d\d \w+ \d{4} \d\d:\d\d:\d\d GMT)!g) {
  
          my $time = Date::Parse::str2time($4, "UTC");
  
          my $rec = {
              name  => $1,
              size  => $2,
              is_scheduled_for_deletion => $3 ? 1:0,
          };
          if ($3) {
              $rec->{deletion_time} = $time;
          } else {
              $rec->{mtime} = $time;
          }
  
          # filter by requested file/wildcard
        FILTER_QUERY:
          {
              last unless @$q;
              for (@$q) {
                  if (ref($_) eq 'Regexp') {
                      last FILTER_QUERY if $rec->{name} =~ $_;
                  } else {
                      last FILTER_QUERY if $rec->{name} eq $_;
                  }
              }
              # nothing matches
              next REC;
          }
          if (defined $del) {
              next REC if $del xor $rec->{is_scheduled_for_deletion};
          }
  
          push @files, $args{detail} ? $rec : $rec->{name};
  
      }
      my %resmeta;
      if ($args{detail}) {
          $resmeta{format_options} = {
              any => {
                  table_column_orders => [[qw/name size mtime is_scheduled_for_deletion deletion_time/]],
              },
          };
      }
      [200, "OK", \@files, \%resmeta];
  }
  
  $SPEC{list_dists} = {
      v => 1.1,
      summary => 'List distributions on your PAUSE account',
      description => <<'_',
  
  Distribution names will be extracted from tarball/zip filenames.
  
  Unknown/unparseable filenames will be skipped.
  
  _
      args => {
          %common_args,
          %detail_l_arg,
          newest => {
              schema => 'bool',
              summary => 'Only show newest non-dev version',
              description => <<'_',
  
  Dev versions will be skipped.
  
  _
          },
          newest_n => {
              schema => ['int*', min=>1],
              summary => 'Only show this number of newest non-dev versions',
              description => <<'_',
  
  Dev versions will be skipped.
  
  _
          },
      },
  };
  sub list_dists {
      require List::MoreUtils;
      require Version::Util;
      use experimental 'smartmatch';
  
      my %args  = @_;
  
      my $res = list_files(_common_args(\%args), del=>0);
      return [500, "Can't list files: $res->[0] - $res->[1]"] if $res->[0] != 200;
  
      my $newest_n;
      if ($args{newest_n}) {
          $newest_n = $args{newest_n};
      } elsif ($args{newest}) {
          $newest_n = 1;
      }
  
      my @dists;
      for my $file (@{$res->[2]}) {
          if ($file =~ m!/!) {
              $log->debugf("Skipping %s: under a subdirectory", $file);
              next;
          }
          unless ($file =~ /\A
                            (\w+(?:-\w+)*)
                            -v?(\d+(?:\.\d+){0,2}(_\d+|-TRIAL)?)
                            \.$re_archive_ext
                            \z/ix) {
              $log->debugf("Skipping %s: doesn't match release regex", $file);
              next;
          }
          my ($dist, $version, $is_dev) = ($1, $2, $3);
          next if $is_dev && $newest_n;
          push @dists, {
              name => $dist,
              file => $file,
              version => $version,
              is_dev_version => $is_dev ? 1:0,
          };
      }
  
      my @old_files;
      if ($newest_n) {
          my %dist_versions;
          for my $dist (@dists) {
              push @{ $dist_versions{$dist->{name}} }, $dist->{version};
          }
          for my $dist (keys %dist_versions) {
              $dist_versions{$dist} = [
                  sort { -Version::Util::cmp_version($a, $b) }
                      @{ $dist_versions{$dist} }];
              if (@{ $dist_versions{$dist} } > $newest_n) {
                  $dist_versions{$dist} = [splice(
                      @{ $dist_versions{$dist} }, 0, $newest_n)];
              }
          }
          my @old_dists = @dists;
          @dists = ();
          for my $dist (@old_dists) {
              if ($dist->{version} ~~ @{ $dist_versions{$dist->{name}} }) {
                  push @dists, $dist;
              } else {
                  push @old_files, $dist->{file};
              }
          }
      }
  
      unless ($args{detail}) {
          @dists = List::MoreUtils::uniq(map { $_->{name} } @dists);
      }
  
      my %resmeta;
      if ($newest_n) {
          $resmeta{"func.old_files"} = \@old_files;
      }
      if ($args{detail}) {
          $resmeta{format_options} = {
              any => {
                  table_column_orders => [[qw/name version is_dev_version file/]],
              },
          };
      }
      [200, "OK", \@dists, \%resmeta];
  }
  
  $SPEC{delete_old_releases} = {
      v => 1.1,
      summary => 'Delete older versions of distributions on your PAUSE account',
      description => <<'_',
  
  Developer releases will not be deleted.
  
  To delete developer releases, you can use `delete_files` (rm), e.g. from the
  command line:
  
      % pause rm 'My-Module-*TRIAL*'; # delete a dist's trial releases
      % pause rm '*TRIAL*' '*_*'; # delete all files containing TRIAL or underscore
  
  _
      args => {
          %common_args,
          %detail_l_arg,
          num_keep => {
              schema => ['int*', min=>1],
              default => 1,
              summary => 'Number of new versions (including newest) to keep',
              cmdline_aliases => { n=>{} },
              description => <<'_',
  
  1 means to only keep the newest version, 2 means to keep the newest and the
  second newest, and so on.
  
  _
          },
      },
      features => {dry_run=>1},
  };
  sub delete_old_releases {
      my %args = @_;
  
      my $res = list_dists(_common_args(\%args), newest_n=>$args{num_keep}//1);
      return [500, "Can't list dists: $res->[0] - $res->[1]"] if $res->[0] != 200;
      my $old_files = $res->[3]{'func.old_files'};
  
      return [304, "No older releases", undef,
              {'cmdline.result'=>'There are no older releases to delete'}]
          unless @$old_files;
      my @to_delete;
      for my $file (@$old_files) {
          $file =~ s/\.$re_archive_ext\z//;
          push @to_delete, "$file.*";
      }
      $res = delete_files(_common_args(\%args),
                          files=>\@to_delete, -dry_run=>$args{-dry_run});
      return $res if $res->[0] != 200 || $args{-dry_run};
      my $deleted_files = $res->[3]{'func.files'} // [];
      if (@$deleted_files) {
          $res->[3]{'cmdline.result'} = $deleted_files;
      } else {
          $res->[3]{'cmdline.result'} = 'Deleted 0 files';
      }
      $res;
  }
  
  sub _delete_or_undelete_or_reindex_files {
      use experimental 'smartmatch';
      require Regexp::Wildcards;
      require String::Wildcard::Bash;
  
      my $which = shift;
      my %args = @_;
  
      my $files0 = $args{files} // [];
      return [400, "Please specify at least one file"] unless @$files0;
  
      my @files;
      {
          my $listres;
          for my $file (@$files0) {
              if (String::Wildcard::Bash::contains_wildcard($file)) {
                  unless ($listres) {
                      $listres = list_files(_common_args(\%args));
                      return [500, "Can't list files: $listres->[0] - $listres->[1]"]
                          unless $listres->[0] == 200;
                  }
                  my $re = Regexp::Wildcards->new(type=>'unix')->convert($file);
                  $re = qr/\A($re)\z/;
                  for my $f (@{$listres->[2]}) {
                      push @files, $f if $f =~ $re && !($f ~~ @files);
                  }
              } else {
                  push @files, $file;
              }
          }
      }
  
      unless (@files) {
          return [304, "No files to process"];
      }
  
      if ($args{-dry_run}) {
          $log->warnf("[dry-run] %s %s", $which, \@files);
          return [200, "OK (dry-run)"];
      } else {
          $log->infof("%s %s ...", $which, \@files);
      }
  
      my $httpres = _request(
          %args,
          post_data => [
              [
                  HIDDENNAME                => $args{username},
                  ($which eq 'delete'   ? (SUBMIT_pause99_delete_files_delete   => "Delete"  ) : ()),
                  ($which eq 'undelete' ? (SUBMIT_pause99_delete_files_undelete => "Undelete") : ()),
                  ($which eq 'reindex'  ? (SUBMIT_pause99_reindex_delete        => "Reindex" ) : ()),
                  ($which =~ /delete/   ? (pause99_delete_files_FILE => \@files) : ()),
                  ($which eq 'reindex'  ? (pause99_reindex_FILE => \@files) : ()),
              ],
          ],
      );
      return _htres2envres($httpres) unless $httpres->is_success;
      return [543, "Can't scrape $which status from response", $httpres->content]
          unless $httpres->content =~ m!<h3>Files in directory!s;
      [200,"OK", undef, {'func.files'=>\@files}];
  }
  
  $SPEC{delete_files} = {
      v => 1.1,
      summary => 'Delete files',
      description => <<'_',
  
  When a file is deleted, it is not immediately deleted but has
  scheduled_for_deletion status for 72 hours, then deleted. During that time, the
  file can be undeleted.
  
  _
      args => {
          %common_args,
          %files_arg,
      },
      features => {dry_run=>1},
  };
  sub delete_files {
      my %args = @_; # only for DZP::Rinci::Wrap
      _delete_or_undelete_or_reindex_files('delete', @_);
  }
  
  $SPEC{undelete_files} = {
      v => 1.1,
      summary => 'Undelete files',
      description => <<'_',
  
  When a file is deleted, it is not immediately deleted but has
  scheduled_for_deletion status for 72 hours, then deleted. During that time, the
  file can be undeleted.
  
  _
      args => {
          %common_args,
          %files_arg,
      },
      features => {dry_run=>1},
  };
  sub undelete_files {
      my %args = @_; # only for DZP::Rinci::Wrap
      _delete_or_undelete_or_reindex_files('undelete', @_);
  }
  
  $SPEC{reindex_files} = {
      v => 1.1,
      summary => 'Force reindexing',
      args => {
          %common_args,
          %files_arg,
      },
      features => {dry_run=>1},
  };
  sub reindex_files {
      my %args = @_; # only for DZP::Rinci::Wrap
      _delete_or_undelete_or_reindex_files('reindex', @_);
  }
  
  $SPEC{set_password} = {
      v => 1.1,
      args => {
          %common_args,
      },
  };
  sub set_password {
      my %args = @_;
      [501, "Not yet implemented"];
  }
  
  $SPEC{set_account_info} = {
      v => 1.1,
      args => {
          %common_args,
      },
  };
  sub set_account_info {
      my %args = @_;
      [501, "Not yet implemented"];
  }
  
  
  1;
  # ABSTRACT: An API for PAUSE
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  WWW::PAUSE::Simple - An API for PAUSE
  
  =head1 VERSION
  
  This document describes version 0.21 of WWW::PAUSE::Simple (from Perl distribution WWW-PAUSE-Simple), released on 2015-04-15.
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  This module provides several API functions for performing common tasks on PAUSE.
  There is also a CLI script L<pause> distributed separately in L<App::pause>.
  
  =head1 FUNCTIONS
  
  
  =head2 delete_files(%args) -> [status, msg, result, meta]
  
  Delete files.
  
  When a file is deleted, it is not immediately deleted but has
  scheduled_for_deletion status for 72 hours, then deleted. During that time, the
  file can be undeleted.
  
  This function supports dry-run operation.
  
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<files>* => I<array[str]>
  
  File names/wildcard patterns.
  
  =item * B<password>* => I<str>
  
  PAUSE password.
  
  =item * B<username>* => I<str>
  
  PAUSE ID.
  
  =back
  
  Special arguments:
  
  =over 4
  
  =item * B<-dry_run> => I<bool>
  
  Pass -dry_run=>1 to enable simulation mode.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 delete_old_releases(%args) -> [status, msg, result, meta]
  
  Delete older versions of distributions on your PAUSE account.
  
  Developer releases will not be deleted.
  
  To delete developer releases, you can use C<delete_files> (rm), e.g. from the
  command line:
  
   % pause rm 'My-Module-*TRIAL*'; # delete a dist's trial releases
   % pause rm '*TRIAL*' '*_*'; # delete all files containing TRIAL or underscore
  
  This function supports dry-run operation.
  
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<detail> => I<bool>
  
  Whether to return detailed records.
  
  =item * B<num_keep> => I<int> (default: 1)
  
  Number of new versions (including newest) to keep.
  
  1 means to only keep the newest version, 2 means to keep the newest and the
  second newest, and so on.
  
  =item * B<password>* => I<str>
  
  PAUSE password.
  
  =item * B<username>* => I<str>
  
  PAUSE ID.
  
  =back
  
  Special arguments:
  
  =over 4
  
  =item * B<-dry_run> => I<bool>
  
  Pass -dry_run=>1 to enable simulation mode.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 list_dists(%args) -> [status, msg, result, meta]
  
  List distributions on your PAUSE account.
  
  Distribution names will be extracted from tarball/zip filenames.
  
  Unknown/unparseable filenames will be skipped.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<detail> => I<bool>
  
  Whether to return detailed records.
  
  =item * B<newest> => I<bool>
  
  Only show newest non-dev version.
  
  Dev versions will be skipped.
  
  =item * B<newest_n> => I<int>
  
  Only show this number of newest non-dev versions.
  
  Dev versions will be skipped.
  
  =item * B<password>* => I<str>
  
  PAUSE password.
  
  =item * B<username>* => I<str>
  
  PAUSE ID.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 list_files(%args) -> [status, msg, result, meta]
  
  List files on your PAUSE account.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<del> => I<bool>
  
  Only list files which are scheduled for deletion.
  
  =item * B<detail> => I<bool>
  
  Whether to return detailed records.
  
  =item * B<files> => I<array[str]>
  
  File names/wildcard patterns.
  
  =item * B<password>* => I<str>
  
  PAUSE password.
  
  =item * B<username>* => I<str>
  
  PAUSE ID.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 reindex_files(%args) -> [status, msg, result, meta]
  
  Force reindexing.
  
  This function supports dry-run operation.
  
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<files>* => I<array[str]>
  
  File names/wildcard patterns.
  
  =item * B<password>* => I<str>
  
  PAUSE password.
  
  =item * B<username>* => I<str>
  
  PAUSE ID.
  
  =back
  
  Special arguments:
  
  =over 4
  
  =item * B<-dry_run> => I<bool>
  
  Pass -dry_run=>1 to enable simulation mode.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 set_account_info(%args) -> [status, msg, result, meta]
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<password>* => I<str>
  
  PAUSE password.
  
  =item * B<username>* => I<str>
  
  PAUSE ID.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 set_password(%args) -> [status, msg, result, meta]
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<password>* => I<str>
  
  PAUSE password.
  
  =item * B<username>* => I<str>
  
  PAUSE ID.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 undelete_files(%args) -> [status, msg, result, meta]
  
  Undelete files.
  
  When a file is deleted, it is not immediately deleted but has
  scheduled_for_deletion status for 72 hours, then deleted. During that time, the
  file can be undeleted.
  
  This function supports dry-run operation.
  
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<files>* => I<array[str]>
  
  File names/wildcard patterns.
  
  =item * B<password>* => I<str>
  
  PAUSE password.
  
  =item * B<username>* => I<str>
  
  PAUSE ID.
  
  =back
  
  Special arguments:
  
  =over 4
  
  =item * B<-dry_run> => I<bool>
  
  Pass -dry_run=>1 to enable simulation mode.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  
  =head2 upload_file(%args) -> [status, msg, result, meta]
  
  Upload file(s) to your PAUSE account.
  
  Arguments ('*' denotes required arguments):
  
  =over 4
  
  =item * B<files>* => I<array[str]>
  
  File names/wildcard patterns.
  
  =item * B<password>* => I<str>
  
  PAUSE password.
  
  =item * B<subdir> => I<str> (default: "")
  
  Subdirectory to put the file(s) into.
  
  =item * B<username>* => I<str>
  
  PAUSE ID.
  
  =back
  
  Returns an enveloped result (an array).
  
  First element (status) is an integer containing HTTP status code
  (200 means OK, 4xx caller error, 5xx function error). Second element
  (msg) is a string containing error message, or 'OK' if status is
  200. Third element (result) is optional, the actual result. Fourth
  element (meta) is called result metadata and is optional, a hash
  that contains extra information.
  
  Return value:  (any)
  
  =head1 SEE ALSO
  
  L<CPAN::Uploader> which also does uploading from CLI.
  
  L<WWW::PAUSE::CleanUpHomeDir> which can clean old releases from your PAUSE
  account (CLI example is provided script).
  
  L<https://perlancar.wordpress.com/2015/03/25/interacting-with-pause-using-cli/>
  
  =head1 HOMEPAGE
  
  Please visit the project's homepage at L<https://metacpan.org/release/WWW-PAUSE-Simple>.
  
  =head1 SOURCE
  
  Source repository is at L<https://github.com/perlancar/perl-WWW-PAUSE-Simple>.
  
  =head1 BUGS
  
  Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=WWW-PAUSE-Simple>
  
  When submitting a bug or request, please include a test-file or a
  patch to an existing test-file that illustrates the bug or desired
  feature.
  
  =head1 AUTHOR
  
  perlancar <perlancar@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2015 by perlancar@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
WWW_PAUSE_SIMPLE

$fatpacked{"YAML/Dumper/Syck.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'YAML_DUMPER_SYCK';
  package YAML::Dumper::Syck;
  use strict;
  
  sub new { $_[0] }
  sub dump { shift; YAML::Syck::Dump( $_[0] ) }
  
  1;
YAML_DUMPER_SYCK

$fatpacked{"YAML/Loader/Syck.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'YAML_LOADER_SYCK';
  package YAML::Loader::Syck;
  use strict;
  
  sub new { $_[0] }
  sub load { shift; YAML::Syck::Load( $_[0] ) }
  
  1;
YAML_LOADER_SYCK

$fatpacked{"YAML/Syck.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'YAML_SYCK';
  package YAML::Syck;
  
  # See documentation after the __END__ mark.
  
  use strict;
  use vars qw(
    @ISA @EXPORT @EXPORT_OK $VERSION
    $Headless $SortKeys $SingleQuote
    $ImplicitBinary $ImplicitTyping $ImplicitUnicode
    $UseCode $LoadCode $DumpCode
    $DeparseObject $LoadBlessed
  );
  use 5.006;
  use Exporter;
  
  BEGIN {
      $VERSION   = '1.29';
      @EXPORT    = qw( Dump Load DumpFile LoadFile );
      @EXPORT_OK = qw( DumpInto );
      @ISA       = qw( Exporter );
  
      $SortKeys    = 1;
      $LoadBlessed = 1;
  
      local $@;
      eval {
          require XSLoader;
          XSLoader::load( __PACKAGE__, $VERSION );
          1;
      } or do {
          require DynaLoader;
          push @ISA, 'DynaLoader';
          __PACKAGE__->bootstrap($VERSION);
      };
  
  }
  
  use constant QR_MAP => {
      ''   => sub { qr{$_[0]} },
      x    => sub { qr{$_[0]}x },
      i    => sub { qr{$_[0]}i },
      s    => sub { qr{$_[0]}s },
      m    => sub { qr{$_[0]}m },
      ix   => sub { qr{$_[0]}ix },
      sx   => sub { qr{$_[0]}sx },
      mx   => sub { qr{$_[0]}mx },
      si   => sub { qr{$_[0]}si },
      mi   => sub { qr{$_[0]}mi },
      ms   => sub { qr{$_[0]}sm },
      six  => sub { qr{$_[0]}six },
      mix  => sub { qr{$_[0]}mix },
      msx  => sub { qr{$_[0]}msx },
      msi  => sub { qr{$_[0]}msi },
      msix => sub { qr{$_[0]}msix },
  };
  
  sub __qr_helper {
      if ( $_[0] =~ /\A  \(\?  ([ixsm]*)  (?:-  (?:[ixsm]*))?  : (.*) \)  \z/x ) {
          my $sub = QR_MAP()->{$1} || QR_MAP()->{''};
          &$sub($2);
      }
      else {
          qr/$_[0]/;
      }
  }
  
  sub Dump {
      $#_
        ? join( '', map { YAML::Syck::DumpYAML($_) } @_ )
        : YAML::Syck::DumpYAML( $_[0] );
  }
  
  sub Load {
      if (wantarray) {
          my ($rv) = YAML::Syck::LoadYAML( $_[0] );
          @{$rv};
      }
      else {
          @_ = $_[0];
          goto &YAML::Syck::LoadYAML;
      }
  }
  
  sub _is_glob {
      my $h = shift;
  
      return 1 if ( ref($h) eq 'GLOB' );
      return 1 if ( ref( \$h ) eq 'GLOB' );
      return 1 if ( ref($h) =~ m/^IO::/ );
  
      return;
  }
  
  sub DumpFile {
      my $file = shift;
      if ( _is_glob($file) ) {
          for (@_) {
              my $err = YAML::Syck::DumpYAMLFile( $_, $file );
              if ($err) {
                  $! = 0 + $err;
                  die "Error writing to filehandle $file: $!\n";
              }
          }
      }
      else {
          open( my $fh, '>', $file ) or die "Cannot write to $file: $!";
          for (@_) {
              my $err = YAML::Syck::DumpYAMLFile( $_, $fh );
              if ($err) {
                  $! = 0 + $err;
                  die "Error writing to file $file: $!\n";
              }
          }
          close $fh
            or die "Error writing to file $file: $!\n";
      }
      return 1;
  }
  
  sub LoadFile {
      my $file = shift;
      if ( _is_glob($file) ) {
          Load(
              do { local $/; <$file> }
          );
      }
      else {
          if ( !-e $file || -z $file ) {
              die("'$file' is empty or non-existent");
          }
          open( my $fh, '<', $file ) or die "Cannot read from $file: $!";
          Load(
              do { local $/; <$fh> }
          );
      }
  }
  
  sub DumpInto {
      my $bufref = shift;
      ( ref $bufref ) or die "DumpInto not given reference to output buffer\n";
      YAML::Syck::DumpYAMLInto( $_, $bufref ) for @_;
      1;
  }
  
  1;
  
  __END__
  =pod
  
  =head1 NAME 
  
  YAML::Syck - Fast, lightweight YAML loader and dumper
  
  =head1 SYNOPSIS
  
      use YAML::Syck;
  
      # Set this for interoperability with other YAML/Syck bindings:
      # e.g. Load('Yes') becomes 1 and Load('No') becomes ''.
      $YAML::Syck::ImplicitTyping = 1;
  
      $data = Load($yaml);
      $yaml = Dump($data);
  
      # $file can be an IO object, or a filename
      $data = LoadFile($file);
      DumpFile($file, $data);
  
      # A string with multiple YAML streams in it
      $yaml = Dump(@data);
      @data = Load($yaml);
  
      # Dumping into a pre-existing output buffer
      my $yaml;
      DumpInto(\$yaml, @data);
  
  =head1 DESCRIPTION
  
  This module provides a Perl interface to the B<libsyck> data serialization
  library.  It exports the C<Dump> and C<Load> functions for converting
  Perl data structures to YAML strings, and the other way around.
  
  B<NOTE>: If you are working with other language's YAML/Syck bindings
  (such as Ruby), please set C<$YAML::Syck::ImplicitTyping> to C<1> before
  calling the C<Load>/C<Dump> functions.  The default setting is for
  preserving backward-compatibility with C<YAML.pm>.
  
  =head1 Differences Between YAML::Syck and YAML
  
  =head2 Error handling
  
  Some calls are designed to die rather than returning YAML. You should wrap
  your calls in eval to assure you do not get unexpected results.
  
  =head1 FLAGS
  
  =head2 $YAML::Syck::Headless
  
  Defaults to false.  Setting this to a true value will make C<Dump> omit the
  leading C<---\n> marker.
  
  =head2 $YAML::Syck::SortKeys
  
  Defaults to false.  Setting this to a true value will make C<Dump> sort
  hash keys.
  
  =head2 $YAML::Syck::SingleQuote
  
  Defaults to false.  Setting this to a true value will make C<Dump> always emit
  single quotes instead of bare strings.
  
  =head2 $YAML::Syck::ImplicitTyping
  
  Defaults to false.  Setting this to a true value will make C<Load> recognize
  various implicit types in YAML, such as unquoted C<true>, C<false>, as well as
  integers and floating-point numbers.  Otherwise, only C<~> is recognized to
  be C<undef>.
  
  =head2 $YAML::Syck::ImplicitUnicode
  
  Defaults to false.  For Perl 5.8.0 or later, setting this to a true value will
  make C<Load> set Unicode flag on for every string that contains valid UTF8
  sequences, and make C<Dump> return a unicode string.
  
  Regardless of this flag, Unicode strings are dumped verbatim without escaping;
  byte strings with high-bit set will be dumped with backslash escaping.
  
  However, because YAML does not distinguish between these two kinds of strings,
  so this flag will affect loading of both variants of strings.
  
  If you want to use LoadFile or DumpFile with unicode, you are required to open
  your own file in order to assure it's UTF8 encoded:
  
    open(my $fh, ">:encoding(UTF-8)", "out.yml");
    DumpFile($fh, $hashref);
  
  =head2 $YAML::Syck::ImplicitBinary
  
  Defaults to false.  For Perl 5.8.0 or later, setting this to a true value will
  make C<Dump> generate Base64-encoded C<!!binary> data for all non-Unicode
  scalars containing high-bit bytes.
  
  =head2 $YAML::Syck::UseCode / $YAML::Syck::LoadCode / $YAML::Syck::DumpCode
  
  These flags control whether or not to try and eval/deparse perl source code;
  each of them defaults to false.
  
  Setting C<$YAML::Syck::UseCode> to a true value is equivalent to setting
  both C<$YAML::Syck::LoadCode> and C<$YAML::Syck::DumpCode> to true.
  
  =head2 $YAML::Syck::LoadBlessed
  
  Defaults to true. Setting to false will block YAML::Syck from doing ANY
  blessing. This is an interface change since 1.21. The variable name was
  misleading, implying that no blessing would happen when in fact it did.
  
  Prior to 1.22, setting this to a false value only prevented C<Load> from
  blessing tag names that did not begin with C<!!perl> or C<!perl>;.
  
  =head1 BUGS
  
  Dumping Glob/IO values do not work yet.
  
  Dumping of Tied variables is unsupported.
  
  Dumping into tied (or other magic variables) with C<DumpInto> might not work
  properly in all cases.
  
  =head1 CAVEATS
  
  This module implements the YAML 1.0 spec.  To deal with data in YAML 1.1, 
  please use the C<YAML::XS> module instead.
  
  The current implementation bundles libsyck source code; if your system has a
  site-wide shared libsyck, it will I<not> be used.
  
  Tag names such as C<!!perl/hash:Foo> is blessed into the package C<Foo>, but
  the C<!hs/foo> and C<!!hs/Foo> tags are blessed into C<hs::Foo>.  Note that
  this holds true even if the tag contains non-word characters; for example,
  C<!haskell.org/Foo> is blessed into C<haskell.org::Foo>.  Please use
  L<Class::Rebless> to cast it into other user-defined packages. You can also
  set the LoadBlessed flag false to disable all blessing.
  
  This module has L<a lot of known
  issues|https://rt.cpan.org/Public/Dist/Display.html?Name=YAML-Syck>
  and has only been semi-actively maintained since 2007. If you
  encounter an issue with it probably won't be fixed unless you L<offer
  up a patch|http://github.com/toddr/YAML-Syck> in Git that's ready for
  release.
  
  There are still good reasons to use this module, such as better
  interoperability with other syck wrappers (like Ruby's), or some edge
  case of YAML's syntax that it handles better. It'll probably work
  perfectly for you, but if it doesn't you may want to look at
  L<YAML::XS>, or perhaps at looking another serialization format like
  L<JSON>.
  
  =head1 SEE ALSO
  
  L<YAML>, L<JSON::Syck>
  
  L<http://www.yaml.org/>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2005-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  The F<libsyck> code bundled with this library is released by
  "why the lucky stiff", under a BSD-style license.  See the F<COPYING>
  file for details.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =cut
YAML_SYCK

$fatpacked{"experimental.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPERIMENTAL';
  package experimental;
  $experimental::VERSION = '0.013';
  use strict;
  use warnings;
  use version ();
  
  use feature ();
  use Carp qw/croak carp/;
  
  my %warnings = map { $_ => 1 } grep { /^experimental::/ } keys %warnings::Offsets;
  my %features = map { $_ => 1 } $] > 5.015006 ? keys %feature::feature : do {
  	my @features;
  	if ($] >= 5.010) {
  		push @features, qw/switch say state/;
  		push @features, 'unicode_strings' if $] > 5.011002;
  	}
  	@features;
  };
  
  my %min_version = (
  	array_base      => '5',
  	autoderef       => '5.14.0',
  	current_sub     => '5.16.0',
  	evalbytes       => '5.16.0',
  	fc              => '5.16.0',
  	lexical_topic   => '5.10.0',
  	lexical_subs    => '5.18.0',
  	postderef       => '5.20.0',
  	postderef_qq    => '5.20.0',
  	refaliasing     => '5.21.5',
  	regex_sets      => '5.18.0',
  	say             => '5.10.0',
  	smartmatch      => '5.10.0',
  	signatures      => '5.20.0',
  	state           => '5.10.0',
  	switch          => '5.10.0',
  	unicode_eval    => '5.16.0',
  	unicode_strings => '5.12.0',
  );
  $_ = version->new($_) for values %min_version;
  
  my %additional = (
  	postderef  => ['postderef_qq'],
  	switch     => ['smartmatch'],
  );
  
  sub _enable {
  	my $pragma = shift;
  	if ($warnings{"experimental::$pragma"}) {
  		warnings->unimport("experimental::$pragma");
  		feature->import($pragma) if exists $features{$pragma};
  		_enable(@{ $additional{$pragma} }) if $additional{$pragma};
  	}
  	elsif ($features{$pragma}) {
  		feature->import($pragma);
  		_enable(@{ $additional{$pragma} }) if $additional{$pragma};
  	}
  	elsif (not exists $min_version{$pragma}) {
  		croak "Can't enable unknown feature $pragma";
  	}
  	elsif ($min_version{$pragma} > $]) {
  		my $stable = $min_version{$pragma};
  		if ($stable->{version}[1] % 2) {
  			$stable = version->new(
  				"5.".($stable->{version}[1]+1).'.0'
  			);
  		}
  		croak "Need perl $stable or later for feature $pragma";
  	}
  }
  
  sub import {
  	my ($self, @pragmas) = @_;
  
  	for my $pragma (@pragmas) {
  		_enable($pragma);
  	}
  	return;
  }
  
  sub _disable {
  	my $pragma = shift;
  	if ($warnings{"experimental::$pragma"}) {
  		warnings->import("experimental::$pragma");
  		feature->unimport($pragma) if exists $features{$pragma};
  		_disable(@{ $additional{$pragma} }) if $additional{$pragma};
  	}
  	elsif ($features{$pragma}) {
  		feature->unimport($pragma);
  		_disable(@{ $additional{$pragma} }) if $additional{$pragma};
  	}
  	elsif (not exists $min_version{$pragma}) {
  		carp "Can't disable unknown feature $pragma, ignoring";
  	}
  }
  
  sub unimport {
  	my ($self, @pragmas) = @_;
  
  	for my $pragma (@pragmas) {
  		_disable($pragma);
  	}
  	return;
  }
  
  1;
  
  #ABSTRACT: Experimental features made easy
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  experimental - Experimental features made easy
  
  =head1 VERSION
  
  version 0.013
  
  =head1 SYNOPSIS
  
   use experimental 'lexical_subs', 'smartmatch';
   my sub foo { $_[0] ~~ 1 }
  
  =head1 DESCRIPTION
  
  This pragma provides an easy and convenient way to enable or disable
  experimental features.
  
  Every version of perl has some number of features present but considered
  "experimental."  For much of the life of Perl 5, this was only a designation
  found in the documentation.  Starting in Perl v5.10.0, and more aggressively in
  v5.18.0, experimental features were placed behind pragmata used to enable the
  feature and disable associated warnings.
  
  The C<experimental> pragma exists to combine the required incantations into a
  single interface stable across releases of perl.  For every experimental
  feature, this should enable the feature and silence warnings for the enclosing
  lexical scope:
  
    use experimental 'feature-name';
  
  To disable the feature and, if applicable, re-enable any warnings, use:
  
    no experimental 'feature-name';
  
  The supported features, documented further below, are:
  
  	array_base    - allow the use of $[ to change the starting index of @array
  	autoderef     - allow push, each, keys, and other built-ins on references
  	lexical_topic - allow the use of lexical $_ via "my $_"
  	postderef     - allow the use of postfix dereferencing expressions, including
  	                in interpolating strings
  	refaliasing   - allow aliasing via \$x = \$y
  	regex_sets    - allow extended bracketed character classes in regexps
  	signatures    - allow subroutine signatures (for named arguments)
  	smartmatch    - allow the use of ~~
  	switch        - allow the use of ~~, given, and when
  
  =head2 Ordering matters
  
  Using this pragma to 'enable an experimental feature' is another way of saying
  that this pragma will disable the warnings which would result from using that
  feature.  Therefore, the order in which pragmas are applied is important.  In
  particular, you probably want to enable experimental features I<after> you
  enable warnings:
  
    use warnings;
    use experimental 'smartmatch';
  
  You also need to take care with modules that enable warnings for you.  A common
  example being Moose.  In this example, warnings for the 'smartmatch' feature are
  first turned on by the warnings pragma, off by the experimental pragma and back
  on again by the Moose module (fix is to switch the last two lines):
  
    use warnings;
    use experimental 'smartmatch';
    use Moose;
  
  =head2 Disclaimer
  
  Because of the nature of the features it enables, forward compatibility can not
  be guaranteed in any way.
  
  =head1 AUTHOR
  
  Leon Timmermans <leont@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Leon Timmermans.
  
  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
EXPERIMENTAL

s/^  //mg for values %fatpacked;

my $class = 'FatPacked::'.(0+\%fatpacked);
no strict 'refs';
*{"${class}::files"} = sub { keys %{$_[0]} };

if ($] < 5.008) {
  *{"${class}::INC"} = sub {
     if (my $fat = $_[0]{$_[1]}) {
       return sub {
         return 0 unless length $fat;
         $fat =~ s/^([^\n]*\n?)//;
         $_ = $1;
         return 1;
       };
     }
     return;
  };
}

else {
  *{"${class}::INC"} = sub {
    if (my $fat = $_[0]{$_[1]}) {
      open my $fh, '<', \$fat
        or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
      return $fh;
    }
    return;
  };
}

unshift @INC, bless \%fatpacked, $class;
  } # END OF FATPACK CODE


# DATE
# VERSION

use 5.010001;
use strict;
use warnings;

use Perinci::CmdLine::pause;

BEGIN { $ENV{DATA_SAH_PP} = 1 }

my $prefix = '/WWW/PAUSE/Simple/';
Perinci::CmdLine::pause->new(
    url => $prefix,
    subcommands => {
        upload     => { url => "${prefix}upload_file" },
        list       => { url => "${prefix}list_files" },
        ls         => {
            url => "${prefix}list_files",
            summary => 'Alias for list',
            is_alias => 1,
        },
        "list-dists" => { url => "${prefix}list_dists" },
        delete     => { url => "${prefix}delete_files" },
        rm         => {
            url => "${prefix}delete_files",
            summary => 'Alias for delete',
            is_alias => 1,
        },
        undelete   => { url => "${prefix}undelete_files" },
        reindex    => { url => "${prefix}reindex_files" },
        password   => { url => "${prefix}set_password" },
        #'account-info' => { url => "${prefix}set_account_info" },
        cleanup    => { url => "${prefix}delete_old_releases" },
    },
    log => 1,
)->run;

# ABSTRACT: An API for PAUSE
# PODNAME: pause

__END__

=pod

=encoding UTF-8

=head1 NAME

pause - An API for PAUSE

=head1 VERSION

This document describes version 0.27 of pause (from Perl distribution App-pause), released on 2015-04-15.

=head1 SYNOPSIS

First create a config file C<~/pause.conf> containing:

 username=<Your PAUSE ID>
 password=<Your PAUSE password>

or if you have C<~/.pause> from L<cpan-upload>, C<pause> can read it too
(encrypted C<.pause> is currently not supported).

Then:

 # upload one or more files
 % pause upload Foo-Bar-0.12.tar.gz Baz-2.24.tar.gz
 % pause upload Foo-Bar-0.12.tar.gz --subdir old/2014; # upload to a subdir

 # list your files
 % pause list
 % pause ls 'App-*'; # accept filenames/wildcard patterns, note: quote first
 % pause ls -l     ; # see file sizes/mtimes/etc instead of just names

 # delete files
 % pause delete Foo-Bar-0.12.tar.gz Foo-Bar-0.12.readme Foo-Bar-0.12.meta
 % pause rm 'Foo-Bar-*'; # accept wildcard patterns, but quote first

 # undelete files scheduled for deletion (but not actually deleted yet)
 % pause undelete Foo-Bar-0.12.tar.gz Foo-Bar-0.12.readme Foo-Bar-0.12.meta
 % pause undelete 'Foo-Bar-*'; # accept wildcard patterns, but quote first

 # force reindexing
 % pause reindex Foo-Bar-0.12.tar.gz Foo-Bar-0.12.meta
 % pause reindex 'Foo-Bar-*'; # accept wildcard patterns, but quote first

 # clean old releases, by default will only leave the newest non-dev version
 % pause cleanup
 % pause cleanup -n 3 ; # keep 3 versions (newest + previous two)

 # change your password
 ...

 # view your account info
 ...

 # change your email forwarding
 ...

=head1 SUBCOMMANDS

=head2 B<cleanup>

Delete older versions of distributions on your PAUSE account.

Developer releases will not be deleted.

To delete developer releases, you can use C<delete_files> (rm), e.g. from the
command line:

 % pause rm 'My-Module-*TRIAL*'; # delete a dist's trial releases
 % pause rm '*TRIAL*' '*_*'; # delete all files containing TRIAL or underscore


=head2 B<delete>

Delete files.

When a file is deleted, it is not immediately deleted but has
scheduled_for_deletion status for 72 hours, then deleted. During that time, the
file can be undeleted.


=head2 B<list>

List files on your PAUSE account.

=head2 B<list-dists>

List distributions on your PAUSE account.

Distribution names will be extracted from tarball/zip filenames.

Unknown/unparseable filenames will be skipped.


=head2 B<ls>

Alias for list.

=head2 B<password>

=head2 B<reindex>

Force reindexing.

=head2 B<rm>

Alias for delete.

=head2 B<undelete>

Undelete files.

When a file is deleted, it is not immediately deleted but has
scheduled_for_deletion status for 72 hours, then deleted. During that time, the
file can be undeleted.


=head2 B<upload>

Upload file(s) to your PAUSE account.

=head1 OPTIONS

C<*> marks required options.

=head2 Common options

=over

=item B<--config-path>=I<filename>

Set path to configuration file.

Can be specified multiple times.

=item B<--config-profile>=I<s>

Set configuration profile to use.

=item B<--debug>

Set log level to debug.

=item B<--format>=I<s>

Choose output format, e.g. json, text.

Default value:

 undef

=item B<--help>, B<-h>, B<-?>

Display help message and exit.

=item B<--json>

Set output format to json.

=item B<--log-level>=I<s>

Set log level.

=item B<--naked-res>

When outputing as JSON, strip result envelope.

Default value:

 0

By default, when outputing as JSON, the full enveloped result is returned, e.g.:

    [200,"OK",[1,2,3],{"func.extra"=>4}]

The reason is so you can get the status (1st element), status message (2nd
element) as well as result metadata/extra result (4th element) instead of just
the result (3rd element). However, sometimes you want just the result, e.g. when
you want to pipe the result for more post-processing. In this case you can use
`--naked-res` so you just get:

    [1,2,3]


=item B<--no-config>

Do not use any configuration file.

=item B<--no-env>

Do not read environment for default options.

=item B<--password>=I<s>*

PAUSE password.

=item B<--quiet>

Set log level to quiet.

=item B<--subcommands>

List available subcommands.

=item B<--trace>

Set log level to trace.

=item B<--username>=I<s>*

PAUSE ID.

=item B<--verbose>

Set log level to info.

=item B<--version>, B<-v>

Display program's version and exit.

=back

=head2 Options for subcommand cleanup

=over

=item B<--detail>, B<-l>

Whether to return detailed records.

=item B<--num-keep>=I<i>, B<-n>

Number of new versions (including newest) to keep.

Default value:

 1

1 means to only keep the newest version, 2 means to keep the newest and the
second newest, and so on.


=back

=head2 Options for subcommand delete

=over

=item B<--file>=I<s@>*

File name/wildcard pattern.

Can be specified multiple times.

=item B<--files-json>=I<s>

File names/wildcard patterns (JSON-encoded).

See C<--file>.

=back

=head2 Options for subcommand list

=over

=item B<--del>

Only list files which are scheduled for deletion.

=item B<--detail>, B<-l>

Whether to return detailed records.

=item B<--file>=I<s@>

File name/wildcard pattern.

Can be specified multiple times.

=item B<--files-json>=I<s>

File names/wildcard patterns (JSON-encoded).

See C<--file>.

=back

=head2 Options for subcommand list-dists

=over

=item B<--detail>, B<-l>

Whether to return detailed records.

=item B<--newest>

Only show newest non-dev version.

Dev versions will be skipped.


=item B<--newest-n>=I<i>

Only show this number of newest non-dev versions.

Dev versions will be skipped.


=back

=head2 Options for subcommand reindex

=over

=item B<--file>=I<s@>*

File name/wildcard pattern.

Can be specified multiple times.

=item B<--files-json>=I<s>

File names/wildcard patterns (JSON-encoded).

See C<--file>.

=back

=head2 Options for subcommand undelete

=over

=item B<--file>=I<s@>*

File name/wildcard pattern.

Can be specified multiple times.

=item B<--files-json>=I<s>

File names/wildcard patterns (JSON-encoded).

See C<--file>.

=back

=head2 Options for subcommand upload

=over

=item B<--file>=I<s@>*

File name/wildcard pattern.

Can be specified multiple times.

=item B<--files-json>=I<s>

File names/wildcard patterns (JSON-encoded).

See C<--file>.

=item B<--subdir>=I<s>

Subdirectory to put the file(s) into.

Default value:

 ""

=back

=head1 COMPLETION

This script has shell tab completion capability with support for several
shells.

=head2 bash

To activate bash completion for this script, put:

 complete -C pause pause

in your bash startup (e.g. C<~/.bashrc>). Your next shell session will then
recognize tab completion for the command. Or, you can also directly execute the
line above in your shell to activate immediately.

It is recommended, however, that you install L<shcompgen> which allows you to
activate completion scripts for several kinds of scripts on multiple shells.
Some CPAN distributions (those that are built with
L<Dist::Zilla::Plugin::GenShellCompletion>) will even automatically enable shell
completion for their included scripts (using C<shcompgen>) at installation time,
so you can immadiately have tab completion.

=head2 tcsh

To activate tcsh completion for this script, put:

 complete pause 'p/*/`pause`/'

in your tcsh startup (e.g. C<~/.tcshrc>). Your next shell session will then
recognize tab completion for the command. Or, you can also directly execute the
line above in your shell to activate immediately.

It is also recommended to install C<shcompgen> (see above).

=head2 other shells

For fish and zsh, install C<shcompgen> as described above.

=head1 ENVIRONMENT

=over

=item * PAUSE_OPT

Specify additional command-line options

=back

=head1 CONFIGURATION FILE

This script can read configuration file, which by default is searched at C<~/.config/pause.conf>, C<~/pause.conf> or C</etc/pause.conf> (can be changed by specifying C<--config-path>). All found files will be read and merged.

To disable searching for configuration files, pass C<--no-config>.

Configuration file is in the format of L<IOD>, which is basically INI with some extra features. Section names map to subcommand names. 

You can put multiple profiles in a single file by using section names like C<[profile=SOMENAME]> or C<[SUBCOMMAND_NAME profile=SOMENAME]>. Those sections will only be read if you specify the matching C<--config-profile SOMENAME>.

List of available configuration parameters:

=head2 Common for all subcommands

 format (see --format)
 log_level (see --log-level)
 naked_res (see --naked-res)
 password (see --password)
 username (see --username)

=head2 For subcommand 'cleanup'

 detail (see --detail)
 num_keep (see --num-keep)

=head2 For subcommand 'delete'

 files (see --file)

=head2 For subcommand 'list'

 del (see --del)
 detail (see --detail)
 files (see --file)

=head2 For subcommand 'list-dists'

 detail (see --detail)
 newest (see --newest)
 newest_n (see --newest-n)

=head2 For subcommand 'password'


=head2 For subcommand 'reindex'

 files (see --file)

=head2 For subcommand 'undelete'

 files (see --file)

=head2 For subcommand 'upload'

 files (see --file)
 subdir (see --subdir)

=head1 FILES

~/.pause

~/.config/pause.conf

~/pause.conf

/etc/pause.conf

=head1 HOMEPAGE

Please visit the project's homepage at L<https://metacpan.org/release/App-pause>.

=head1 SOURCE

Source repository is at L<https://github.com/perlancar/perl-App-pause>.

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=App-pause>

When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.

=head1 AUTHOR

perlancar <perlancar@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2015 by perlancar@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
