Config-GitLike-1.18/000755 000765 000024 00000000000 13632622657 014470 5ustar00chmrrstaff000000 000000 Config-GitLike-1.18/inc/000755 000765 000024 00000000000 13632622657 015241 5ustar00chmrrstaff000000 000000 Config-GitLike-1.18/SIGNATURE000644 000765 000024 00000007553 13632622657 015766 0ustar00chmrrstaff000000 000000 This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.83. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA256 SHA256 5646ee3d73fa04e4b52a7d10e25692264f18caa1eece400b15d9075ced98096a Changes SHA256 407a5d3c5cbd61f43c7c1d5ab07eab02baeeb71294f1560f9c3e54c0e51aead1 MANIFEST SHA256 422647f0d4f3c6a216993f8df4f2e90a555c999ab384757f2ded1bff11e2404a META.yml SHA256 7d63a26075445fa1a4e61c546bcbade14fc29547947be21034c2ca5332e4ecc8 Makefile.PL SHA256 67d139199c03b8bf8447a5a62f0d0b6dc1bd5bf6dbe04de6d21998c577823ed6 inc/Module/Install.pm SHA256 6ebcc53a161dd5dc0aae69e4704575f2b00181901d768a82e26722a309cfdbe4 inc/Module/Install/Base.pm SHA256 d3f8c839d03fd21c197d05362dbb277cd7cadb15da6390d124b61e851f15146e inc/Module/Install/Can.pm SHA256 3f5f298d2804c3c283d5d75d1bdc972b1a178a27c4e981959d070ce41bb89b9f inc/Module/Install/ExtraTests.pm SHA256 e9e72e18921c10c87bc4ea4c20af83e52015b9f5775d00ac64073042403717ca inc/Module/Install/Fetch.pm SHA256 a7a681bf2c9eee58a372cb642ffe42b0301d1200432ba8de9f7791cd1ecc9827 inc/Module/Install/Makefile.pm SHA256 aa887fa65a5eb6bbd1805706ce298b3f3cd55b353ecfd37aa7d35ae419331a49 inc/Module/Install/Metadata.pm SHA256 26b166ff62aacdb55317d1659f160aa4935097eea9810ea980e6d747206b5dc0 inc/Module/Install/Win32.pm SHA256 5f73a6851a91ea44e65b924f918743ad6e860620ad7a38a39d0295e0c5652a9f inc/Module/Install/WriteAll.pm SHA256 524aea674343b6029b7991bcc14a35efc425461073c62d0bce2ec7241b704789 lib/Config/GitLike.pm SHA256 726d345a29c4f89f358e7fbc7c28b224655a67022316a5bff7f101cbfaddaee9 lib/Config/GitLike/Cascaded.pm SHA256 f39e5ae87dd44ebe353c05de9f4360f624dd8978efbecbeb3f77d55b1ac3507a lib/Config/GitLike/Git.pm SHA256 79d053d9bd28a6e392ad984a7a1e8ba534d31b7300cab8003f042695579e69ac t/00_use.t SHA256 f130bb4e5cdf84603ab4fe6f02a03353b8d5ac29692a237fef24a8fc7a54c5cc t/casing.t SHA256 1478c9bbe8fcf741cbd60d89493caa2568d4094609363b1d39dbf035b06a09ea t/comment.t SHA256 cb7b2032ac6d96caae6d2c12501b7878cb95733e5f6be77b9f5216c0e9c08429 t/dos.conf SHA256 ed1f83906ea7244d88e02d9813c5141257a6e15f5be35e5506800a6f8e3171d3 t/encoding.t SHA256 57a969b7876f22fdc885e0aa24e6fa90f3057c263d89ab4f0f007bab203ffa33 t/get_regexp_filter_multiple.t SHA256 462faabb1cfaa37c87790426aa299e9c20ff4c11b4c8788bb26115f162a629e5 t/lib/TestConfig.pm SHA256 6ab11145dc9e06ed4fff8f7342243fe96727f37603fed6f106dcd4b766093f91 t/mac.conf SHA256 e147911a10bac7e0594bc036512422ba68bc9f80948d829acf3418e123655fcf t/platforms.t SHA256 a825d10438ed3187875124d22f1b1dea52fb5a0bd3dea7ae909b52cfdc31e83e t/t1300-repo-config.t SHA256 cb7b2032ac6d96caae6d2c12501b7878cb95733e5f6be77b9f5216c0e9c08429 t/unix.conf SHA256 734a34df3e8bda32907cdde139ff80541aca71fc5e09fe77c9e04c0d9e51436e t/util/translate.pl -----BEGIN PGP SIGNATURE----- iQIzBAEBCAAdFiEEjbxBryL5b+Ppzen1kezo28rFwwUFAl5rJa8ACgkQkezo28rF wwUm6w//bGN28vI2GCcOiZDtZpSCbjua6eIXNL9KQ0lQcuSPIvJNpkgiIfR5sJ29 j8ncDZIYADp9dmtXXiTJudmk7w2jrvbIWGiY3E3CC7bDUDqcQLTkKvWyKntk9sZF Uu98gU4Pens16AtyWKYgrQ94WSOzZL8Od5Py511vo0JUGxC8ww2q54THOJYtvdic 46amyXr85edXI/XYQ/H21npauoxrUcPEWybuvQBkIY+3tmVr4xiwUrBTX0isi8XQ K7TvuQYUq+VQOfhIsdq3aod4+jJWPUmAW8AAcSYzHr62JbZy2cG2wu381zAM1H/I MwfbeFHc0ZYRMZ0h5POGlXSRIqqsYhDFr6kXMLmVrpkZDn7V4JWAW20scksNZ0Jh PPeoUjthjnb4LUHIdRQCulJISRD+G1ZsGy1/ArZSnEH+RW47/plosqQkC1nTmzGd HET5tFjunXxlwFtDkR3tku1AfNTReI5xzyIzw3sDrmlpM86AwrcTzmOpsh64ejI4 tNS/hKkBn0zpT++riB11ybiVHNPqO0wzfX5ROQdvexdeZbscwlYmCHFCcdncGhvw nRex8A2MYvAZiXucTuEU/mDZaetvcYAKl81mzFZVbz4q8fAR6FApMKNelaDkizqM ca0sBWUEFo2NK90ai+djqdjk/ePqOK1jVOSBDm1UMbecABo38lo= =pPjZ -----END PGP SIGNATURE----- Config-GitLike-1.18/Changes000644 000765 000024 00000007770 13632621310 015757 0ustar00chmrrstaff000000 000000 Revision history for perl module Config::GitLike 1.18 2020-03-12 - Return a more correct `dir_file` for Config::GitLike::Git; this change is not backwards-compatible, but matches behavior to existing documentation and expectation. 1.17 2017-07-16 - Read and write files with non-UNIX-newlines - Filter multiple values correctly when using `get_regexp` - Throw an error when `get` is passed no section - Perl 5.28.0 compatibility, by pushing '.' into @INC in Makefile.PL for Module::Install 1.16 2015-02-16 - Canonicalize paths using File::Spec->canonpath; this addresses failures on Windows where /-separated paths were stored in the origins hash, due to Cwd::abs_path returning them 1.15 2014-06-24 - Cope with Cwd::abs_path dying on non-existant paths on Windows 1.14 2014-05-20 - Fix tests under MacOS, where TMPDIR is, by default, under a symlink 1.13 2014-04-22 - Only expand ~ in paths if they are the first character - Implement include.path, as git 1.7.10 and above do 1.12 2013-08-05 - Reformat Changes file to follow CPAN::Changes::Spec; no functional changes. 1.11 2013-08-04 - Switch from the deprecated Any::Moose to Moo 1.10 2012-11-07 - Provide and API got accessing the original key that a value was set with, in a case-preserving way. If the case of the key in a file matters, it is now possible to determine. - The 'name' value passed to the 'callback' parameter is now no longer forced to lower-case, as a consequence. 1.09 2012-08-10 - Multiple bug fixes concerning filters, including empty filters, valueless keys, and applying filters to single values. - Add "human" argument to get_all and get_regexp, to match get - Add an add_comment method - Add an encoding attribute, which adds the appropriate layer on file I/O - Enforce that all keys must have sections, as git 1.7.4.4 began doing 1.08 2012-02-15 - Fix loading of user_file, broken in dcdd01f, due to unexpanded ~ (alexmv, clkao@clkao.org) 1.07 2011-10-25 - Fix a spelling mistake in Config::GitLike::Cascaded (gregoa@debian.org, forwarded by carnil@debian.org) 1.06 2011-10-12 - Allow calling ->load_file as a class method, for simple use cases (alexmv) - Fix a parsing bug when quoted strings directly adjoined to unquoted strings (alexmv) - Calling ->load_file on a nonexistant file no longer sets ->is_loaded (alexmv) - Document that getters implicitly call ->load (alexmv) - Make ->dump implicitly call ->load as well (alexmv) - Minor POD fixes (alexmv, spang) 1.05 2011-01-07 - support Module::Install::ExtraTests 0.007 (sunnavy) - properly set is => 'rw' in inherited classes (trs, alexmv) - silence lc warnings on undef under perl 5.12 (iarnell@gmail.com) 1.04 2010-04-03 - The functionality of Config::GitLike::Cascaded has been folded into Config::GitLike as a "cascade" option, and the subpackage is now deprecated. (alexmv) - Config::GitLike::Git->new->load("/path/to/git") when the path is lacking a ".git", or is a bare repository, now works. (alexmv) - Fixed a bug wherein the home directory config file would be loaded twice, causing all values to be multiple, if that was your cwd. Reported by rjbs. (alexmv) - Allow explicitly calling ->load_file without previously having called ->load (alexmv) 1.03 2010-01-03 - Filter without replace_all should only replace the _first_ match (alexmv) - Having a matching filter with multiple and not replace_all does mean replacement (alexmv) - Fix a test that failed because multiple now works, and we're too smart (alexmv) - Fix for when ->set_multiple called with no arguments (alexmv) 1.02 2009-08-19 - Bugfixes and extra tests for escaped \ and " in subsections (sunnavy) - win32 fixes (sunnavy) - auto-escape \ and " in subsections on set (sunnavy) 1.01 2009-08-11 - Fix breakage under Mouse due to Moose references - New Config::GitLike::Git module for loading config files from the git locations - various cleanups of Makefile.PL - remove extraneous dep Regexp::Common 1.00 2009-07-08 - Initial release Config-GitLike-1.18/MANIFEST000644 000765 000024 00000001121 13632621764 015612 0ustar00chmrrstaff000000 000000 Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/ExtraTests.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Config/GitLike.pm lib/Config/GitLike/Cascaded.pm lib/Config/GitLike/Git.pm Makefile.PL MANIFEST This list of files META.yml SIGNATURE t/00_use.t t/casing.t t/comment.t t/dos.conf t/encoding.t t/get_regexp_filter_multiple.t t/lib/TestConfig.pm t/mac.conf t/platforms.t t/t1300-repo-config.t t/unix.conf t/util/translate.pl Config-GitLike-1.18/t/000755 000765 000024 00000000000 13632622657 014733 5ustar00chmrrstaff000000 000000 Config-GitLike-1.18/META.yml000644 000765 000024 00000001225 13632621746 015737 0ustar00chmrrstaff000000 000000 --- abstract: 'git-compatible config file parsing' author: - 'Best Practical Solutions, LLC' build_requires: ExtUtils::MakeMaker: 6.59 Test::Exception: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.19' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Config-GitLike no_index: directory: - inc - t - xt requires: Moo: 0 MooX::Types::MooseLike: 0 perl: 5.8.0 resources: license: http://dev.perl.org/licenses/ repository: http://github.com/bestpractical/config-gitlike version: '1.18' Config-GitLike-1.18/lib/000755 000765 000024 00000000000 13632622657 015236 5ustar00chmrrstaff000000 000000 Config-GitLike-1.18/Makefile.PL000644 000765 000024 00000000533 13614253640 016433 0ustar00chmrrstaff000000 000000 BEGIN { push @INC, '.' } use inc::Module::Install; name('Config-GitLike'); all_from('lib/Config/GitLike.pm'); repository('http://github.com/bestpractical/config-gitlike'); perl_version '5.008'; requires 'Moo'; requires 'MooX::Types::MooseLike'; # MooX::Types::MooseLike::Base build_requires 'Test::Exception'; extra_tests(); sign(); WriteAll(); Config-GitLike-1.18/lib/Config/000755 000765 000024 00000000000 13632622657 016443 5ustar00chmrrstaff000000 000000 Config-GitLike-1.18/lib/Config/GitLike.pm000644 000765 000024 00000170234 13632621214 020324 0ustar00chmrrstaff000000 000000 package Config::GitLike; use Moo; use MooX::Types::MooseLike::Base qw(Bool HashRef ArrayRef Maybe Str Int); use File::Spec; use Cwd; use Scalar::Util qw(openhandle); use Fcntl qw(O_CREAT O_EXCL O_WRONLY); use 5.008; our $VERSION = '1.18'; has 'confname' => ( is => 'rw', required => 1, isa => Str, ); # not defaulting to {} allows the predicate is_loaded # to determine whether data has been loaded yet or not has 'data' => ( is => 'rw', predicate => 'is_loaded', isa => HashRef, ); # key => bool has 'multiple' => ( is => 'rw', isa => HashRef, default => sub { +{} }, ); has 'casing' => ( is => 'rw', isa => HashRef, default => sub { +{} }, ); # filename where the definition of each key was loaded from has 'origins' => ( is => 'rw', isa => HashRef, default => sub { +{} }, ); has 'config_files' => ( is => 'rw', isa => ArrayRef, default => sub { [] }, ); # default to being more relaxed than git, but allow enforcement # of only-write-things-that-git-config-can-read if you want to has 'compatible' => ( is => 'rw', isa => Bool, default => sub { 0 }, ); has 'cascade' => ( is => 'rw', isa => Bool, default => sub { 0 }, ); has 'encoding' => ( is => 'rw', isa => Maybe[Str], ); has 'newlines' => ( is => 'rw', isa => HashRef, default => sub { +{} }, ); has 'include' => ( is => 'rw', isa => Str, default => sub { "include.path" }, ); has 'max_depth' => ( is => 'rw', isa => Int, default => sub { 10 }, ); sub set_multiple { my $self = shift; my ($name, $mult) = (@_, 1); $self->multiple->{ $self->canonical_case( $name ) } = $mult; } sub is_multiple { my $self = shift; my $name = shift; return if !defined $name; return $self->multiple->{ $self->canonical_case( $name ) }; } sub load { my $self = shift; my $path = shift || Cwd::cwd; $self->data({}); $self->multiple({}); $self->config_files([]); $self->load_global; $self->load_user; $self->load_dirs( $path ); return wantarray ? %{$self->data} : \%{$self->data}; } sub dir_file { my $self = shift; return "." . $self->confname; } sub load_dirs { my $self = shift; my $path = shift; my($vol, $dirs, undef) = File::Spec->splitpath( $path, 1 ); my @dirs = File::Spec->splitdir( $dirs ); my @found; while (@dirs) { my $path = File::Spec->catpath( $vol, File::Spec->catdir(@dirs), $self->dir_file ); if (-f $path) { push @found, $path; last unless $self->cascade; } pop @dirs; } $self->load_file( $_ ) for reverse @found; } sub global_file { my $self = shift; return "/etc/" . $self->confname; } sub load_global { my $self = shift; return $self->load_file( $self->global_file ); } sub user_file { my $self = shift; return File::Spec->catfile( "~", "." . $self->confname ); } sub load_user { my $self = shift; return $self->load_file( $self->user_file ); } # returns undef if the file was unable to be opened sub _read_config { my $self = shift; my $filename = shift; return unless -f $filename and -r $filename; open(my $fh, '<', $filename) or return; if (my $encoding = $self->encoding) { binmode $fh, ":encoding($encoding)"; } my $c = do {local $/; <$fh>}; my $newlines = "\n"; if ($c =~ m/\r\n/) { # Convert from DOS; `git` applies this on read always, and # simply mangles files on write. $newlines = "\r\n"; $c =~ s/\r\n/\n/g; } elsif ($c !~ /\n/ and $c =~ /\r/) { # Best-guess convert from Mac. $newlines = "\r"; $c =~ s/\r/\n/g; } $self->newlines->{$filename} = $newlines; $c =~ s/\n*$/\n/; # Ensure it ends with a newline return $c; } sub load_file { my $ref = shift; my $self; if (ref $ref) { $self = $ref; } else { # Set up a temporary object $self = $ref->new( confname => "" ); } unshift @_, "filename" if @_ % 2; my %args = ( filename => undef, silent => 0, relative => Cwd::cwd(), depth => 0, force => 0, includes => 1, @_, ); my $filename = $args{filename}; # Do some canonicalization $filename =~ s/^~/$ENV{'HOME'}/g; $filename = eval { Cwd::abs_path( File::Spec->rel2abs($filename, $args{relative}) ) } || $filename; $filename = File::Spec->canonpath( $filename ); return $self->data if grep {$_ eq $filename} @{$self->config_files} and not $args{force}; my $c = $self->_read_config($filename); return $self->data if not $c and $args{silent}; unless (defined $c) { die "Failed to load $filename: $!\n" if not ref $ref; return; } # Note this filename as having been loaded push @{$self->config_files}, $filename; $self->set_multiple( $self->include ) if $self->include and $args{includes}; $self->data({}) unless $self->is_loaded; $self->parse_content( content => $c, callback => sub { my %def = @_; $self->define(@_, origin => $filename); return unless $self->include and $args{includes}; my ($sec, $subsec, $name) = _split_key($self->include); return unless lc( $def{section} || '') eq lc( $sec || ''); return unless ($def{subsection} || '') eq ($subsec || ''); return unless lc( $def{name} || '') eq lc( $name || ''); die "Exceeded maximum include depth (".$self->max_depth.") ". "while including $def{value} from $filename" if $args{depth} > $self->max_depth; my (undef, $dir, undef) = File::Spec->splitpath($filename); $self->load_file( filename => $def{value}, silent => 1, relative => $dir, depth => $args{depth}+1, force => 1, ); }, error => sub { error_callback( @_, filename => $filename ); }, ); return $self->data; } sub error_callback { my %args = @_; my $offset_of_prev_newline = rindex( $args{content}, "\n", $args{offset} ); my $offset_of_next_newline = index( $args{content}, "\n", $args{offset} ); my $line = substr( $args{content}, $offset_of_prev_newline + 1, $offset_of_next_newline - ($offset_of_prev_newline + 1), ); my $line_number = 1; my $current_offset = 0; while ($current_offset <= $args{offset}) { # nibble off a line of content $args{content} =~ s/(.*\n)//; $line_number++; $current_offset += length $1; } my $position = (length $line) - ($current_offset - ($args{offset} + 1)); die "Error parsing $args{filename} at line $line_number, position $position." ."\nBad line was: '$line'\n"; } sub parse_content { my $self = shift; my %args = ( content => '', callback => sub {}, error => sub {}, @_, ); my $c = $args{content}; return if !$c; # nothing to do if content is empty my $length = length $c; my $section_regex = $self->compatible ? qr/\A\[([0-9a-z.-]+)(?:[\t ]*"([^\n]*?)")?\]/im : qr/\A\[([^\s\[\]"]+)(?:[\t ]*"([^\n]*?)")?\]/im; my $key_regex = $self->compatible ? qr/\A([a-z][0-9a-z-]*)[\t ]*(?:[#;].*)?$/im : qr/\A([^\[=\n][^=\n]*?)[\t ]*(?:[#;].*)?$/im; my $key_value_regex = $self->compatible ? qr/\A([a-z][0-9a-z-]*)[\t ]*=[\t ]*/im : qr/\A([^\[=\n][^=\n]*?)[\t ]*=[\t ]*/im; my($section, $prev) = (undef, ''); while (1) { # drop leading white space and blank lines $c =~ s/\A\s*//im; my $offset = $length - length($c); # drop to end of line on comments if ($c =~ s/\A[#;].*?$//im) { next; } # [sub]section headers of the format [section "subsection"] (with # unlimited whitespace between) or [section.subsection] variable # definitions may directly follow the section header, on the same line! # - rules for sections: not case sensitive, only alphanumeric # characters, -, and . allowed # - rules for subsections enclosed in ""s: case sensitive, can # contain any character except newline, " and \ must be escaped # - rules for subsections with section.subsection alternate syntax: # same rules as for sections elsif ($c =~ s/$section_regex//) { $section = lc $1; if ($2) { my $subsection = $2; my $check = $2; $check =~ s{\\\\}{}g; $check =~ s{\\"}{}g; return $args{error}->( content => $args{content}, offset => $offset, # don't allow quoted subsections to contain unescaped # double-quotes or backslashes ) if $check =~ /\\|"/; $subsection =~ s{\\\\}{\\}g; $subsection =~ s{\\"}{"}g; $section .= ".$subsection"; } $args{callback}->( section => $section, offset => $offset, length => ($length - length($c)) - $offset, ); } # keys followed by a unlimited whitespace and (optionally) a comment # (no value) # # for keys, we allow any characters that won't screw up the parsing # (= and newline) in non-compatible mode, and match non-greedily to # allow any trailing whitespace to be dropped # # in compatible mode, keys can contain only 0-9a-z- elsif ($c =~ s/$key_regex//) { return $args{error}->( content => $args{content}, offset => $offset, ) unless defined $section; $args{callback}->( section => $section, name => $1, offset => $offset, length => ($length - length($c)) - $offset, ); } # key/value pairs (this particular regex matches only the key part and # the =, with unlimited whitespace around the =) elsif ($c =~ s/$key_value_regex//) { return $args{error}->( content => $args{content}, offset => $offset, ) unless defined $section; my $name = $1; my $value = ""; # parse the value while (1) { # comment or no content left on line if ($c =~ s/\A([ \t]*[#;].*?)?$//im) { last; } # any amount of whitespace between words becomes a single space elsif ($c =~ s/\A[\t ]+//im) { $value .= ' '; } # line continuation (\ character followed by new line) elsif ($c =~ s/\A\\\r?\n//im) { next; } # escaped backslash characters is translated to actual \ elsif ($c =~ s/\A\\\\//im) { $value .= '\\'; } # escaped quote characters are part of the value elsif ($c =~ s/\A\\(['"])//im) { $value .= $1; } # escaped newline in config is translated to actual newline elsif ($c =~ s/\A\\n//im) { $value .= "\n"; } # escaped tab in config is translated to actual tab elsif ($c =~ s/\A\\t//im) { $value .= "\t"; } # escaped backspace in config is translated to actual backspace elsif ($c =~ s/\A\\b//im) { $value .= "\b"; } # quote-delimited value (possibly containing escape codes) elsif ($c =~ s/\A"([^"\\]*(?:(?:\\\n|\\[tbn"\\])[^"\\]*)*)"//im) { my $v = $1; # remove all continuations (\ followed by a newline) $v =~ s/\\\n//g; # swap escaped newlines with actual newlines $v =~ s/\\n/\n/g; # swap escaped tabs with actual tabs $v =~ s/\\t/\t/g; # swap escaped backspaces with actual backspaces $v =~ s/\\b/\b/g; # swap escaped \ with actual \ $v =~ s/\\\\/\\/g; $value .= $v; } # valid value (no escape codes) elsif ($c =~ s/\A([^\t \\\n"]+)//im) { $value .= $1; # unparseable } else { # Note that $args{content} is the _original_ # content, not the nibbled $c, which is the # remaining unparsed content return $args{error}->( content => $args{content}, offset => $offset, ); } } $args{callback}->( section => $section, name => $name, value => $value, offset => $offset, length => ($length - length($c)) - $offset, ); } # end of content string; all done now elsif (not length $c) { last; } # unparseable else { # Note that $args{content} is the _original_ content, not # the nibbled $c, which is the remaining unparsed content return $args{error}->( content => $args{content}, offset => $offset, ); } } } sub define { my $self = shift; my %args = ( section => undef, name => undef, value => undef, origin => undef, @_, ); return unless defined $args{section} and defined $args{name}; my $original_key = join(".", @args{qw/section name/}); $args{name} = lc $args{name}; my $key = join(".", @args{qw/section name/}); # we're either adding a whole new key or adding a multiple key from # the same file if ( !defined $self->origins->{$key} || $self->origins->{$key} eq $args{origin} ) { if ($self->is_multiple($key)) { push @{$self->data->{$key} ||= []}, $args{value}; push @{$self->casing->{$key} ||= []}, $original_key; } elsif (exists $self->data->{$key}) { $self->set_multiple($key); $self->data->{$key} = [$self->data->{$key}, $args{value}]; $self->casing->{$key} = [$self->casing->{$key}, $original_key]; } else { $self->data->{$key} = $args{value}; $self->casing->{$key} = $original_key; } } # we're overriding a key set previously from a different file else { # un-mark as multiple if it was previously marked as such $self->set_multiple( $key, 0 ) if $self->is_multiple( $key ); # set the new value $self->data->{$key} = $args{value}; $self->casing->{$key} = $original_key; } $self->origins->{$key} = $args{origin}; } sub cast { my $self = shift; my %args = ( value => undef, as => undef, # bool, int, or num human => undef, # true value / false value @_, ); use constant { BOOL_TRUE_REGEX => qr/^(?:true|yes|on|-?0*1)$/i, BOOL_FALSE_REGEX => qr/^(?:false|no|off|0*)$/i, NUM_REGEX => qr/^-?[0-9]*\.?[0-9]*[kmg]?$/, }; if (defined $args{as} && $args{as} eq 'bool-or-int') { if ( $args{value} =~ NUM_REGEX ) { $args{as} = 'int'; } elsif ( $args{value} =~ BOOL_TRUE_REGEX || $args{value} =~ BOOL_FALSE_REGEX ) { $args{as} = 'bool'; } elsif ( !defined $args{value} ) { $args{as} = 'bool'; } else { die "Invalid bool-or-int '$args{value}'\n"; } } my $v = $args{value}; return $v unless defined $args{as}; if ($args{as} =~ /bool/i) { return 1 unless defined $v; if ( $v =~ BOOL_TRUE_REGEX ) { if ( $args{human} ) { return 'true'; } else { return 1; } } elsif ($v =~ BOOL_FALSE_REGEX ) { if ( $args{human} ) { return 'false'; } else { return 0; } } else { die "Invalid bool '$args{value}'\n"; } } elsif ($args{as} =~ /int|num/) { die "Invalid unit while casting to $args{as}\n" unless $v =~ NUM_REGEX; if ($v =~ s/([kmg])$//) { $v *= 1024 if $1 eq "k"; $v *= 1024*1024 if $1 eq "m"; $v *= 1024*1024*1024 if $1 eq "g"; } return $args{as} eq 'int' ? int $v : $v + 0; } } sub _get { my $self = shift; my %args = ( key => undef, filter => '', @_, ); $self->load unless $self->is_loaded; $args{key} = $self->canonical_case( $args{key} ); return () unless exists $self->data->{$args{key}}; my $v = $self->data->{$args{key}}; my @values = ref $v ? @{$v} : ($v); if (defined $args{filter} and length $args{filter}) { if ($args{filter} eq "!") { @values = (); } elsif ($args{filter} =~ s/^!//) { @values = grep { not defined or not m/$args{filter}/i } @values; } else { @values = grep { defined and m/$args{filter}/i } @values; } } return @values; } # I'm pretty sure that someone can come up with an edge case where stripping # all balanced quotes like this is not the right thing to do, but I don't # see it actually being a problem in practice. sub _remove_balanced_quotes { my $key = shift; no warnings 'uninitialized'; $key = join '', map { s/"(.*)"/$1/; $_ } split /("[^"]+"|[^.]+)/, $key; $key = join '', map { s/'(.*)'/$1/; $_ } split /('[^']+'|[^.]+)/, $key; return $key; } sub get { my $self = shift; my %args = ( key => undef, as => undef, human => undef, filter => '', @_, ); my @v = $self->_get( %args ); return undef unless @v; die "Multiple values" if @v > 1; return $self->cast( value => $v[0], as => $args{as}, human => $args{human} ); } sub get_all { my $self = shift; my %args = ( key => undef, as => undef, human => undef, filter => '', @_, ); my @v = $self->_get( %args ); @v = map {$self->cast( value => $_, as => $args{as}, human => $args{human} )} @v; return wantarray ? @v : \@v; } sub get_regexp { my $self = shift; my %args = ( key => undef, as => undef, human => undef, filter => '', @_, ); $self->load unless $self->is_loaded; $args{key} = '.' unless defined $args{key} and length $args{key}; my %results; for my $key (keys %{$self->data}) { $results{$key} = $self->data->{$key} if $key =~ m/$args{key}/i; } if (defined $args{filter} and length $args{filter}) { if ($args{filter} eq "!") { %results = (); } elsif ($args{filter} =~ s/^!//) { for (keys %results) { my @values = ref $results{$_} ? @{$results{$_}} : $results{$_}; @values = grep { not defined or not m/$args{filter}/i } @values; if (!@values) { delete $results{$_}; } else { $results{$_} = @values > 1 ? \@values : $values[0]; } } } else { for (keys %results) { my @values = ref $results{$_} ? @{$results{$_}} : $results{$_}; @values = grep { defined and m/$args{filter}/i } @values; if (!@values) { delete $results{$_}; } else { $results{$_} = @values > 1 ? \@values : $values[0]; } } } } @results{keys %results} = map { $self->cast( value => $results{$_}, as => $args{as}, human => $args{human}, ); } keys %results; return wantarray ? %results : \%results; } sub original_key { my $self = shift; my ($key) = @_; return $self->casing->{ $self->canonical_case( $key ) }; } sub canonical_case { my $self = shift; my ($key) = @_; my ($section, $subsection, $name) = _split_key($key); die "No section given in key: $key\n" unless $section; return join( '.', grep { defined } (lc $section, $subsection, lc $name), ); } sub dump { my $self = shift; $self->load unless $self->is_loaded; return %{$self->data} if wantarray; my $data = ''; for my $key (sort keys %{$self->data}) { my $str; if (defined $self->data->{$key}) { # For git compat, we intentionally always write out in # canonical (i.e. lower) case. $str = "$key="; if ( $self->is_multiple($key) ) { $str .= '['; $str .= join(', ', @{$self->data->{$key}}); $str .= "]\n"; } else { $str .= $self->data->{$key}."\n"; } } else { $str = "$key\n"; } if (!defined wantarray) { print $str; } else { $data .= $str; } } return $data if defined wantarray; } sub format_section { my $self = shift; my %args = ( section => undef, bare => undef, @_, ); if ($args{section} =~ /^(.*?)\.(.*)$/) { my ($section, $subsection) = ($1, $2); my $ret = qq|[$section "$subsection"]|; $ret .= "\n" unless $args{bare}; return $ret; } else { my $ret = qq|[$args{section}]|; $ret .= "\n" unless $args{bare}; return $ret; } } sub format_definition { my $self = shift; my %args = ( key => undef, value => undef, bare => undef, @_, ); my $quote = $args{value} =~ /(^\s|;|#|\s$)/ ? '"' : ''; $args{value} =~ s/\\/\\\\/g; $args{value} =~ s/"/\\"/g; $args{value} =~ s/\t/\\t/g; $args{value} =~ s/\n/\\n/g; my $ret = "$args{key} = $quote$args{value}$quote"; $ret = "\t$ret\n" unless $args{bare}; return $ret; } # Given a key, return its variable name, section, and subsection # parts. Doesn't do any lowercase transformation. sub _split_key { my $key = shift; my ($name, $section, $subsection); # allow quoting of the key to, for example, preserve # . characters in the key if ( $key =~ s/\.["'](.*)["']$// ) { $name = $1; $section = $key; } else { $key =~ /^(.*)\.(.*)$/; # If we wanted, we could interpret quoting of the section name to # allow for setting keys with section names including . characters. # But git-config doesn't do that, so we won't bother for now. (Right # now it will read these section names correctly but won't set them.) ($section, $name) = map { _remove_balanced_quotes($_) } ($1, $2); } # Make sure the section name we're comparing against has # case-insensitive section names and case-sensitive subsection names. $section =~ m/^([^.]+)(?:\.(.*))?$/; ($section, $subsection) = ($1, $2); return ($section, $subsection, $name); } sub group_set { my $self = shift; my ($filename, $args_ref) = @_; my $c = $self->_read_config($filename); # undef if file doesn't exist # loop through each value to set, modifying the content to be written # or erroring out as we go for my $args_hash (@{$args_ref}) { my %args = %{$args_hash}; my ($section, $subsection, $name) = _split_key($args{key}); die "No section given in key or invalid key $args{key}\n" unless defined $section; die "Invalid variable name $name\n" if $self->_invalid_variable_name($name); die "Invalid section name $section\n" if $self->_invalid_section_name($section); # if the subsection to write contains unescaped \ or ", escape them # automatically my $unescaped_subsection; if ( defined $subsection ) { $unescaped_subsection = $subsection; $subsection =~ s{\\}{\\\\}g; $subsection =~ s{"}{\\"}g; } $args{value} = $self->cast( value => $args{value}, as => $args{as}, human => 1, ) if defined $args{value} && defined $args{as}; my $new; my @replace; my $key = $self->canonical_case( $args{key} ); $args{multiple} = $self->is_multiple($key) unless defined $args{multiple}; # use this for comparison my $cmp_section = defined $unescaped_subsection ? join( '.', lc $section, $unescaped_subsection ) : lc $section; # ...but this for writing (don't lowercase) my $combined_section = defined $subsection ? join('.', $section, $subsection) : $section; # There's not really a good, simple way to get around parsing the # content for each of the values we're setting. If we wanted to # extract the offsets for every single one using only a single parse # run, we'd end up having to munge all the offsets afterwards as we # did the actual replacement since every time we did a replacement it # would change the offsets for anything that was formerly to be added # at a later offset. Which I'm not sure is any better than just # parsing it again. $self->parse_content( content => $c, callback => sub { my %got = @_; return unless $got{section} eq $cmp_section; $new = $got{offset} + $got{length}; return unless defined $got{name}; my $matched = 0; # variable names are case-insensitive if (lc $name eq lc $got{name}) { if (defined $args{filter} and length $args{filter}) { # copy the filter arg here since this callback may # be called multiple times and we don't want to # modify the original value my $filter = $args{filter}; if ($filter eq "!") { # Never matches } elsif ($filter =~ s/^!//) { $matched = 1 if ($got{value} !~ m/$filter/i); } elsif ($got{value} =~ m/$filter/i) { $matched = 1; } } else { $matched = 1; } } push @replace, {offset => $got{offset}, length => $got{length}} if $matched; }, error => sub { error_callback(@_, filename => $args{filename}) }, ); die "Multiple occurrences of non-multiple key?" if @replace > 1 && !$args{multiple}; # We're only replacing the first occurrance unless they said # to replace them all. @replace = ($replace[0]) if @replace and $args{value} and not $args{replace_all}; if (defined $args{value}) { if (@replace && (!$args{multiple} || $args{filter} || $args{replace_all})) { # Replacing existing value(s) # if the string we're replacing with is not the same length as # what's being replaced, any offsets following will be wrong. # save the difference between the lengths here and add it to # any offsets that follow. my $difference = 0; # when replacing multiple values, we combine them all into one, # which is kept at the position of the last one my $last = pop @replace; # kill all values that are not last ($c, $difference) = _unset_variables(\@replace, $c, $difference); # substitute the last occurrence with the new value substr( $c, $last->{offset}-$difference, $last->{length}, $self->format_definition( key => $name, value => $args{value}, bare => 1, ), ); } elsif (defined $new) { # Adding a new value to the end of an existing block substr( $c, index($c, "\n", $new)+1, 0, $self->format_definition( key => $name, value => $args{value} ) ); } else { # Adding a new section $c .= $self->format_section( section => $combined_section ); $c .= $self->format_definition( key => $name, value => $args{value}, ); } } else { # Removing an existing value (unset / unset-all) die "No occurrence of $args{key} found to unset in $filename\n" unless @replace; ($c, undef) = _unset_variables(\@replace, $c, 0); } } return $self->_write_config( $filename, $c ); } sub set { my $self = shift; my (%args) = ( key => undef, value => undef, filename => undef, filter => undef, as => undef, multiple => undef, @_ ); my $filename = $args{filename}; delete $args{filename}; return $self->group_set( $filename, [ \%args ] ); } sub _unset_variables { my ($variables, $c, $difference) = @_; for my $var (@{$variables}) { # start from either the last newline or the last section # close bracket, since variable definitions can occur # immediately following a section header without a \n my $newline = rindex($c, "\n", $var->{offset}-$difference); # need to add 1 here to not kill the ] too my $bracket = rindex($c, ']', $var->{offset}-$difference) + 1; my $start = $newline > $bracket ? $newline : $bracket; my $length = index($c, "\n", $var->{offset}-$difference+$var->{length})-$start; substr( $c, $start, $length, '', ); $difference += $length; } return ($c, $difference); } # In non-git-compatible mode, variables names can contain any characters that # aren't newlines or = characters, but cannot start or end with whitespace. # # Allowing . characters in variable names actually makes it so you # can get collisions between identifiers for things that are not # actually the same. # # For example, you could have a collision like this: # [section "foo"] bar.com = 1 # [section] foo.bar.com = 1 # # Both of these would be turned into 'section.foo.bar.com'. But it's # unlikely to ever actually come up, since you'd have to have # a *need* to have two things like this that are very similar # and yet different. sub _invalid_variable_name { my ($self, $name) = @_; if ($self->compatible) { return $name !~ /^[a-z][0-9a-z-]*$/i; } else { return $name !~ /^[^=\n\[][^=\n]*$/ || $name =~ /(?:^[ \t]+|[ \t+]$)/; } } # section, NOT subsection! sub _invalid_section_name { my ($self, $section) = @_; if ($self->compatible) { return $section !~ /^[0-9a-z-.]+$/i; } else { return $section =~ /\s|\[|\]|"/; } } # write config with locking sub _write_config { my $self = shift; my($filename, $content) = @_; my $newlines = $self->newlines->{$filename} || "\n"; $content =~ s/\n/$newlines/g if $newlines ne "\n"; # allow nested symlinks but only within reason my $max_depth = 5; # resolve symlinks while ($max_depth--) { my $readlink = readlink $filename; $filename = $readlink if defined $readlink; } # write new config file to temp file # (the only reason we call it .lock is because that's the # way git does it) sysopen(my $fh, "${filename}.lock", O_CREAT|O_EXCL|O_WRONLY) or die "Can't open ${filename}.lock for writing: $!\n"; if (my $encoding = $self->encoding) { binmode $fh, ":encoding($encoding)"; } print $fh $content; close $fh; # atomic rename rename("${filename}.lock", ${filename}) or die "Can't rename ${filename}.lock to ${filename}: $!\n"; } sub rename_section { my $self = shift; my (%args) = ( from => undef, to => undef, filename => undef, @_ ); die "No section to rename from given\n" unless defined $args{from}; my $c = $self->_read_config($args{filename}); # file couldn't be opened = nothing to rename return if !defined($c); ($args{from}, $args{to}) = map { _remove_balanced_quotes($_) } grep { defined $_ } ($args{from}, $args{to}); my @replace; my $prev_matched = 0; $self->parse_content( content => $c, callback => sub { my %got = @_; $replace[-1]->{section_is_last} = 0 if (@replace && !defined($got{name})); if (lc($got{section}) eq lc($args{from})) { if (defined $got{name}) { # if we're removing rather than replacing and # there was a previous section match, increase # its length so it will kill this variable # assignment too if ($prev_matched && !defined $args{to} ) { $replace[-1]->{length} += ($got{offset} + $got{length}) - ($replace[-1]{offset} + $replace[-1]->{length}); } } else { # if we're removing rather than replacing, increase # the length of the previous match so when it's # replaced it will kill all the way up to the # beginning of this next section (this will kill # any leading whitespace on the line of the # next section, but that's OK) $replace[-1]->{length} += $got{offset} - ($replace[-1]->{offset} + $replace[-1]->{length}) if @replace && $prev_matched && !defined($args{to}); push @replace, {offset => $got{offset}, length => $got{length}, section_is_last => 1}; $prev_matched = 1; } } else { # if we're removing rather than replacing and there was # a previous section match, increase its length to kill all # the way up to this non-matching section (takes care # of newlines between here and there, etc.) $replace[-1]->{length} += $got{offset} - ($replace[-1]->{offset} + $replace[-1]->{length}) if @replace && $prev_matched && !defined($args{to}); $prev_matched = 0; } }, error => sub { error_callback( @_, filename => $args{filename} ); }, ); die "No such section '$args{from}'\n" unless @replace; # if the string we're replacing with is not the same length as what's # being replaced, any offsets following will be wrong. save the difference # between the lengths here and add it to any offsets that follow. my $difference = 0; # rename ALL section headers that matched to # (there may be more than one) my $replace_with = defined $args{to} ? $self->format_section( section => $args{to}, bare => 1 ) : ''; for my $header (@replace) { substr( $c, $header->{offset} + $difference, # if we're removing the last section, just kill all the way to the # end of the file !defined($args{to}) && $header->{section_is_last} ? length($c) - ($header->{offset} + $difference) : $header->{length}, $replace_with, ); $difference += (length($replace_with) - $header->{length}); } return $self->_write_config($args{filename}, $c); } sub remove_section { my $self = shift; my (%args) = ( section => undef, filename => undef, @_ ); die "No section given to remove\n" unless $args{section}; # remove section is just a rename to nothing return $self->rename_section( from => $args{section}, filename => $args{filename} ); } sub add_comment { my $self = shift; my (%args) = ( comment => undef, filename => undef, indented => undef, semicolon => undef, @_ ); my $filename = $args{filename} or die "No filename passed to add_comment()"; die "No comment to add\n" unless defined $args{comment}; # Comment, preserving leading whitespace. my $chars = $args{indented} ? '[[:blank:]]*' : ''; my $char = $args{semicolon} ? ';' : '#'; (my $comment = $args{comment}) =~ s/^($chars)/$1$char /mg; $comment .= "\n" if $comment !~ /\n\z/; my $c = $self->_read_config($filename); $c = '' unless defined $c; return $self->_write_config( $filename, $c . $comment ); } 1; __END__ =head1 NAME Config::GitLike - git-compatible config file parsing =head1 SYNOPSIS This module parses git-style config files, which look like this: [core] repositoryformatversion = 0 filemode = true bare = false logallrefupdates = true [remote "origin"] url = spang.cc:/srv/git/home.git fetch = +refs/heads/*:refs/remotes/origin/* [another-section "subsection"] key = test key = multiple values are OK emptyvalue = novalue Code that uses this config module might look like: use Config::GitLike; # just load a specific file my $data = Config::GitLike->load_file("~/.fooconf"); # or use the object interface to load /etc/config, ~/.config, and # `pwd`/.config my $c = Config::GitLike->new(confname => 'config'); $c->get( key => 'section.name' ); # make the return value a Perl true/false value $c->get( key => 'core.filemode', as => 'bool' ); # replace the old value $c->set( key => 'section.name', value => 'val1', filename => '/home/user/.config', ); # make this key have multiple values rather than replacing the # old value $c->set( key => 'section.name', value => 'val2', filename => '/home/user/.config', multiple => 1, ); # replace all occurrences of the old value for section.name with a new one $c->set( key => 'section.name', value => 'val3', filename => '/home/user/.config', multiple => 1, replace_all => 1, ); # make sure to reload the config files before reading if you've set # any variables! $c->load; # get only the value of 'section.name' that matches '2' $c->get( key => 'section.name', filter => '2' ); $c->get_all( key => 'section.name' ); # prefixing a search regexp with a ! negates it $c->get_regexp( key => '!na' ); $c->rename_section( from => 'section', to => 'new-section', filename => '/home/user/.config' ); $c->remove_section( section => 'section', filename => '/home/user/.config' ); # unsets all instances of the given key $c->set( key => 'section.name', filename => '/home/user/.config' ); my %config_vals = $config->dump; # string representation of config data my $str = $config->dump; # prints rather than returning $config->dump; =head1 DESCRIPTION This module handles interaction with configuration files of the style used by the version control system Git. It can both parse and modify these files, as well as create entirely new ones. You only need to know a few things about the configuration format in order to use this module. First, a configuration file is made up of key/value pairs. Every key must be contained in a section. Sections can have subsections, but they don't have to. For the purposes of setting and getting configuration variables, we join the section name, subsection name, and variable name together with dots to get a key name that looks like "section.subsection.variable". These are the strings that you'll be passing in to C arguments. Configuration files inherit from each other. By default, C loads data from a system-wide configuration file, a per-user configuration file, and a per-directory configuration file, but by subclassing and overriding methods you can obtain any combination of configuration files. By default, configuration files that don't exist are just skipped. See L for details on the syntax of git configuration files. We won't waste pixels on the nitty gritty here. While the behavior of a couple of this module's methods differ slightly from the C equivalents, this module can read any config file written by git. The converse is usually true, but only if you don't take advantage of this module's increased permissiveness when it comes to key names. (See L for details.) This is an object-oriented module using L. All subroutines are object method calls. A few methods have parameters that are always used for the same purpose: =head2 Filenames All methods that change things in a configuration file require a filename to write to, via the C parameter. Since a C object can be working with multiple config files that inherit from each other, we don't try to figure out which one to write to automatically and let you specify instead. =head2 Casting All get and set methods can make sure the values they're returning or setting are valid values of a certain type: C, C, C, or C (or at least as close as Perl can get to having these types). Do this by passing one of these types in via the C parameter. The set method, if told to write bools, will always write "true" or "false" (not anything else that C considers a valid bool). Methods that are told to cast values will throw exceptions if the values they're trying to cast aren't valid values of the given type. See the L<"cast"> method documentation for more on what is considered valid for each type. =head2 Filtering All get and set methods can filter what values they return via their C parameter, which is expected to be a string that is a valid regex. If you want to filter items OUT instead of IN, you can prefix your regex with a ! and that will do the trick. Now, on the the methods! =head1 MAIN METHODS There are the methods you're likely to use the most. =head2 new( confname => 'config', encoding => 'UTF-8' ) Create a new configuration object with the base config name C. If you are interested simply in loading one specific file, and not in automatically loading a global file, a per-user file, and a per-directory file, see L, below. C is used to construct the filenames that will be loaded; by default, these are C (global configuration file), C<~/.confname> (user configuration file), and C</.confname> (directory configuration file). You can override these defaults by subclassing C and overriding the methods C, C, and C. (See L<"METHODS YOU MAY WISH TO OVERRIDE"> for details.) If you wish to enforce only being able to read/write config files that git can read or write, pass in C 1> to this constructor. The default rules for some components of the config file are more permissive than git's (see L<"DIFFERENCES FROM GIT-CONFIG">). If you know that your Git config files are encoded with a known character encoding, pass in C $encoding> to specify the name of the encoding. Config::GitLike will then properly serialize and deserialize the files with that encoding. Note that configutation files written with C are usually, but are not required to be, in UTF-8. =head2 confname The configuration filename that you passed in when you created the C object. You can change it if you want by passing in a new name (and then reloading via L<"load">). =head2 load This method is usually called implicitly on the first L, L, L, or L call used, and is only necessary if you want to explicitly reload the data. Load the global, local, and directory configuration file with the filename C(if they exist). Configuration variables loaded later override those loaded earlier, so variables from the directory configuration file have the highest precedence. Pass in an optional path, and it will be passed on to L<"load_dirs"> (which loads the directory configuration file(s)). Returns a hash copy of all loaded configuration data stored in the module after the files have been loaded, or a hashref to this hash in scalar context. =head2 config_files An array reference containing the absolute filenames of all config files that are currently loaded, in the order they were loaded. =head2 get Parameters: key => 'sect.subsect.key' as => 'int' human => 1 filter => '!foo' Return the config value associated with C cast as an C. The C option is required (will return undef if unspecified); the C amd C options are not (see L for their meaning). Sections and subsections are specified in the key by separating them from the key name with a C<.> character. Sections, subsections, and keys may all be quoted (double or single quotes). If C doesn't exist in the config, or has no values which match the filter, undef is returned. Dies with the exception "Multiple values" if the given key has more than one value associated with it which match the filter. (Use L<"get_all"> to retrieve multiple values.) Calls L<"load"> if it hasn't been done already. Note that if you've run any C calls to the loaded configuration files since the last time they were loaded, you MUST call L<"load"> again before getting, or the returned configuration data may not match the configuration variables on-disk. =head2 get_all Parameters: key => 'section.sub' as => 'int' human => 1 filter => 'regex' Like L<"get"> but does not fail if the number of values for the key is not exactly one. Returns a list of values (or an arrayref in scalar context). =head2 get_regexp Parameters: key => 'regex' as => 'bool' human => 1 filter => 'regex' Similar to L<"get_all"> but searches for values based on a key regex. Returns a hash of name/value pairs (or a hashref in scalar context). =head2 dump In scalar context, return a string containing all configuration data, sorted in ASCII order, in the form: section.key=value section2.key=value If called in void context, this string is printed instead. In list context, returns a hash containing all the configuration data. =head2 set Parameters: key => 'section.name' value => 'bar' filename => File::Spec->catfile(qw/home user/, '.'.$config->confname) filter => 'regex' as => 'bool' multiple => 1 replace_all => 1 Set the key C in the configuration section C
to the value C in the given filename. Replace C's value if C already exists. To unset a key, pass in C but not C. Returns true on success. If you need to have a . character in your variable name, you can surround the name with quotes (single or double): C Don't do this unless you really have to. =head3 multiple values By default, set will replace the old value rather than giving a key multiple values. To override this, pass in C 1>. If you want to replace all instances of a multiple-valued key with a new value, you need to pass in C 1> as well. =head2 group_set( $filename, $array_ref ) Same as L<"set">, but set a group of variables at the same time without writing to disk separately for each. C<$array_ref> contains a list of hash references which are essentially hashes of arguments to C, excluding the C<$filename> argument since that is specified separately and the same file is used for all variables to be set at once. =head2 rename_section Parameters: from => 'name.subname' to => 'new.subname' filename => '/file/to/edit' Rename the section existing in C given by C to the section given by C. Throws an exception C if the section in C doesn't exist in C. If no value is given for C, the section is removed instead of renamed. Returns true on success, false if C didn't exist and thus the rename did nothing. =head2 remove_section Parameters: section => 'section.subsection' filename => '/file/to/edit' Just a convenience wrapper around L<"rename_section"> for readability's sake. Removes the given section (which you can do by renaming to nothing as well). =head2 add_comment Parameters: comment => "Begin editing here\n and then stop", filename => '/file/to/edit' indented => 1, semicolon => 0, Add a comment to the specified configuration file. The C and C parameters are required. Comments will be added to the file with C<# > at the begnning of each line of the comment. Pass a true value to C if you'd rather they start with C<; >. If your comments are indented with leading white space, and you want that white space to appear in front of the comment character, rather than after, pass a true value to C. =head2 cascade( $bool ) Gets or sets if only the B configuration file in a directory tree is loaded, or if all of them are loaded, shallowest to deepest. Alternately, C 1> can be passed to C. =head2 origins Returns a hash mapping each config key with the file it was loaded from. =head1 METHODS YOU MAY WISH TO OVERRIDE If your application's configuration layout is different from the default, e.g. if its home directory config files are in a directory within the home directory (like C<~/.git/config>) instead of just dot-prefixed, override these methods to return the right directory names. For fancier things like altering precedence, you'll need to override L<"load"> as well. =head2 dir_file Return a string containing the path to a configuration file with the name C in a directory. Called with no arguments, returns the path for a generic directory; if called with a directory as an argument, returns the path for I directory. =head2 global_file Return the string C, the absolute name of the system-wide configuration file with name C. =head2 user_file Return a string containing the path to a configuration file in the current user's home directory with filename C. =head2 load_dirs Parameters: '/path/to/look/in/' Load the configuration file with the filename L<"dir_file"> in the current working directory into the memory or, if there is no config matching C in the current working directory, walk up the directory tree until one is found. (No error is thrown if none is found.) If an optional path is passed in, that directory will be used as the base directory instead of the working directory. You'll want to use L<"load_file"> to load config files from your overridden version of this subroutine. Returns nothing of note. =head1 OTHER METHODS These are mostly used internally in other methods, but could be useful anyway. =head2 load_global If a global configuration file with the absolute name given by L<"global_file"> exists, load its configuration variables into memory. Returns the current contents of all the loaded configuration variables after the file has been loaded, or undef if no global config file is found. =head2 load_user If a configuration file with the absolute name given by L<"user_file"> exists, load its config variables into memory. Returns the current contents of all the loaded configuration variables after the file has been loaded, or undef if no user config file is found. =head2 load_file( $filename ) Takes a string containing the path to a file, opens it if it exists, loads its config variables into memory, and returns the currently loaded config variables (a hashref). This method can also be called as a class method, which will die if the file cannot be read. If called as an instance method, returns undef on failure. This method may also be passed additional key-value parameters which control how the file is loaded: =over =item silent Defaults to off; if set, merely returns instead of die'ing if the file cannot be found or read. =item includes Defaults to on; if passed a false value, ignores the L directive. =item force Defaults to off; if set, will re-load a file even if it was previously loaded. =back =head2 parse_content Parameters: content => 'str' callback => sub {} error => sub {} Parses the given content and runs callbacks as it finds valid information. Returns undef on success and C (the original content) on failure. C is called like: callback(section => $str, offset => $num, length => $num, name => $str, value => $str) C and C may be omitted if the callback is not being called on a key/value pair, or if it is being called on a key with no value. C is called like: error( content => $content, offset => $offset ) Where C is the point in the content where the parse error occurred. If you need to use this method, you might be interested in L<"error_callback"> as well. =head2 error_callback Parameters: content => 'str' offset => 45 filename => '/foo/bar/.baz' Made especially for passing to L<"parse_content">, passed through the C parameter like this: error => sub { error_callback( @_, filename => '/file/you/were/parsing' ) } It's used internally wherever L<"parse_content"> is used and will throw an exception with a useful message detailing the line number, position on the line, and contents of the bad line; if you find the need to use L<"parse_content"> elsewhere, you may find it useful as well. =head2 include ( $name ) When reading configuration files, Git versions 1.7.10 and later parse the C key as a directive to include an additional configuration file. This option controls the equivalent behavior; setting it to a false value will disable inclusion, and any true value will be taken as the name of the configuration parameter which controls inclusion. Defaults to C, as Git does. =head2 set_multiple( $name ) Mark the key string C<$name> as containing multiple values. Returns nothing. =head2 is_multiple( $name ) Return a true value if the key string C<$name> contains multiple values; false otherwise. =head2 define Parameters: section => 'str' name => 'str' value => 'str' Given a section, a key name, and a value, store this information in memory in the config object. Returns the value that was just defined on success, or undef if no name and section were given and thus the key cannot be defined. =head2 cast Parameters: value => 'foo' as => 'int' human => 1 Return C cast into the type specified by C. Valid values for C are C, C, C, or C. For C, C, C, C, C<1>, and undef are translated into a true value (for Perl); anything else is false. Specifying a true value for the C argument will get you a human-readable 'true' or 'false' rather than a value that plays along with Perl's definition of truthiness (0 or 1). For Cs and Cs, if C ends in C, C, or C, it will be multiplied by 1024, 1048576, and 1073741824, respectively, before being returned. Cs are truncated after being multiplied, if they have a decimal portion. C, as you might have guessed, gives you either a bool or an int depending on which one applies. If C is unspecified, C is returned unchanged. =head2 format_section Parameters: section => 'section.subsection' base => 1 Return a string containing the section/subsection header, formatted as it should appear in a config file. If C is true, the returned value is not followed be a newline. =head2 format_definition Parameters: key => 'str' value => 'str' bare => 1 Return a string containing the key/value pair as they should be printed in the config file. If C is true, the returned value is not tab-indented nor followed by a newline. =head2 canonical_case( $name ) Given a full key name, returns the canonical name of the key; this is the key with the section and name lower-cased; the subsection is left as-is. =head2 original_key( $name ) Given a full key name, returns the key as it was last loaded from the file, retaining what ever upper/lower case was used. Note that for multiple-valued keys, this returns an array reference of key names, as each definition may have been provided in a different choice of case. =head1 DIFFERENCES FROM GIT-CONFIG This module does the following things differently from git-config: We are much more permissive about valid key names and section names. For variables, instead of limiting variable names to alphanumeric characters and -, we allow any characters except for = and newlines, including spaces as long as they are not leading or trailing, and . as long as the key name is quoted. For sections, any characters but whitespace, [], and " are allowed. You can enforce reading/writing only git-compatible variable names and section headers by passing C 1> to the constructor. When replacing variable values and renaming sections, we merely use a substring replacement rather than writing out new lines formatted in the default manner for new lines. Git's replacement/renaming (as of 1.6.3.2) is currently buggy and loses trailing comments and variables that are defined on the same line as a section being renamed. Our method preserves original formatting and surrounding information. We also allow the 'num' type for casting, since in many cases we might want to be more lenient on numbers. We truncate decimal numbers that are cast to Cs, whereas Git just rejects them. We don't support NUL-terminating output (the --null flag to git-config). Who needs it? Git only supports reading UNIX- and DOS-style newlines ("\n" and "\r\n"), and always uses "\n" when modifying files. We also support reading Mac-style newlines ("\r"), and write updates to files using the same newlines as they were read with. =head1 BUGS If you find any bugs in this module, report them at: http://rt.cpan.org/ Include the version of the module you're using and any relevant problematic configuration files or code snippets. =head1 SEE ALSO L, L, L (C is used in Prophet/SD and provides a working example) =head1 LICENSE This program is free software; you may modify and/or redistribute it under the same terms as Perl itself. =head1 COPYRIGHT Copyright 2010 Best Practical Solutions, LLC =head1 AUTHORS Alex Vandiver , Christine Spang Config-GitLike-1.18/lib/Config/GitLike/000755 000765 000024 00000000000 13632622657 017773 5ustar00chmrrstaff000000 000000 Config-GitLike-1.18/lib/Config/GitLike/Git.pm000644 000765 000024 00000006142 13632620372 021047 0ustar00chmrrstaff000000 000000 package Config::GitLike::Git; use Moo; use strict; use warnings; extends 'Config::GitLike'; has '+confname' => ( default => 'gitconfig', ); has '+compatible' => ( default => 1, ); sub dir_file { my $self = shift; return ".git/config" unless @_; my $path = shift; my $dir = $self->is_git_dir( $path ); return File::Spec->catfile( $dir, "config" ) if $dir; $path = File::Spec->rel2abs( $path ); return File::Spec->catfile( $path, ".git/config"); } sub is_git_dir { my $self = shift; my $path = File::Spec->rel2abs( shift ); $path =~ s{/+$}{}; ($path) = grep {-d} map {"$path$_"} (".git/.git", "/.git", ".git", ""); return unless $path; # Has to have objects/ and refs/ directories return unless -d "$path/objects" and -d "$path/refs"; # Has to have a HEAD file return unless -f "$path/HEAD"; if (-l "$path/HEAD" ) { # Symbolic link into refs/ return unless readlink("$path/HEAD") =~ m{^refs/}; } else { open(HEAD, "$path/HEAD") or return; my ($line) = ; close HEAD; # Is either 'ref: refs/whatever' or a sha1 return unless $line =~ m{^(ref:\s*refs/|[0-9a-fA-F]{20})}; } return $path; } sub load_dirs { my $self = shift; my $path = shift; my $dir = $self->is_git_dir($path) or return; $self->load_file( File::Spec->catfile( $dir, "config" ) ); } __PACKAGE__->meta->make_immutable; no Moo; 1; __END__ =head1 NAME Config::GitLike::Git - load Git configuration files =head1 SYNOPSIS use Config::GitLike::Git; my $config = Config::GitLike::Git->new; $config->load("/path/to/repo"); =head1 DESCRIPTION This is a modification of L to look at the same locations that Git writes to. Unlike with L, you do not need to pass a confname to its constructor. This module also enables the L option to maintain git compatibility when reading and writing variables. L should be passed path to the top level of a git repository -- this defaults to the current directory. It will append C<.git> as necessary. It supports both bare and non-bare repositories. =head1 METHODS This module overrides these methods from C: =head2 dir_file The per-directory configuration file is F<.git/config>. With an optional directory argument, will return a fully-qualified path to the configuration file, as git would edit with C. =head2 user_file The per-user configuration file is F<~/.gitconfig> =head2 global_file The per-host configuration file is F =head2 is_git_dir Returns true if a file contains the necessary files (as git would reckon it) for the path to be a git repository. =head2 load_dirs Loads the relevant .git/config file. =head1 SEE ALSO L =head1 LICENSE You may modify and/or redistribute this software under the same terms as Perl 5.8.8. =head1 COPYRIGHT Copyright 2010 Best Practical Solutions, LLC =head1 AUTHORS Alex Vandiver , Christine Spang Config-GitLike-1.18/lib/Config/GitLike/Cascaded.pm000644 000765 000024 00000001556 13614253640 022017 0ustar00chmrrstaff000000 000000 package Config::GitLike::Cascaded; use Moo; use Cwd; use File::Spec; extends 'Config::GitLike'; has 'cascade' => ( default => sub { 1 }, is => 'rw', ); __PACKAGE__->meta->make_immutable; no Moo; 1; __END__ =head1 NAME Config::GitLike::Cascaded - git-like config file parsing with cascaded inheritance =head1 SYNOPSIS This module exists purely for backwards compatibility; its use is deprecated, and will be removed in a future release. =head1 METHODS =head2 cascade This module simply defaults L to a true value. =head1 SEE ALSO L =head1 LICENSE You may modify and/or redistribute this software under the same terms as Perl 5.8.8. =head1 COPYRIGHT Copyright 2010 Best Practical Solutions, LLC =head1 AUTHORS Alex Vandiver , Christine Spang Config-GitLike-1.18/t/util/000755 000765 000024 00000000000 13632622657 015710 5ustar00chmrrstaff000000 000000 Config-GitLike-1.18/t/casing.t000644 000765 000024 00000006600 13614253640 016356 0ustar00chmrrstaff000000 000000 use strict; use warnings; use Test::More; use File::Spec; use Cwd; use File::Temp qw/tempdir/; use lib 't/lib'; use TestConfig; my $config_dirname = Cwd::abs_path( tempdir( CLEANUP => !$ENV{CONFIG_GITLIKE_DEBUG} ) ); my $config_filename = File::Spec->catfile( $config_dirname, 'config' ); diag "config file is: $config_filename" if $ENV{TEST_VERBOSE}; my $config = TestConfig->new( confname => 'config', tmpdir => $config_dirname, ); $config->load; $config->set( key => 'core.FooBar', value => 'baz', filename => $config_filename, ); my $expect = qq{[core]\n\tFooBar = baz\n}; is( $config->slurp, $expect, 'mixed-case key is preserved when written' ); $config->load; is $config->get( key => 'core.FooBar' ), "baz", "Can be referenced with original case"; is $config->get( key => 'core.foobar' ), "baz", "Can be referenced with lower case"; is $config->get( key => 'core.FOObar' ), "baz", "Can be referenced with different case"; is $config->original_key( 'core.FooBar' ), "core.FooBar", "Find original case when asked in original case"; is $config->original_key( 'core.foobar' ), "core.FooBar", "Find original case when asked in lower case"; is $config->original_key( 'core.FOObar' ), "core.FooBar", "Find original case when asked in different case"; eval { $config->get( key => 'core') }; ok my $err = $@, 'Should get an error when no section passed to get().'; like $err, qr/No section given in key: core/, 'The missing section error should be correct'; my $other_filename = File::Spec->catfile( $config_dirname, 'other' ); $config->set( key => 'core.fooBAR', value => 'troz', filename => $other_filename, ); is $config->get( key => 'core.FooBar' ), "baz", "->set without ->load does not alter value in ->get"; $config->load_file( $other_filename ); is $config->origins->{'core.foobar'}, $other_filename, "Found definition from second file"; is $config->get( key => 'core.foobar' ), "troz", "Loaded value from second file"; is $config->original_key( 'core.foobar' ), "core.fooBAR", "Find new case in second file"; $config->set_multiple( "core.FOOBAR" ); is $config->is_multiple( "core.FoObAr" ), 1, "multiple respects any case"; $config->set( key => 'core.fOObAR', value => 'zort', filename => $other_filename, ); $config->set( key => 'core.fOobAr', value => 'poit', filename => $other_filename, ); $expect = qq{[core]\n\tfooBAR = troz\n\tfOObAR = zort\n\tfOobAr = poit\n}; is( $config->slurp($other_filename), $expect, 'mixed-case key is preserved when written as multiple' ); # Since we cache which files are loaded, so we can't just call # ->load_file( $other_filename ) again to get the updated value. # Instead, re-create the object and load each file again. $config = TestConfig->new( confname => 'config', tmpdir => $config_dirname, ); $config->load; is $config->get( key => 'core.FooBar' ), "baz", "Got original value"; is $config->original_key( 'core.FooBar' ), "core.FooBar", "Got original case"; ok $config->load_file( $other_filename ), "Loaded second file"; is $config->is_multiple( "core.foobar" ), 1, "Is marked as multiple"; is_deeply scalar $config->get_all( key => 'core.foobar' ), ["troz", "zort", "poit"], "Got all three new values"; is_deeply $config->original_key( 'core.foobar' ), ["core.fooBAR", "core.fOObAR", "core.fOobAr" ], "Got all three new casings"; done_testing; Config-GitLike-1.18/t/comment.t000644 000765 000024 00000003017 13614253640 016553 0ustar00chmrrstaff000000 000000 use strict; use warnings; use Test::More; use File::Spec; use File::Temp qw/tempdir/; use lib 't/lib'; use TestConfig; my $config_dirname = tempdir( CLEANUP => !$ENV{CONFIG_GITLIKE_DEBUG} ); my $config_filename = File::Spec->catfile( $config_dirname, 'config' ); diag "config file is: $config_filename" if $ENV{TEST_VERBOSE}; my $config = TestConfig->new( confname => 'config', tmpdir => $config_dirname ); $config->load; # Test add_comment. $config->add_comment( filename => $config_filename, comment => 'yo dawg', ); my $expect = "# yo dawg\n"; is( $config->slurp, $expect, 'comment' ); # Make sure leading whitespace is maintained. $config->add_comment( filename => $config_filename, comment => ' for you.' ); $expect .= "# for you.\n"; is( $config->slurp, $expect, 'comment with ws' ); # Make sure it interacts well with configuration. $config->set( key => 'core.penguin', value => 'little blue', filename => $config_filename ); $config->add_comment( filename => $config_filename, comment => "this is\n for you\n \n you know", indented => 1, ); $expect = <<'EOF' # yo dawg # for you. [core] penguin = little blue # this is # for you # # you know EOF ; is( $config->slurp, $expect, 'indented comment with newlines and config' ); $config->add_comment( filename => $config_filename, comment => ' gimme a semicolon', semicolon => 1, ); $expect .= "; gimme a semicolon\n"; is( $config->slurp, $expect, 'comment with semicolon' ); done_testing; Config-GitLike-1.18/t/encoding.t000644 000765 000024 00000001550 13614253640 016677 0ustar00chmrrstaff000000 000000 use strict; use warnings; use Test::More; use File::Spec; use File::Temp qw/tempdir/; use lib 't/lib'; use TestConfig; my $config_dirname = tempdir( CLEANUP => !$ENV{CONFIG_GITLIKE_DEBUG} ); my $config_filename = File::Spec->catfile( $config_dirname, 'config' ); diag "config file is: $config_filename" if $ENV{TEST_VERBOSE}; my $config = TestConfig->new( confname => 'config', tmpdir => $config_dirname, encoding => 'UTF-8', ); $config->load; UTF8: { use utf8; $config->set( key => 'core.penguin', value => 'little blüe', filename => $config_filename ); } my $expect = qq{[core]\n\tpenguin = little blüe\n}; is( $config->slurp, $expect, 'Value with UTF-8' ); $config->load; UTF8: { use utf8; is $config->get(key => 'core.penguin'), 'little blüe', 'Get value with UTF-8'; } done_testing; Config-GitLike-1.18/t/dos.conf000644 000765 000024 00000000077 13614253640 016363 0ustar00chmrrstaff000000 000000 [core] engine = pg topdir = sql [deploy] verify = true Config-GitLike-1.18/t/t1300-repo-config.t000644 000765 000024 00000100444 13614253640 020070 0ustar00chmrrstaff000000 000000 use strict; use warnings; use File::Copy; use Test::More tests => 142; use Test::Exception; use File::Spec; use File::Temp qw/tempdir/; use lib 't/lib'; use TestConfig; # Tests whose expected behaviour has been modified from that of the # original git-config test suite are marked with comments. # # Additional tests that were not pulled from the git-config test-suite # are also marked. # create an empty test directory in /tmp my $config_dirname = tempdir( CLEANUP => !$ENV{CONFIG_GITLIKE_DEBUG} ); my $config_filename = File::Spec->catfile( $config_dirname, 'config' ); diag "config file is: $config_filename" if $ENV{TEST_VERBOSE}; my $config = TestConfig->new( confname => 'config', tmpdir => $config_dirname ); $config->load; diag('Test git config in different settings') if $ENV{TEST_VERBOSE}; $config->set( key => 'core.penguin', value => 'little blue', filename => $config_filename ); my $expect = <<'EOF' [core] penguin = little blue EOF ; is( $config->slurp, $expect, 'initial' ); $config->set( key => 'Core.Movie', value => 'BadPhysics', filename => $config_filename ); $expect = <<'EOF' [core] penguin = little blue Movie = BadPhysics EOF ; is( $config->slurp, $expect, 'mixed case' ); $config->set( key => 'Cores.WhatEver', value => 'Second', filename => $config_filename ); $expect = <<'EOF' [core] penguin = little blue Movie = BadPhysics [Cores] WhatEver = Second EOF ; is( $config->slurp, $expect, 'similar section' ); $config->set( key => 'CORE.UPPERCASE', value => 'true', filename => $config_filename ); $expect = <<'EOF' [core] penguin = little blue Movie = BadPhysics UPPERCASE = true [Cores] WhatEver = Second EOF ; is( $config->slurp, $expect, 'similar section' ); # set returns nothing on success lives_ok { $config->set( key => 'core.penguin', value => 'kingpin', filter => '!blue', filename => $config_filename ); } 'replace with non-match'; lives_ok { $config->set( key => 'core.penguin', value => 'very blue', filter => '!kingpin', filename => $config_filename ); } 'replace with non-match'; $expect = <<'EOF' [core] penguin = very blue Movie = BadPhysics UPPERCASE = true penguin = kingpin [Cores] WhatEver = Second EOF ; is( $config->slurp, $expect, 'non-match result' ); $config->burp( '[alpha] bar = foo [beta] baz = multiple \ lines ' ); lives_ok { $config->set( key => 'beta.baz', filename => $config_filename ) } 'unset with cont. lines'; $expect = <<'EOF' [alpha] bar = foo [beta] EOF ; is( $config->slurp, $expect, 'unset with cont. lines is correct' ); $config->burp( '[beta] ; silly comment # another comment noIndent= sillyValue ; \'nother silly comment # empty line ; comment haha = hello haha = bello [nextSection] noNewline = ouch ' ); my $config2_filename = File::Spec->catfile( $config_dirname, '.config2' ); copy( $config_filename, $config2_filename ) or die "File cannot be copied: $!"; $config->set( key => 'beta.haha', filename => $config_filename, multiple => 1 ); $expect = <<'EOF' [beta] ; silly comment # another comment noIndent= sillyValue ; 'nother silly comment # empty line ; comment [nextSection] noNewline = ouch EOF ; is( $config->slurp, $expect, 'multiple unset is correct' ); copy( $config2_filename, $config_filename ) or die "File cannot be copied: $!"; unlink $config2_filename; lives_ok { $config->set( key => 'beta.haha', value => 'gamma', multiple => 1, replace_all => 1, filename => $config_filename ); } 'replace all'; $expect = <<'EOF' [beta] ; silly comment # another comment noIndent= sillyValue ; 'nother silly comment # empty line ; comment haha = gamma [nextSection] noNewline = ouch EOF ; is( $config->slurp, $expect, 'all replaced' ); $config->set( key => 'beta.haha', value => 'alpha', filename => $config_filename ); $expect = <<'EOF' [beta] ; silly comment # another comment noIndent= sillyValue ; 'nother silly comment # empty line ; comment haha = alpha [nextSection] noNewline = ouch EOF ; is( $config->slurp, $expect, 'really mean test' ); $config->set( key => 'nextsection.nonewline', value => 'wow', filename => $config_filename ); # NOTE: git moves the definition of the variable without a newline # to the next line; # let's not do that since we do substring replacement rather than # reformatting $expect = <<'EOF' [beta] ; silly comment # another comment noIndent= sillyValue ; 'nother silly comment # empty line ; comment haha = alpha [nextSection] nonewline = wow EOF ; is( $config->slurp, $expect, 'really really mean test' ); $config->load; is( $config->get( key => 'beta.haha' ), 'alpha', 'get value' ); # unset beta.haha (unset accomplished by value = undef) $config->set( key => 'beta.haha', filename => $config_filename ); $expect = <<'EOF' [beta] ; silly comment # another comment noIndent= sillyValue ; 'nother silly comment # empty line ; comment [nextSection] nonewline = wow EOF ; is( $config->slurp, $expect, 'unset' ); $config->set( key => 'nextsection.NoNewLine', value => 'wow2 for me', filter => qr/for me$/, filename => $config_filename ); $expect = <<'EOF' [beta] ; silly comment # another comment noIndent= sillyValue ; 'nother silly comment # empty line ; comment [nextSection] nonewline = wow NoNewLine = wow2 for me EOF ; is( $config->slurp, $expect, 'multivar' ); $config->load; lives_ok { $config->get( key => 'nextsection.nonewline', filter => '!for' ); } 'non-match'; lives_and { is( $config->get( key => 'nextsection.nonewline', filter => '!for' ), 'wow' ); } 'non-match value'; # must use get_all to get multiple values throws_ok { $config->get( key => 'nextsection.nonewline' ) } qr/multiple values/i, 'ambiguous get'; is_deeply( scalar $config->get_all( key => 'nextsection.nonewline' ), [ 'wow', 'wow2 for me' ], 'get multivar' ); $config->set( key => 'nextsection.nonewline', value => 'wow3', filter => qr/wow/, filename => $config_filename ); $expect = <<'EOF' [beta] ; silly comment # another comment noIndent= sillyValue ; 'nother silly comment # empty line ; comment [nextSection] nonewline = wow3 NoNewLine = wow2 for me EOF ; is( $config->slurp, $expect, 'multivar replace only the first match' ); $config->load; throws_ok { $config->set( key => 'nextsection.nonewline', filename => $config_filename, multiple => 0, # Otherwise we Do The Right Thing, as we know it's multiple ); } qr/Multiple occurrences of non-multiple key/i, 'ambiguous unset'; throws_ok { $config->set( key => 'somesection.nonewline', filename => $config_filename ); } qr/No occurrence of somesection.nonewline found to unset/i, 'invalid unset'; lives_ok { $config->set( key => 'nextsection.nonewline', filter => qr/wow3$/, filename => $config_filename ); } "multivar unset doesn't crash"; $expect = <<'EOF' [beta] ; silly comment # another comment noIndent= sillyValue ; 'nother silly comment # empty line ; comment [nextSection] NoNewLine = wow2 for me EOF ; is( $config->slurp, $expect, 'multivar unset' ); # ADDITIONAL TESTS (7): our rules for valid keys are # much more permissive than git's throws_ok { $config->set( key => "inval.key=foo", value => 'blabla', filename => $config_filename ); } qr/invalid variable name/i, 'invalid name containing = char'; throws_ok { $config->set( key => 'inval. key', value => 'blabla', filename => $config_filename ); } qr/invalid variable name/i, 'invalid name starting with whitespace'; throws_ok { $config->set( key => 'inval.key ', value => 'blabla', filename => $config_filename ); } qr/invalid variable name/i, 'invalid name ending with whitespace'; throws_ok { $config->set( key => "inval.key\n2", value => 'blabla', filename => $config_filename ); } qr/invalid key/i, 'invalid name containing newline'; lives_ok { $config->set( key => 'valid."http://example.com/"', value => 'true', filename => $config_filename, ); } 'can have . char in key if quoted'; lives_and { $config->load; is( $config->get( key => 'valid."http://example.com/"' ), 'true' ); } 'URL key value is correct'; # kill this section just to not have to modify all the following tests lives_ok { $config->remove_section( section => 'valid', filename => $config_filename ); $config->load; } 'remove URL key section'; lives_ok { $config->set( key => '123456.a123', value => '987', filename => $config_filename ); } 'correct key'; lives_ok { $config->set( key => 'Version.1.2.3eX.Alpha', value => 'beta', filename => $config_filename ); } 'correct key'; $expect = <<'EOF' [beta] ; silly comment # another comment noIndent= sillyValue ; 'nother silly comment # empty line ; comment [nextSection] NoNewLine = wow2 for me [123456] a123 = 987 [Version "1.2.3eX"] Alpha = beta EOF ; is( $config->slurp, $expect, 'hierarchical section value' ); $expect = <<'EOF' 123456.a123=987 beta.noindent=sillyValue nextsection.nonewline=wow2 for me version.1.2.3eX.alpha=beta EOF ; $config->load; is( $config->dump, $expect, 'working dump' ); ### ADDITIONAL TEST for dump my %results = $config->dump; is_deeply( \%results, { '123456.a123' => '987', 'beta.noindent' => 'sillyValue', 'nextsection.nonewline' => 'wow2 for me', 'version.1.2.3eX.alpha' => 'beta' }, 'dump works in array context' ); $expect = { 'beta.noindent', 'sillyValue', 'nextsection.nonewline', 'wow2 for me' }; # test get_regexp lives_and { is_deeply( scalar $config->get_regexp( key => 'in' ), $expect ) } '--get-regexp'; $config->set( key => 'nextsection.nonewline', value => 'wow4 for you', filename => $config_filename, multiple => 1 ); $config->load; $expect = [ 'wow2 for me', 'wow4 for you' ]; $config->load; is_deeply( scalar $config->get_all( key => 'nextsection.nonewline' ), $expect, '--add' ); $config->burp( '[novalue] variable [emptyvalue] variable = ' ); $config->load; lives_and { is( $config->get( key => 'novalue.variable', filter => qr/^$/ ), undef ); } 'get variable with no value'; lives_and { is( $config->get( key => 'emptyvalue.variable', filter => qr/^$/ ), '' ); } 'get variable with empty value'; # more get_regexp lives_and { is_deeply( scalar $config->get_regexp( key => 'novalue' ), { 'novalue.variable' => undef } ); } 'get_regexp variable with no value'; lives_and { is_deeply( scalar $config->get_regexp( key => qr/emptyvalue/ ), { 'emptyvalue.variable' => '' } ); } 'get_regexp variable with empty value'; # should evaluate to a true value ok( $config->get( key => 'novalue.variable', as => 'bool' ), 'get bool variable with no value' ); # should evaluate to a false value ok( !$config->get( key => 'emptyvalue.variable', as => 'bool' ), 'get bool variable with empty value' ); # testing alternate subsection notation $config->burp( '[a.b] c = d ' ); $config->set( key => 'a.x', value => 'y', filename => $config_filename ); $expect = <<'EOF' [a.b] c = d [a] x = y EOF ; is( $config->slurp, $expect, 'new section is partial match of another' ); $config->set( key => 'b.x', value => 'y', filename => $config_filename ); $config->set( key => 'a.b', value => 'c', filename => $config_filename ); $config->load; $expect = <<'EOF' [a.b] c = d [a] x = y b = c [b] x = y EOF ; is( $config->slurp, $expect, 'new variable inserts into proper section' ); # testing rename_section # NOTE: added comment after [branch "1 234 blabl/a"] to check that our # implementation doesn't blow away trailing text after a rename like # git-config currently does $config->burp( '# Hallo #Bello [branch "eins"] x = 1 [branch.eins] y = 1 [branch "1 234 blabl/a"] ; comment weird ' ); lives_ok { $config->rename_section( from => 'branch.eins', to => 'branch.zwei', filename => $config_filename ); } 'rename_section lives'; $expect = <<'EOF' # Hallo #Bello [branch "zwei"] x = 1 [branch "zwei"] y = 1 [branch "1 234 blabl/a"] ; comment weird EOF ; is( $config->slurp, $expect, 'rename succeeded' ); throws_ok { $config->rename_section( from => 'branch."world domination"', to => 'branch.drei', filename => $config_filename ); } qr/no such section/i, 'rename non-existing section'; is( $config->slurp, $expect, 'rename non-existing section changes nothing' ); lives_ok { $config->rename_section( from => 'branch."1 234 blabl/a"', to => 'branch.drei', filename => $config_filename ); } 'rename another section'; # NOTE: differs from current git behaviour, because the way that git handles # renames / variable replacement is buggy (git would write [branch "drei"] # without the leading tab, and then clobber anything that followed) $expect = <<'EOF' # Hallo #Bello [branch "zwei"] x = 1 [branch "zwei"] y = 1 [branch "drei"] ; comment weird EOF ; is( $config->slurp, $expect, 'rename succeeded' ); # [branch "vier"] doesn't get interpreted as a real section # header because the variable definition before it means # that all the way to the end of that line is a part of # a's value $config->burp( $config->slurp . '[branch "zwei"] a = 1 [branch "vier"] ' ); lives_ok { $config->remove_section( section => 'branch.zwei', filename => $config_filename ); } 'remove section'; # we kill leading whitespace on section removes because it makes # the implementation easier (can just kill all the way up to # the following section or the end of the file) $expect = <<'EOF' # Hallo #Bello [branch "drei"] ; comment weird EOF ; is( $config->slurp, $expect, 'section was removed properly' ); unlink $config_filename; $expect = <<'EOF' [gitcvs] enabled = true dbname = %Ggitcvs2.%a.%m.sqlite [gitcvs "ext"] dbname = %Ggitcvs1.%a.%m.sqlite EOF ; $config->set( key => 'gitcvs.enabled', value => 'true', filename => $config_filename ); $config->set( key => 'gitcvs.ext.dbname', value => '%Ggitcvs1.%a.%m.sqlite', filename => $config_filename ); $config->set( key => 'gitcvs.dbname', value => '%Ggitcvs2.%a.%m.sqlite', filename => $config_filename ); is( $config->slurp, $expect, 'section ending' ); # testing int casting $config->set( key => 'kilo.gram', value => '1k', filename => $config_filename ); $config->set( key => 'mega.ton', value => '1m', filename => $config_filename ); $config->load; is( $config->get( key => 'kilo.gram', as => 'int' ), 1024, 'numbers: int k interp' ); is( $config->get( key => 'mega.ton', as => 'int' ), 1048576, 'numbers: int m interp' ); # units that aren't k/m/g should throw an error $config->set( key => 'aninvalid.unit', value => '1auto', filename => $config_filename ); $config->load; throws_ok { $config->get( key => 'aninvalid.unit', as => 'int' ) } qr/invalid unit/i, 'invalid unit'; my %pairs = qw( true1 01 true2 -1 true3 YeS true4 true false1 000 false3 nO false4 FALSE); $pairs{false2} = ''; for my $key ( keys %pairs ) { $config->set( key => "bool.$key", value => $pairs{$key}, filename => $config_filename ); } $config->load; my @results = (); for my $i ( 1 .. 4 ) { push( @results, $config->get( key => "bool.true$i", as => 'bool' ), $config->get( key => "bool.false$i", as => 'bool' ) ); } my $b = 1; while (@results) { if ($b) { ok( shift @results, 'correct true bool from get' ); } else { ok( !shift @results, 'correct false bool from get' ); } $b = !$b; } $config->set( key => 'bool.nobool', value => 'foobar', filename => $config_filename ); $config->load; throws_ok { $config->get( key => 'bool.nobool', as => 'bool' ) } qr/invalid bool/i, 'invalid bool (get)'; # test casting with set throws_ok { $config->set( key => 'bool.nobool', value => 'foobar', as => 'bool', filename => $config_filename ); } qr/invalid bool/i, 'invalid bool (set)'; unlink $config_filename; for my $key ( keys %pairs ) { $config->set( key => "bool.$key", value => $pairs{$key}, filename => $config_filename, as => 'bool' ); } $config->load; @results = (); for my $i ( 1 .. 4 ) { push( @results, $config->get( key => "bool.true$i" ), $config->get( key => "bool.false$i" ) ); } $b = 1; while (@results) { if ($b) { is( shift @results, 'true', 'correct true bool from set' ); } else { is( shift @results, 'false', 'correct false bool from set' ); } $b = !$b; } unlink $config_filename; $expect = <<'EOF' [int] val1 = 1 val2 = -1 val3 = 5242880 EOF ; $config->set( key => 'int.val1', value => '01', filename => $config_filename, as => 'int' ); $config->set( key => 'int.val2', value => '-1', filename => $config_filename, as => 'int' ); $config->set( key => 'int.val3', value => '5m', filename => $config_filename, as => 'int' ); is( $config->slurp, $expect, 'set --int' ); unlink $config_filename; $config->burp( '[bool] true1 = on true2 = yes false1 = off false2 = no [int] int1 = 00 int2 = 01 int3 = -01 ' ); $config->load; is( $config->get( key => 'bool.true1', as => 'bool-or-int', human => 1 ), 'true', 'get bool-or-int' ); is( $config->get( key => 'bool.true2', as => 'bool-or-int', human => 1 ), 'true', 'get bool-or-int' ); is( $config->get( key => 'bool.false1', as => 'bool-or-int', human => 1 ), 'false', 'get bool-or-int' ); is( $config->get( key => 'bool.false2', as => 'bool-or-int', human => 1 ), 'false', 'get bool-or-int' ); is( $config->get( key => 'int.int1', as => 'bool-or-int' ), 0, 'get bool-or-int' ); is( $config->get( key => 'int.int2', as => 'bool-or-int' ), 1, 'get bool-or-int' ); is( $config->get( key => 'int.int3', as => 'bool-or-int' ), -1, 'get bool-or-int' ); unlink $config_filename; $expect = <<'EOF' [bool] true1 = true false1 = false true2 = true false2 = false [int] int1 = 0 int2 = 1 int3 = -1 EOF ; $config->set( key => 'bool.true1', value => 'true', as => 'bool-or-int', filename => $config_filename ); $config->set( key => 'bool.false1', value => 'false', as => 'bool-or-int', filename => $config_filename ); $config->set( key => 'bool.true2', value => 'yes', as => 'bool-or-int', filename => $config_filename ); $config->set( key => 'bool.false2', value => 'no', as => 'bool-or-int', filename => $config_filename ); $config->set( key => 'int.int1', value => '0', as => 'bool-or-int', filename => $config_filename ); $config->set( key => 'int.int2', value => '1', as => 'bool-or-int', filename => $config_filename ); $config->set( key => 'int.int3', value => '-1', as => 'bool-or-int', filename => $config_filename ); is( $config->slurp, $expect, 'set bool-or-int' ); unlink $config_filename; $config->set( key => 'quote.leading', value => ' test', filename => $config_filename ); $config->set( key => 'quote.ending', value => 'test ', filename => $config_filename ); $config->set( key => 'quote.semicolon', value => 'test;test', filename => $config_filename ); $config->set( key => 'quote.hash', value => 'test#test', filename => $config_filename ); $expect = <<'EOF' [quote] leading = " test" ending = "test " semicolon = "test;test" hash = "test#test" EOF ; is( $config->slurp, $expect, 'quoting' ); throws_ok { $config->set( key => "key.with\nnewline", value => '123', filename => $config_filename ); } qr/invalid key/, 'key with newline'; lives_ok { $config->set( key => 'key.sub', value => "value.with\nnewline", filename => $config_filename ); } 'value with newline'; $config->burp( '[section] ; comment \ continued = cont\ inued noncont = not continued ; \ quotecont = "cont;\ inued" ' ); $expect = <<'EOF' section.continued=continued section.noncont=not continued section.quotecont=cont;inued EOF ; $config->load; is( $config->dump, $expect, 'value continued on next line' ); # testing symlinked configuration SKIP: { skip 'windows does *not* support symlink', 2 if $^O =~ /MSWin/; symlink File::Spec->catfile( $config_dirname, 'notyet' ), File::Spec->catfile( $config_dirname, 'myconfig' ); my $myconfig = TestConfig->new( confname => 'myconfig', tmpdir => $config_dirname ); $myconfig->set( key => 'test.frotz', value => 'nitfol', filename => File::Spec->catfile( $config_dirname, 'myconfig' ) ); my $notyet = TestConfig->new( confname => 'notyet', tmpdir => $config_dirname ); $notyet->set( key => 'test.xyzzy', value => 'rezrov', filename => File::Spec->catfile( $config_dirname, 'notyet' ) ); $notyet->load; is( $notyet->get( key => 'test.frotz' ), 'nitfol', 'can get 1st val from symlink' ); is( $notyet->get( key => 'test.xyzzy' ), 'rezrov', 'can get 2nd val from symlink' ); } ### ADDITIONAL TESTS (not from the git test suite, just things that I didn't ### see tests for and think should be tested) # weird yet valid edge case $config->burp( '# foo [section] [section2] a = 1 b = 2 ' ); $config->load; $expect = <<'EOF' section2.a=1 section2.b=2 EOF ; is( $config->dump, $expect, 'section headers are valid w/out newline' ); $config->burp( '# foo [section] b = off b = on exact = 0 inexact = 01 delicieux = true ' ); $config->load; is_deeply( scalar $config->get_regexp( key => 'x', as => 'bool' ), { 'section.exact' => 0, 'section.inexact' => 1, 'section.delicieux' => 1 }, 'get_regexp casting works' ); is_deeply( scalar $config->get_regexp( key => 'x', filter => '!0' ), { 'section.delicieux' => 'true' }, 'get_regexp filter works' ); is_deeply( scalar $config->get_all( key => 'section.b', filter => 'f' ), ['off'], 'get_all filter works' ); is_deeply( scalar $config->get_all( key => 'section.b', as => 'bool' ), [ 0, 1 ], 'get_all casting works' ); # we don't strip the quotes on this, right? $config->set( key => 'test.foo', value => '"ssh" for "kernel.org"', filename => $config_filename, ); $config->load; is( $config->get( key => 'test.foo' ), '"ssh" for "kernel.org"', "don't strip quotes contained in value" ); $config->set( key => 'test.foo', value => '1.542', filename => $config_filename, ); $config->load; # test difference between int/num casting, since git config doesn't # do num is( $config->get( key => 'test.foo', as => 'int' ), 1, 'int casting truncates'); is( $config->get( key => 'test.foo', as => 'num' ), 1.542, 'num casting doesn\'t truncate'); # Test config file inheritance/overriding. # Config files are loaded in the order: global, user, dir. Variables contained # in files loaded later replace variables of the same name that were # loaded earlier. unlink $config_filename; my $global_config = File::Spec->catfile( $config_dirname, 'etc', 'config' ); my $user_config = File::Spec->catfile( $config_dirname, 'home', 'config' ); my $repo_config = $config_filename; mkdir File::Spec->catdir( $config_dirname, 'etc' ); mkdir File::Spec->catdir( $config_dirname, 'home' ); $config->burp( $repo_config, '[section] b = off ' ); $config->burp( $user_config, '[section] b = on a = off ' ); $config->load; is( $config->get( key => 'section.b' ), 'off', 'repo config overrides user config'); is( $config->get( key => 'section.a' ), 'off', 'user config is loaded'); $config->burp( $global_config, '[section] b = true a = true c = true ' ); $config->load; %results = $config->dump; is_deeply( \%results, { 'section.a' => 'off', 'section.b' => 'off', 'section.c' => 'true' }, 'global config is loaded and user/repo configs override it' ); unlink $config_filename; # Tests for group_set, which git doesn't have. # Anything beyond the basics should be covered by the fact that # set is implemented in terms of group_set. We just want to # make sure that passing in multiple things to set works here, # since set only passes in one. $config->group_set( $config_filename, [ { key => 'foo.test1', value => '1', as => 'bool', }, { key => 'foo.test2', value => 'bar', }, ] ); $config->load; is( $config->get( key => 'foo.test1' ), 'true', 'basic group_set' ); is( $config->get( key => 'foo.test2' ), 'bar', 'basic group_set' ); unlink $global_config; unlink $user_config; unlink $repo_config; # Test to make sure subsection comparison is case-sensitive. $config->burp( '[section "FOO"] b = true [section "foo"] b = yes ' ); $config->load; # If comparison were actually case-insensitive, this would blow # up on a multival. is( $config->get( key => 'section.FOO.b' ), 'true', 'subsection comparison is case-sensitive' ); # Test section names with with weird characters in them (non git-compat) $config->burp( '[http://www.example.com/test/] admin = foo@bar.com [http://www.example.com/test/ "users"] epe = Eddie P. Example ' ); lives_and { $config->load; is( $config->get( key => 'http://www.example.com/test/.admin' ), 'foo@bar.com' ); } 'parse weird characters in section in non-git compat mode'; lives_and { $config->set( key => 'http://www.example.com/test/.devs.joe', value => 'Joe Schmoe', filename => $config_filename, ); $config->load; is( $config->get( key => 'http://www.example.com/test/.devs.joe' ), 'Joe Schmoe', ); } 'set weird characters in section in non-git compat mode'; # Test git compat flag. $config->compatible(1); # variables names that start with numbers or contain characters other # than a-zA-Z- are illegal $config->burp( '[section "FOO"] foo..bar = true ' ); throws_ok { $config->load; } qr/error parsing/im, 'variable names cannot contain . in git-compat mode'; $config->burp( '[section "FOO"] foo%@$#bar = true ' ); throws_ok { $config->load; } qr/error parsing/im, 'variable names cannot contain symbols in git-compat mode'; $config->burp( '[section "FOO"] 01inval = true ' ); throws_ok { $config->load; } qr/error parsing/im, 'variable names cannot start with a number git-compat mode'; $config->burp( '[section "FOO"] -inval = true ' ); throws_ok { $config->load; } qr/error parsing/im, 'variable names cannot start with a dash git-compat mode'; # set has a different check than the parsing code, so test it too throws_ok { $config->set( key => 'section.01inval', value => 'none', filename => $config_filename, ) } qr/invalid variable name/im, 'variable names cannot start with a number in git-compat mode'; throws_ok { $config->set( key => 'section.foo%$@bar', value => 'none', filename => $config_filename, ) } qr/invalid variable name/im, 'variable names cannot contain symbols in git-compat mode'; throws_ok { $config->set( key => 'section."foo..bar"', value => 'none', filename => $config_filename, ) } qr/invalid variable name/im, 'variable names cannot contain . in git-compat mode'; throws_ok { $config->set( key => 'section.-inval', value => 'none', filename => $config_filename, ) } qr/invalid variable name/im, 'variable names cannot start with - in git-compat mode'; # section names cannot contain characters other than a-zA-Z-. in compat mode $config->burp( '[se$^%#& "FOO"] a = b ' ); throws_ok { $config->load; } qr/error parsing/im, 'section names cannot contain symbols in git-compat mode'; $config->burp( '[sec tion "FOO"] a = b ' ); throws_ok { $config->load; } qr/error parsing/im, 'section names cannot contain whitespace in git-compat mode'; $config->burp( '[-foo.bar-baz "FOO"] a = b ' ); lives_ok { $config->load; } 'section names can contain - and . in git-compat mode'; # set has a different check than the parsing code, so test it too throws_ok { $config->set( key => 'sec tion.foo.baz', value => 'none', filename => $config_filename, ) } qr/invalid section name/im, 'section names cannot contain whitespace in git-compat mode'; throws_ok { $config->set( key => 's^*&^#$.foo.baz', value => 'none', filename => $config_filename, ) } qr/invalid section name/im, 'section names cannot contain symbols in git-compat mode'; lives_and { $config->set( key => '-foo.bar-baz.foo.baz', value => 'none', filename => $config_filename, ); $config->load; is( $config->get( key => '-foo.bar-baz.foo.baz' ), 'none' ); } 'section names can contain - and . while setting in git-compat mode'; throws_ok { $config->set( key => "section.foo\nbar.baz", value => 'none', filename => $config_filename, ) } qr/invalid key/im, 'subsection names cannot contain unescaped newlines in compat mode'; # these should be the case in no-compat mode too $config->compatible(0); throws_ok { $config->set( key => "section.foo\nbar.baz", value => 'none', filename => $config_filename, ) } qr/invalid key/im, 'subsection names cannot contain unescaped newlines in nocompat mode'; # Make sure some bad configs throw errors. $config->burp( '[testing "FOO" a = b ' ); throws_ok { $config->load } qr/error parsing/i, 'invalid section (nocompat)'; $config->compatible(1); throws_ok { $config->load } qr/error parsing/i, 'invalid section (compat)'; # This should be OK since the variable name doesn't start with [ $config->burp( '[test] a[] = b ' ); throws_ok { $config->load } qr/error parsing/i, 'key cannot contain [] in compat mode'; $config->compatible(0); lives_and { $config->load; is( $config->get( key => 'test.a[]' ), 'b' ); } 'key can contain but not start with [ in nocompat mode'; lives_and { $config->set( key => "section.foo\\\\bar.baz", value => 'none', filename => $config_filename, ); $config->load; is( $config->get( key => "section.foo\\\\bar.baz" ), 'none' ); } "subsection with escaped backslashes"; # special values in subsection my %special_in_value = ( backslash => "\\", doublequote => q{"} ); while ( my ( $k, $v ) = each %special_in_value ) { for my $times ( 1 .. 3 ) { my $value = 'chan' . $v x $times . "mon" . $v x $times; lives_and { $config->set( key => "section.foo", value => $value, filename => $config_filename, ); $config->load; is( $config->get( key => "section.foo" ), $value ); } "value with $k occurs $times time" . ( $times == 1 ? '' : 's' ); } } # special chars in subsection, particularly auto-escaping \ and " on set my %special_in_subsection = ( backslash => "\\", doublequote => q{"} ); while ( my ( $k, $v ) = each %special_in_subsection ) { for my $times ( 1 .. 3 ) { my $key = 'section.foo' . $v x $times . 'bar' . $v x $times . 'baz'; lives_and { $config->set( key => $key, value => 'none', filename => $config_filename, ); $config->load; is( $config->get( key => $key ), 'none' ); } "subsection with $k occurs with $times time" . ( $times == 1 ? '' : 's' ); } } Config-GitLike-1.18/t/unix.conf000644 000765 000024 00000000072 13614253640 016554 0ustar00chmrrstaff000000 000000 [core] engine = pg topdir = sql [deploy] verify = true Config-GitLike-1.18/t/00_use.t000644 000765 000024 00000000210 13614253640 016174 0ustar00chmrrstaff000000 000000 use warnings; use strict; use Test::More tests => 2; BEGIN { use_ok('Config::GitLike'); use_ok('Config::GitLike::Cascaded'); } Config-GitLike-1.18/t/lib/000755 000765 000024 00000000000 13632622657 015501 5ustar00chmrrstaff000000 000000 Config-GitLike-1.18/t/mac.conf000644 000765 000024 00000000072 13614253640 016331 0ustar00chmrrstaff000000 000000 [core] engine = pg topdir = sql [deploy] verify = true Config-GitLike-1.18/t/get_regexp_filter_multiple.t000644 000765 000024 00000013270 13614253640 022524 0ustar00chmrrstaff000000 000000 # tests that serve to expose a problem with the interaction of filtering and # multiple values in get_regexp() in Config::GitLike 1.16 use strict; use warnings; use File::Copy; use Test::More tests => 30; use Test::Exception; use File::Spec; use File::Temp qw/tempdir/; use lib 't/lib'; use TestConfig; # create an empty test directory in /tmp my $config_dirname = tempdir( CLEANUP => !$ENV{CONFIG_GITLIKE_DEBUG} ); my $config_filename = File::Spec->catfile( $config_dirname, 'config' ); diag "config file is: $config_filename" if $ENV{TEST_VERBOSE}; my $config = TestConfig->new( confname => 'config', tmpdir => $config_dirname ); $config->burp( '# foo [section] b = off b = on exact = 0 inexact = 01 delicieux = true ' ); $config->load; # 'delicieux' has only 1 value is_deeply( scalar $config->get_all( key => 'section.delicieux' ), ['true'], 'get all values for key delicieux' ); is_deeply( scalar $config->get_all( key => 'section.delicieux', filter => 'true' ), ['true'], 'get all values for key delicieux, filter by regexp' ); is_deeply( scalar $config->get_all( key => 'section.delicieux', filter => 'false' ), [], 'get all values for key delicieux, filter by regexp "false"' ); is_deeply( scalar $config->get_regexp( key => 'section\.delicieux' ), { 'section.delicieux' => 'true' }, 'get all values for key delicieux by regexp' ); is_deeply( scalar $config->get_regexp( key => 'section\.delicieux', filter => 'true' ), { 'section.delicieux' => 'true' }, 'get all values for key delicieux by regexp, filter by true' ); is_deeply( scalar $config->get_regexp( key => 'section\.delicieux', filter => '!true' ), {}, 'get all values for key delicieux by regexp, filter by !true' ); is_deeply( scalar $config->get_regexp( key => 'section\.delicieux', filter => 'false' ), {}, 'get all values for key delicieux by regexp, filter by false' ); is_deeply( scalar $config->get_regexp( key => 'section\.delicieux', filter => '!false' ), { 'section.delicieux' => 'true' }, 'get all values for key delicieux by regexp, filter by !false' ); # 'b' has multiple values (2) is_deeply( scalar $config->get_all( key => 'section.b' ), ['off', 'on'], 'get all values for key b' ); is_deeply( scalar $config->get_all( key => 'section.b', filter => 'o' ), ['off', 'on'], 'get all values for key b, filter by letter "o"' ); is_deeply( scalar $config->get_all( key => 'section.b', filter => 'n' ), ['on'], 'get all values for key b, filter by letter "n"' ); is_deeply( scalar $config->get_all( key => 'section.b', filter => 'Q' ), [], 'get all values for key b, filter by letter "Q"' ); is_deeply( scalar $config->get_regexp( key => 'section\.b' ), { 'section.b' => ['off', 'on'] }, 'get all values for key b by regexp' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '' ), { 'section.b' => ['off', 'on'] }, 'get all values for key b by regexp, filter by empty regex' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '.*' ), { 'section.b' => ['off', 'on'] }, 'get all values for key b by regexp, filter by catch-all regex' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '^.*$' ), { 'section.b' => ['off', 'on'] }, 'get all values for key b by regexp, filter by anchored catch-all regex' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => qr/(on|off)/ ), { 'section.b' => ['off', 'on'] }, 'get all values for key b by regexp, filter by regex on|off' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => qr/^(on|off)$/ ), { 'section.b' => ['off', 'on'] }, 'get all values for key b by regexp, filter by anchored regex on|off' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => 'o' ), { 'section.b' => ['off', 'on'] }, 'get all values for key b by regexp, filter by letter "o"' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => 'n' ), { 'section.b' => 'on' }, 'get all values for key b by regexp, filter by letter "n"' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => 'Q' ), {}, 'get all values for key b by regexp, filter by letter "Q"' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => 'ARRAY' ), {}, 'get all values for key b by regexp, filter by word "ARRAY"' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '!' ), {}, 'get all values for key b by regexp, filter by negated regex' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '!.*' ), {}, 'get all values for key b by regexp, filter by negated catch-all regex' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '!(on|off)' ), {}, 'get all values for key b by regexp, filter by "!(on|off)"' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '!on|off' ), {}, 'get all values for key b by regexp, filter by "!on|off"' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '!good|bad' ), { 'section.b' => ['off', 'on'] }, 'get all values for key b by regexp, filter by negated regex good|bad' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '!o' ), {}, 'get all values for key b by regexp, filter by "!o"' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '!n' ), { 'section.b' => 'off' }, 'get all values for key b by regexp, filter by "!n"' ); is_deeply( scalar $config->get_regexp( key => 'section\.b', filter => '!ARRAY' ), { 'section.b' => ['off', 'on'] }, 'get all values for key b by regexp, filter by "!ARRAY"' ); Config-GitLike-1.18/t/platforms.t000644 000765 000024 00000000737 13614253640 017126 0ustar00chmrrstaff000000 000000 use strict; use warnings; use Test::More; use Config::GitLike; use File::Spec; for my $platform (qw(unix dos mac)) { my $config_filename = File::Spec->catfile('t', "$platform.conf"); ok my $data = Config::GitLike->load_file($config_filename), "Load $platform config"; is_deeply $data, { 'core.engine' => 'pg', 'core.topdir' => 'sql', 'deploy.verify' => 'true', }, "Should have proper config for $platform file"; } done_testing; Config-GitLike-1.18/t/lib/TestConfig.pm000644 000765 000024 00000002737 13614253640 020105 0ustar00chmrrstaff000000 000000 package TestConfig; use Moo; use MooX::Types::MooseLike::Base qw(Str); use File::Spec; extends 'Config::GitLike'; has 'tmpdir' => ( is => 'rw', required => 1, isa => Str, ); # override these methods so: # (1) test cases don't need to chdir into the tmp directory in order to work correctly # (2) we don't try loading configs from the user's home directory or the system # /etc during tests, which could (a) cause tests to break and (b) change things on # the user's system during tests # (3) files in the test directory are not hidden (for easier debugging) sub dir_file { my $self = shift; my $dirs = (File::Spec->splitpath( $self->tmpdir, 1 ))[1]; return File::Spec->catfile($dirs, $self->confname); } sub user_file { my $self = shift; return File::Spec->catfile( ( File::Spec->splitpath( $self->tmpdir, 1 ) )[1], 'home', $self->confname ); } sub global_file { my $self = shift; return File::Spec->catfile( ( File::Spec->splitpath( $self->tmpdir, 1 ) )[1], 'etc', $self->confname ); } sub slurp { my $self = shift; my $file = shift || $self->dir_file; local ($/); open( my $fh, $file ) or die "Unable to open file $file: $!"; return <$fh>; } sub burp { my $self = shift; my $content = pop; my $file_name = shift || $self->dir_file; open( my $fh, ">", $file_name ) || die "can't open $file_name: $!"; print $fh $content; } __PACKAGE__->meta->make_immutable; no Moo; 1; Config-GitLike-1.18/t/util/translate.pl000755 000765 000024 00000007057 13614253640 020246 0ustar00chmrrstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use 5.0100; # script to translate some bits of the git configuration test suite into a perl # test suite my $prepend = 1; while (<>) { if ($prepend) { # header test stuff say "use File::Copy;"; say "use Test::More tests => 75;"; $prepend = 0; } # translate lines like: # test_expect_success 'mixed case' 'cmp .git/config expect' # leaves more complicated test_expect_success lines alone elsif (/test_expect_success ('[^']+') 'cmp ([^\s]+) ([^\s]+)'/) { my $config = $2 eq '.git/config'? 'gitconfig' : $2; say "is(slurp(\$${config}), \$${3}, ${1});"; } # translate cat'ing text into the 'expect' file into uninterpolated # heredocs in the $expect var elsif (/cat (>+) ?(expect|\.git\/config) << ?\\?EOF/) { given ($2) { when ('expect') { say "\$expect = <<'EOF'"; } when ('.git/config') { say "open FH, '$1', \$config_filename or die \"Could not open \${config_filename}: \$!\";"; say "print FH <<'EOF'"; } } } # add semicolon after heredocs elsif (/^EOF$/) { print; say ';'; } # echoing into expect puts that string into $expect elsif (/^echo (?:'([a-zA-Z0-9. ]+)'|([^\s]+)) > expect/) { say "\$expect = '$1';"; } # translate some git config commands into Config::GitLike code elsif (s/^git config//) { if (/--unset ([a-zA-Z0-9.]+)(?: ["']?([a-zA-Z0-9 \$]+)["']?)?$/) { # filter can be empty my($key,$filter) = ($1, $2); say "\$config->set(key => $key, filter => '$filter', filename => \$config_filename);" } elsif (/([a-zA-Z0-9.]+) ["']?([a-zA-Z0-9 ]+)["']?(?: ["']?([a-zA-Z0-9 \$]+)["']?)?$/) { # filter can be empty my($key,$val,$filter) = ($1, $2, $3); print "\$config->set(key => '$key', value => '$val', "; print "filter => '$filter', " if $filter; say "filename => \$config_filename);"; } } # translate cp commands into copy()s elsif (/^cp .git\/([^\s]+) .git\/([^\s]+)/) { say "copy(File::Spec->catfile(\$config_dirname, '$1'),"; say " File::Spec->catfile(\$config_dirname, '$2'))"; say " or die \"File cannot be copied: \$!\";"; } # translate rm into unlink elsif (/^rm .git\/(.+)$/) { say "unlink File::Spec->catfile(\$config_dirname, '$1');"; } # translate test description into a diag elsif (/^test_description=('.+')$/) { say "diag($1);" } # this really means "load this other config file that is not # $config_filename" and then compare it to $expect elsif (/^GIT_CONFIG=([^ ]+) git config ([^ ]+)(?:(?: > (output))?| ([^ ]+))/) { my($conffile, $cmd) = ($1, $2); say "my \$$conffile = TestConfig->new(confname => '$conffile');"; if ($3 eq 'output') { # like git config -l (though the output won't be exactly the same # in cases where there's more than one var in the file since # dump is sorted and -l isn't) say "my \$$3 = \$$conffile->dump;"; } else { say "\$${conffile}->set(key => '$cmd', value => '$3', file => File::Spec->catfile(\$config_dirname, ${conffile}));"; } } # stuff that can just be canned elsif (/^(?:#!\/bin\/sh|#|# Copyright|\. \.\/test-lib.sh|test -f .git\/config && rm \.git\/config|test_done)/) { } # print any unknown stuff for manual frobbing else { print; } } Config-GitLike-1.18/inc/Module/000755 000765 000024 00000000000 13632622657 016466 5ustar00chmrrstaff000000 000000 Config-GitLike-1.18/inc/Module/Install/000755 000765 000024 00000000000 13632622657 020074 5ustar00chmrrstaff000000 000000 Config-GitLike-1.18/inc/Module/Install.pm000644 000765 000024 00000027145 13632621746 020441 0ustar00chmrrstaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.19'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( {no_chdir => 1, wanted => sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($File::Find::name); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }}, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Config-GitLike-1.18/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 13632621746 021472 0ustar00chmrrstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Config-GitLike-1.18/inc/Module/Install/Metadata.pm000644 000765 000024 00000043302 13632621746 022152 0ustar00chmrrstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Config-GitLike-1.18/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 13632621746 021332 0ustar00chmrrstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Config-GitLike-1.18/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 13632621746 022163 0ustar00chmrrstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Config-GitLike-1.18/inc/Module/Install/Can.pm000644 000765 000024 00000006405 13632621746 021136 0ustar00chmrrstaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; if ($^O eq 'VMS') { require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new( quiet => 1, ); return $builder->have_compiler; } my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 245 Config-GitLike-1.18/inc/Module/Install/Makefile.pm000644 000765 000024 00000027437 13632621746 022162 0ustar00chmrrstaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Config-GitLike-1.18/inc/Module/Install/ExtraTests.pm000644 000765 000024 00000005666 13632621746 022553 0ustar00chmrrstaff000000 000000 #line 1 use strict; use warnings; use 5.006; package Module::Install::ExtraTests; use Module::Install::Base; BEGIN { our $VERSION = '0.008'; our $ISCORE = 1; our @ISA = qw{Module::Install::Base}; } our $use_extratests = 0; sub extra_tests { my ($self) = @_; return unless -d 'xt'; return unless my @content = grep { $_ !~ /^[.]/ } ; die "unknown files found in ./xt" if grep { !-d } @content; my %known = map {; "xt/$_" => 1 } qw(author smoke release); my @unknown = grep { not $known{$_} } @content; die "unknown directories found in ./xt: @unknown" if @unknown; $use_extratests = 1; return; } { no warnings qw(once); package # The newline tells PAUSE, "DO NOT INDEXING!" MY; sub test_via_harness { my $self = shift; return $self->SUPER::test_via_harness(@_) unless $use_extratests; my ($perl, $tests) = @_; my $a_str = -d 'xt/author' ? 'xt/author' : ''; my $r_str = -d 'xt/release' ? 'xt/release' : ''; my $s_str = -d 'xt/smoke' ? 'xt/smoke' : ''; my $is_author = $Module::Install::AUTHOR ? 1 : 0; return qq{\t$perl "-Iinc" "-MModule::Install::ExtraTests" } . qq{"-e" "Module::Install::ExtraTests::__harness('Test::Harness', $is_author, '$a_str', '$r_str', '$s_str', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n}; } sub dist_test { my ($self, @args) = @_; return $self->SUPER::dist_test(@args) unless $use_extratests; my $text = $self->SUPER::dist_test(@args); my @lines = split /\n/, $text; $_ =~ s/ (\S*MAKE\S* test )/ RELEASE_TESTING=1 $1 / for grep { m/ test / } @lines; return join "\n", @lines; } } sub __harness { my $harness_class = shift; my $is_author = shift; my $author_tests = shift; my $release_tests = shift; my $smoke_tests = shift; eval "require $harness_class; 1" or die; require File::Spec; my $verbose = shift; eval "\$$harness_class\::verbose = $verbose; 1" or die; # Because Windows doesn't do this for us and listing all the *.t files # out on the command line can blow over its exec limit. require ExtUtils::Command; push @ARGV, __PACKAGE__->_deep_t($author_tests) if $author_tests and (exists $ENV{AUTHOR_TESTING} ? $ENV{AUTHOR_TESTING} : $is_author); push @ARGV, __PACKAGE__->_deep_t($release_tests) if $release_tests and $ENV{RELEASE_TESTING}; push @ARGV, __PACKAGE__->_deep_t($smoke_tests) if $smoke_tests and $ENV{AUTOMATED_TESTING}; my @argv = ExtUtils::Command::expand_wildcards(@ARGV); local @INC = @INC; unshift @INC, map { File::Spec->rel2abs($_) } @_; $harness_class->can('runtests')->(sort { lc $a cmp lc $b } @argv); } sub _wanted { my $href = shift; no warnings 'once'; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _deep_t { my ($self, $dir) = @_; require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), $dir); return map { "$_/*.t" } sort keys %test_dir; } 1; __END__ Config-GitLike-1.18/inc/Module/Install/Base.pm000644 000765 000024 00000002147 13632621746 021306 0ustar00chmrrstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.19'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159