diff options
Diffstat (limited to 'perl')
| -rw-r--r-- | perl/.gitignore | 2 | ||||
| -rw-r--r-- | perl/Git.pm | 108 | ||||
| -rw-r--r-- | perl/Git/I18N.pm | 89 | ||||
| -rw-r--r-- | perl/Makefile | 3 | ||||
| -rw-r--r-- | perl/Makefile.PL | 14 |
5 files changed, 164 insertions, 52 deletions
diff --git a/perl/.gitignore b/perl/.gitignore index 98b24772c7..d5c6e22d0f 100644 --- a/perl/.gitignore +++ b/perl/.gitignore @@ -1,5 +1,7 @@ perl.mak perl.mak.old +MYMETA.json +MYMETA.yml blib blibdirs pm_to_blib diff --git a/perl/Git.pm b/perl/Git.pm index 1926dc9a4b..f7ce511bbb 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -7,6 +7,7 @@ Git - Perl interface to the Git version control system package Git; +use 5.008; use strict; @@ -98,7 +99,7 @@ increase notwithstanding). use Carp qw(carp croak); # but croak is bad - throw instead use Error qw(:try); -use Cwd qw(abs_path); +use Cwd qw(abs_path cwd); use IPC::Open2 qw(open2); use Fcntl qw(SEEK_SET SEEK_CUR); } @@ -172,7 +173,7 @@ sub repository { } if (defined $opts{Directory}) { - -d $opts{Directory} or throw Error::Simple("Directory not found: $!"); + -d $opts{Directory} or throw Error::Simple("Directory not found: $opts{Directory} $!"); my $search = Git->repository(WorkingCopy => $opts{Directory}); my $dir; @@ -395,7 +396,16 @@ See C<command_close_bidi_pipe()> for details. sub command_bidi_pipe { my ($pid, $in, $out); + my ($self) = _maybe_self(@_); + local %ENV = %ENV; + my $cwd_save = undef; + if ($self) { + shift; + $cwd_save = cwd(); + _setup_git_cmd_env($self); + } $pid = open2($in, $out, 'git', @_); + chdir($cwd_save) if $cwd_save; return ($pid, $in, $out, join(' ', @_)); } @@ -545,7 +555,7 @@ sub wc_chdir { or throw Error::Simple("bare repository"); -d $self->wc_path().'/'.$subdir - or throw Error::Simple("subdir not found: $!"); + or throw Error::Simple("subdir not found: $subdir $!"); # Of course we will not "hold" the subdirectory so anyone # can delete it now and we will never know. But at least we tried. @@ -560,30 +570,10 @@ does. In scalar context requires the variable to be set only one time (exception is thrown otherwise), in array context returns allows the variable to be set multiple times and returns all the values. -This currently wraps command('config') so it is not so fast. - =cut sub config { - my ($self, $var) = _maybe_self(@_); - - try { - my @cmd = ('config'); - unshift @cmd, $self if $self; - if (wantarray) { - return command(@cmd, '--get-all', $var); - } else { - return command_oneline(@cmd, '--get', $var); - } - } catch Git::Error::Command with { - my $E = shift; - if ($E->value() == 1) { - # Key not found. - return; - } else { - throw $E; - } - }; + return _config_common({}, @_); } @@ -593,30 +583,33 @@ Retrieve the bool configuration C<VARIABLE>. The return value is usable as a boolean in perl (and C<undef> if it's not defined, of course). -This currently wraps command('config') so it is not so fast. - =cut sub config_bool { - my ($self, $var) = _maybe_self(@_); + my $val = scalar _config_common({'kind' => '--bool'}, @_); - try { - my @cmd = ('config', '--bool', '--get', $var); - unshift @cmd, $self if $self; - my $val = command_oneline(@cmd); - return undef unless defined $val; + # Do not rewrite this as return (defined $val && $val eq 'true') + # as some callers do care what kind of falsehood they receive. + if (!defined $val) { + return undef; + } else { return $val eq 'true'; - } catch Git::Error::Command with { - my $E = shift; - if ($E->value() == 1) { - # Key not found. - return undef; - } else { - throw $E; - } - }; + } } + +=item config_path ( VARIABLE ) + +Retrieve the path configuration C<VARIABLE>. The return value +is an expanded path or C<undef> if it's not defined. + +=cut + +sub config_path { + return _config_common({'kind' => '--path'}, @_); +} + + =item config_int ( VARIABLE ) Retrieve the integer configuration C<VARIABLE>. The return value @@ -625,22 +618,31 @@ or 'g' in the config file will cause the value to be multiplied by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output. It would return C<undef> if configuration variable is not defined, -This currently wraps command('config') so it is not so fast. - =cut sub config_int { + return scalar _config_common({'kind' => '--int'}, @_); +} + +# Common subroutine to implement bulk of what the config* family of methods +# do. This curently wraps command('config') so it is not so fast. +sub _config_common { + my ($opts) = shift @_; my ($self, $var) = _maybe_self(@_); try { - my @cmd = ('config', '--int', '--get', $var); + my @cmd = ('config', $opts->{'kind'} ? $opts->{'kind'} : ()); unshift @cmd, $self if $self; - return command_oneline(@cmd); + if (wantarray) { + return command(@cmd, '--get-all', $var); + } else { + return command_oneline(@cmd, '--get', $var); + } } catch Git::Error::Command with { my $E = shift; if ($E->value() == 1) { # Key not found. - return undef; + return; } else { throw $E; } @@ -842,7 +844,7 @@ sub _open_hash_and_insert_object_if_needed { ($self->{hash_object_pid}, $self->{hash_object_in}, $self->{hash_object_out}, $self->{hash_object_ctx}) = - command_bidi_pipe(qw(hash-object -w --stdin-paths --no-filters)); + $self->command_bidi_pipe(qw(hash-object -w --stdin-paths --no-filters)); } sub _close_hash_and_insert_object { @@ -931,7 +933,7 @@ sub _open_cat_blob_if_needed { ($self->{cat_blob_pid}, $self->{cat_blob_in}, $self->{cat_blob_out}, $self->{cat_blob_ctx}) = - command_bidi_pipe(qw(cat-file --batch)); + $self->command_bidi_pipe(qw(cat-file --batch)); } sub _close_cat_blob { @@ -1278,6 +1280,14 @@ sub _command_common_pipe { # for the given repository and execute the git command. sub _cmd_exec { my ($self, @args) = @_; + _setup_git_cmd_env($self); + _execv_git_cmd(@args); + die qq[exec "@args" failed: $!]; +} + +# set up the appropriate state for git command +sub _setup_git_cmd_env { + my $self = shift; if ($self) { $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path(); $self->repo_path() and $self->wc_path() @@ -1285,8 +1295,6 @@ sub _cmd_exec { $self->wc_path() and chdir($self->wc_path()); $self->wc_subdir() and chdir($self->wc_subdir()); } - _execv_git_cmd(@args); - die qq[exec "@args" failed: $!]; } # Execute the given Git command ($_[0]) with arguments ($_[1..]) diff --git a/perl/Git/I18N.pm b/perl/Git/I18N.pm new file mode 100644 index 0000000000..07597dcb93 --- /dev/null +++ b/perl/Git/I18N.pm @@ -0,0 +1,89 @@ +package Git::I18N; +use 5.008; +use strict; +use warnings; +use Exporter 'import'; + +our @EXPORT = qw(__); +our @EXPORT_OK = @EXPORT; + +sub __bootstrap_locale_messages { + our $TEXTDOMAIN = 'git'; + our $TEXTDOMAINDIR = $ENV{GIT_TEXTDOMAINDIR} || '++LOCALEDIR++'; + + require POSIX; + POSIX->import(qw(setlocale)); + # Non-core prerequisite module + require Locale::Messages; + Locale::Messages->import(qw(:locale_h :libintl_h)); + + setlocale(LC_MESSAGES(), ''); + setlocale(LC_CTYPE(), ''); + textdomain($TEXTDOMAIN); + bindtextdomain($TEXTDOMAIN => $TEXTDOMAINDIR); + + return; +} + +BEGIN +{ + # Used by our test script to see if it should test fallbacks or + # not. + our $__HAS_LIBRARY = 1; + + local $@; + eval { + __bootstrap_locale_messages(); + *__ = \&Locale::Messages::gettext; + 1; + } or do { + # Tell test.pl that we couldn't load the gettext library. + $Git::I18N::__HAS_LIBRARY = 0; + + # Just a fall-through no-op + *__ = sub ($) { $_[0] }; + }; +} + +1; + +__END__ + +=head1 NAME + +Git::I18N - Perl interface to Git's Gettext localizations + +=head1 SYNOPSIS + + use Git::I18N; + + print __("Welcome to Git!\n"); + + printf __("The following error occured: %s\n"), $error; + +=head1 DESCRIPTION + +Git's internal Perl interface to gettext via L<Locale::Messages>. If +L<Locale::Messages> can't be loaded (it's not a core module) we +provide stub passthrough fallbacks. + +This is a distilled interface to gettext, see C<info '(gettext)Perl'> +for the full interface. This module implements only a small part of +it. + +=head1 FUNCTIONS + +=head2 __($) + +L<Locale::Messages>'s gettext function if all goes well, otherwise our +passthrough fallback function. + +=head1 AUTHOR + +E<AElig>var ArnfjE<ouml>rE<eth> Bjarmason <avarab@gmail.com> + +=head1 COPYRIGHT + +Copyright 2010 E<AElig>var ArnfjE<ouml>rE<eth> Bjarmason <avarab@gmail.com> + +=cut diff --git a/perl/Makefile b/perl/Makefile index 4ab21d61b8..b2977cd0bc 100644 --- a/perl/Makefile +++ b/perl/Makefile @@ -5,6 +5,7 @@ makfile:=perl.mak PERL_PATH_SQ = $(subst ','\'',$(PERL_PATH)) prefix_SQ = $(subst ','\'',$(prefix)) +localedir_SQ = $(subst ','\'',$(localedir)) ifndef V QUIET = @ @@ -38,7 +39,7 @@ $(makfile): ../GIT-CFLAGS Makefile echo ' echo $(instdir_SQ)' >> $@ else $(makfile): Makefile.PL ../GIT-CFLAGS - $(PERL_PATH) $< PREFIX='$(prefix_SQ)' + $(PERL_PATH) $< PREFIX='$(prefix_SQ)' INSTALL_BASE='' --localedir='$(localedir_SQ)' endif # this is just added comfort for calling make directly in perl dir diff --git a/perl/Makefile.PL b/perl/Makefile.PL index 0b9deca2cc..456d45bf40 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -1,4 +1,12 @@ +use strict; +use warnings; use ExtUtils::MakeMaker; +use Getopt::Long; + +# Sanity: die at first unknown option +Getopt::Long::Configure qw/ pass_through /; + +GetOptions("localedir=s" => \my $localedir); sub MY::postamble { return <<'MAKE_FRAG'; @@ -16,7 +24,10 @@ endif MAKE_FRAG } -my %pm = ('Git.pm' => '$(INST_LIBDIR)/Git.pm'); +my %pm = ( + 'Git.pm' => '$(INST_LIBDIR)/Git.pm', + 'Git/I18N.pm' => '$(INST_LIBDIR)/Git/I18N.pm', +); # We come with our own bundled Error.pm. It's not in the set of default # Perl modules so install it if it's not available on the system yet. @@ -33,6 +44,7 @@ WriteMakefile( NAME => 'Git', VERSION_FROM => 'Git.pm', PM => \%pm, + PM_FILTER => qq[\$(PERL) -pe "s<\\Q++LOCALEDIR++\\E><$localedir>"], MAKEFILE => 'perl.mak', INSTALLSITEMAN3DIR => '$(SITEPREFIX)/share/man/man3' ); |