Config-GitLike-1.17/0000755000175000017500000000000013133012324013175 5ustar chmrrchmrrConfig-GitLike-1.17/MANIFEST0000644000175000017500000000123213133012324014324 0ustar chmrrchmrrChanges 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 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 SIGNATURE Public-key signature (added by MakeMaker) Config-GitLike-1.17/Changes0000644000175000017500000000747213133012204014477 0ustar chmrrchmrrRevision history for perl module Config::GitLike 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.17/t/0000755000175000017500000000000013133012324013440 5ustar chmrrchmrrConfig-GitLike-1.17/t/00_use.t0000644000175000017500000000021012640077362014730 0ustar chmrrchmrruse warnings; use strict; use Test::More tests => 2; BEGIN { use_ok('Config::GitLike'); use_ok('Config::GitLike::Cascaded'); } Config-GitLike-1.17/t/platforms.t0000644000175000017500000000073713133007213015644 0ustar chmrrchmrruse 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.17/t/t1300-repo-config.t0000644000175000017500000010044412640077362016624 0ustar chmrrchmrruse 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.17/t/unix.conf0000644000175000017500000000007213133005755015303 0ustar chmrrchmrr[core] engine = pg topdir = sql [deploy] verify = true Config-GitLike-1.17/t/util/0000755000175000017500000000000013133012324014415 5ustar chmrrchmrrConfig-GitLike-1.17/t/util/translate.pl0000755000175000017500000000705712640077362017002 0ustar chmrrchmrr#!/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.17/t/encoding.t0000644000175000017500000000155012640077362015433 0ustar chmrrchmrruse 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.17/t/lib/0000755000175000017500000000000013133012324014206 5ustar chmrrchmrrConfig-GitLike-1.17/t/lib/TestConfig.pm0000644000175000017500000000273712640077362016641 0ustar chmrrchmrrpackage 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.17/t/casing.t0000644000175000017500000000660013133011736015101 0ustar chmrrchmrruse 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.17/t/dos.conf0000644000175000017500000000007713133005744015110 0ustar chmrrchmrr[core] engine = pg topdir = sql [deploy] verify = true Config-GitLike-1.17/t/comment.t0000644000175000017500000000301712640077362015307 0ustar chmrrchmrruse 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.17/t/get_regexp_filter_multiple.t0000644000175000017500000001327013133010257021244 0ustar chmrrchmrr# 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.17/t/mac.conf0000644000175000017500000000007213133005752015055 0ustar chmrrchmrr[core] engine = pg topdir = sql [deploy] verify = true Config-GitLike-1.17/META.yml0000644000175000017500000000122513133012221014442 0ustar chmrrchmrr--- 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.18' 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.17' Config-GitLike-1.17/SIGNATURE0000664000175000017500000000620513133012324014466 0ustar chmrrchmrrThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.79. 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: SHA512 SHA1 917fa846691295e7c7f386d2417cc4df46c64257 Changes SHA1 671ffd9e57a56b87c3aa6c311274770bc4ec0b75 MANIFEST SHA1 3274a397ad59d7854e333d7f780b63914662cd6b META.yml SHA1 52cb72683bcd12cb0eb441f2b31f08bceb87a2d0 Makefile.PL SHA1 fb87e7e7964647af0e7f6422bc7943754935dca7 inc/Module/Install.pm SHA1 06ca84c52f555dfd7cf8bb7c941c975e25adfc9d inc/Module/Install/Base.pm SHA1 3eeb29878c8a435182b492e22315166a0229a373 inc/Module/Install/Can.pm SHA1 b3839b235991bae672b2db69de102cccef72ef8f inc/Module/Install/ExtraTests.pm SHA1 3bb596078a0413cc568ff3a834d9fc54dbddd54b inc/Module/Install/Fetch.pm SHA1 5885b5a7af6c3d54cbeb1274a896a565e5cbdb9a inc/Module/Install/Makefile.pm SHA1 9247628a32ad889e815a356fb39b2bc94ff3cc3a inc/Module/Install/Metadata.pm SHA1 b0b3ad3cfea40b508eb61e0e5c8ea477f81f3eb1 inc/Module/Install/Win32.pm SHA1 b162866505fb2a1141efa422cfdc864394cb4444 inc/Module/Install/WriteAll.pm SHA1 00dc2b5afaf35b72c9e54af90a43e8338c94206a lib/Config/GitLike.pm SHA1 806e7cb2ac15a460866e1e1c9c3984ad41d2f850 lib/Config/GitLike/Cascaded.pm SHA1 a15b556bdedea16668a170ea52e2ff6f415b7295 lib/Config/GitLike/Git.pm SHA1 8c30f69743e7a9d743d7206f2306ff9f12bb59a0 t/00_use.t SHA1 6b2873180b2db6e0a122e5874fc74927c4470355 t/casing.t SHA1 34c0acc86d479971c0723abac2dc4bbbca3247bb t/comment.t SHA1 8b2803a04139668a93eeead8e90ab2ce53e599f1 t/dos.conf SHA1 0e98fd5383d929fbe63e3513a7697478c3abbf51 t/encoding.t SHA1 0813010c4459e7e7e1824283eb4ea36f6b5c1391 t/get_regexp_filter_multiple.t SHA1 e884df4ffae7428768c76b54882ba3872d5a3b47 t/lib/TestConfig.pm SHA1 b086291482ee5dca0ca4e5dfb8dc65291c8cd560 t/mac.conf SHA1 b82ae53518889fc295b4cd59e923151e2e289cbd t/platforms.t SHA1 24a4fbfdeb3268280fa1a10ac5934274c33a9a55 t/t1300-repo-config.t SHA1 8d0a69c0b80d383ba1fb5a60ca3beb2edf0668b0 t/unix.conf SHA1 53b21b0f0227909dd299d8adb033f5aff8f5fc42 t/util/translate.pl -----BEGIN PGP SIGNATURE----- Version: GnuPG v1 iQIcBAEBCgAGBQJZbBTUAAoJEJHs6NvKxcMFMmAP/j98nI/9O5ALjiDs1kDpfTkv DPZ2VidojTtBW7vWS9uI9jXMFMYvdm8YpgF1QzJ7o1wjWF2Gl+OQBTeAKDoP4bZR /IgrnICTBPfiRWEEIDy8C5Ue5M+er0rJTb0UgLxc0Jb3vif3wUuSBvkngY8R39k4 6gxa41mAgCy3g887samjmtD0/3kNx088JngO+NXRniXs3xILopnacXkjrYhGcgkD uqJkGnxNG6IB1q4b7L8/l4aUy7f1tDOc2SrxHbFAaWT4OJRP5PWl3bL2FTNbcQIT Aen5fcIV7fpapYaEtb4QTwdFui7rCF1li7W7e9QNDRvVwMYPhlexH1azswyijVoc rSJeN15h/pBL0sQTDvTE+Tbucgsfs81ExicMYDr3HkKBCa4vrf90bgSlrL375ixz jsEmNdc8BSaWFe55g/9bcPFlOpskydsm4juFk6B3rI+AKhZwVmeLEvb2dEUGttvY XGGIzYO+WzZCinfHFBNxPRCtkgcqdlenzDlpAhI3yspAo9tYpZGmbEZiTFusD1Z6 /FVljS/pXnBz76uDKs6s1GmsGKL2k94E+YUepkalYV2x3jzEzSETqSp59FQd+OEC uA1NdvIPScE0hqRuxQGg7S7INqZyxgv+XgVRq4XTQQLLlBaFS3wuSQ9GZZBbFqFC u+zhkpKpBTPfFSKa4z+b =w7MY -----END PGP SIGNATURE----- Config-GitLike-1.17/Makefile.PL0000644000175000017500000000053313132771307015164 0ustar chmrrchmrrBEGIN { 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.17/lib/0000755000175000017500000000000013133012324013743 5ustar chmrrchmrrConfig-GitLike-1.17/lib/Config/0000755000175000017500000000000013133012324015150 5ustar chmrrchmrrConfig-GitLike-1.17/lib/Config/GitLike.pm0000644000175000017500000017005013133011776017053 0ustar chmrrchmrrpackage 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.17'; 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. The directory isn't specified here. =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.17/lib/Config/GitLike/0000755000175000017500000000000013133012324016500 5ustar chmrrchmrrConfig-GitLike-1.17/lib/Config/GitLike/Git.pm0000644000175000017500000000523712640077362017607 0ustar chmrrchmrrpackage Config::GitLike::Git; use Moo; use strict; use warnings; extends 'Config::GitLike'; has '+confname' => ( default => 'gitconfig', ); has '+compatible' => ( default => 1, ); 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> =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.17/lib/Config/GitLike/Cascaded.pm0000644000175000017500000000155612640077362020553 0ustar chmrrchmrrpackage 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.17/inc/0000755000175000017500000000000013133012324013746 5ustar chmrrchmrrConfig-GitLike-1.17/inc/Module/0000755000175000017500000000000013133012324015173 5ustar chmrrchmrrConfig-GitLike-1.17/inc/Module/Install.pm0000644000175000017500000002714513133012220017143 0ustar chmrrchmrr#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.18'; # 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.17/inc/Module/Install/0000755000175000017500000000000013133012324016601 5ustar chmrrchmrrConfig-GitLike-1.17/inc/Module/Install/Fetch.pm0000644000175000017500000000462713133012221020175 0ustar chmrrchmrr#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.18'; @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.17/inc/Module/Install/WriteAll.pm0000644000175000017500000000237613133012221020666 0ustar chmrrchmrr#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.18'; @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.17/inc/Module/Install/Metadata.pm0000644000175000017500000004330213133012221020655 0ustar chmrrchmrr#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.18'; @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.17/inc/Module/Install/Base.pm0000644000175000017500000000214713133012221020011 0ustar chmrrchmrr#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.18'; } # 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 Config-GitLike-1.17/inc/Module/Install/Makefile.pm0000644000175000017500000002743713133012221020665 0ustar chmrrchmrr#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.18'; @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.17/inc/Module/Install/Win32.pm0000644000175000017500000000340313133012221020035 0ustar chmrrchmrr#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.18'; @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.17/inc/Module/Install/ExtraTests.pm0000644000175000017500000000566613133012221021256 0ustar chmrrchmrr#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.17/inc/Module/Install/Can.pm0000644000175000017500000000640513133012221017641 0ustar chmrrchmrr#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.18'; @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